├── doc ├── sphinx │ ├── _static │ │ └── .gitignore │ ├── requirements.txt │ ├── CMakeLists.txt │ ├── index.rst │ ├── fortran_dynamic_loader.rst │ ├── conf.py │ ├── map_any_type.rst │ ├── json.rst │ └── timer_tree_type.rst ├── parameter_lists.pdf ├── state_history_type.pdf ├── secure_hash.tex └── state_history_type.tex ├── templates ├── CMakeLists.txt ├── wavl-tree │ ├── src │ │ └── CMakeLists.txt │ ├── CMakeLists.txt │ ├── test │ │ ├── CMakeLists.txt │ │ └── perf_test.F90 │ ├── doc │ │ └── performance.md │ ├── TODO.md │ ├── README.md │ └── LICENSE.md └── README.md ├── test ├── secure_hash │ ├── test_secure_hash.F90 │ └── CMakeLists.txt ├── timer_tree │ └── CMakeLists.txt ├── map_any_type │ └── CMakeLists.txt ├── yajl_fort │ ├── strip-cmp.sh │ ├── CMakeLists.txt │ ├── file1.json │ └── strip.F90 ├── state_history_type │ ├── CMakeLists.txt │ └── test_state_history_type.F90 ├── json │ ├── CMakeLists.txt │ ├── json-ex9.F90 │ ├── json-ex2.F90 │ ├── json-ex3.F90 │ ├── json-ex1.F90 │ ├── json-ex7.F90 │ ├── json-ex6.F90 │ ├── json-ex4.F90 │ ├── json-ex5.F90 │ └── json-ex8.F90 ├── fortran_dynamic_loader │ ├── mylib.F90 │ ├── CMakeLists.txt │ └── test_fortran_dynamic_loader.F90.in ├── CMakeLists.txt └── parameter_list_type │ ├── CMakeLists.txt │ └── test_parameter_list_json.F90 ├── examples ├── yajl-fort │ ├── data.json │ ├── CMakeLists.txt │ ├── yajl_fort_emit_example.F90 │ └── yajl_fort_parse_example.F90 ├── timer_tree │ ├── CMakeLists.txt │ └── timer_tree_example.F90 ├── parameter_list_type │ ├── CMakeLists.txt │ ├── json_input_example.F90 │ └── parameter_list_example.F90 ├── CMakeLists.txt └── map_any_type │ ├── CMakeLists.txt │ └── example.F90 ├── include ├── stringify.h ├── concatenate.h └── f90_assert.fpp ├── src ├── yajl_ext.c ├── CMakeLists.txt ├── f90_assert.F90 └── secure_hash │ ├── secure_hash_factory.F90 │ └── reference-C-code │ ├── sha1.h │ ├── sha256.h │ ├── sha512.h │ └── md5.h ├── TODO ├── cmake ├── SearchHeaderFile.cmake ├── FindSphinx.cmake └── FindYAJL.cmake ├── .readthedocs.yaml ├── README.md ├── modules └── tridiagonal-solvers │ ├── src │ ├── CMakeLists.txt │ ├── td_matrix_type.F90 │ ├── block_solver_procs.F90 │ └── btd_matrix_type.F90 │ ├── CMakeLists.txt │ ├── test │ ├── CMakeLists.txt │ ├── td_matrix_test.F90 │ ├── btd_matrix_test.F90 │ ├── block_solver_procs_test.F90 │ ├── co_td_matrix_test.F90 │ └── co_btd_matrix_test.F90 │ └── README.md ├── COPYRIGHT └── CMakeLists.txt /doc/sphinx/_static/.gitignore: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /doc/sphinx/requirements.txt: -------------------------------------------------------------------------------- 1 | guzzle_sphinx_theme 2 | -------------------------------------------------------------------------------- /templates/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_subdirectory(wavl-tree) 2 | -------------------------------------------------------------------------------- /doc/parameter_lists.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nncarlson/petaca/HEAD/doc/parameter_lists.pdf -------------------------------------------------------------------------------- /doc/state_history_type.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nncarlson/petaca/HEAD/doc/state_history_type.pdf -------------------------------------------------------------------------------- /test/secure_hash/test_secure_hash.F90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nncarlson/petaca/HEAD/test/secure_hash/test_secure_hash.F90 -------------------------------------------------------------------------------- /examples/yajl-fort/data.json: -------------------------------------------------------------------------------- 1 | { "first": 1, "second": 2.0, 2 | "sublist": 3 | { "foo": "bar"}, 4 | "array": [1, true] 5 | } 6 | -------------------------------------------------------------------------------- /include/stringify.h: -------------------------------------------------------------------------------- 1 | #ifdef PP_HAS_STRINGIFY 2 | #define TO_STRING(name) #name 3 | #else 4 | #define TO_STRING(name) "name" 5 | #endif 6 | -------------------------------------------------------------------------------- /examples/timer_tree/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (timer_tree_example timer_tree_example.F90) 2 | target_link_libraries(timer_tree_example petaca) 3 | -------------------------------------------------------------------------------- /examples/parameter_list_type/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (json_input_example json_input_example.F90) 2 | target_link_libraries(json_input_example petaca) 3 | -------------------------------------------------------------------------------- /examples/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_subdirectory(map_any_type) 2 | add_subdirectory(parameter_list_type) 3 | add_subdirectory(yajl-fort) 4 | add_subdirectory(timer_tree) 5 | -------------------------------------------------------------------------------- /examples/yajl-fort/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (yajl_fort_parse_example yajl_fort_parse_example.F90) 2 | target_link_libraries(yajl_fort_parse_example petaca) 3 | -------------------------------------------------------------------------------- /test/timer_tree/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (test_timer_tree test_timer_tree.F90) 2 | target_link_libraries(test_timer_tree petaca) 3 | add_test(timer_tree test_timer_tree) 4 | -------------------------------------------------------------------------------- /include/concatenate.h: -------------------------------------------------------------------------------- 1 | #ifdef PP_HAS_CONCATENATE 2 | #define CONCATENATE(a,b) a ## b 3 | #else 4 | #define IDENTITY(x) x 5 | #define CONCATENATE(a,b) IDENTITY(a)IDENTITY(b) 6 | #endif 7 | -------------------------------------------------------------------------------- /test/map_any_type/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (test_map_any_type test_map_any_type.F90) 2 | target_link_libraries(test_map_any_type petaca) 3 | add_test(map_any test_map_any_type) 4 | -------------------------------------------------------------------------------- /test/yajl_fort/strip-cmp.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # $1 = strip executable 3 | # $2 = JSON input file 4 | 5 | $1 $2 > out1.json 6 | $1 out1.json > out2.json 7 | cmp -s out1.json out2.json 8 | -------------------------------------------------------------------------------- /templates/wavl-tree/src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_library(common OBJECT wavl_tree_type.F90) 2 | target_include_directories(common PUBLIC 3 | $ 4 | ) 5 | -------------------------------------------------------------------------------- /test/state_history_type/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (test_state_history_type test_state_history_type.F90) 2 | target_link_libraries(test_state_history_type petaca) 3 | add_test(state_history test_state_history_type) 4 | -------------------------------------------------------------------------------- /doc/sphinx/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | if(SPHINX_FOUND) 2 | add_custom_target(petaca-doc ALL 3 | ${SPHINX_EXECUTABLE} -b html 4 | ${CMAKE_CURRENT_SOURCE_DIR} 5 | ${CMAKE_CURRENT_BINARY_DIR}/html 6 | ) 7 | endif() 8 | -------------------------------------------------------------------------------- /templates/wavl-tree/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.19) 2 | 3 | project(wavl-tree Fortran) 4 | 5 | include(CTest) 6 | 7 | add_subdirectory(src) 8 | add_subdirectory(test) 9 | #add_subdirectory(example) 10 | -------------------------------------------------------------------------------- /include/f90_assert.fpp: -------------------------------------------------------------------------------- 1 | 2 | #ifdef NDEBUG 3 | # define ASSERT(x) !! assert( x ) 4 | #else 5 | # define ASSERT(x) if(.not.(x)) call f90_assert(__FILE__,__LINE__) 6 | #endif 7 | 8 | #define INSIST(x) if(.not.(x)) call f90_assert(__FILE__,__LINE__) 9 | -------------------------------------------------------------------------------- /test/json/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Tests for json.F90; also exercise yajl_fort.F90 2 | foreach(n RANGE 1 9) 3 | add_executable(json-ex${n} json-ex${n}.F90) 4 | target_link_libraries(json-ex${n} petaca) 5 | add_test(json-ex${n} json-ex${n}) 6 | endforeach() 7 | -------------------------------------------------------------------------------- /templates/wavl-tree/test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Want test modules in the build directory. 2 | #unset(CMAKE_Fortran_MODULE_DIRECTORY) 3 | 4 | add_executable(perf_test perf_test.F90) 5 | target_link_libraries(perf_test common) 6 | add_test(perf_test ./perf_test) 7 | -------------------------------------------------------------------------------- /test/yajl_fort/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable(json-strip strip.F90) 2 | target_link_libraries(json-strip petaca) 3 | 4 | add_test(NAME strip-file1 COMMAND 5 | ${CMAKE_CURRENT_SOURCE_DIR}/strip-cmp.sh json-strip 6 | ${CMAKE_CURRENT_SOURCE_DIR}/file1.json) 7 | -------------------------------------------------------------------------------- /test/fortran_dynamic_loader/mylib.F90: -------------------------------------------------------------------------------- 1 | function square (x) result (xsq) bind (c) 2 | real, value :: x 3 | real :: xsq 4 | xsq = x*x 5 | end function 6 | 7 | module global_data 8 | integer, bind(c,name='FORTYTWO') :: FORTYTWO = 42 9 | end module global_data 10 | -------------------------------------------------------------------------------- /test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_subdirectory(fortran_dynamic_loader) 2 | add_subdirectory(map_any_type) 3 | add_subdirectory(parameter_list_type) 4 | add_subdirectory(state_history_type) 5 | add_subdirectory(secure_hash) 6 | add_subdirectory(timer_tree) 7 | add_subdirectory(yajl_fort) 8 | add_subdirectory(json) 9 | -------------------------------------------------------------------------------- /examples/map_any_type/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (example example.F90) 2 | target_link_libraries(example petaca) 3 | 4 | ### Preprocessor defines; mainly compiler bug workarounds. 5 | foreach (def ${Fortran_COMPILE_DEFINITIONS}) 6 | set_property (TARGET example APPEND PROPERTY COMPILE_DEFINITIONS ${def}) 7 | endforeach () 8 | -------------------------------------------------------------------------------- /src/yajl_ext.c: -------------------------------------------------------------------------------- 1 | /* Fortran interoperable interfaces to the varargs function yajl_config */ 2 | 3 | #include "yajl/yajl_parse.h" 4 | 5 | int yajl_set_option(yajl_handle h, yajl_option opt) 6 | { 7 | return yajl_config(h, opt, 1); 8 | } 9 | 10 | int yajl_unset_option(yajl_handle h, yajl_option opt) 11 | { 12 | return yajl_config(h, opt, 0); 13 | } 14 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | CMAKE STUFF 2 | ----------- 3 | Figure out how to gracefully build the documentation via cmake. 4 | Requires pdflatex and the latex2man style files to build the pdf, 5 | and the latex2man program to create the man file. This may well 6 | not exist on many systems. 7 | 8 | Figure out how to install the petaca library, associated mod 9 | files, documentations, etc. 10 | 11 | Figure out how to build a distribution tarball using CPack(?) 12 | -------------------------------------------------------------------------------- /test/fortran_dynamic_loader/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | configure_file(test_fortran_dynamic_loader.F90.in 2 | test_fortran_dynamic_loader.F90 3 | @ONLY) 4 | 5 | add_executable (test_fortran_dynamic_loader 6 | ${CMAKE_CURRENT_BINARY_DIR}/test_fortran_dynamic_loader.F90) 7 | target_link_libraries(test_fortran_dynamic_loader petaca) 8 | add_test(fortran_dynamic_loader test_fortran_dynamic_loader) 9 | 10 | # Shared library loaded by the test. 11 | add_library(mylib SHARED mylib.F90) 12 | -------------------------------------------------------------------------------- /test/secure_hash/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (test_secure_hash test_secure_hash.F90) 2 | target_link_libraries(test_secure_hash petaca) 3 | add_test(secure_hash test_secure_hash) 4 | 5 | #add_executable (time_hash time_hash.F90) 6 | #target_link_libraries(time_hash petaca) 7 | 8 | ### Preprocessor defines; mainly compiler bug workarounds. 9 | foreach (def ${Fortran_COMPILE_DEFINITIONS}) 10 | set_property (TARGET test_secure_hash APPEND PROPERTY COMPILE_DEFINITIONS ${def}) 11 | endforeach () 12 | -------------------------------------------------------------------------------- /cmake/SearchHeaderFile.cmake: -------------------------------------------------------------------------------- 1 | function(search_header_file config_h defmacro outvar) 2 | cmake_parse_arguments(search_header_file "STRIP_QUOTES" "" "" ${ARGN}) 3 | if(EXISTS "${config_h}") 4 | set(_regexp "^#define[ \t]+${defmacro}[ \t]+") 5 | file(STRINGS "${config_h}" _string REGEX "${_regexp}") 6 | string(REGEX REPLACE "${_regexp}(.+)$" "\\1" _string "${_string}") 7 | if(search_header_file_STRIP_QUOTES) 8 | string(REPLACE "\"" "" _string "${_string}") 9 | endif() 10 | else() 11 | set(_string ${outvar}-NOTFOUND) 12 | endif() 13 | set(${outvar} ${_string} PARENT_SCOPE) 14 | endfunction() 15 | -------------------------------------------------------------------------------- /.readthedocs.yaml: -------------------------------------------------------------------------------- 1 | # .readthedocs.yaml 2 | # Read the Docs configuration file 3 | # See https://docs.readthedocs.io/en/stable/config-file/v2.html for details 4 | 5 | # Required 6 | version: 2 7 | 8 | # Set the version of Python and other tools you might need 9 | build: 10 | os: ubuntu-22.04 11 | tools: 12 | python: "3.11" 13 | 14 | # Build documentation in the docs/ directory with Sphinx 15 | sphinx: 16 | configuration: doc/sphinx/conf.py 17 | 18 | # We recommend specifying your dependencies to enable reproducible builds: 19 | # https://docs.readthedocs.io/en/stable/guides/reproducible-builds.html 20 | python: 21 | install: 22 | - requirements: doc/sphinx/requirements.txt 23 | -------------------------------------------------------------------------------- /templates/wavl-tree/doc/performance.md: -------------------------------------------------------------------------------- 1 | ### Performance Results 2 | 3 | Current results of `perf_test`, which times the insertion of 1M random values 4 | (from a range of 100M values), lookup of 1M different random values (from the 5 | same range), and sequential deletion of the values originally inserted. 6 | 7 | * AMD Threadripper 2920X 8 | 9 | compiler | flags | insertion | lookup | deletion | 10 | ---------|-------|-----------|--------|----------| 11 | nagfor 7.1.7103 | -O3 | 0.45 s | 0.50 s | 0.50 s 12 | gfortran 11.2.0 | -O2 | 0.57 s | 0.59 s | 0.62 s 13 | ifort 2021.5.0 | -O2 | 0.67 s | 0.65 s | 0.72 s 14 | 15 | - Significant improvement for nagfor increasing optimization to -O3; 16 | no change for gfortran and ifort. 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Petaca 2 | ====== 3 | Petaca is an ad hoc collection of modern Fortran modules that provide 4 | broadly useful capabilities -- things that I have found myself using 5 | repeatedly across many projects. A unifying feature of the modules is 6 | their object-oriented interfaces and implementation. 7 | 8 | Read the documentation on [readthedocs.org](http://petaca.readthedocs.io/) 9 | (under development). 10 | 11 | The compilers currently supported/tested are: 12 | * NAG nagfor 7.0, 7.1, and 7.2 (recent builds of those versions) 13 | * GNU gfortran 12, 13, 14, and 15 14 | * Intel ifx OneAPI 2024, 2025; also classic ifort from OneAPI 15 | * LLVM flang versions 19.1 and 20.1 16 | 17 | Other compilers supporting the Fortran 2018 standard should work as well. 18 | -------------------------------------------------------------------------------- /templates/wavl-tree/TODO.md: -------------------------------------------------------------------------------- 1 | ### To-Do's 2 | 3 | * Unit tests, especially those that verify that the rebalancing conforms to 4 | the WAVL rules. The "tests" originally used during development have been 5 | lost unfortunately. 6 | 7 | * Would a recursion-less implementation perform significantly better? The 8 | implementation would be complicated by the required rebalancing that needs 9 | to walk (partway) back up the tree. 10 | 11 | * Investigate the cost/benefit of maintaining a parent pointer component of 12 | the `rbt_node` derived type. It would trade the need for the iterator to 13 | maintain a node stack (using O(log(n)) storage) for O(n) of storage plus the 14 | cost of maintaining the parent pointer during insertion/deletion/rebalancing. 15 | 16 | * Tree traversal methods (inorder, preorder, postorder) with visitor procedure. 17 | -------------------------------------------------------------------------------- /doc/sphinx/index.rst: -------------------------------------------------------------------------------- 1 | Petaca Documentation 2 | ==================== 3 | The Petaca library is an ad hoc collection of modern Fortran modules that 4 | provide broadly useful capabilities; things that I find myself using 5 | repeatedly across many software projects. 6 | 7 | .. todo:: 8 | * Build instructions 9 | * Convert documentation to html for: 10 | 11 | * secure_hash module 12 | * state_history_type module 13 | 14 | See their pdf documentation in https://github.com/nncarlson/petaca/tree/master/doc 15 | 16 | .. toctree:: 17 | :maxdepth: 2 18 | :caption: Contents: 19 | 20 | parameter_lists 21 | map_any_type 22 | fortran_dynamic_loader 23 | timer_tree_type 24 | yajl_fort 25 | json 26 | 27 | 28 | 29 | .. Indices and tables 30 | .. ================== 31 | .. 32 | .. * :ref:`genindex` 33 | .. * :ref:`modindex` 34 | .. * :ref:`search` 35 | -------------------------------------------------------------------------------- /examples/parameter_list_type/json_input_example.F90: -------------------------------------------------------------------------------- 1 | program parameter_list_input_example 2 | 3 | use,intrinsic :: iso_fortran_env 4 | use parameter_list_type 5 | use parameter_list_json 6 | implicit none 7 | 8 | character(len=64) :: prog, file 9 | character(:), allocatable :: errmsg 10 | type(parameter_list), pointer :: plist 11 | 12 | if (command_argument_count() == 1) then 13 | call get_command_argument (1, file) 14 | else 15 | call get_command (prog) 16 | write(error_unit,'(a)') 'usage: ' // trim(prog) // ' file' 17 | stop 18 | end if 19 | 20 | open(10,file=file,action='read',access='stream',form='unformatted') 21 | call parameter_list_from_json_stream(10, plist, errmsg) 22 | if (associated(plist)) then 23 | call parameter_list_to_json (plist, output_unit) 24 | deallocate(plist) 25 | else 26 | write(error_unit,'(a)') errmsg 27 | end if 28 | 29 | end program 30 | -------------------------------------------------------------------------------- /test/parameter_list_type/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_executable (test_any_scalar_type test_any_scalar_type.F90) 2 | target_link_libraries(test_any_scalar_type petaca) 3 | add_test(any_scalar test_any_scalar_type) 4 | 5 | add_executable (test_any_vector_type test_any_vector_type.F90) 6 | target_link_libraries(test_any_vector_type petaca) 7 | add_test(any_vector test_any_vector_type) 8 | 9 | add_executable (test_any_matrix_type test_any_matrix_type.F90) 10 | target_link_libraries(test_any_matrix_type petaca) 11 | add_test(any_matrix test_any_matrix_type) 12 | 13 | add_executable (test_parameter_list_type test_parameter_list_type.F90) 14 | target_link_libraries(test_parameter_list_type petaca) 15 | add_test(parameter_list test_parameter_list_type) 16 | 17 | add_executable (test_parameter_list_json test_parameter_list_json.F90) 18 | target_link_libraries(test_parameter_list_json petaca) 19 | add_test(parameter_list_json test_parameter_list_json) 20 | -------------------------------------------------------------------------------- /templates/wavl-tree/README.md: -------------------------------------------------------------------------------- 1 | ### Module `wavl_tree_type` (Template) 2 | This module defines the `wavl_tree` derived type which implements a core 3 | reference implementation of a weak AVL (WAVL) binary search tree with 4 | bottom-up rebalancing [1]. It uses integer keys and integer values, and 5 | includes only the basic methods of insertion, deletion, and lookup. The 6 | module also defines a companion `wavl_tree_iterator` derived type for 7 | in-order iteration of the nodes of the tree. 8 | 9 | While this is a compilable and testable module, it is intended to serve 10 | *only* as a template, or starting point, for creating custom containers 11 | that use a binary search tree as the internal data structure; e.g., set 12 | and map. Simply copy the module and modify it to suit the specific need. 13 | 14 | [1] Haeupler, B., Sen, S., and Tarjan, S. E. 2015. Rank-Balanced Trees. 15 | ACM Trans. Algorithms 11, 4. DOI:https://doi.org/10.1145/2689412 16 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_library(serial-lib td_matrix_type.F90 btd_matrix_type.F90 block_solver_procs.F90) 2 | target_include_directories(serial-lib PUBLIC 3 | $ 4 | $ 5 | ) 6 | 7 | # Required for use by coarray code 8 | target_compile_options(serial-lib PRIVATE $<$:-thread_safe>) 9 | 10 | add_library(parallel-lib co_td_matrix_type.F90 co_btd_matrix_type.F90) 11 | target_link_libraries(parallel-lib PUBLIC serial-lib) 12 | target_compile_options(parallel-lib PUBLIC $<$:-coarray>) 13 | target_link_options(parallel-lib PUBLIC $<$:-coarray>) 14 | target_include_directories(parallel-lib PUBLIC 15 | $ 16 | $ 17 | ) 18 | -------------------------------------------------------------------------------- /templates/README.md: -------------------------------------------------------------------------------- 1 | ## Templates 2 | 3 | This directory contains modules that provide reference implementations of 4 | various data structures. They are not intended to be used as is, but rather 5 | to serve as starting code for developing application-specific code that will 6 | use the data structures. Ideally these would be true templates, but Fortran 7 | lacks capabilities for generic programming[^1]. 8 | 9 | ### Contents 10 | * [`wavl-tree`](./wavl-tree): A weak AVL binary search tree. WAVL trees are 11 | self-balancing binary search trees that combine the best properties of AVL 12 | and red-black trees. 13 | 14 | [^1]: There are pre-processing options for implementing a form of generic 15 | programming. See for example, the 16 | [Fortran Standard Library](https://github.com/fortran-lang/stdlib) 17 | and its use of the [`fypp`](https://github.com/aradi/fypp) pre-processor, 18 | or Tom Clune's [gFTL](https://github.com/Goddard-Fortran-Ecosystem/gFTL) 19 | library and its use of the GNU `m4` macro processor. I'd like to explore 20 | these in the future. 21 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright (c) 2096, 2013, Neil N. Carlson 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a 4 | copy of this software and associated documentation files (the "Software"), 5 | to deal in the Software without restriction, including without limitation 6 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 7 | and/or sell copies of the Software, and to permit persons to whom the 8 | Software is furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included 11 | in all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 16 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 19 | DEALINGS IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /examples/yajl-fort/yajl_fort_emit_example.F90: -------------------------------------------------------------------------------- 1 | program yajl_fort_emit_example 2 | 3 | use yajl_fort 4 | 5 | type(fyajl_emitter) :: emitter 6 | character(:), pointer :: buffer 7 | 8 | call emitter%init 9 | 10 | call emitter%emit_map_open 11 | call emitter%emit_map_key ('foo') 12 | call emitter%emit_value (1.1d0) 13 | call emitter%emit_map_key ('bar') 14 | call emitter%emit_value ('albatross') 15 | call emitter%emit_map_key ('dog') 16 | call emitter%emit_map_open 17 | 18 | call emitter%get_buffer (buffer) 19 | print *, buffer 20 | call emitter%clear_buffer 21 | 22 | call emitter%emit_map_key ('wild') 23 | call emitter%emit_value (.true.) 24 | call emitter%emit_array_close 25 | call emitter%emit_map_close 26 | call emitter%emit_map_key ('red') 27 | call emitter%emit_array_open 28 | call emitter%emit_value (0.5d0) 29 | call emitter%emit_value (0.5d0) 30 | call emitter%emit_value (0.1d0) 31 | call emitter%emit_array_close 32 | call emitter%emit_map_close 33 | 34 | call emitter%get_buffer (buffer) 35 | print *, buffer 36 | call emitter%clear_buffer 37 | 38 | end program 39 | -------------------------------------------------------------------------------- /templates/wavl-tree/LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022 Neil N. Carlson 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a 4 | copy of this software and associated documentation files (the "Software"), 5 | to deal in the Software without restriction, including without limitation 6 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 7 | and/or sell copies of the Software, and to permit persons to whom the 8 | Software is furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included 11 | in all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 16 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 18 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 19 | DEALINGS IN THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.20.2) 2 | 3 | project(tridiagonal-solvers Fortran) 4 | 5 | # Set missing CMake defaults for the NAG Fortran compiler 6 | if(CMAKE_Fortran_COMPILER_ID MATCHES NAG) 7 | set(CMAKE_Fortran_FLAGS_DEBUG "-u -O0 -g -C=all -nan") 8 | set(CMAKE_Fortran_FLAGS_RELEASE "-u -O3") 9 | set(CMAKE_Fortran_FLAGS_RELWITHDEBINFO "${CMAKE_Fortran_FLAGS_RELEASE} -g") 10 | endif() 11 | 12 | # Disable assertions in release builds 13 | add_compile_definitions($<$:NDEBUG>) 14 | 15 | add_compile_options($<$:-fpe0>) 16 | add_compile_options($<$:-ffpe-trap=invalid,zero,overflow>) 17 | 18 | add_compile_definitions( 19 | $<$:NAG_BUG20230603b> 20 | $<$:NAG_BUG20230603c> 21 | $<$:INTEL_BUG20230604> 22 | ) 23 | 24 | if(NOT CMAKE_BUILD_TYPE) 25 | message(STATUS "Setting build type to 'Release' as none was specified.") 26 | set(CMAKE_BUILD_TYPE "Release" CACHE STRING "Choose the type of build." FORCE) 27 | endif() 28 | 29 | include(CTest) 30 | 31 | add_subdirectory(src) 32 | add_subdirectory(test) 33 | #add_subdirectory(example) 34 | -------------------------------------------------------------------------------- /cmake/FindSphinx.cmake: -------------------------------------------------------------------------------- 1 | # - This module looks for Sphinx 2 | # Find the Sphinx documentation generator 3 | # 4 | # This modules defines 5 | # SPHINX_EXECUTABLE 6 | # SPHINX_FOUND 7 | find_program(SPHINX_EXECUTABLE 8 | NAMES sphinx-build 9 | PATHS 10 | /usr/bin 11 | /usr/local/bin 12 | /opt/local/bin 13 | DOC "Sphinx documentation generator" 14 | ) 15 | 16 | if( NOT SPHINX_EXECUTABLE ) 17 | set(_Python_VERSIONS 18 | 2.7 2.6 2.5 2.4 2.3 2.2 2.1 2.0 1.6 1.5 19 | ) 20 | foreach( _version ${_Python_VERSIONS} ) 21 | set( _sphinx_NAMES sphinx-build-${_version} ) 22 | find_program( SPHINX_EXECUTABLE 23 | NAMES ${_sphinx_NAMES} 24 | PATHS 25 | /usr/bin 26 | /usr/local/bin 27 | /opt/loca/bin 28 | DOC "Sphinx documentation generator" 29 | ) 30 | endforeach() 31 | endif() 32 | 33 | include(FindPackageHandleStandardArgs) 34 | find_package_handle_standard_args(Sphinx DEFAULT_MSG SPHINX_EXECUTABLE) 35 | mark_as_advanced(SPHINX_EXECUTABLE) 36 | 37 | function(Sphinx_add_target target_name builder conf source destination) 38 | 39 | add_custom_target(${target_name} ALL 40 | COMMAND ${SPHINX_EXECUTABLE} -b ${builder} 41 | -c ${conf} 42 | ${source} 43 | ${destination} 44 | COMMENT "Generating sphinx documentation: ${builder}" 45 | ) 46 | 47 | set_property(DIRECTORY 48 | APPEND PROPERTY ADDITIONAL_MAKE_CLEAN_FILES ${destination} 49 | ) 50 | 51 | endfunction() 52 | -------------------------------------------------------------------------------- /src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(SRC 2 | f90_assert.F90 3 | fortran_dynamic_loader.F90 4 | map_any_type.F90 5 | yajl_fort.F90 6 | yajl_ext.c 7 | json.F90 8 | parameter_list_type.F90 9 | parameter_list_json.F90 10 | state_history_type.F90 11 | secure_hash/secure_hash_class.F90 12 | secure_hash/secure_hash_factory.F90 13 | secure_hash/md5_hash_type.F90 14 | secure_hash/sha1_hash_type.F90 15 | timer_tree_type.F90 16 | ) 17 | 18 | if(CMAKE_Fortran_COMPILER_ID MATCHES GNU) 19 | set_property (SOURCE secure_hash/md5_hash_type.F90 20 | secure_hash/sha1_hash_type.F90 21 | PROPERTY COMPILE_FLAGS -fno-range-check) 22 | endif() 23 | 24 | if(CMAKE_Fortran_COMPILER_ID MATCHES Intel) 25 | set_property(SOURCE parameter_list_json.F90 26 | PROPERTY COMPILE_FLAGS "-assume old_e0g0_format") 27 | endif() 28 | 29 | add_library(petaca ${SRC}) 30 | 31 | set(LIB_MOD_DIR ${CMAKE_CURRENT_BINARY_DIR}/mod_files/) 32 | set_target_properties(petaca PROPERTIES Fortran_MODULE_DIRECTORY ${LIB_MOD_DIR}) 33 | 34 | target_link_libraries(petaca PUBLIC YAJL::YAJL dl) 35 | 36 | target_include_directories(petaca PUBLIC 37 | $ 38 | $ 39 | $ 40 | ) 41 | 42 | install(TARGETS petaca 43 | EXPORT petaca 44 | LIBRARY DESTINATION lib 45 | ARCHIVE DESTINATION lib 46 | ) 47 | install(DIRECTORY ${LIB_MOD_DIR} DESTINATION lib) 48 | -------------------------------------------------------------------------------- /test/json/json-ex9.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | integer :: stat 30 | character(:), allocatable :: errmsg 31 | 32 | call json_from_string('[1,2,foo,3]', val, stat, errmsg) 33 | if (stat == 0) stop 1 ! should have been an error 34 | write(*,*) errmsg 35 | 36 | end 37 | -------------------------------------------------------------------------------- /examples/parameter_list_type/parameter_list_example.F90: -------------------------------------------------------------------------------- 1 | program parameter_list_example 2 | 3 | use parameter_list_type 4 | 5 | type(parameter_list) :: plist 6 | type(parameter_list), pointer :: sublist 7 | type(parameter_list_iterator) :: iter 8 | integer :: p 9 | character(:), allocatable :: f 10 | class(*), allocatable :: origin 11 | 12 | type point 13 | real x, y 14 | end type 15 | 16 | !! Parameter lists come into existence well-defined and empty. 17 | !! Define some parameters; note the different types and ranks. 18 | call plist%set ('page', 3) 19 | call plist%set ('size', 1.4) 20 | call plist%set ('color', 'blue') 21 | call plist%set ('boundingbox', [10, 10, 90, 90]) 22 | call plist%set ('crop', .true.) 23 | 24 | !! Replace an existing parameter value with a different value of different type. 25 | call plist%set ('size', 'default') 26 | 27 | !! Retrieve a specific parameter value; its type must match p. 28 | call plist%get ('page', p) 29 | 30 | !! Retrieve a parameter value that doesn't exist; 31 | !! it is created with the specified default value. 32 | call plist%get ('font', f, default='courier') 33 | 34 | !! Create a sublist parameter named 'picture'. 35 | sublist => plist%sublist('picture') 36 | 37 | !! Define a parameter in the sublist; note the derived-type value. 38 | call sublist%set ('origin', point(1.0,2.0)) 39 | 40 | !! Now retrieve the derived type value 41 | call sublist%get ('origin', origin) 42 | select type (origin) 43 | type is (point) 44 | print *, origin%x, origin%y 45 | end select 46 | 47 | !! Walk 48 | iter = parameter_list_iterator(plist) 49 | do while (.not.piter%at_end()) 50 | select case 51 | end do 52 | 53 | 54 | -------------------------------------------------------------------------------- /examples/map_any_type/example.F90: -------------------------------------------------------------------------------- 1 | program example 2 | 3 | use map_any_type 4 | 5 | type(map_any) :: map, map_copy 6 | type(map_any_iterator) :: iter 7 | class(*), pointer :: value 8 | #if defined(INTEL_BUG20180115) 9 | class(*), pointer :: uptr 10 | #endif 11 | 12 | type point 13 | real x, y 14 | end type 15 | 16 | if (.not.map%empty()) print *, 'error: map is not empty!' 17 | 18 | !! Insert some elements into the map; note the different types. 19 | call map%insert ('page', 3) 20 | call map%insert ('size', 1.4) 21 | call map%insert ('color', 'black') 22 | call map%insert ('origin', point(1.0, 2.0)) 23 | 24 | !! Replace existing mapping with a different value of different type. 25 | call map%insert ('size', 'default') 26 | 27 | !! Remove a mapping. 28 | call map%remove ('color') 29 | if (map%mapped('color')) print *, 'error: mapping not removed!' 30 | 31 | !! Retrieve a specific value. 32 | value => map%value('origin') 33 | 34 | !! Write the contents. 35 | iter = map_any_iterator(map) 36 | do while (.not.iter%at_end()) 37 | #if defined(INTEL_BUG20180115) 38 | uptr => iter%value() 39 | select type (uptr) 40 | #else 41 | select type (uptr => iter%value()) 42 | #endif 43 | type is (integer) 44 | print *, iter%key(), ' = ', uptr 45 | type is (real) 46 | print *, iter%key(), ' = ', uptr 47 | type is (character(*)) 48 | print *, iter%key(), ' = ', uptr 49 | type is (point) 50 | print *, iter%key(), ' = ', uptr 51 | end select 52 | call iter%next 53 | end do 54 | 55 | !! Make a copy of the map. 56 | map_copy = map 57 | 58 | !! Delete the contents of map; map_copy is unchanged. 59 | call map%clear 60 | if (map%size() /= 0) print *, 'error: map size is not 0!' 61 | if (map_copy%empty()) print *, 'error: map_copy is empty!' 62 | 63 | call map_copy%clear 64 | 65 | end program 66 | -------------------------------------------------------------------------------- /doc/secure_hash.tex: -------------------------------------------------------------------------------- 1 | \documentclass[11pt]{article} 2 | 3 | \usepackage[latin1]{inputenc} 4 | \usepackage{times} 5 | \usepackage[T1]{fontenc} 6 | 7 | \usepackage{underscore} 8 | \usepackage{verbatim} 9 | \usepackage{enumitem} 10 | 11 | \usepackage[nofancy]{latex2man} 12 | 13 | \usepackage[margin=1.25in,letterpaper]{geometry} 14 | 15 | \setlength{\parindent}{0pt} 16 | 17 | \begin{document} 18 | 19 | %%% SET THE DATE 20 | \setDate{August 2013} 21 | \setVersion{1.0} 22 | 23 | \begin{Name}{3}{Secure Hashes}{Neil N. Carlson}{Petaca}{Secure Hashes} 24 | %%% THE ABSTRACT GOES HERE 25 | This collection of modules provides a common interface to several different 26 | secure hash or message digest algorithms. Currently only MD5 and SHA1 are 27 | implemented, but others are easily implemented within the provided framework. 28 | \end{Name} 29 | 30 | \section{Synopsis} 31 | \begin{description}[style=nextline] 32 | \item[Usage] 33 | \verb+use :: map_any_type+ 34 | \item[Derived Types] 35 | \texttt{map_any},\texttt{ map_any_iterator} 36 | \item[Parameters] 37 | \end{description} 38 | 39 | \section{Mo} 40 | 41 | module secure_hash_class defines the abstract base class secure_hash 42 | from which specific secure hash algorithms are derived. It has the 43 | methods update, hexdigest, reset. 44 | 45 | instantiation. 46 | 47 | 48 | m = md5_hash() 49 | 50 | \section{SECTION TITLE} 51 | 52 | \subsection{Type bound subroutines} 53 | \begin{description}[style=nextline]\setlength{\itemsep}{0pt} 54 | \item[\texttt{some_subroutine(and_its_arguments)}] 55 | \end{description} 56 | 57 | \subsection{Type bound functions} 58 | \begin{description}[style=nextline]\setlength{\itemsep}{0pt} 59 | \item[\texttt{some_function(and_its_arguments)}] 60 | \end{description} 61 | 62 | \section{Example} 63 | \begin{verbatim} 64 | %%% SOME EXAMPLE CODE 65 | \end{verbatim} 66 | 67 | \section{Bugs} 68 | Bug reports and improvement suggestions should be directed to 69 | \Email{neil.n.carlson@gmail.com} 70 | 71 | \LatexManEnd 72 | 73 | \end{document} 74 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | macro(add_serial_test test exe) 2 | add_executable(${exe} ${exe}.F90) 3 | target_link_libraries(${exe} serial-lib) 4 | add_test(${test} ./${exe}) 5 | endmacro() 6 | 7 | add_serial_test(block_solver_procs block_solver_procs_test) 8 | add_serial_test(td_matrix td_matrix_test) 9 | add_serial_test(btd_matrix btd_matrix_test) 10 | 11 | macro(add_parallel_test test exe nproc) 12 | if (CMAKE_Fortran_COMPILER_ID MATCHES GNU) 13 | add_test(${test} cafrun -n ${nproc} ./${exe} ${ARGN}) 14 | else() 15 | add_test(${test} ./${exe} ${ARGN}) 16 | if (CMAKE_Fortran_COMPILER_ID MATCHES NAG) 17 | set_tests_properties(${test} PROPERTIES ENVIRONMENT NAGFORTRAN_NUM_IMAGES=${nproc}) 18 | elseif(CMAKE_Fortran_COMPILER_ID MATCHES Intel) 19 | set_tests_properties(${test} PROPERTIES ENVIRONMENT "FOR_COARRAY_NUM_IMAGES=${nproc}") 20 | endif() 21 | endif() 22 | set_tests_properties(${test} PROPERTIES PROCESSORS ${nproc}) 23 | endmacro() 24 | 25 | add_executable(co_td_matrix_test co_td_matrix_test.F90) 26 | target_link_libraries(co_td_matrix_test parallel-lib) 27 | 28 | # This delegates to the serial td_matrix methods (1 image) 29 | add_parallel_test(co_td_matrix_1 co_td_matrix_test 1 5) 30 | 31 | # This follows the 1x1 and 2x2 non-periodic Schur code paths (2 images) 32 | add_parallel_test(co_td_matrix_2 co_td_matrix_test 2 4) 33 | 34 | # This follows the 2x2 non-periodic and 3x3 periodic Schur code paths (3 images) 35 | add_parallel_test(co_td_matrix_3 co_td_matrix_test 3 6) 36 | 37 | # This follows the code paths for the general case (num_images > 3) 38 | add_parallel_test(co_td_matrix_4 co_td_matrix_test 4 20) 39 | 40 | add_executable(co_btd_matrix_test co_btd_matrix_test.F90) 41 | target_link_libraries(co_btd_matrix_test parallel-lib) 42 | 43 | # This delegates to the serial btd_matrix methods (1 image) 44 | add_parallel_test(co_btd_matrix_1 co_btd_matrix_test 1 2 5) 45 | 46 | # This follows the 1x1 and 2x2 non-periodic Schur code paths (2 images) 47 | add_parallel_test(co_btd_matrix_2 co_btd_matrix_test 2 2 4) 48 | 49 | # This follows the 2x2 non-periodic and 3x3 periodic Schur code paths (3 images) 50 | add_parallel_test(co_btd_matrix_3 co_btd_matrix_test 3 2 6) 51 | 52 | # This follows the code paths for the general case (num_images > 3) 53 | add_parallel_test(co_btd_matrix_4 co_btd_matrix_test 4 4 20) 54 | -------------------------------------------------------------------------------- /src/f90_assert.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! F90_ASSERT -- C-style assertions for Fortran. 3 | !! 4 | !! Neil N. Carlson 5 | !! 6 | !! USAGE 7 | !! 8 | !! At the top of each source file where you wish to use assertions, 9 | !! outside the definition of any module or procedure, include the 10 | !! preprocessor file f90_assert.fpp, 11 | !! 12 | !! #include "f90_assert.fpp" 13 | !! 14 | !! to define the ASSERT() and INSIST() preprocessor macros. If the macro 15 | !! NDEBUG is not defined when the file is passed through the preprocessor, 16 | !! lines of the form 17 | !! 18 | !! ASSERT( ) 19 | !! 20 | !! will be expanded to Fortran code which tests whether the logical 21 | !! expression is true, and if not, calls the following routine which 22 | !! will print the file name and line number and then halt execution. 23 | !! If the macro NDEBUG is defined (e.g., -D NDEBUG), then the ASSERT() 24 | !! is expanded to a Fortran comment line. 25 | !! 26 | !! The INSIST() macro functions exactly like ASSERT() except that it is 27 | !! always expanded to Fortran code that tests the logical expression, 28 | !! regardless of whether NDEBUG is defined or not. 29 | !! 30 | !! This is intentionally not a module procedure. 31 | !! 32 | !! NB: Use with Fortran-aware preprocessors like fpp is robust. One 33 | !! can use the C preprocessor cpp, but if the expanded macro extends 34 | !! the line past 132 characters, a compiler error will probably result. 35 | !! 36 | 37 | subroutine f90_assert (file, line) 38 | 39 | use iso_fortran_env, only: error_unit 40 | 41 | character(*), intent(in) :: file 42 | integer, intent(in) :: line 43 | 44 | write(error_unit,fmt='(3a,i4.4)') 'Assertion failed at ', file, ':', line 45 | stop 1 46 | 47 | end subroutine f90_assert 48 | 49 | !! Here is a possible alternative that should throw an exception instead of 50 | !! terminating normally. Debuggers will catch this. However a breakpoint 51 | !! could be set in the above routine almost as easily. 52 | 53 | !subroutine f90_assert (file, line) 54 | ! 55 | ! use iso_fortran_env, only: error_unit 56 | ! use ieee_exceptions 57 | ! 58 | ! character(*), intent(in) :: file 59 | ! integer, intent(in) :: line 60 | ! 61 | ! write(error_unit,fmt='(3a,i4.4)') 'Assertion failed at ', file, ':', line 62 | ! call ieee_set_halting_mode (ieee_invalid, .true.) 63 | ! call ieee_set_flag (ieee_invalid, .true.) 64 | ! stop 65 | ! 66 | !end subroutine f90_assert 67 | -------------------------------------------------------------------------------- /test/yajl_fort/file1.json: -------------------------------------------------------------------------------- 1 | { 2 | "physical-constants": { 3 | "stefan-boltzmann": 5.67e-14 4 | }, 5 | "mesh": { 6 | "lo": [0,0,0], 7 | "hi": [119,19,14], 8 | "box-size": 30, 9 | "prob-lo": [0.0, 0.0, -0.15], 10 | "prob-hi": [1.2, 0.2, 0.0] 11 | }, 12 | "laser-scan-path": { 13 | "laser": { 14 | "type": "gaussian", 15 | "power": 100.0, // [W] 16 | "sigma": 0.035 // [mm] 17 | }, 18 | "laser-absorp": 0.4, 19 | "laser-time-constant": 0.01, 20 | "scan-path": { 21 | "start-coord": [0.20, 0.0], 22 | "command-file": "path1.json" 23 | }, 24 | "write-plotfile": true, 25 | "plotfile-dt": 0.02 // [ms] 26 | }, 27 | "phase-properties": { 28 | "IN625-sol": { 29 | "conductivity": 0.03, 30 | "density": 7.5e-3, 31 | "specific-heat": 750.0 32 | } 33 | }, 34 | "model": { 35 | "solid": "IN625-sol", 36 | "liquid": "IN625-sol", 37 | "solidus-temp": 1531.0, 38 | "liquidus-temp": 1616.0, 39 | "latent-heat": 2.1754e5, // [g-mm^2/ms^2/g] 40 | "smoothing-radius": 10.0, 41 | "bc": { 42 | "top": { 43 | "condition": "flux", 44 | "sides": ["zhi"], 45 | "data": "laser" 46 | }, 47 | "top-rad": { 48 | "condition": "radiation", 49 | "sides": ["zhi"], 50 | "emissivity": 0.6, 51 | "ambient-temp": 300.0 52 | }, 53 | "bottom": { 54 | "condition": "htc", 55 | "sides": ["zlo"], 56 | "coefficient": 1.0e-4, // [W/mm^2-K] 57 | "ambient-temp": 300.0 58 | }, 59 | "adiabatic": { 60 | "condition": "flux", 61 | "sides": ["xlo", "xhi", "ylo", "yhi"], 62 | "data": 0.0 63 | } 64 | } 65 | }, 66 | "solver": { 67 | "temp-rel-tol": 1.0e-2, 68 | "num-cycles": 2, 69 | "nlk-max-itr": 5, 70 | "nlk-tol": 0.01 71 | }, 72 | "sim-control": { 73 | "initial-time": 0.0, 74 | "initial-time-step": 1.0e-6, 75 | "min-time-step": 1.0e-9, 76 | "output-times": [0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0] 77 | }, 78 | "initial-temperature": { 79 | "type": "constant", 80 | "value": 300.0 81 | }, 82 | 83 | // This sublist is consumed by AMREX_INIT 84 | "amrex": { 85 | "amrex": {"fpe_trap_invalid": 1} 86 | } 87 | } 88 | -------------------------------------------------------------------------------- /test/json/json-ex2.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_array_iterator) :: iter 30 | character(:), allocatable :: errmsg 31 | integer :: stat, n 32 | 33 | call json_from_string('[42,3.14,"foo",true,null]', val, stat, errmsg) 34 | if (stat /= 0) stop 1 35 | 36 | select type (val) 37 | type is (json_array) 38 | 39 | n = 0 40 | iter = json_array_iterator(val) 41 | do while (.not.iter%at_end()) 42 | n = n + 1 43 | select type (ival => iter%value()) 44 | type is (json_integer) 45 | if (n /= 1) stop 11 46 | if (ival%value /= 42) stop 12 47 | type is (json_real) 48 | if (n /= 2) stop 21 49 | if (ival%value /= 3.14d0) stop 22 50 | type is (json_string) 51 | if (n /= 3) stop 31 52 | if (ival%value /= 'foo') stop 32 53 | type is (json_boolean) 54 | if (n /= 4) stop 41 55 | if (.not.ival%value) stop 42 56 | type is (json_null) 57 | if (n /= 5) stop 51 58 | class default 59 | stop 3 60 | end select 61 | call iter%next 62 | end do 63 | 64 | class default 65 | stop 2 66 | end select 67 | 68 | end 69 | -------------------------------------------------------------------------------- /test/json/json-ex3.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_object_iterator) :: iter 30 | character(:), allocatable :: errmsg 31 | integer :: stat 32 | 33 | call json_from_string('{"abc":42,"pi":3.14,"x":"foo","y":true,"z":null}', val, stat, errmsg) 34 | if (stat /= 0) stop 1 35 | 36 | select type (val) 37 | type is (json_object) 38 | 39 | iter = json_object_iterator(val) 40 | do while (.not.iter%at_end()) 41 | select type (ival => iter%value()) 42 | type is (json_integer) 43 | if (iter%name() /= 'abc') stop 11 44 | if (ival%value /= 42) stop 12 45 | type is (json_real) 46 | if (iter%name() /= 'pi') stop 21 47 | if (ival%value /= 3.14d0) stop 22 48 | type is (json_string) 49 | if (iter%name() /= 'x') stop 31 50 | if (ival%value /= 'foo') stop 32 51 | type is (json_boolean) 52 | if (iter%name() /= 'y') stop 41 53 | if (.not.ival%value) stop 42 54 | type is (json_null) 55 | if (iter%name() /= 'z') stop 51 56 | class default 57 | stop 3 58 | end select 59 | call iter%next 60 | end do 61 | 62 | class default 63 | stop 2 64 | end select 65 | 66 | end 67 | -------------------------------------------------------------------------------- /cmake/FindYAJL.cmake: -------------------------------------------------------------------------------- 1 | # This module finds the YAJL library and include file directory. 2 | # YAJL_FOUND is set to True if both are found, and the following 3 | # variables are returned. 4 | # 5 | # YAJL_INCLUDE_DIRS 6 | # YAJL_LIBRARIES 7 | # YAJL_VERSION 8 | # 9 | # This module defines the imported library target YAJL::YAJL. It is 10 | # generally enough to include YAJL::YAJL as a target link library; cmake 11 | # will automatically handle adding the appropriate compile include flags 12 | # and collection of link libraries. 13 | # 14 | # To provide the module with a hint about where to find your YAJL installation 15 | # you have several options. You can include the root installation directory in 16 | # the setting of the CMAKE_PREFIX_PATH variable, or you can set the environment 17 | # variable YAJL_ROOT or the cmake variable YAJL_ROOT. 18 | 19 | if(NOT YAJL_ROOT) 20 | set(YAJL_ROOT $ENV{YAJL_ROOT}) 21 | endif() 22 | if(YAJL_ROOT) 23 | set(yajl_search_opts NO_DEFAULT_PATH) 24 | else() 25 | set(yajl_search_opts) 26 | endif() 27 | 28 | find_path(YAJL_INCLUDE_DIR NAMES yajl/yajl_common.h 29 | HINTS ${YAJL_ROOT} ${yajl_search_opts} PATH_SUFFIXES include) 30 | find_library(YAJL_LIBRARY NAMES yajl yajl_s 31 | HINTS ${YAJL_ROOT} ${yajl_search_opts} PATH_SUFFIXES lib) 32 | 33 | if(NOT YAJL_VERSION) 34 | if(YAJL_INCLUDE_DIR AND YAJL_LIBRARY) 35 | set(yajl_version_h ${YAJL_INCLUDE_DIR}/yajl/yajl_version.h) 36 | include(SearchHeaderFile) 37 | search_header_file(${yajl_version_h} "YAJL_MAJOR" _major) 38 | search_header_file(${yajl_version_h} "YAJL_MINOR" _minor) 39 | search_header_file(${yajl_version_h} "YAJL_MICRO" _micro) 40 | set(YAJL_VERSION ${_major}.${_minor}.${_micro}) 41 | unset(_major) 42 | unset(_minor) 43 | unset(_micro) 44 | unset(yajl_version_h) 45 | else() 46 | set(YAJL_VERSION YAJL_VERSION-NOTFOUND) 47 | endif() 48 | endif() 49 | 50 | include(FindPackageHandleStandardArgs) 51 | find_package_handle_standard_args(YAJL 52 | REQUIRED_VARS YAJL_LIBRARY YAJL_INCLUDE_DIR 53 | VERSION_VAR YAJL_VERSION) 54 | 55 | if(YAJL_FOUND) 56 | set(YAJL_INCLUDE_DIRS ${YAJL_INCLUDE_DIR}) 57 | set(YAJL_LIBRARIES ${YAJL_LIBRARY}) 58 | mark_as_advanced(YAJL_INCLUDE_DIR YAJL_LIBRARY) 59 | if(NOT TARGET YAJL::YAJL) 60 | add_library(YAJL::YAJL UNKNOWN IMPORTED) 61 | set_target_properties(YAJL::YAJL PROPERTIES 62 | IMPORTED_LOCATION "${YAJL_LIBRARY}" 63 | INTERFACE_INCLUDE_DIRECTORIES "${YAJL_INCLUDE_DIRS}" 64 | INTERFACE_LINK_LIBRARIES "${YAJL_LIBRARIES}") 65 | endif() 66 | endif() 67 | -------------------------------------------------------------------------------- /test/fortran_dynamic_loader/test_fortran_dynamic_loader.F90.in: -------------------------------------------------------------------------------- 1 | program shlib_type_test 2 | 3 | use,intrinsic :: iso_fortran_env, only: error_unit 4 | use,intrinsic :: iso_c_binding, only: c_funptr, c_ptr, c_f_procpointer, c_f_pointer, c_float 5 | use fortran_dynamic_loader 6 | implicit none 7 | 8 | abstract interface 9 | real function f(x) bind(c) 10 | real, value :: x 11 | end function 12 | end interface 13 | #ifdef INTEL_BUG20231122 14 | procedure(f), pointer :: fptr => null() 15 | #else 16 | procedure(f), pointer :: fptr 17 | #endif 18 | 19 | integer :: status = 0 20 | 21 | !call test_libm_cbrtf 22 | call test_mylib_square 23 | call test_mylib_var 24 | 25 | if (status /= 0) stop 1 26 | 27 | contains 28 | 29 | ! The libm.so library is no longer an actual library on some platforms, but 30 | ! a linker script which the system dlopen does not know how to deal with. 31 | ! Thus this test is too fragile to be used. Code retained for reference. 32 | 33 | subroutine test_libm_cbrtf 34 | 35 | type(c_funptr) :: funptr 36 | type(shlib) :: libm 37 | 38 | !! Load the C math library libm.so and calculate the cube root 39 | !! of 8.0 using the function cbrtf from the library. 40 | call libm%open ('libm@CMAKE_SHARED_LIBRARY_SUFFIX@', RTLD_NOW) 41 | call libm%func ('cbrtf', funptr) ! cube root function 42 | call c_f_procpointer (funptr, fptr) 43 | if (fptr(8.0) /= 2.0) then 44 | status = 1 45 | write(error_unit,*) 'test_libm_cbrtf failed' 46 | end if 47 | call libm%close 48 | 49 | end subroutine test_libm_cbrtf 50 | 51 | subroutine test_mylib_square 52 | 53 | type(c_funptr) :: funptr 54 | type(shlib) :: mylib 55 | 56 | call mylib%open('./libmylib@CMAKE_SHARED_LIBRARY_SUFFIX@', RTLD_NOW) 57 | call mylib%func ('square', funptr) ! square function 58 | call c_f_procpointer (funptr, fptr) 59 | if (fptr(3.0) /= 9.0) then 60 | print *, fptr(3.0_c_float) 61 | status = 1 62 | write(error_unit,*) 'test_mylib_square failed' 63 | end if 64 | call mylib%close 65 | 66 | end subroutine test_mylib_square 67 | 68 | subroutine test_mylib_var 69 | type(shlib) :: mylib 70 | integer, pointer :: n 71 | type(c_ptr) :: ptr 72 | call mylib%open('./libmylib@CMAKE_SHARED_LIBRARY_SUFFIX@', RTLD_NOW) 73 | call mylib%sym('FORTYTWO', ptr) 74 | call c_f_pointer(ptr, n) 75 | if (n /= 42) then 76 | status = 1 77 | write(error_unit,*) 'test_mylib_var failed' 78 | end if 79 | call mylib%close 80 | end subroutine test_mylib_var 81 | 82 | end program 83 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/README.md: -------------------------------------------------------------------------------- 1 | # Tridiagonal Linear System Solvers 2 | 3 | This directory contains several modules that define derived types for storing 4 | tridiagonal matrices with methods for solving associated linear systems and 5 | matrix-vector products. The derived types also provide optional support for 6 | periodic tridiagonal matrices and linear systems. These are suitable for 7 | diagonally-dominant matrices or other matrix types that do not require 8 | pivoting for stability when factoring. The modules are 9 | 10 | * `td_matrix_type` -- standard tridiagonal matrix 11 | * `btd_matrix_type` -- block tridiagonal matrix 12 | * `co_td_matrix_type` -- parallel version of `td_matrix_type` using coarrays 13 | * `co_btd_matrix_type` -- parallel version of `btd_matrix_type` using coarrays 14 | 15 | For the parallel versions, the rows (or block rows here and following) of the 16 | matrix (and the corresponding unknowns) are partitioned with successive 17 | partitions stored in successive images. The last row of each partition (except 18 | the last if not periodic), which couples unknowns in adjacent images, are 19 | *boundary* rows. The remaining rows are *interior* rows. To compute an LU 20 | factorization of the matrix, the interior rows are first eliminated. This is 21 | done in parallel and requires no communication between images. This leaves a 22 | reduced tridiagonal Schur complement system involving just the boundary 23 | unknowns (one per image) whose LU factorization is computed in serial. 24 | 25 | ## Class Diagram 26 | ```mermaid 27 | classDiagram 28 | direction LR 29 | td_matrix <|-- co_td_matrix 30 | btd_matrix <|-- co_btd_matrix 31 | co_btd_matrix ..> block_solver_procs 32 | btd_matrix ..> block_solver_procs 33 | <> block_solver_procs 34 | ``` 35 | 36 | ## Module Dependency 37 | ```mermaid 38 | flowchart LR 39 | co_td_matrix_type --> td_matrix_type 40 | co_btd_matrix_type --> btd_matrix_type --> block_solver_procs 41 | ``` 42 | 43 | ## Compiling and Testing 44 | From the directory containing this README file: 45 | ```sh 46 | $ mkdir build 47 | $ cd build 48 | $ cmake .. 49 | $ make 50 | $ ctest -V 51 | ``` 52 | The CMake build system understands the NAG, Intel oneAPI classic `ifort` and 53 | LLVM-based `ifx`, and gfortran/opencoarray compilers. You may need to set your 54 | `FC` environment variable to the path to your compiler before running `cmake`. 55 | For gfortran you must set `FC=caf` (the compiler wrapper `caf` is provided by 56 | opencoarrays). 57 | 58 | The test problems in the `test` directory serve as usage examples. 59 | 60 | ## Status 61 | 62 | * All tests are working with the above mentioned compilers. 63 | * The perfomance of the parallel versions is currently quite disappointing and 64 | is being investigated. 65 | -------------------------------------------------------------------------------- /test/json/json-ex1.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | call run_tests 29 | 30 | contains 31 | 32 | subroutine run_tests 33 | 34 | class(json_value), allocatable :: val 35 | character(:), allocatable :: errmsg 36 | integer :: stat 37 | 38 | call json_from_string('42', val, stat, errmsg) 39 | if (stat /= 0) stop 11 40 | select type (val) 41 | type is (json_integer) 42 | if (val%value /= 42) stop 12 43 | class default 44 | stop 13 45 | end select 46 | 47 | call json_from_string('3.14', val, stat, errmsg) 48 | if (stat /= 0) stop 21 49 | select type (val) 50 | type is (json_real) 51 | if (val%value /= 3.14d0) stop 22 52 | class default 53 | stop 23 54 | end select 55 | 56 | call json_from_string('"foo"', val, stat, errmsg) 57 | if (stat /= 0) stop 31 58 | select type (val) 59 | type is (json_string) 60 | if (val%value /= 'foo') stop 32 61 | class default 62 | stop 33 63 | end select 64 | 65 | call json_from_string('true', val, stat, errmsg) 66 | if (stat /= 0) stop 41 67 | select type (val) 68 | type is (json_boolean) 69 | if (.not.val%value) stop 42 70 | class default 71 | stop 43 72 | end select 73 | 74 | call json_from_string('false', val, stat, errmsg) 75 | if (stat /= 0) stop 51 76 | select type (val) 77 | type is (json_boolean) 78 | if (val%value) stop 52 79 | class default 80 | stop 53 81 | end select 82 | 83 | call json_from_string('null', val, stat, errmsg) 84 | if (stat /= 0) stop 61 85 | select type (val) 86 | type is (json_null) 87 | class default 88 | stop 63 89 | end select 90 | 91 | end subroutine 92 | 93 | end 94 | -------------------------------------------------------------------------------- /test/json/json-ex7.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_array_iterator) :: iter1, iter3 30 | type(json_object_iterator) :: iter2 31 | character(:), allocatable :: errmsg 32 | integer :: stat, n1, n3 33 | 34 | call json_from_string('[{"a":[42]}]', val, stat, errmsg) 35 | if (stat /= 0) stop 1 36 | 37 | select type (val) 38 | type is (json_array) 39 | 40 | n1 = 0 41 | iter1 = json_array_iterator(val) 42 | do while (.not.iter1%at_end()) 43 | n1 = n1 + 1 44 | select type (ival1 => iter1%value()) 45 | type is (json_object) 46 | if (n1 /= 1) stop 11 47 | iter2 = json_object_iterator(ival1) 48 | do while (.not.iter2%at_end()) 49 | select case (iter2%name()) 50 | case ('a') 51 | select type (ival2 => iter2%value()) 52 | type is (json_array) 53 | n3 = 0 54 | iter3 = json_array_iterator(ival2) 55 | do while (.not.iter3%at_end()) 56 | n3 = n3 + 1 57 | select type (ival3 => iter3%value()) 58 | type is (json_integer) 59 | if (n3 /= 1) stop 10 60 | if (ival3%value /= 42) stop 9 61 | class default 62 | stop 8 63 | end select 64 | call iter3%next 65 | end do 66 | if (n3 /= 1) stop 7 67 | class default 68 | stop 6 69 | end select 70 | case default 71 | stop 5 72 | end select 73 | call iter2%next 74 | end do 75 | class default 76 | stop 4 77 | end select 78 | call iter1%next 79 | end do 80 | if (n1 /= 1) stop 3 81 | 82 | class default 83 | stop 2 84 | end select 85 | 86 | end 87 | -------------------------------------------------------------------------------- /test/json/json-ex6.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_object_iterator) :: iter1, iter3 30 | type(json_array_iterator) :: iter2 31 | character(:), allocatable :: errmsg 32 | integer :: stat, n2 33 | 34 | call json_from_string('{"a":[{"b":42}]}', val, stat, errmsg) 35 | if (stat /= 0) stop 1 36 | 37 | select type (val) 38 | type is (json_object) 39 | 40 | iter1 = json_object_iterator(val) 41 | do while (.not.iter1%at_end()) 42 | select case (iter1%name()) 43 | case ('a') 44 | select type (ival1 => iter1%value()) 45 | type is (json_array) 46 | n2 = 0 47 | iter2 = json_array_iterator(ival1) 48 | do while (.not.iter2%at_end()) 49 | n2 = n2 + 1 50 | select type (ival2 => iter2%value()) 51 | type is (json_object) 52 | if (n2 /= 1) stop 10 53 | iter3 = json_object_iterator(ival2) 54 | do while (.not.iter3%at_end()) 55 | select case (iter3%name()) 56 | case ('b') 57 | select type (ival3 => iter3%value()) 58 | type is (json_integer) 59 | if (ival3%value /= 42) stop 9 60 | class default 61 | stop 8 62 | end select 63 | case default 64 | stop 7 65 | end select 66 | call iter3%next 67 | end do 68 | class default 69 | stop 6 70 | end select 71 | call iter2%next 72 | end do 73 | if (n2 /= 1) stop 5 74 | class default 75 | stop 4 76 | end select 77 | case default 78 | stop 3 79 | end select 80 | call iter1%next 81 | end do 82 | 83 | class default 84 | stop 2 85 | end select 86 | 87 | end 88 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.20.2) 2 | 3 | project(Petaca Fortran C) 4 | 5 | set(CMAKE_MODULE_PATH "${Petaca_SOURCE_DIR}/cmake/") 6 | 7 | # If necessary, set YAJL_ROOT to the yajl installation root 8 | find_package(YAJL REQUIRED) 9 | if(YAJL_VERSION VERSION_LESS "2.0.1") 10 | message(FATAL_ERROR "libyajl 2.0.1 or later is required") 11 | endif() 12 | 13 | # CMake build options 14 | option(BUILD_EXAMPLES "Build example programs" OFF) 15 | option(BUILD_HTML "Build HTML documentation (requires Sphinx)" OFF) 16 | option(BUILD_SHARED_LIBS "Build shared object library" ON) 17 | option(ENABLE_STD_MOD_PROC_NAME "Build with -assume std_mod_proc_name when using Intel" OFF) 18 | 19 | # Some Fortran compilers may not support 128-bit reals 20 | include(CheckFortranSourceCompiles) 21 | check_fortran_source_compiles("use::iso_fortran_env;real(real128)::x;end" real128 SRC_EXT ".f90") 22 | if(real128) 23 | add_compile_definitions($<$:HAVE_REAL128>) 24 | endif() 25 | 26 | include(CTest) # defines option BUILD_TESTING (on) 27 | 28 | if(NOT CMAKE_BUILD_TYPE) 29 | message(STATUS "Setting build type to 'Release' as none was specified") 30 | set(CMAKE_BUILD_TYPE "Release" CACHE STRING "Choose the type of build" FORCE) 31 | endif() 32 | 33 | # Set missing CMake defaults for the NAG Fortran compiler 34 | if(CMAKE_Fortran_COMPILER_ID STREQUAL NAG) 35 | set(CMAKE_Fortran_FLAGS_DEBUG "-u -O0 -gline -C -nan") 36 | set(CMAKE_Fortran_FLAGS_RELEASE "-u -O3") 37 | set(CMAKE_Fortran_FLAGS_RELWITHDEBINFO "${CMAKE_Fortran_FLAGS_RELEASE} -g") 38 | endif() 39 | 40 | set(Petaca_INCLUDE_DIR ${Petaca_SOURCE_DIR}/include) 41 | 42 | # Disable assertions in release builds 43 | add_compile_definitions($<$:NDEBUG>) 44 | 45 | # Compiler bug workarounds 46 | add_compile_definitions( 47 | $<$:INTEL_BUG20231123> 48 | $<$:INTEL_BUG20231122> 49 | $<$:INTEL_BUG20231123> 50 | $<$:INTEL_BUG20231205> 51 | $<$:INTEL_BUG20231210> 52 | $<$:GNU_PR93762> 53 | $<$:GNU_PR112964> 54 | $<$:GNU_PR114827> 55 | $<$:NAG_BUG20231204> 56 | $<$:NAG_BUG20231206> 57 | ) 58 | 59 | # Required compiler options 60 | add_compile_options($<$:-f2018>) 61 | add_compile_options($<$:-ffree-line-length-none>) 62 | add_compile_options("$<$:-standard-semantics>" 63 | "$<$>,$>:SHELL:-assume nostd_mod_proc_name>") 64 | 65 | add_subdirectory(src) 66 | 67 | if(BUILD_TESTING) 68 | add_subdirectory(test) 69 | endif() 70 | 71 | if(BUILD_EXAMPLES) 72 | add_subdirectory(examples) 73 | endif() 74 | 75 | if(BUILD_HTML) 76 | find_package(Sphinx REQUIRED) 77 | add_subdirectory(doc/sphinx) 78 | endif() 79 | 80 | add_subdirectory(templates) 81 | -------------------------------------------------------------------------------- /templates/wavl-tree/test/perf_test.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2022 Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | program perf_test 26 | 27 | use,intrinsic :: iso_fortran_env, only: i8 => int64 28 | use wavl_tree_type 29 | implicit none 30 | 31 | integer :: n, p 32 | integer, allocatable :: seed(:), array1(:), array2(:) 33 | integer(i8) :: t1, t2, rate 34 | real :: r 35 | type(wavl_tree) :: tree 36 | 37 | call random_seed(size=n) 38 | allocate(seed(n)) 39 | seed = -452913 40 | 41 | p = 20 42 | n = 2**p - 1 43 | allocate(array1(n), array2(n)) 44 | do n = 1, size(array1) 45 | call random_number(r) 46 | array1(n) = r * 2**(p+2) 47 | call random_number(r) 48 | array2(n) = r * 2**(p+2) 49 | end do 50 | 51 | call insertion(array1) 52 | call lookup(array2) 53 | call deletion(array1) 54 | 55 | contains 56 | 57 | subroutine insertion(array) 58 | integer, intent(in) :: array(:) 59 | call system_clock(t1) 60 | do n = 1, size(array) 61 | call tree%insert(array(n), -array(n)) 62 | end do 63 | call system_clock(t2, rate) 64 | write(*,'(a,i0,a,g0,a)') 'insertion of ', size(array), ' random values: ', real(t2-t1)/real(rate), ' sec' 65 | end subroutine 66 | 67 | subroutine lookup(array) 68 | integer, intent(in) :: array(:) 69 | type(rbt_node), pointer :: node 70 | logical :: dummy 71 | call system_clock(t1) 72 | do n = 1, size(array) 73 | node => tree%lookup(array(n)) 74 | end do 75 | call system_clock(t2, rate) 76 | write(*,'(a,i0,a,g0,a)') 'lookup of ', size(array), ' random values: ', real(t2-t1)/real(rate), ' sec' 77 | end subroutine 78 | 79 | subroutine deletion(array) 80 | integer, intent(in) :: array(:) 81 | call system_clock(t1) 82 | do n = 1, size(array) 83 | call tree%delete(array(n)) 84 | end do 85 | call system_clock(t2, rate) 86 | write(*,'(a,i0,a,g0,a)') 'deletion of ', size(array), ' random values: ', real(t2-t1)/real(rate), ' sec' 87 | end subroutine 88 | 89 | end program 90 | -------------------------------------------------------------------------------- /test/json/json-ex4.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_array_iterator) :: iter1, iter2, iter3 30 | character(:), allocatable :: errmsg 31 | integer :: stat, n1, n2, n3 32 | 33 | call json_from_string('[1,[2,[3]],[]]', val, stat, errmsg) 34 | if (stat /= 0) stop 1 35 | 36 | select type (val) 37 | type is (json_array) 38 | 39 | n1 = 0 40 | iter1 = json_array_iterator(val) 41 | do while (.not.iter1%at_end()) 42 | n1 = n1 + 1 43 | select type (ival1 => iter1%value()) 44 | type is (json_integer) 45 | if (n1 /= 1) stop 11 46 | if (ival1%value /= 1) stop 12 47 | type is (json_array) 48 | select case (n1) 49 | case (2) 50 | n2 = 0 51 | iter2 = json_array_iterator(ival1) 52 | do while (.not.iter2%at_end()) 53 | n2 = n2 + 1 54 | select type (ival2 => iter2%value()) 55 | type is (json_integer) 56 | if (n2 /= 1) stop 21 57 | if (ival2%value /= 2) stop 22 58 | type is (json_array) 59 | if (n2 /= 2) stop 21 60 | n3 = 0 61 | iter3 = json_array_iterator(ival2) 62 | do while (.not.iter3%at_end()) 63 | n3 = n3 + 1 64 | select type (ival3 => iter3%value()) 65 | type is (json_integer) 66 | if (n3 /= 1) stop 31 67 | if (ival3%value /= 3) stop 32 68 | class default 69 | stop 10 70 | end select 71 | call iter3%next 72 | end do 73 | if (n3 /= 1) stop 9 74 | class default 75 | stop 8 76 | end select 77 | call iter2%next 78 | end do 79 | if (n2 /= 2) stop 7 80 | case (3) 81 | iter2 = json_array_iterator(ival1) 82 | if (.not.iter2%at_end()) stop 6 83 | case default 84 | stop 5 85 | end select 86 | class default 87 | stop 4 88 | end select 89 | call iter1%next 90 | end do 91 | if (n1 /= 3) stop 3 92 | class default 93 | stop 2 94 | end select 95 | 96 | end 97 | -------------------------------------------------------------------------------- /src/secure_hash/secure_hash_factory.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! SECURE_HASH_FACTORY 3 | !! 4 | !! Convenience procedure to create a CLASS(SECURE_HASH) variable of a given 5 | !! dynamic type. 6 | !! 7 | !! Neil N. Carlson 8 | !! 9 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 10 | !! 11 | !! Copyright (c) 2013 Neil N. Carlson 12 | !! 13 | !! Permission is hereby granted, free of charge, to any person obtaining a 14 | !! copy of this software and associated documentation files (the "Software"), 15 | !! to deal in the Software without restriction, including without limitation 16 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 17 | !! and/or sell copies of the Software, and to permit persons to whom the 18 | !! Software is furnished to do so, subject to the following conditions: 19 | !! 20 | !! The above copyright notice and this permission notice shall be included 21 | !! in all copies or substantial portions of the Software. 22 | !! 23 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 24 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 25 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 26 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 27 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 28 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 29 | !! DEALINGS IN THE SOFTWARE. 30 | !! 31 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 32 | !! 33 | !! PROGRAMMING INTERFACE 34 | !! 35 | !! CALL NEW_SECURE_HASH (HASH, HASH_TYPE) allocates a new CLASS(SECURE_HASH) 36 | !! variable HASH, of the type specified by HASH_TYPE. The allowed values 37 | !! for HASH_TYPE are 'md5' and 'sha1'. HASH may be either allocatable or 38 | !! a pointer. 39 | !! 40 | !! With the Intel compiler, HASH is limited to being allocatable only, due 41 | !! to a missing implementation of a Fortran 2008 feature. 42 | !! 43 | 44 | #include "f90_assert.fpp" 45 | 46 | module secure_hash_factory 47 | 48 | use secure_hash_class 49 | use md5_hash_type 50 | use sha1_hash_type 51 | implicit none 52 | private 53 | 54 | public :: secure_hash, new_secure_hash 55 | 56 | interface new_secure_hash 57 | #ifdef INTEL_BUG20231123 58 | ! Intel compiler can't distinguish the two specifics per F2008 59 | procedure new_secure_hash_alloc!, new_secure_hash_ptr 60 | #else 61 | procedure new_secure_hash_alloc, new_secure_hash_ptr 62 | #endif 63 | end interface 64 | 65 | contains 66 | 67 | subroutine new_secure_hash_alloc (hash, hash_type) 68 | class(secure_hash), allocatable, intent(out) :: hash 69 | character(*), intent(in) :: hash_type 70 | select case (hash_type) 71 | case ('sha1') 72 | allocate(sha1_hash::hash) 73 | case ('md5') 74 | allocate(md5_hash::hash) 75 | case default 76 | INSIST(.false.) 77 | end select 78 | end subroutine new_secure_hash_alloc 79 | 80 | subroutine new_secure_hash_ptr (hash, hash_type) 81 | class(secure_hash), pointer, intent(out) :: hash 82 | character(*), intent(in) :: hash_type 83 | select case (hash_type) 84 | case ('sha1') 85 | allocate(sha1_hash::hash) 86 | case ('md5') 87 | allocate(md5_hash::hash) 88 | case default 89 | INSIST(.false.) 90 | end select 91 | end subroutine new_secure_hash_ptr 92 | 93 | end module secure_hash_factory 94 | -------------------------------------------------------------------------------- /src/secure_hash/reference-C-code/sha1.h: -------------------------------------------------------------------------------- 1 | /* Declarations of functions and data types used for SHA1 sum 2 | library functions. 3 | Copyright (C) 2000-2001, 2003, 2005-2006, 2008-2013 Free Software 4 | Foundation, Inc. 5 | 6 | This program is free software; you can redistribute it and/or modify it 7 | under the terms of the GNU General Public License as published by the 8 | Free Software Foundation; either version 3, or (at your option) any 9 | later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program; if not, see . */ 18 | 19 | #ifndef SHA1_H 20 | # define SHA1_H 1 21 | 22 | # include 23 | # include 24 | 25 | # ifdef __cplusplus 26 | extern "C" { 27 | # endif 28 | 29 | #define SHA1_DIGEST_SIZE 20 30 | 31 | /* Structure to save state of computation between the single steps. */ 32 | struct sha1_ctx 33 | { 34 | uint32_t A; 35 | uint32_t B; 36 | uint32_t C; 37 | uint32_t D; 38 | uint32_t E; 39 | 40 | uint32_t total[2]; 41 | uint32_t buflen; 42 | uint32_t buffer[32]; 43 | }; 44 | 45 | 46 | /* Initialize structure containing state of computation. */ 47 | extern void sha1_init_ctx (struct sha1_ctx *ctx); 48 | 49 | /* Starting with the result of former calls of this function (or the 50 | initialization function update the context for the next LEN bytes 51 | starting at BUFFER. 52 | It is necessary that LEN is a multiple of 64!!! */ 53 | extern void sha1_process_block (const void *buffer, size_t len, 54 | struct sha1_ctx *ctx); 55 | 56 | /* Starting with the result of former calls of this function (or the 57 | initialization function update the context for the next LEN bytes 58 | starting at BUFFER. 59 | It is NOT required that LEN is a multiple of 64. */ 60 | extern void sha1_process_bytes (const void *buffer, size_t len, 61 | struct sha1_ctx *ctx); 62 | 63 | /* Process the remaining bytes in the buffer and put result from CTX 64 | in first 20 bytes following RESBUF. The result is always in little 65 | endian byte order, so that a byte-wise output yields to the wanted 66 | ASCII representation of the message digest. */ 67 | extern void *sha1_finish_ctx (struct sha1_ctx *ctx, void *resbuf); 68 | 69 | 70 | /* Put result from CTX in first 20 bytes following RESBUF. The result is 71 | always in little endian byte order, so that a byte-wise output yields 72 | to the wanted ASCII representation of the message digest. */ 73 | extern void *sha1_read_ctx (const struct sha1_ctx *ctx, void *resbuf); 74 | 75 | 76 | /* Compute SHA1 message digest for bytes read from STREAM. The 77 | resulting message digest number will be written into the 20 bytes 78 | beginning at RESBLOCK. */ 79 | extern int sha1_stream (FILE *stream, void *resblock); 80 | 81 | /* Compute SHA1 message digest for LEN bytes beginning at BUFFER. The 82 | result is always in little endian byte order, so that a byte-wise 83 | output yields to the wanted ASCII representation of the message 84 | digest. */ 85 | extern void *sha1_buffer (const char *buffer, size_t len, void *resblock); 86 | 87 | # ifdef __cplusplus 88 | } 89 | # endif 90 | 91 | #endif 92 | -------------------------------------------------------------------------------- /examples/timer_tree/timer_tree_example.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2013 Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | program timer_tree_example 26 | 27 | use timer_tree_type 28 | use,intrinsic :: iso_fortran_env, only: output_unit 29 | 30 | real :: tspin, x 31 | integer :: nspin 32 | 33 | call calibrate_spin ! configures spin to do a fixed amount of work 34 | 35 | call start_timer ("A") 36 | call start_timer ("B") 37 | call spin ! do some work 38 | call stop_timer ("B") 39 | call spin 40 | call start_timer ("C") 41 | call spin 42 | call start_timer ("B") 43 | call spin 44 | call stop_timer ("B") 45 | call stop_timer ("C") 46 | call stop_timer ("A") 47 | call start_timer ("B") 48 | call start_timer ("X") 49 | call spin 50 | call stop_timer ("X") 51 | call start_timer ("Y") 52 | call spin 53 | call stop_timer ("Y") 54 | call start_timer ("Z") 55 | call spin 56 | call stop_timer ("Z") 57 | call stop_timer ("B") 58 | call start_timer ("A") 59 | call spin 60 | call stop_timer ("A") 61 | 62 | call write_timer_tree (output_unit, indent=2) 63 | 64 | contains 65 | 66 | subroutine spin() 67 | integer :: j 68 | x = 0.0 69 | do j = 1, nspin 70 | x = (x**2 - 1.0)**2 71 | end do 72 | end subroutine spin 73 | 74 | subroutine calibrate_spin () 75 | 76 | real, parameter :: TARGET_TIME = 0.01 77 | integer, parameter :: SAMPLE_SIZE = 1 78 | integer :: n0, n1 79 | real :: t0, t1 80 | 81 | nspin = 8192 82 | tspin = 0.0 !average_spin_time() 83 | do while (tspin < TARGET_TIME) 84 | n0 = nspin 85 | t0 = tspin 86 | nspin = 4*nspin 87 | tspin = average_spin_time(SAMPLE_SIZE) 88 | end do 89 | 90 | n1 = nspin 91 | t1 = tspin 92 | 93 | nspin = n0 + (n1-n0)*((TARGET_TIME-t0)/(t1-t0)) 94 | tspin = average_spin_time(SAMPLE_SIZE) 95 | 96 | end subroutine calibrate_spin 97 | 98 | real function average_spin_time (n) 99 | integer, intent(in) :: n 100 | integer :: j 101 | real :: t0, t1 102 | average_spin_time = 0.0 103 | do j = 1, n 104 | call cpu_time (t0) 105 | call spin 106 | call cpu_time (t1) 107 | average_spin_time = average_spin_time + (t1 - t0) 108 | end do 109 | average_spin_time = average_spin_time / n 110 | end function average_spin_time 111 | 112 | end program 113 | -------------------------------------------------------------------------------- /src/secure_hash/reference-C-code/sha256.h: -------------------------------------------------------------------------------- 1 | /* Declarations of functions and data types used for SHA256 and SHA224 sum 2 | library functions. 3 | Copyright (C) 2005-2006, 2008-2013 Free Software Foundation, Inc. 4 | 5 | This program is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . */ 17 | 18 | #ifndef SHA256_H 19 | # define SHA256_H 1 20 | 21 | # include 22 | # include 23 | 24 | # ifdef __cplusplus 25 | extern "C" { 26 | # endif 27 | 28 | /* Structure to save state of computation between the single steps. */ 29 | struct sha256_ctx 30 | { 31 | uint32_t state[8]; 32 | 33 | uint32_t total[2]; 34 | size_t buflen; 35 | uint32_t buffer[32]; 36 | }; 37 | 38 | enum { SHA224_DIGEST_SIZE = 224 / 8 }; 39 | enum { SHA256_DIGEST_SIZE = 256 / 8 }; 40 | 41 | /* Initialize structure containing state of computation. */ 42 | extern void sha256_init_ctx (struct sha256_ctx *ctx); 43 | extern void sha224_init_ctx (struct sha256_ctx *ctx); 44 | 45 | /* Starting with the result of former calls of this function (or the 46 | initialization function update the context for the next LEN bytes 47 | starting at BUFFER. 48 | It is necessary that LEN is a multiple of 64!!! */ 49 | extern void sha256_process_block (const void *buffer, size_t len, 50 | struct sha256_ctx *ctx); 51 | 52 | /* Starting with the result of former calls of this function (or the 53 | initialization function update the context for the next LEN bytes 54 | starting at BUFFER. 55 | It is NOT required that LEN is a multiple of 64. */ 56 | extern void sha256_process_bytes (const void *buffer, size_t len, 57 | struct sha256_ctx *ctx); 58 | 59 | /* Process the remaining bytes in the buffer and put result from CTX 60 | in first 32 (28) bytes following RESBUF. The result is always in little 61 | endian byte order, so that a byte-wise output yields to the wanted 62 | ASCII representation of the message digest. */ 63 | extern void *sha256_finish_ctx (struct sha256_ctx *ctx, void *resbuf); 64 | extern void *sha224_finish_ctx (struct sha256_ctx *ctx, void *resbuf); 65 | 66 | 67 | /* Put result from CTX in first 32 (28) bytes following RESBUF. The result is 68 | always in little endian byte order, so that a byte-wise output yields 69 | to the wanted ASCII representation of the message digest. */ 70 | extern void *sha256_read_ctx (const struct sha256_ctx *ctx, void *resbuf); 71 | extern void *sha224_read_ctx (const struct sha256_ctx *ctx, void *resbuf); 72 | 73 | 74 | /* Compute SHA256 (SHA224) message digest for bytes read from STREAM. The 75 | resulting message digest number will be written into the 32 (28) bytes 76 | beginning at RESBLOCK. */ 77 | extern int sha256_stream (FILE *stream, void *resblock); 78 | extern int sha224_stream (FILE *stream, void *resblock); 79 | 80 | /* Compute SHA256 (SHA224) message digest for LEN bytes beginning at BUFFER. The 81 | result is always in little endian byte order, so that a byte-wise 82 | output yields to the wanted ASCII representation of the message 83 | digest. */ 84 | extern void *sha256_buffer (const char *buffer, size_t len, void *resblock); 85 | extern void *sha224_buffer (const char *buffer, size_t len, void *resblock); 86 | 87 | # ifdef __cplusplus 88 | } 89 | # endif 90 | 91 | #endif 92 | -------------------------------------------------------------------------------- /src/secure_hash/reference-C-code/sha512.h: -------------------------------------------------------------------------------- 1 | /* Declarations of functions and data types used for SHA512 and SHA384 sum 2 | library functions. 3 | Copyright (C) 2005-2006, 2008-2013 Free Software Foundation, Inc. 4 | 5 | This program is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . */ 17 | 18 | #ifndef SHA512_H 19 | # define SHA512_H 1 20 | 21 | # include 22 | 23 | # include "u64.h" 24 | 25 | # ifdef __cplusplus 26 | extern "C" { 27 | # endif 28 | 29 | /* Structure to save state of computation between the single steps. */ 30 | struct sha512_ctx 31 | { 32 | u64 state[8]; 33 | 34 | u64 total[2]; 35 | size_t buflen; 36 | u64 buffer[32]; 37 | }; 38 | 39 | enum { SHA384_DIGEST_SIZE = 384 / 8 }; 40 | enum { SHA512_DIGEST_SIZE = 512 / 8 }; 41 | 42 | /* Initialize structure containing state of computation. */ 43 | extern void sha512_init_ctx (struct sha512_ctx *ctx); 44 | extern void sha384_init_ctx (struct sha512_ctx *ctx); 45 | 46 | /* Starting with the result of former calls of this function (or the 47 | initialization function update the context for the next LEN bytes 48 | starting at BUFFER. 49 | It is necessary that LEN is a multiple of 128!!! */ 50 | extern void sha512_process_block (const void *buffer, size_t len, 51 | struct sha512_ctx *ctx); 52 | 53 | /* Starting with the result of former calls of this function (or the 54 | initialization function update the context for the next LEN bytes 55 | starting at BUFFER. 56 | It is NOT required that LEN is a multiple of 128. */ 57 | extern void sha512_process_bytes (const void *buffer, size_t len, 58 | struct sha512_ctx *ctx); 59 | 60 | /* Process the remaining bytes in the buffer and put result from CTX 61 | in first 64 (48) bytes following RESBUF. The result is always in little 62 | endian byte order, so that a byte-wise output yields to the wanted 63 | ASCII representation of the message digest. */ 64 | extern void *sha512_finish_ctx (struct sha512_ctx *ctx, void *resbuf); 65 | extern void *sha384_finish_ctx (struct sha512_ctx *ctx, void *resbuf); 66 | 67 | 68 | /* Put result from CTX in first 64 (48) bytes following RESBUF. The result is 69 | always in little endian byte order, so that a byte-wise output yields 70 | to the wanted ASCII representation of the message digest. 71 | 72 | IMPORTANT: On some systems it is required that RESBUF is correctly 73 | aligned for a 32 bits value. */ 74 | extern void *sha512_read_ctx (const struct sha512_ctx *ctx, void *resbuf); 75 | extern void *sha384_read_ctx (const struct sha512_ctx *ctx, void *resbuf); 76 | 77 | 78 | /* Compute SHA512 (SHA384) message digest for bytes read from STREAM. The 79 | resulting message digest number will be written into the 64 (48) bytes 80 | beginning at RESBLOCK. */ 81 | extern int sha512_stream (FILE *stream, void *resblock); 82 | extern int sha384_stream (FILE *stream, void *resblock); 83 | 84 | /* Compute SHA512 (SHA384) message digest for LEN bytes beginning at BUFFER. The 85 | result is always in little endian byte order, so that a byte-wise 86 | output yields to the wanted ASCII representation of the message 87 | digest. */ 88 | extern void *sha512_buffer (const char *buffer, size_t len, void *resblock); 89 | extern void *sha384_buffer (const char *buffer, size_t len, void *resblock); 90 | 91 | # ifdef __cplusplus 92 | } 93 | # endif 94 | 95 | #endif 96 | -------------------------------------------------------------------------------- /test/json/json-ex5.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_object_iterator) :: iter1, iter2, iter3 30 | character(:), allocatable :: errmsg 31 | integer :: stat 32 | 33 | call json_from_string('{"a":1,"b":{"c":2,"d":{"e":3}},"f":{}}', val, stat, errmsg) 34 | if (stat /= 0) stop 1 35 | 36 | select type (val) 37 | type is (json_object) 38 | 39 | iter1 = json_object_iterator(val) 40 | do while (.not.iter1%at_end()) 41 | select case (iter1%name()) 42 | case ('a') 43 | select type (ival1 => iter1%value()) 44 | type is (json_integer) 45 | if (ival1%value /= 1) stop 15 46 | class default 47 | stop 14 48 | end select 49 | case ('b') 50 | select type (ival1 => iter1%value()) 51 | type is (json_object) 52 | iter2 = json_object_iterator(ival1) 53 | do while (.not.iter2%at_end()) 54 | select case (iter2%name()) 55 | case ('c') 56 | select type (ival2 => iter2%value()) 57 | type is (json_integer) 58 | if (ival2%value /= 2) stop 13 59 | class default 60 | stop 12 61 | end select 62 | case ('d') 63 | select type (ival2 => iter2%value()) 64 | type is (json_object) 65 | iter3 = json_object_iterator(ival2) 66 | do while (.not.iter3%at_end()) 67 | select case (iter3%name()) 68 | case ('e') 69 | select type (ival3 => iter3%value()) 70 | type is (json_integer) 71 | if (ival3%value /= 3) stop 11 72 | class default 73 | stop 10 74 | end select 75 | case default 76 | stop 9 77 | end select 78 | call iter3%next 79 | end do 80 | class default 81 | stop 8 82 | end select 83 | case default 84 | stop 7 85 | end select 86 | call iter2%next 87 | end do 88 | class default 89 | stop 6 90 | end select 91 | case ('f') 92 | select type (ival1 => iter1%value()) 93 | type is (json_object) 94 | iter2 = json_object_iterator(ival1) 95 | if (.not.iter2%at_end()) stop 5 96 | class default 97 | stop 4 98 | end select 99 | case default 100 | stop 3 101 | end select 102 | call iter1%next 103 | end do 104 | 105 | class default 106 | stop 2 107 | end select 108 | 109 | end 110 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/test/td_matrix_test.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! Unit Tests for the TD_MATRIX_TYPE Module 3 | !! 4 | !! Copyright (c) 2023 Neil N. Carlson 5 | !! 6 | !! Permission is hereby granted, free of charge, to any person obtaining a 7 | !! copy of this software and associated documentation files (the "Software"), 8 | !! to deal in the Software without restriction, including without limitation 9 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | !! and/or sell copies of the Software, and to permit persons to whom the 11 | !! Software is furnished to do so, subject to the following conditions: 12 | !! 13 | !! The above copyright notice and this permission notice shall be included 14 | !! in all copies or substantial portions of the Software. 15 | !! 16 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | !! DEALINGS IN THE SOFTWARE. 23 | !! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | 26 | program td_matrix_test 27 | 28 | use,intrinsic :: iso_fortran_env, only: r8 => real64 29 | use td_matrix_type 30 | implicit none 31 | 32 | integer :: stat = 0 33 | 34 | call test_non_periodic_2x2 35 | call test_non_periodic_gen 36 | call test_periodic_3x3 37 | call test_periodic_gen 38 | 39 | if (stat /= 0) stop 1 40 | 41 | contains 42 | 43 | subroutine test_non_periodic_2x2 44 | type(td_matrix) :: a 45 | real(r8) :: x(2), b(2) 46 | call a%init(2) 47 | call conv_diff_fill(a, 0.5_r8, 0.1_r8) 48 | call random_number(x) 49 | call a%matvec(x, b) 50 | call a%factor 51 | call a%solve(b) 52 | call report('test_non_periodic_2x2', maxval(abs(x-b)), 1.0e-15_r8) 53 | end subroutine 54 | 55 | subroutine test_non_periodic_gen 56 | type(td_matrix) :: a 57 | integer, parameter :: N = 20 58 | real(r8) :: x(N), b(N) 59 | call a%init(N) 60 | call conv_diff_fill(a, 0.5_r8, 0.1_r8) 61 | call random_number(x) 62 | call a%matvec(x, b) 63 | call a%factor 64 | call a%solve(b) 65 | call report('test_non_periodic_gen', maxval(abs(x-b)), 1.0e-15_r8) 66 | end subroutine 67 | 68 | subroutine test_periodic_3x3 69 | type(td_matrix) :: a 70 | real(r8) :: x(3), b(3) 71 | call a%init(3, periodic=.true.) 72 | call conv_diff_fill(a, 0.5_r8, 0.1_r8) 73 | call random_number(x) 74 | call a%matvec(x, b) 75 | call a%factor 76 | call a%solve(b) 77 | call report('test_periodic_3x3', maxval(abs(x-b)), 1.0e-15_r8) 78 | end subroutine 79 | 80 | subroutine test_periodic_gen 81 | type(td_matrix) :: a 82 | integer, parameter :: N = 20 83 | real(r8) :: x(N), b(N) 84 | call a%init(N, periodic=.true.) 85 | call conv_diff_fill(a, 0.5_r8, 0.1_r8) 86 | call random_number(x) 87 | call a%matvec(x, b) 88 | call a%factor 89 | call a%solve(b) 90 | call report('test_periodic_gen', maxval(abs(x-b)), 1.0e-15_r8) 91 | end subroutine 92 | 93 | !! Fill the matrix with values proportional to a finite difference 94 | !! approximation to a 1D convection-diffusion operator. 95 | 96 | subroutine conv_diff_fill(a, s, t) 97 | type(td_matrix), intent(inout) :: a 98 | real(r8), intent(in) :: s, t 99 | real(r8) :: rn 100 | call random_number(rn) 101 | rn = (2*rn - 1)/10 102 | a%d = (1+rn)*2.0_r8 + s 103 | a%l = -(1+rn)*(1.0_r8 + t) 104 | a%u = -(1+rn)*(1.0_r8 - t) 105 | end subroutine 106 | 107 | subroutine report(name, error, tol) 108 | use,intrinsic :: iso_fortran_env, only: output_unit 109 | character(*), intent(in) :: name 110 | real(r8), intent(in) :: error, tol 111 | character(6) :: pf 112 | if (error > tol) stat = stat + 1 113 | pf = merge('PASS: ', 'FAIL: ', error <= tol) 114 | write(output_unit,'(3a,2(g0,a))') pf, name, ', error=', error, ' (tol=', tol, ')' 115 | end subroutine 116 | 117 | end program 118 | -------------------------------------------------------------------------------- /test/json/json-ex8.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | use json 26 | implicit none 27 | 28 | class(json_value), allocatable :: val 29 | type(json_object_iterator) :: iter1, iter2 30 | type(json_array_iterator) :: iter3 31 | character(:), allocatable :: errmsg 32 | integer :: lun, stat, n 33 | character(8), parameter :: file = 'ex8.json' 34 | 35 | !! Write a JSON file to read back in 36 | open(newunit=lun,file=file,status='replace',action='write') 37 | write(lun,'(a)') '{ ', & 38 | ' "foo": [ 1.0, 2.0, 3.0 ],', & 39 | ' "bar": { ', & 40 | ' "a": true, ', & 41 | ' "b": "fubar" ', & 42 | ' }, ', & 43 | ' "whiz": null ', & 44 | '} // this is a comment ' 45 | close(lun) 46 | 47 | open(newunit=lun,file=file,access='stream',action='read') 48 | call json_from_stream(lun, val, stat, errmsg, bufsize=32) 49 | if (stat /= 0) stop 1 50 | 51 | select type (val) 52 | type is (json_object) 53 | 54 | iter1 = json_object_iterator(val) 55 | do while (.not.iter1%at_end()) 56 | select case (iter1%name()) 57 | case ('foo') 58 | select type (ival1 => iter1%value()) 59 | type is (json_array) 60 | n = 0 61 | iter3 = json_array_iterator(ival1) 62 | do while (.not.iter3%at_end()) 63 | n = n + 1 64 | select type (ival => iter3%value()) 65 | type is (json_real) 66 | if (ival%value /= n) stop 12 67 | class default 68 | stop 11 69 | end select 70 | call iter3%next 71 | end do 72 | class default 73 | stop 10 74 | end select 75 | case ('bar') 76 | select type (ival1 => iter1%value()) 77 | type is (json_object) 78 | iter2 = json_object_iterator(ival1) 79 | do while (.not.iter2%at_end()) 80 | select case (iter2%name()) 81 | case ('a') 82 | select type (ival2 => iter2%value()) 83 | type is (json_boolean) 84 | if (.not.ival2%value) stop 9 85 | class default 86 | stop 8 87 | end select 88 | case ('b') 89 | select type (ival2 => iter2%value()) 90 | type is (json_string) 91 | if (ival2%value /= 'fubar') stop 7 92 | class default 93 | stop 6 94 | end select 95 | case default 96 | stop 5 97 | end select 98 | call iter2%next 99 | end do 100 | end select 101 | case ('whiz') 102 | select type (ival1 => iter1%value()) 103 | type is (json_null) 104 | class default 105 | stop 4 106 | end select 107 | case default 108 | stop 3 109 | end select 110 | call iter1%next 111 | end do 112 | 113 | class default 114 | stop 2 115 | end select 116 | 117 | end 118 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/test/btd_matrix_test.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! Unit Tests for the BTD_MATRIX_TYPE Module 3 | !! 4 | !! Copyright (c) 2023 Neil N. Carlson 5 | !! 6 | !! Permission is hereby granted, free of charge, to any person obtaining a 7 | !! copy of this software and associated documentation files (the "Software"), 8 | !! to deal in the Software without restriction, including without limitation 9 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | !! and/or sell copies of the Software, and to permit persons to whom the 11 | !! Software is furnished to do so, subject to the following conditions: 12 | !! 13 | !! The above copyright notice and this permission notice shall be included 14 | !! in all copies or substantial portions of the Software. 15 | !! 16 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | !! DEALINGS IN THE SOFTWARE. 23 | !! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | 26 | program btd_matrix_test 27 | 28 | use,intrinsic :: iso_fortran_env, only: r8 => real64 29 | use btd_matrix_type 30 | implicit none 31 | 32 | integer :: stat = 0 33 | 34 | call test_non_periodic_2x2 35 | call test_non_periodic_gen 36 | call test_periodic_3x3 37 | call test_periodic_gen 38 | 39 | if (stat /= 0) stop 1 40 | 41 | contains 42 | 43 | subroutine test_non_periodic_2x2 44 | type(btd_matrix) :: a 45 | real(r8) :: x(2,2), b(2,2) 46 | call a%init(nb=2, n=2) 47 | call matrix_fill(a) 48 | call random_number(x) 49 | call a%matvec(x, b) 50 | call a%factor 51 | call a%solve(b) 52 | call report('test_non_periodic_2x2', maxval(abs(x-b)), 1.0e-15_r8) 53 | end subroutine 54 | 55 | subroutine test_non_periodic_gen 56 | type(btd_matrix) :: a 57 | integer, parameter :: NB = 4, N = 20 58 | real(r8) :: x(NB,N), b(NB,N) 59 | call a%init(NB, N) 60 | call matrix_fill(a) 61 | call random_number(x) 62 | call a%matvec(x, b) 63 | call a%factor 64 | call a%solve(b) 65 | call report('test_non_periodic_gen', maxval(abs(x-b)), 1.0e-15_r8) 66 | end subroutine 67 | 68 | subroutine test_periodic_3x3 69 | type(btd_matrix) :: a 70 | real(r8) :: x(2,3), b(2,3) 71 | call a%init(nb=2, n=3, periodic=.true.) 72 | call matrix_fill(a) 73 | call random_number(x) 74 | call a%matvec(x, b) 75 | call a%factor 76 | call a%solve(b) 77 | call report('test_periodic_3x3', maxval(abs(x-b)), 1.0e-15_r8) 78 | end subroutine 79 | 80 | subroutine test_periodic_gen 81 | type(btd_matrix) :: a 82 | integer, parameter :: NB = 4, N = 20 83 | real(r8) :: x(NB,N), b(NB,N) 84 | call a%init(NB, N, periodic=.true.) 85 | call matrix_fill(a) 86 | call random_number(x) 87 | call a%matvec(x, b) 88 | call a%factor 89 | call a%solve(b) 90 | call report('test_periodic_gen', maxval(abs(x-b)), 1.0e-15_r8) 91 | end subroutine 92 | 93 | !! Fill with a random-ish M-matrix: negative off-diagonal elements, 94 | !! positive diagonal elements, and strictly diagonally dominant. 95 | 96 | subroutine matrix_fill(a) 97 | type(btd_matrix), intent(inout) :: a 98 | integer :: i, j 99 | call random_number(a%l) 100 | call random_number(a%d) 101 | call random_number(a%u) 102 | a%l = -a%l 103 | a%d = -a%d 104 | a%u = -a%u 105 | do j = 1, a%n 106 | do i = 1, a%nb 107 | a%d(i,i,j) = 3*a%nb 108 | end do 109 | end do 110 | end subroutine 111 | 112 | subroutine report(name, error, tol) 113 | use,intrinsic :: iso_fortran_env, only: output_unit 114 | character(*), intent(in) :: name 115 | real(r8), intent(in) :: error, tol 116 | character(6) :: pf 117 | if (error > tol) stat = stat + 1 118 | pf = merge('PASS: ', 'FAIL: ', error <= tol) 119 | write(output_unit,'(3a,2(g0,a))') pf, name, ', error=', error, ' (tol=', tol, ')' 120 | end subroutine 121 | 122 | end program 123 | -------------------------------------------------------------------------------- /src/secure_hash/reference-C-code/md5.h: -------------------------------------------------------------------------------- 1 | /* Declaration of functions and data types used for MD5 sum computing 2 | library functions. 3 | Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2013 Free Software 4 | Foundation, Inc. 5 | This file is part of the GNU C Library. 6 | 7 | This program is free software; you can redistribute it and/or modify it 8 | under the terms of the GNU General Public License as published by the 9 | Free Software Foundation; either version 3, or (at your option) any 10 | later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, see . */ 19 | 20 | #ifndef _MD5_H 21 | #define _MD5_H 1 22 | 23 | #include 24 | #include 25 | 26 | #define MD5_DIGEST_SIZE 16 27 | #define MD5_BLOCK_SIZE 64 28 | 29 | #ifndef __GNUC_PREREQ 30 | # if defined __GNUC__ && defined __GNUC_MINOR__ 31 | # define __GNUC_PREREQ(maj, min) \ 32 | ((__GNUC__ << 16) + __GNUC_MINOR__ >= ((maj) << 16) + (min)) 33 | # else 34 | # define __GNUC_PREREQ(maj, min) 0 35 | # endif 36 | #endif 37 | 38 | #ifndef __THROW 39 | # if defined __cplusplus && __GNUC_PREREQ (2,8) 40 | # define __THROW throw () 41 | # else 42 | # define __THROW 43 | # endif 44 | #endif 45 | 46 | #ifndef _LIBC 47 | # define __md5_buffer md5_buffer 48 | # define __md5_finish_ctx md5_finish_ctx 49 | # define __md5_init_ctx md5_init_ctx 50 | # define __md5_process_block md5_process_block 51 | # define __md5_process_bytes md5_process_bytes 52 | # define __md5_read_ctx md5_read_ctx 53 | # define __md5_stream md5_stream 54 | #endif 55 | 56 | # ifdef __cplusplus 57 | extern "C" { 58 | # endif 59 | 60 | /* Structure to save state of computation between the single steps. */ 61 | struct md5_ctx 62 | { 63 | uint32_t A; 64 | uint32_t B; 65 | uint32_t C; 66 | uint32_t D; 67 | 68 | uint32_t total[2]; 69 | uint32_t buflen; 70 | uint32_t buffer[32]; 71 | }; 72 | 73 | /* 74 | * The following three functions are build up the low level used in 75 | * the functions 'md5_stream' and 'md5_buffer'. 76 | */ 77 | 78 | /* Initialize structure containing state of computation. 79 | (RFC 1321, 3.3: Step 3) */ 80 | extern void __md5_init_ctx (struct md5_ctx *ctx) __THROW; 81 | 82 | /* Starting with the result of former calls of this function (or the 83 | initialization function update the context for the next LEN bytes 84 | starting at BUFFER. 85 | It is necessary that LEN is a multiple of 64!!! */ 86 | extern void __md5_process_block (const void *buffer, size_t len, 87 | struct md5_ctx *ctx) __THROW; 88 | 89 | /* Starting with the result of former calls of this function (or the 90 | initialization function update the context for the next LEN bytes 91 | starting at BUFFER. 92 | It is NOT required that LEN is a multiple of 64. */ 93 | extern void __md5_process_bytes (const void *buffer, size_t len, 94 | struct md5_ctx *ctx) __THROW; 95 | 96 | /* Process the remaining bytes in the buffer and put result from CTX 97 | in first 16 bytes following RESBUF. The result is always in little 98 | endian byte order, so that a byte-wise output yields to the wanted 99 | ASCII representation of the message digest. */ 100 | extern void *__md5_finish_ctx (struct md5_ctx *ctx, void *resbuf) __THROW; 101 | 102 | 103 | /* Put result from CTX in first 16 bytes following RESBUF. The result is 104 | always in little endian byte order, so that a byte-wise output yields 105 | to the wanted ASCII representation of the message digest. */ 106 | extern void *__md5_read_ctx (const struct md5_ctx *ctx, void *resbuf) __THROW; 107 | 108 | 109 | /* Compute MD5 message digest for bytes read from STREAM. The 110 | resulting message digest number will be written into the 16 bytes 111 | beginning at RESBLOCK. */ 112 | extern int __md5_stream (FILE *stream, void *resblock) __THROW; 113 | 114 | /* Compute MD5 message digest for LEN bytes beginning at BUFFER. The 115 | result is always in little endian byte order, so that a byte-wise 116 | output yields to the wanted ASCII representation of the message 117 | digest. */ 118 | extern void *__md5_buffer (const char *buffer, size_t len, 119 | void *resblock) __THROW; 120 | 121 | # ifdef __cplusplus 122 | } 123 | # endif 124 | 125 | #endif /* md5.h */ 126 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/test/block_solver_procs_test.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! Unit Tests for the BLOCK_SOLVER_PROCS Module 3 | !! 4 | !! Copyright (c) 2023 Neil N. Carlson 5 | !! 6 | !! Permission is hereby granted, free of charge, to any person obtaining a 7 | !! copy of this software and associated documentation files (the "Software"), 8 | !! to deal in the Software without restriction, including without limitation 9 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | !! and/or sell copies of the Software, and to permit persons to whom the 11 | !! Software is furnished to do so, subject to the following conditions: 12 | !! 13 | !! The above copyright notice and this permission notice shall be included 14 | !! in all copies or substantial portions of the Software. 15 | !! 16 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | !! DEALINGS IN THE SOFTWARE. 23 | !! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | 26 | program block_solver_procs_test 27 | 28 | use,intrinsic :: iso_fortran_env, only: r8 => real64 29 | use block_solver_procs 30 | implicit none 31 | 32 | integer :: stat = 0 33 | 34 | call test_fct_slv_small 35 | call test_fct_slv_gen 36 | call test_mslv_small 37 | call test_mslv_gen 38 | call test_ymax 39 | call test_ypax 40 | call test_cmab 41 | 42 | if (stat /= 0) stop 1 43 | 44 | contains 45 | 46 | subroutine test_fct_slv_gen 47 | real(r8) :: a(5,5), b(5), x(5) 48 | call fill_matrix(a) 49 | call random_number(x) 50 | b = matmul(a, x) 51 | call fct(a) 52 | call slv(a, b) 53 | call report('test_fct_slv_gen', maxval(abs(x-b)), 1.0e-15_r8) 54 | end subroutine 55 | 56 | subroutine test_fct_slv_small 57 | real(r8) :: a(2,2), b(2), x(2) 58 | call fill_matrix(a) 59 | call random_number(x) 60 | b = matmul(a, x) 61 | call fct(a) 62 | call slv(a, b) 63 | call report('test_fct_slv_small', maxval(abs(x-b)), 1.0e-15_r8) 64 | end subroutine 65 | 66 | subroutine test_mslv_gen 67 | real(r8) :: a(5,5), b(5,6), x(5,6) 68 | call fill_matrix(a) 69 | call random_number(x) 70 | b = matmul(a, x) 71 | call fct(a) 72 | call mslv(a, b) 73 | call report('test_mslv_gen', maxval(abs(x-b)), 1.0e-15_r8) 74 | end subroutine 75 | 76 | subroutine test_mslv_small 77 | real(r8) :: a(2,2), b(2,3), x(2,3) 78 | call fill_matrix(a) 79 | call random_number(x) 80 | b = matmul(a, x) 81 | call fct(a) 82 | call mslv(a, b) 83 | call report('test_mslv_small', maxval(abs(x-b)), 1.0e-15_r8) 84 | end subroutine 85 | 86 | subroutine test_ymax 87 | real(r8) :: a(3,3), x(3), y(3), z(3) 88 | call random_number(a) 89 | call random_number(x) 90 | call random_number(y) 91 | z = y 92 | call ymax(y, a, x) 93 | z = z - matmul(a, x) 94 | call report('test_ymax', maxval(abs(y-z)), 1.0e-15_r8) 95 | end subroutine 96 | 97 | subroutine test_ypax 98 | real(r8) :: a(3,3), x(3), y(3), z(3) 99 | call random_number(a) 100 | call random_number(x) 101 | call random_number(y) 102 | z = y 103 | call ypax(y, a, x) 104 | z = z + matmul(a, x) 105 | call report('test_ypax', maxval(abs(y-z)), 1.0e-15_r8) 106 | end subroutine 107 | 108 | subroutine test_cmab 109 | real(r8) :: a(3,4), b(4,2), c(3,2), d(3,2) 110 | call random_number(a) 111 | call random_number(b) 112 | call random_number(c) 113 | d = c 114 | call cmab(c, a, b) 115 | d = d - matmul(a, b) 116 | call report('test_cmab', maxval(abs(c-d)), 1.0e-15_r8) 117 | end subroutine 118 | 119 | !! Fill with a random-ish M-matrix: negative off-diagonal elements, 120 | !! positive diagonal elements, and strictly diagonally dominant. 121 | 122 | subroutine fill_matrix(a) 123 | real(r8), intent(out) :: a(:,:) 124 | integer :: i 125 | call random_number(a) 126 | a = -a 127 | do i = 1, size(a,2) 128 | a(i,i) = size(a,2) 129 | end do 130 | end subroutine 131 | 132 | subroutine report(name, error, tol) 133 | use,intrinsic :: iso_fortran_env, only: output_unit 134 | character(*), intent(in) :: name 135 | real(r8), intent(in) :: error, tol 136 | character(6) :: pf 137 | if (error > tol) stat = stat + 1 138 | pf = merge('PASS: ', 'FAIL: ', error <= tol) 139 | write(output_unit,'(3a,2(g0,a))') pf, name, ', error=', error, ' (tol=', tol, ')' 140 | end subroutine 141 | 142 | end program 143 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/test/co_td_matrix_test.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! Unit Tests for the CO_TD_MATRIX_TYPE Module 3 | !! 4 | !! Copyright (c) 2023 Neil N. Carlson 5 | !! 6 | !! Permission is hereby granted, free of charge, to any person obtaining a 7 | !! copy of this software and associated documentation files (the "Software"), 8 | !! to deal in the Software without restriction, including without limitation 9 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | !! and/or sell copies of the Software, and to permit persons to whom the 11 | !! Software is furnished to do so, subject to the following conditions: 12 | !! 13 | !! The above copyright notice and this permission notice shall be included 14 | !! in all copies or substantial portions of the Software. 15 | !! 16 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | !! DEALINGS IN THE SOFTWARE. 23 | !! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | 26 | program co_td_matrix_test 27 | 28 | use,intrinsic :: iso_fortran_env, only: r8 => real64 29 | use co_td_matrix_type 30 | implicit none 31 | 32 | integer :: stat = 0, ntotal 33 | character(16) :: arg 34 | 35 | call get_command_argument(1, arg) 36 | read(arg,*) ntotal 37 | 38 | if (this_image() == 1) then 39 | write(*,'(a,i0,a)') 'Using ', num_images(), ' images' 40 | write(*,'(a,i0)') 'total size ', ntotal 41 | end if 42 | 43 | call test_non_periodic 44 | call test_periodic 45 | 46 | if (stat /= 0) error stop 47 | 48 | contains 49 | 50 | subroutine test_non_periodic 51 | 52 | real(r8), allocatable :: x(:), b(:) 53 | type(co_td_matrix) :: a 54 | 55 | integer :: n 56 | real(r8) :: error 57 | 58 | !! Partition the NTOTAL equations into nearly equal blocks 59 | n = ntotal/num_images() 60 | if (this_image() <= ntotal - n*num_images()) n = n + 1 61 | 62 | !! Initialize the tridiagonal matrix 63 | call a%init(n) 64 | call conv_diff_fill(a, 0.5_r8, 0.1_r8) 65 | 66 | !! Initialize the target solution 67 | allocate(x(n)) 68 | call random_number(x) 69 | 70 | !! Compute the corresponding RHS 71 | allocate(b(n)) 72 | call a%matvec(x, b) 73 | 74 | !! Solve the tridiagonal linear system; should recover X 75 | call a%factor 76 | call a%solve(b) 77 | error = maxval(abs(x-b)) 78 | call co_max(error) 79 | call report('test_non_periodic', error, 1e-15_r8) 80 | 81 | end subroutine test_non_periodic 82 | 83 | subroutine test_periodic 84 | 85 | real(r8), allocatable :: x(:), b(:) 86 | type(co_td_matrix) :: a 87 | 88 | integer :: n 89 | real(r8) :: error 90 | 91 | !! Partition the NTOTAL equations into nearly equal blocks 92 | n = ntotal/num_images() 93 | if (this_image() <= ntotal - n*num_images()) n = n + 1 94 | 95 | !! Initialize the periodic tridiagonal matrix 96 | call a%init(n, periodic=.true.) 97 | call conv_diff_fill(a, 0.5_r8, 0.1_r8) 98 | 99 | !! Initialize the target solution 100 | allocate(x(n)) 101 | call random_number(x) 102 | 103 | !! Compute the corresponding RHS 104 | allocate(b(n)) 105 | call a%matvec(x, b) 106 | 107 | !! Solve the tridiagonal linear system; should recover X 108 | call a%factor 109 | call a%solve(b) 110 | error = maxval(abs(x-b)) 111 | call co_max(error) 112 | call report('test_periodic', error, 1e-15_r8) 113 | 114 | end subroutine test_periodic 115 | 116 | !! Fill the matrix with values proportional to a finite difference 117 | !! approximation to a 1D convection-diffusion operator. 118 | 119 | subroutine conv_diff_fill(a, s, t) 120 | type(co_td_matrix), intent(inout) :: a 121 | real(r8), intent(in) :: s, t 122 | real(r8) :: rn 123 | call random_number(rn) 124 | rn = (2*rn - 1)/10 125 | a%d = (1+rn)*2.0_r8 + s 126 | a%l = -(1+rn)*(1.0_r8 + t) 127 | a%u = -(1+rn)*(1.0_r8 - t) 128 | end subroutine 129 | 130 | subroutine report(name, error, tol) 131 | use,intrinsic :: iso_fortran_env, only: output_unit 132 | character(*), intent(in) :: name 133 | real(r8), intent(in) :: error, tol 134 | character(6) :: pf 135 | if (error > tol) stat = stat + 1 136 | pf = merge('PASS: ', 'FAIL: ', error <= tol) 137 | if (this_image() == 1) & 138 | write(output_unit,'(3a,2(g0,a))') pf, name, ', error=', error, ' (tol=', tol, ')' 139 | sync all 140 | end subroutine 141 | 142 | end program 143 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/test/co_btd_matrix_test.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! Unit Tests for the CO_BTD_MATRIX_TYPE Module 3 | !! 4 | !! Copyright (c) 2023 Neil N. Carlson 5 | !! 6 | !! Permission is hereby granted, free of charge, to any person obtaining a 7 | !! copy of this software and associated documentation files (the "Software"), 8 | !! to deal in the Software without restriction, including without limitation 9 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | !! and/or sell copies of the Software, and to permit persons to whom the 11 | !! Software is furnished to do so, subject to the following conditions: 12 | !! 13 | !! The above copyright notice and this permission notice shall be included 14 | !! in all copies or substantial portions of the Software. 15 | !! 16 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 22 | !! DEALINGS IN THE SOFTWARE. 23 | !! 24 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 25 | 26 | program co_btd_matrix_test 27 | 28 | use,intrinsic :: iso_fortran_env, only: r8 => real64 29 | use co_btd_matrix_type 30 | implicit none 31 | 32 | integer :: stat = 0, nb, ntotal 33 | character(16) :: arg 34 | 35 | call get_command_argument(1, arg) 36 | read(arg,*) nb 37 | 38 | call get_command_argument(2, arg) 39 | read(arg,*) ntotal 40 | 41 | if (this_image() == 1) then 42 | write(*,'(a,i0,a)') 'Using ', num_images(), ' images' 43 | write(*,'(2(a,i0))') 'block size ', nb, '; total size ', ntotal 44 | end if 45 | 46 | call test_non_periodic 47 | call test_periodic 48 | 49 | if (stat /= 0) error stop 50 | 51 | contains 52 | 53 | subroutine test_non_periodic 54 | 55 | real(r8), allocatable :: x(:,:), b(:,:) 56 | type(co_btd_matrix) :: a 57 | 58 | integer :: n 59 | real(r8) :: error 60 | 61 | !! Partition the NTOTAL equations into nearly equal blocks 62 | n = ntotal/num_images() 63 | if (this_image() <= ntotal - n*num_images()) n = n + 1 64 | 65 | !! Initialize the tridiagonal matrix 66 | call a%init(nb, n) 67 | call matrix_fill(a) 68 | !call matrix_simple(a) 69 | 70 | !! Initialize the target solution 71 | allocate(x(nb,n)) 72 | call random_number(x) 73 | 74 | !! Compute the corresponding RHS 75 | allocate(b(nb,n)) 76 | call a%matvec(x, b) 77 | 78 | !! Solve the tridiagonal linear system; should recover X 79 | call a%factor 80 | call a%solve(b) 81 | error = maxval(abs(x-b)) 82 | call co_max(error) 83 | call report('test_non_periodic', error, 1.0e-15_r8) 84 | 85 | end subroutine 86 | 87 | subroutine test_periodic 88 | 89 | real(r8), allocatable :: x(:,:), b(:,:) 90 | type(co_btd_matrix) :: a 91 | 92 | integer :: n 93 | real(r8) :: error 94 | 95 | !! Partition the NTOTAL equations into nearly equal blocks 96 | n = ntotal/num_images() 97 | if (this_image() <= ntotal - n*num_images()) n = n + 1 98 | 99 | !! Initialize the tridiagonal matrix 100 | call a%init(nb, n, periodic=.true.) 101 | call matrix_fill(a) 102 | 103 | !! Initialize the target solution 104 | allocate(x(nb,n)) 105 | call random_number(x) 106 | 107 | !! Compute the corresponding RHS 108 | allocate(b(nb,n)) 109 | call a%matvec(x, b) 110 | !! Solve the tridiagonal linear system; should recover X 111 | call a%factor 112 | call a%solve(b) 113 | error = maxval(abs(x-b)) 114 | call co_max(error) 115 | call report('test_periodic', error, 1.0e-15_r8) 116 | 117 | end subroutine 118 | 119 | !! Fill with a random-ish M-matrix: negative off-diagonal elements, 120 | !! positive diagonal elements, and strictly diagonally dominant. 121 | 122 | subroutine matrix_fill(a) 123 | type(co_btd_matrix), intent(inout) :: a 124 | integer :: i, j 125 | call random_number(a%l) 126 | call random_number(a%d) 127 | call random_number(a%u) 128 | a%l = -a%l 129 | a%d = -a%d 130 | a%u = -a%u 131 | do j = 1, a%n 132 | do i = 1, a%nb 133 | a%d(i,i,j) = 3*a%nb 134 | end do 135 | end do 136 | end subroutine 137 | 138 | subroutine matrix_simple(a) 139 | type(co_btd_matrix), intent(inout) :: a 140 | integer :: i, j 141 | a%l = 0 142 | a%d = 0 143 | a%u = 0 144 | do j = 1, a%n 145 | do i = 1, a%nb 146 | a%l(i,i,j) = -1.0_r8 147 | a%d(i,i,j) = 3.0_r8 148 | a%u(i,i,j) = -1.0_r8 149 | end do 150 | end do 151 | end subroutine 152 | 153 | subroutine report(name, error, tol) 154 | use,intrinsic :: iso_fortran_env, only: output_unit 155 | character(*), intent(in) :: name 156 | real(r8), intent(in) :: error, tol 157 | character(6) :: pf 158 | if (error > tol) stat = stat + 1 159 | pf = merge('PASS: ', 'FAIL: ', error <= tol) 160 | if (this_image() == 1) & 161 | write(output_unit,'(3a,2(g0,a))') pf, name, ', error=', error, ' (tol=', tol, ')' 162 | sync all 163 | end subroutine 164 | 165 | end program 166 | -------------------------------------------------------------------------------- /doc/sphinx/fortran_dynamic_loader.rst: -------------------------------------------------------------------------------- 1 | ================================= 2 | The fortran_dynamic_loader module 3 | ================================= 4 | The ``fortran_dynamic_loader`` module defines an object-oriented Fortran 5 | interface to the system dynamic loader as implemented by the POSIX C functions 6 | ``dlopen``, ``dlclose``, ``dlsym``, and ``dlerror``. 7 | 8 | Synopsis 9 | ======== 10 | 11 | .. code-block:: fortran 12 | 13 | use fortran_dynamic_loader 14 | use,intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer 15 | use,intrinsic :: iso_c_binding, only: c_funptr, c_f_procpointer 16 | 17 | Defines: 18 | 19 | * derived type: ``shlib`` 20 | * subroutines: ``shlib%open``, ``shlib%close``, ``shlib%func``, ``shlib%sym`` 21 | * parameters: ``RTLD_LAZY``, ``RTLD_NOW``, ``RTLD_LOCAL``, ``RTLD_GLOBAL`` 22 | 23 | Link with the system DL library (``-ldl`` on Linux) to 24 | resolve the symbols ``dlopen``, ``dlclose``, ``dlsym``, and ``dlerror``. 25 | 26 | The shlib derived type 27 | ====================== 28 | The derived type ``shlib`` implements the dynamic loading of a shared 29 | library and access to data and procedures defined by the library. 30 | 31 | Type bound subroutines 32 | ---------------------- 33 | The derived type has the following type bound subroutines. Each subroutine has 34 | the optional ``intent(out)`` arguments ``stat`` and ``errmsg``. If the integer 35 | ``stat`` is present, it is assigned the value 0 if the subroutine completes 36 | successfully, and a nonzero value if an error occurs. In the latter case, 37 | the deferred-length allocatable character variable ``errmsg``, if present, 38 | is assigned the error string returned by the underlying system dl library. 39 | If ``stat`` is not present and an error occurs, the error string is written 40 | to the preconnected error unit and the program exits with a nonzero status. 41 | 42 | ``open(filename, mode [,stat [,errmsg]])`` 43 | Load the shared library file named by the character argument ``filename`` 44 | and associate it with the ``shlib`` object. If ``filename`` contains a slash 45 | ``/`` it is interpreted as a relative or absolute pathname. Otherwise the 46 | dynamic loader searches a certain list of directories for the library; see 47 | the system documentation for ``dlopen`` for a detailed description of the 48 | search process. 49 | 50 | One of the following two parameters must be passed as the ``mode`` argument: 51 | 52 | ``RTLD_LAZY`` 53 | Only resolve symbols as the code that references them is executed 54 | (lazy binding). 55 | 56 | ``RTLD_NOW`` 57 | All undefined symbols in the library are resolved before the ``open`` 58 | procedure returns. An error occurs if this is not possible. This 59 | is also the behavior if the environment variable ``LD_BIND_NOW`` is 60 | set to a nonempty string (Linux). 61 | 62 | One of the following parameters may optionally be or'ed with the preceding 63 | values before being passed as the ``mode`` argument; for example, 64 | ``mode = ior(RTLD_LAZY,RTLD_GLOBAL)``. 65 | 66 | ``RTLD_GLOBAL`` 67 | The symbols defined by this library will be made available for symbol 68 | resolution of subsequently loaded libraries. 69 | 70 | ``RTLD_LOCAL`` 71 | This is the converse of ``RTLD_GLOBAL`` and the default. Symbols 72 | defined by this library are not made available to resolve references 73 | in subsequently loaded libraries. 74 | 75 | See the system documentation for ``dlopen`` for more details. 76 | 77 | ``close([stat [,errmsg]])`` 78 | Decrement the reference count on the shared library. When the reference 79 | count reaches zero, the shared library is unloaded. See the system 80 | documentation for ``dlclose`` for a detailed description of the behavior. 81 | 82 | ``func(symbol, funptr [,stat [,errmsg]])`` 83 | Get the memory address where the specified function symbol from the shared 84 | library is loaded. The character argument ``symbol`` gives the symbol name, 85 | and the address is returned in the ``type(c_funptr)`` argument ``funptr``. 86 | The caller is responsible for converting this C function pointer to an 87 | appropriate Fortran procedure pointer using ``c_f_procpointer`` from the 88 | intrinsic ``iso_c_binding`` module. 89 | 90 | ``sym(symbol, symptr [,stat [,errmsg]])`` 91 | Get the memory address where the specified data symbol from the shared 92 | library is loaded. The character argument ``symbol`` gives the symbol 93 | name, and the address is returned in the ``type(c_ptr)`` argument 94 | ``symptr``. The caller is responsible for converting this C pointer 95 | value to an appropriate Fortran data pointer using ``c_f_pointer`` from 96 | the intrinsic ``iso_c_binding`` module. 97 | 98 | An example 99 | ========== 100 | Load the C math library libm.so and calculate the cube root of 8 using 101 | the function cbrtf from the library. 102 | 103 | .. code-block:: fortran 104 | 105 | use fortran_dynamic_loader 106 | use,intrinsic :: iso_c_binding, only: c_funptr, c_f_procpointer 107 | 108 | abstract interface 109 | real function f(x) 110 | real, value :: x 111 | end function 112 | end interface 113 | procedure(f), pointer :: cbrtf 114 | 115 | type(shlib) :: libm 116 | type(c_funptr) :: funptr 117 | 118 | call libm%open('libm.so', RTLD_NOW) 119 | call libm%func('cbrtf', funptr) 120 | call c_f_procpointer(funptr, cbrtf) 121 | if (cbrtf(8.0) /= 2.0) print *, 'error' 122 | call libm%close 123 | -------------------------------------------------------------------------------- /test/parameter_list_type/test_parameter_list_json.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2013 Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | program test_parameter_list_json 26 | 27 | use parameter_list_type 28 | use parameter_list_json 29 | 30 | integer :: stat = 0 31 | 32 | call test_vector_valid 33 | call test_vector_invalid 34 | call test_string_array 35 | 36 | if (stat /= 0) stop 1 37 | 38 | contains 39 | 40 | !! This is meant to test the MY_SAME_TYPE_AS function which replaced earlier 41 | !! non-portable/non-standard use of the SAME_TYPE_AS intrinsic function. 42 | !! Here we are processing valid vectors (for a parameter list) of the JSON 43 | !! values integer, real, boolean, and string. 44 | 45 | subroutine test_vector_valid 46 | type(parameter_list), pointer :: plist 47 | character(:), allocatable :: errmsg 48 | call parameter_list_from_json_string('{"array":[1,2]}', plist, errmsg) 49 | if (.not.associated(plist)) call write_fail('test_vector_valid failed test 1') 50 | deallocate(plist) 51 | call parameter_list_from_json_string('{"array":[1.0,2.0]}', plist, errmsg) 52 | if (.not.associated(plist)) call write_fail('test_vector_valid failed test 2') 53 | deallocate(plist) 54 | call parameter_list_from_json_string('{"array":[true,false]}', plist, errmsg) 55 | if (.not.associated(plist)) call write_fail('test_vector_valid failed test 3') 56 | deallocate(plist) 57 | call parameter_list_from_json_string('{"array":["boy","girl"]}', plist, errmsg) 58 | if (.not.associated(plist)) call write_fail('test_vector_valid failed test 4') 59 | deallocate(plist) 60 | end subroutine 61 | 62 | !! This is meant to test the MY_SAME_TYPE_AS function which replaced earlier 63 | !! non-portable/non-standard use of the SAME_TYPE_AS intrinsic function. 64 | !! Here we are processing invalid vectors (for a parameter list) which mix 65 | !! different JSON types. 66 | 67 | subroutine test_vector_invalid 68 | type(parameter_list), pointer :: plist 69 | character(:), allocatable :: errmsg 70 | call parameter_list_from_json_string('{"array":[1,2.0]}', plist, errmsg) 71 | if (associated(plist)) call write_fail('test_vector_invalid failed test 1') 72 | call parameter_list_from_json_string('{"array":[1,true]}', plist, errmsg) 73 | if (associated(plist)) call write_fail('test_vector_invalid failed test 2') 74 | call parameter_list_from_json_string('{"array":[1,"girl"]}', plist, errmsg) 75 | if (associated(plist)) call write_fail('test_vector_invalid failed test 3') 76 | call parameter_list_from_json_string('{"array":[1.0,false]}', plist, errmsg) 77 | if (associated(plist)) call write_fail('test_vector_invalid failed test 4') 78 | call parameter_list_from_json_string('{"array":[1.0,"boy"]}', plist, errmsg) 79 | if (associated(plist)) call write_fail('test_vector_invalid failed test 5') 80 | call parameter_list_from_json_string('{"array":[true,"boy"]}', plist, errmsg) 81 | if (associated(plist)) call write_fail('test_vector_invalid failed test 6') 82 | end subroutine 83 | 84 | !! This tests the construction of string-valued arrays, which trips bugs in 85 | !! some compilers. 86 | 87 | subroutine test_string_array 88 | type(parameter_list), pointer :: plist 89 | character(:), allocatable :: errmsg, array(:) 90 | integer :: stat 91 | call parameter_list_from_json_string('{"array":["foo","bar"]}', plist, errmsg) 92 | if (.not.associated(plist)) then 93 | call write_fail('test_string_array failed test 1') 94 | return 95 | end if 96 | call plist%get('array', array, stat=stat, errmsg=errmsg) 97 | if (stat /= 0) call write_fail('test_string_array failed test 2: ' // errmsg) 98 | if (size(array) /= 2) call write_fail('test_string_array failed test3') 99 | if (array(1) /= 'foo') call write_fail('test_string_array failed test4: "' // array(1) // '"') 100 | if (array(2) /= 'bar') call write_fail('test_string_array failed test5: "' // array(2) // '"') 101 | deallocate(plist) 102 | end subroutine 103 | 104 | subroutine write_fail(errmsg) 105 | use,intrinsic :: iso_fortran_env, only: error_unit 106 | character(*), intent(in) :: errmsg 107 | stat = 1 108 | write(error_unit,'(a)') errmsg 109 | end subroutine 110 | 111 | end program test_parameter_list_json 112 | -------------------------------------------------------------------------------- /doc/sphinx/conf.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | # 3 | # Petaca documentation build configuration file, created by 4 | # sphinx-quickstart on Sat Mar 10 09:50:31 2018. 5 | # 6 | # This file is execfile()d with the current directory set to its 7 | # containing dir. 8 | # 9 | # Note that not all possible configuration values are present in this 10 | # autogenerated file. 11 | # 12 | # All configuration values have a default; values that are commented out 13 | # serve to show the default. 14 | 15 | # If extensions (or modules to document with autodoc) are in another directory, 16 | # add these directories to sys.path here. If the directory is relative to the 17 | # documentation root, use os.path.abspath to make it absolute, like shown here. 18 | # 19 | import guzzle_sphinx_theme 20 | # import os 21 | # import sys 22 | # sys.path.insert(0, os.path.abspath('.')) 23 | 24 | 25 | # -- General configuration ------------------------------------------------ 26 | 27 | # If your documentation needs a minimal Sphinx version, state it here. 28 | # 29 | # needs_sphinx = '1.0' 30 | 31 | # Add any Sphinx extension module names here, as strings. They can be 32 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 33 | # ones. 34 | extensions = ['sphinx.ext.todo', 35 | 'sphinx.ext.mathjax', 'sphinx.ext.graphviz'] 36 | 37 | # Add any paths that contain templates here, relative to this directory. 38 | templates_path = ['_templates'] 39 | 40 | # The suffix(es) of source filenames. 41 | # You can specify multiple suffix as a list of string: 42 | # 43 | # source_suffix = ['.rst', '.md'] 44 | source_suffix = '.rst' 45 | 46 | # The master toctree document. 47 | master_doc = 'index' 48 | 49 | # General information about the project. 50 | project = u'Petaca' 51 | copyright = u'2018, Neil N. Carlson' 52 | author = u'Neil N. Carlson' 53 | 54 | # The version info for the project you're documenting, acts as replacement for 55 | # |version| and |release|, also used in various other places throughout the 56 | # built documents. 57 | # 58 | # The short X.Y version. 59 | version = u'1.0' 60 | # The full version, including alpha/beta/rc tags. 61 | release = u'1.0' 62 | 63 | # The language for content autogenerated by Sphinx. Refer to documentation 64 | # for a list of supported languages. 65 | # 66 | # This is also used if you do content translation via gettext catalogs. 67 | # Usually you set "language" from the command line for these cases. 68 | language = 'en' 69 | 70 | # List of patterns, relative to source directory, that match files and 71 | # directories to ignore when looking for source files. 72 | # This patterns also effect to html_static_path and html_extra_path 73 | exclude_patterns = [] 74 | 75 | # The name of the Pygments (syntax highlighting) style to use. 76 | pygments_style = 'sphinx' 77 | 78 | # If true, `todo` and `todoList` produce output, else they produce nothing. 79 | todo_include_todos = True 80 | 81 | 82 | # -- Options for HTML output ---------------------------------------------- 83 | 84 | # The theme to use for HTML and HTML Help pages. See the documentation for 85 | # a list of builtin themes. 86 | # 87 | #html_theme = 'alabaster' 88 | html_theme_path = guzzle_sphinx_theme.html_theme_path() 89 | html_theme = 'guzzle_sphinx_theme' 90 | 91 | # Theme options are theme-specific and customize the look and feel of a theme 92 | # further. For a list of options available for each theme, see the 93 | # documentation. 94 | # 95 | # html_theme_options = {} 96 | html_theme_options = { 97 | "project_nav_name": "Petaca" 98 | } 99 | 100 | # Add any paths that contain custom static files (such as style sheets) here, 101 | # relative to this directory. They are copied after the builtin static files, 102 | # so a file named "default.css" will overwrite the builtin "default.css". 103 | html_static_path = ['_static'] 104 | 105 | 106 | # -- Options for HTMLHelp output ------------------------------------------ 107 | 108 | # Output file base name for HTML help builder. 109 | htmlhelp_basename = 'Petacadoc' 110 | 111 | 112 | # -- Options for LaTeX output --------------------------------------------- 113 | 114 | latex_elements = { 115 | # The paper size ('letterpaper' or 'a4paper'). 116 | # 117 | # 'papersize': 'letterpaper', 118 | 119 | # The font size ('10pt', '11pt' or '12pt'). 120 | # 121 | # 'pointsize': '10pt', 122 | 123 | # Additional stuff for the LaTeX preamble. 124 | # 125 | # 'preamble': '', 126 | 127 | # Latex figure (float) alignment 128 | # 129 | # 'figure_align': 'htbp', 130 | } 131 | 132 | # Grouping the document tree into LaTeX files. List of tuples 133 | # (source start file, target name, title, 134 | # author, documentclass [howto, manual, or own class]). 135 | latex_documents = [ 136 | (master_doc, 'Petaca.tex', u'Petaca Documentation', 137 | u'Neil N. Carlson', 'manual'), 138 | ] 139 | 140 | 141 | # -- Options for manual page output --------------------------------------- 142 | 143 | # One entry per manual page. List of tuples 144 | # (source start file, name, description, authors, manual section). 145 | man_pages = [ 146 | (master_doc, 'petaca', u'Petaca Documentation', 147 | [author], 1) 148 | ] 149 | 150 | 151 | # -- Options for Texinfo output ------------------------------------------- 152 | 153 | # Grouping the document tree into Texinfo files. List of tuples 154 | # (source start file, target name, title, author, 155 | # dir menu entry, description, category) 156 | texinfo_documents = [ 157 | (master_doc, 'Petaca', u'Petaca Documentation', 158 | author, 'Petaca', 'One line description of project.', 159 | 'Miscellaneous'), 160 | ] 161 | 162 | 163 | 164 | -------------------------------------------------------------------------------- /examples/yajl-fort/yajl_fort_parse_example.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2011, 2013, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | module echo_callbacks_type 26 | 27 | use yajl_fort 28 | implicit none 29 | private 30 | 31 | type, extends(fyajl_callbacks), public :: echo_callbacks 32 | ! no context data is needed 33 | contains 34 | procedure :: start_map 35 | procedure :: end_map 36 | procedure :: map_key 37 | procedure :: null_value 38 | procedure :: logical_value 39 | procedure :: integer_value 40 | procedure :: double_value 41 | procedure :: string_value 42 | procedure :: start_array 43 | procedure :: end_array 44 | end type 45 | 46 | contains 47 | 48 | integer function null_value (this) result (stat) 49 | class(echo_callbacks) :: this 50 | write(*,*) '(null)' 51 | stat = FYAJL_CONTINUE_PARSING 52 | end function 53 | 54 | integer function logical_value (this, value) result (stat) 55 | class(echo_callbacks) :: this 56 | logical, intent(in) :: value 57 | write(*,*) value 58 | stat = FYAJL_CONTINUE_PARSING 59 | end function 60 | 61 | integer function integer_value (this, value) result(stat) 62 | class(echo_callbacks) :: this 63 | integer(fyajl_integer_kind), intent(in) :: value 64 | write(*,*) value 65 | stat = FYAJL_CONTINUE_PARSING 66 | end function 67 | 68 | integer function double_value (this, value) result(stat) 69 | class(echo_callbacks) :: this 70 | real(fyajl_real_kind), intent(in) :: value 71 | write(*,*) value 72 | stat = FYAJL_CONTINUE_PARSING 73 | end function 74 | 75 | integer function string_value (this, value) result (stat) 76 | class(echo_callbacks) :: this 77 | character(*), intent(in) :: value 78 | write(*,*) '"', value, '"' 79 | stat = FYAJL_CONTINUE_PARSING 80 | end function 81 | 82 | integer function map_key (this, value) result (stat) 83 | class(echo_callbacks) :: this 84 | character(*), intent(in) :: value 85 | write(*,*) '"', value, '":' 86 | stat = FYAJL_CONTINUE_PARSING 87 | end function 88 | 89 | integer function start_map (this) result(stat) 90 | class(echo_callbacks) :: this 91 | write(*,*) '{' 92 | stat = FYAJL_CONTINUE_PARSING 93 | end function 94 | 95 | integer function end_map (this) result(stat) 96 | class(echo_callbacks) :: this 97 | write(*,*) '}' 98 | stat = FYAJL_CONTINUE_PARSING 99 | end function 100 | 101 | integer function start_array (this) result(stat) 102 | class(echo_callbacks) :: this 103 | write(*,*) '[' 104 | stat = FYAJL_CONTINUE_PARSING 105 | end function 106 | 107 | integer function end_array (this) result(stat) 108 | class(echo_callbacks) :: this 109 | write(*,*) ']' 110 | stat = FYAJL_CONTINUE_PARSING 111 | end function 112 | 113 | end module echo_callbacks_type 114 | 115 | program yajl_fort_parse_example 116 | 117 | use,intrinsic :: iso_fortran_env 118 | use,intrinsic :: iso_c_binding 119 | use yajl_fort 120 | use echo_callbacks_type 121 | implicit none 122 | 123 | character(len=64) :: prog, file 124 | 125 | if (command_argument_count() == 1) then 126 | call get_command_argument (1, file) 127 | else 128 | call get_command (prog) 129 | write(error_unit,'(a)') 'usage: ' // trim(prog) // ' file' 130 | stop 131 | end if 132 | 133 | call echo_json_events (file) 134 | 135 | contains 136 | 137 | subroutine echo_json_events (file) 138 | 139 | character(*), intent(in) :: file 140 | 141 | type(echo_callbacks), target :: callbacks 142 | type(fyajl_parser), target :: parser 143 | type(fyajl_status) :: stat 144 | integer :: ios, last_pos, curr_pos, buflen 145 | character :: buffer(128) ! intentionally small buffer 146 | 147 | call parser%init (callbacks) 148 | call parser%set_option (FYAJL_ALLOW_COMMENTS) 149 | 150 | open(10,file=trim(file),action='read',access='stream',form='unformatted') 151 | inquire(10,pos=last_pos) 152 | do 153 | read(10,iostat=ios) buffer 154 | if (ios /= 0 .and. ios /= iostat_end) then 155 | write(error_unit,'(a,i0)') 'read error: iostat=', ios 156 | exit 157 | end if 158 | 159 | inquire(10,pos=curr_pos) 160 | buflen = curr_pos - last_pos 161 | last_pos = curr_pos 162 | if (buflen > 0) then 163 | call parser%parse (buffer(:buflen), stat) 164 | if (stat /= FYAJL_STATUS_OK) then 165 | write(error_unit,'(a)') fyajl_get_error(parser, .true., buffer(:buflen)) 166 | exit 167 | end if 168 | end if 169 | 170 | if (ios == iostat_end) then 171 | call parser%complete_parse (stat) 172 | if (stat /= FYAJL_STATUS_OK) then 173 | write(error_unit,'(a)') fyajl_get_error(parser, .false., buffer(:buflen)) 174 | end if 175 | exit 176 | end if 177 | end do 178 | close(10) 179 | 180 | end subroutine 181 | 182 | end program 183 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/src/td_matrix_type.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! TD_MATRIX_TYPE 3 | !! 4 | !! A data structure for tridiagonal matrices, with methods for linear equations 5 | !! and matrix-vector products. Supports periodic tridiagonal matrices as well. 6 | !! Linear equation solution uses direct LU factorization without pivoting and 7 | !! is thus only suitable for classes of matrices not requiring pivoting, such 8 | !! as diagonally-dominant matrices. 9 | !! 10 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 11 | !! 12 | !! Copyright (c) 2023 Neil N. Carlson 13 | !! 14 | !! Permission is hereby granted, free of charge, to any person obtaining a 15 | !! copy of this software and associated documentation files (the "Software"), 16 | !! to deal in the Software without restriction, including without limitation 17 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 18 | !! and/or sell copies of the Software, and to permit persons to whom the 19 | !! Software is furnished to do so, subject to the following conditions: 20 | !! 21 | !! The above copyright notice and this permission notice shall be included 22 | !! in all copies or substantial portions of the Software. 23 | !! 24 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 25 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 26 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 27 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 28 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 29 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 30 | !! DEALINGS IN THE SOFTWARE. 31 | !! 32 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 33 | 34 | module td_matrix_type 35 | 36 | use,intrinsic :: iso_fortran_env, only: r8 => real64 37 | implicit none 38 | private 39 | 40 | type, public :: td_matrix 41 | integer :: n ! number of rows/columns 42 | logical :: periodic = .false. 43 | real(r8), allocatable :: l(:), d(:), u(:) 44 | real(r8), allocatable :: q(:) ! factorization fill-in (periodic case) 45 | contains 46 | procedure :: init 47 | procedure :: factor 48 | procedure :: solve 49 | procedure :: matvec 50 | ! auxiliary procedures; available to type extensions 51 | procedure :: factor_submatrix 52 | procedure :: solve_submatrix 53 | end type 54 | 55 | contains 56 | 57 | subroutine init(this, n, periodic) 58 | class(td_matrix), intent(out) :: this 59 | integer, intent(in) :: n 60 | logical, intent(in), optional :: periodic 61 | this%n = n 62 | if (present(periodic)) this%periodic = periodic 63 | if (n < 2) error stop 'td_matrix%init: matrix size < 2' 64 | if (this%periodic .and. n < 3) error stop 'td_matrix%init: periodic matrix size < 3' 65 | allocate(this%l(n), this%d(n), this%u(n)) 66 | end subroutine 67 | 68 | subroutine factor(this) 69 | class(td_matrix), intent(inout) :: this 70 | if (this%periodic) then 71 | call factor_periodic(this) 72 | else 73 | call factor_submatrix(this, 1, this%n) 74 | end if 75 | end subroutine 76 | 77 | pure subroutine factor_periodic(this) 78 | class(td_matrix), intent(inout) :: this 79 | associate (n => this%n) 80 | call this%factor_submatrix(1, n-1) 81 | allocate(this%q(n-1)) 82 | this%q(1) = this%l(1) 83 | this%q(2:n-2) = 0.0_r8 84 | this%q(n-1) = this%u(n-1) 85 | call this%solve_submatrix(1, n-1, this%q) 86 | this%d(n) = 1.0_r8/(this%d(n) - this%u(n)*this%q(1) - this%l(n)*this%q(n-1)) 87 | end associate 88 | end subroutine 89 | 90 | !! This auxiliary subroutine computes the usual LU factorization of the 91 | !! local submatrix composed of rows/columns j1 through j2. The elements 92 | !! of the local submatrix are overwritten with the elements of L and unit 93 | !! upper triangular U. 94 | 95 | pure subroutine factor_submatrix(this, j1, j2) 96 | class(td_matrix), intent(inout) :: this 97 | integer, intent(in) :: j1, j2 98 | integer :: j 99 | this%d(j1) = 1.0_r8/this%d(j1) 100 | do j = j1+1, j2 101 | this%u(j-1) = this%d(j-1)*this%u(j-1) 102 | this%d(j) = 1.0_r8/(this%d(j) - this%l(j)*this%u(j-1)) 103 | end do 104 | end subroutine 105 | 106 | subroutine solve(this, b) 107 | class(td_matrix), intent(in) :: this 108 | real(r8), intent(inout) :: b(:) 109 | if (this%periodic) then 110 | call solve_periodic(this, b) 111 | else 112 | call solve_submatrix(this, 1, this%n, b) 113 | end if 114 | end subroutine 115 | 116 | pure subroutine solve_periodic(this, b) 117 | class(td_matrix), intent(in) :: this 118 | real(r8), intent(inout) :: b(:) 119 | associate (n => this%n) 120 | call this%solve_submatrix(1, n-1, b) 121 | b(n) = this%d(n)*(b(n) - this%u(n)*b(1) - this%l(n)*b(n-1)) 122 | b(1:n-1) = b(1:n-1) - b(n)*this%q 123 | end associate 124 | end subroutine 125 | 126 | !! This auxiliary subroutine solves the linear system Ax = b where A is 127 | !! the submatrix composed of rows/columns j1 through j2. The submatrix 128 | !! must store the LU factorization computed by SERIAL_FACTOR. The RHS b 129 | !! is the subvector of the passed B composed of elements j1 through j2, 130 | !! and the computed solution overwrites those elements. Other elements 131 | !! of B are unmodified. 132 | 133 | pure subroutine solve_submatrix(this, j1, j2, b) 134 | class(td_matrix), intent(in) :: this 135 | integer, intent(in) :: j1, j2 136 | real(r8), intent(inout) :: b(:) 137 | integer :: j 138 | b(j1) = this%d(j1)*b(j1) 139 | do j = j1+1, j2 140 | b(j) = this%d(j)*(b(j) - this%l(j)*b(j-1)) 141 | end do 142 | do j = j2-1, j1, -1 143 | b(j) = b(j) - this%u(j)*b(j+1) 144 | end do 145 | end subroutine 146 | 147 | subroutine matvec(this, x, y) 148 | class(td_matrix), intent(in) :: this 149 | real(r8), intent(in) :: x(:) 150 | real(r8), intent(out) :: y(:) 151 | integer :: j 152 | y(1) = this%d(1)*x(1) + this%u(1)*x(2) 153 | if (this%periodic) y(1) = y(1) + this%l(1)*x(this%n) 154 | do j = 2, this%n-1 155 | y(j) = this%l(j)*x(j-1) + this%d(j)*x(j) + this%u(j)*x(j+1) 156 | end do 157 | y(j) = this%l(j)*x(j-1) + this%d(j)*x(j) 158 | if (this%periodic) y(j) = y(j) + this%u(j)*x(1) 159 | end subroutine 160 | 161 | end module td_matrix_type 162 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/src/block_solver_procs.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! BLOCK_SOLVER_PROCS 3 | !! 4 | !! This is a collection of low-level linear equation subroutines that are 5 | !! intended for use by the various block linear solvers. The linear equations 6 | !! are expected to be those corresponding to individual block equations: that 7 | !! is, they involve just a few unknowns and have a dense, diagonally-dominant 8 | !! coefficient matrix. There are subroutines to compute the LU factorization 9 | !! of the coefficient matrix and for solving the linear system using the 10 | !! factorization. There are also some matrix-vector and matrix-matrix 11 | !! subroutines that are specialized versions of similar BLAS subroutines. 12 | !! 13 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 14 | !! 15 | !! Copyright (c) 1997, 2013. 2023 Neil N. Carlson 16 | !! 17 | !! Permission is hereby granted, free of charge, to any person obtaining a 18 | !! copy of this software and associated documentation files (the "Software"), 19 | !! to deal in the Software without restriction, including without limitation 20 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 21 | !! and/or sell copies of the Software, and to permit persons to whom the 22 | !! Software is furnished to do so, subject to the following conditions: 23 | !! 24 | !! The above copyright notice and this permission notice shall be included 25 | !! in all copies or substantial portions of the Software. 26 | !! 27 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 28 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 29 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 30 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 31 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 32 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 33 | !! DEALINGS IN THE SOFTWARE. 34 | !! 35 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 36 | 37 | module block_solver_procs 38 | 39 | use,intrinsic :: iso_fortran_env, only: r8 => real64 40 | implicit none 41 | private 42 | 43 | public :: fct, slv, mslv, ymax, ypax, cmab 44 | 45 | contains 46 | 47 | !! LU factorization of a square matrix. No pivoting (intentionally). 48 | !! Unit lower triangular factor; unit diagonal not stored. Reciprocal 49 | !! of upper triangular diagonal stored. Matrix is overwritten with the 50 | !! elements of L and U. I'm not aware of an equivalent LAPACK routine 51 | !! (no pivoting!) 52 | 53 | pure subroutine fct(a) 54 | 55 | real(r8), intent(inout) :: a(:,:) 56 | 57 | integer :: n, i, j, k 58 | real(r8) :: lkk, lkj, ujk 59 | 60 | n = size(a,1) 61 | select case (n) 62 | case (2) 63 | 64 | a(1,1) = 1.0_r8 / a(1,1) 65 | a(2,1) = a(2,1) * a(1,1) 66 | a(2,2) = 1.0_r8 / (a(2,2) - a(2,1)*a(1,2)) 67 | 68 | case default 69 | 70 | a(1,1) = 1.0_r8 / a(1,1) 71 | do k = 2, n 72 | lkk = a(k,k) 73 | do j = 1, k - 1 74 | lkj = a(k,j) 75 | ujk = a(j,k) 76 | do i = 1, j - 1 77 | lkj = lkj - a(k,i)*a(i,j) 78 | ujk = ujk - a(j,i)*a(i,k) 79 | end do 80 | lkj = lkj * a(j,j) 81 | lkk = lkk - lkj*ujk 82 | a(k,j) = lkj 83 | a(j,k) = ujk 84 | end do 85 | a(k,k) = 1.0_r8 / lkk 86 | end do 87 | 88 | end select 89 | 90 | end subroutine fct 91 | 92 | !! Solves the system Ax = b, where A stores its LU factorization. The RHS 93 | !! vector b is overwritten with the solution x. 94 | 95 | pure subroutine slv(a, b) 96 | 97 | real(r8), intent(in) :: a(:,:) 98 | real(r8), intent(inout) :: b(:) 99 | 100 | integer :: n, i, j 101 | real(r8) :: bj 102 | 103 | n = size(a,1) 104 | select case (n) 105 | case (2) 106 | 107 | b(2) = (b(2) - a(2,1)*b(1))*a(2,2) 108 | b(1) = (b(1) - a(1,2)*b(2))*a(1,1) 109 | 110 | case default 111 | 112 | do j = 2, n 113 | bj = b(j) 114 | do i = 1, j-1 115 | bj = bj - a(j,i)*b(i) 116 | end do 117 | b(j) = bj 118 | end do 119 | b(n) = b(n) * a(n,n) 120 | do j = n-1, 1, -1 121 | bj = b(j) 122 | do i = j+1, n 123 | bj = bj - a(j,i)*b(i) 124 | end do 125 | b(j) = bj * a(j,j) 126 | end do 127 | 128 | end select 129 | 130 | end subroutine slv 131 | 132 | !! Solves the system AX=B where A stores its LU factorization, and the RHS 133 | !! B is a matrix (i.e., multiple RHS vectors). B is overwritten with the 134 | !! solution matrix X. 135 | 136 | pure subroutine mslv(a, b) 137 | 138 | real(r8), intent(in) :: a(:,:) 139 | real(r8), intent(inout) :: b(:,:) 140 | 141 | integer :: n, i, j 142 | real(r8) :: bj(size(b,2)) 143 | 144 | n = size(a,1) 145 | select case (n) 146 | case (2) 147 | 148 | b(2,:) = (b(2,:) - a(2,1)*b(1,:)) * a(2,2) 149 | b(1,:) = (b(1,:) - a(1,2)*b(2,:)) * a(1,1) 150 | 151 | case default 152 | 153 | do j = 2, n 154 | bj = b(j,:) 155 | do i = 1, j-1 156 | bj = bj - a(j,i)*b(i,:) 157 | end do 158 | b(j,:) = bj 159 | end do 160 | b(n,:) = b(n,:) * a(n,n) 161 | do j = n-1, 1, -1 162 | bj = b(j,:) 163 | do i = j+1, n 164 | bj = bj - a(j,i)*b(i,:) 165 | end do 166 | b(j,:) = bj * a(j,j) 167 | end do 168 | 169 | end select 170 | 171 | end subroutine mslv 172 | 173 | !! Computes the matrix-vector update y <- y - Ax. 174 | !! Equivalent to gemv(a, x, y, alpha=-1.0_r8, beta=1.0_r8) 175 | 176 | pure subroutine ymax(y, a, x) 177 | real(r8), intent(inout) :: y(:) 178 | real(r8), intent(in) :: a(:,:), x(:) 179 | integer :: i, j 180 | real(r8) :: yi 181 | do i = 1, size(y) 182 | yi = y(i) 183 | do j = 1, size(x) 184 | yi = yi - a(i,j)*x(j) 185 | end do 186 | y(i) = yi 187 | end do 188 | end subroutine 189 | 190 | !! Computes the matrix-vector update y <- y + Ax. 191 | !! Equivalent to gemv(a, x, y, alpha=1.0_r8, beta=1.0_r8) 192 | 193 | pure subroutine ypax(y, a, x) 194 | real(r8), intent(inout) :: y(:) 195 | real(r8), intent(in) :: a(:,:), x(:) 196 | integer :: i, j 197 | real(r8) :: yi 198 | do i = 1, size(y) 199 | yi = y(i) 200 | do j = 1, size(x) 201 | yi = yi + a(i,j)*x(j) 202 | end do 203 | y(i) = yi 204 | end do 205 | end subroutine 206 | 207 | !! Computes the matrix-matrix update C <- C - AB. 208 | !! Equivalent to gemm(a, b, c, alpha=-1.0_r8, beta=1.0_r8) 209 | 210 | pure subroutine cmab(c, a, b) 211 | real(r8), intent(inout) :: c(:,:) 212 | real(r8), intent(in) :: a(:,:), b(:,:) 213 | integer :: i, j, k 214 | real(r8) :: cjk 215 | do k = 1, size(c,2) 216 | do j = 1, size(c,1) 217 | cjk = c(j,k) 218 | do i = 1, size(a,2) 219 | cjk = cjk - a(j,i)*b(i,k) 220 | end do 221 | c(j,k) = cjk 222 | end do 223 | end do 224 | end subroutine 225 | 226 | end module block_solver_procs 227 | -------------------------------------------------------------------------------- /test/yajl_fort/strip.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2018, Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | module strip_cb_type 26 | 27 | use,intrinsic :: iso_fortran_env, only: output_unit 28 | use yajl_fort 29 | implicit none 30 | private 31 | 32 | type, extends(fyajl_callbacks), public :: strip_cb 33 | integer :: top = 1 34 | logical :: comma(99) = .false. 35 | contains 36 | procedure :: start_map 37 | procedure :: end_map 38 | procedure :: map_key 39 | procedure :: null_value 40 | procedure :: logical_value 41 | procedure :: integer_value 42 | procedure :: double_value 43 | procedure :: string_value 44 | procedure :: start_array 45 | procedure :: end_array 46 | end type 47 | 48 | contains 49 | 50 | subroutine push(this) 51 | class(strip_cb), intent(inout) :: this 52 | this%top = this%top + 1 53 | this%comma(this%top) = .false. 54 | end subroutine 55 | 56 | subroutine pop(this) 57 | class(strip_cb), intent(inout) :: this 58 | this%top = this%top - 1 59 | end subroutine 60 | 61 | subroutine write_comma(this, next) 62 | class(strip_cb), intent(inout) :: this 63 | logical, intent(in) :: next 64 | if (this%comma(this%top)) write(output_unit,'(",")',advance='no') 65 | this%comma(this%top) = next 66 | end subroutine 67 | 68 | integer function null_value(this) result(stat) 69 | class(strip_cb) :: this 70 | call write_comma(this, next=.true.) 71 | write(output_unit,'("null")',advance='no') 72 | stat = FYAJL_CONTINUE_PARSING 73 | end function 74 | 75 | integer function logical_value(this, value) result(stat) 76 | class(strip_cb) :: this 77 | logical, intent(in) :: value 78 | call write_comma(this, next=.true.) 79 | if (value) then 80 | write(output_unit,'("true")',advance='no') 81 | else 82 | write(output_unit,'("false")',advance='no') 83 | end if 84 | stat = FYAJL_CONTINUE_PARSING 85 | end function 86 | 87 | integer function integer_value(this, value) result(stat) 88 | class(strip_cb) :: this 89 | integer(fyajl_integer_kind), intent(in) :: value 90 | call write_comma(this, next=.true.) 91 | write(output_unit,'(i0)',advance='no') value 92 | stat = FYAJL_CONTINUE_PARSING 93 | end function 94 | 95 | integer function double_value(this, value) result(stat) 96 | class(strip_cb) :: this 97 | real(fyajl_real_kind), intent(in) :: value 98 | call write_comma(this, next=.true.) 99 | write(output_unit,'(es12.5)',advance='no') value 100 | stat = FYAJL_CONTINUE_PARSING 101 | end function 102 | 103 | integer function string_value(this, value) result(stat) 104 | class(strip_cb) :: this 105 | character(*), intent(in) :: value 106 | call write_comma(this, next=.true.) 107 | write(output_unit,'(3a)',advance='no') '"', value, '"' 108 | stat = FYAJL_CONTINUE_PARSING 109 | end function 110 | 111 | integer function map_key(this, value) result(stat) 112 | class(strip_cb) :: this 113 | character(*), intent(in) :: value 114 | call write_comma(this, next=.false.) 115 | write(output_unit,'(3a)',advance='no') '"', value, '":' 116 | stat = FYAJL_CONTINUE_PARSING 117 | end function 118 | 119 | integer function start_map(this) result(stat) 120 | class(strip_cb) :: this 121 | call write_comma(this, next=.true.) 122 | write(output_unit,'("{")',advance='no') 123 | call push(this) 124 | stat = FYAJL_CONTINUE_PARSING 125 | end function 126 | 127 | integer function end_map(this) result(stat) 128 | class(strip_cb) :: this 129 | write(output_unit,'("}")',advance='no') 130 | call pop(this) 131 | stat = FYAJL_CONTINUE_PARSING 132 | end function 133 | 134 | integer function start_array(this) result(stat) 135 | class(strip_cb) :: this 136 | call write_comma(this, next=.true.) 137 | write(output_unit,'("[")',advance='no') 138 | call push(this) 139 | stat = FYAJL_CONTINUE_PARSING 140 | end function 141 | 142 | integer function end_array(this) result(stat) 143 | class(strip_cb) :: this 144 | write(output_unit,'("]")',advance='no') 145 | call pop(this) 146 | stat = FYAJL_CONTINUE_PARSING 147 | end function 148 | 149 | end module 150 | 151 | program strip_json 152 | 153 | use,intrinsic :: iso_fortran_env 154 | use yajl_fort 155 | use strip_cb_type 156 | implicit none 157 | 158 | integer :: ios, lun, last_pos, curr_pos, buflen 159 | character(64) :: arg 160 | character(:), allocatable :: file 161 | character :: buffer(64) ! intentionally small buffer for testing 162 | type(strip_cb), target :: callbacks 163 | type(fyajl_parser), target :: parser 164 | type(fyajl_status) :: stat 165 | 166 | if (command_argument_count() == 1) then 167 | call get_command_argument(1, arg) 168 | file = trim(arg) 169 | else 170 | call get_command(arg) 171 | write(error_unit,'(a)') 'usage: ' // trim(arg) // ' file' 172 | stop 173 | end if 174 | 175 | call parser%init(callbacks) 176 | call parser%set_option(FYAJL_ALLOW_COMMENTS) 177 | 178 | open(newunit=lun,file=file,action='read',access='stream') 179 | inquire(lun,pos=last_pos) 180 | 181 | do 182 | read(lun,iostat=ios) buffer 183 | if (ios /= 0 .and. ios /= iostat_end) then 184 | write(error_unit,'(a,i0)') 'read error: iostat=', ios 185 | exit 186 | end if 187 | 188 | inquire(lun,pos=curr_pos) 189 | buflen = curr_pos - last_pos 190 | last_pos = curr_pos 191 | if (buflen > 0) then 192 | call parser%parse(buffer(:buflen), stat) 193 | if (stat /= FYAJL_STATUS_OK) then 194 | write(error_unit,'(a)') fyajl_get_error(parser, .true., buffer(:buflen)) 195 | exit 196 | end if 197 | end if 198 | 199 | if (ios == iostat_end) then 200 | call parser%complete_parse(stat) 201 | if (stat /= FYAJL_STATUS_OK) then 202 | write(error_unit,'(a)') fyajl_get_error(parser, .false., buffer(:buflen)) 203 | end if 204 | exit 205 | end if 206 | end do 207 | close(lun) 208 | 209 | end program 210 | -------------------------------------------------------------------------------- /doc/sphinx/map_any_type.rst: -------------------------------------------------------------------------------- 1 | .. _map_any-module: 2 | 3 | ======================= 4 | The map_any_type module 5 | ======================= 6 | The ``map_any_type`` module defines a map data structure or associative 7 | array which stores (key, value) pairs as the elements of the structure. 8 | The keys are unique and are regarded as mapping or indexing to the value 9 | associated with the key. In this implementation keys are character strings 10 | but the values may be a scalar value of any intrinsic or derived type. An 11 | associated iterator derived type is also defined which gives sequential 12 | access to all elements of the map structure. 13 | 14 | Synopsis 15 | ======== 16 | 17 | .. code-block:: fortran 18 | 19 | use map_any_type 20 | type(map_any) :: map 21 | type(map_any_iterator) :: iter 22 | 23 | The map_any derived type 24 | ======================== 25 | The derived type ``map_any`` defines a map data structure which stores 26 | (key, value) pairs. The keys are unique character strings that map (or index) 27 | to the value associated with the key. Values may be a scalar of any intrinsic 28 | or derived type. There are limitations, however, with some derived type values; 29 | see the caution_ below. The derived type has the following properties: 30 | 31 | * ``map_any`` objects are properly finalized when deallocated or when they 32 | otherwise cease to exist. 33 | 34 | * Scalar assignment is defined for ``map_any`` objects with the expected 35 | semantics. The contents of the lhs map are first cleared, and then the lhs 36 | map defined with the same (key, value) pairs as the rhs map, becoming an 37 | independent copy of the rhs map; but see the caution_ below for derived 38 | type values. 39 | 40 | * The structure constructor ``map_any()`` evaluates to an empty map, 41 | and ``map_any`` variables come into existence as empty maps. 42 | 43 | Type bound subroutines 44 | ---------------------- 45 | 46 | ``insert(key, value)`` 47 | Add the specified key and associated value to the map. If the mapping 48 | already exists, its value is replaced with the specified one. ``key`` is 49 | a character string and ``value`` may be a scalar of any intrinsic or 50 | derived type. A copy of ``value`` is stored in the map; see the caution_ 51 | below for derived type values. 52 | 53 | ``remove(key)`` 54 | Remove the specified key from the map and deallocate the associated value. 55 | If the mapping does not exist, the map is unchanged. 56 | 57 | ``clear()`` 58 | Remove all elements from the map. 59 | 60 | Type bound functions 61 | -------------------- 62 | 63 | ``mapped(key)`` 64 | Return true if a mapping for the specified key exists. 65 | 66 | ``value(key)`` 67 | Return a ``class(*)`` pointer to the mapped value for the specified 68 | key, or a null pointer if the map does not contain the key. 69 | 70 | ``size()`` 71 | Return the number of elements in the map. 72 | 73 | ``empty()`` 74 | Return true if the map contains no elements; otherwise false. 75 | 76 | .. caution:: 77 | :name: caution 78 | 79 | Derived type values with pointer components, direct or indirect, should 80 | only be used advisedly. The map values are sourced-allocation copies of 81 | the values passed to the ``insert`` procedure, and this only makes a 82 | *shallow* copy of any pointer component. The original pointer and its 83 | copy will have the same target; no copy of the target is made. This also 84 | applies to map assignment where the values in the lhs map are 85 | sourced-allocation copies of the values in the rhs map. 86 | 87 | The map_any_iterator derived type 88 | ================================= 89 | The derived type ``map_any_iterator`` provides a means of iterating through 90 | the elements of a ``map_any`` object, sequentially visiting each element of 91 | a map once and only once. A defined ``map_any_iterator`` object is positioned 92 | at a particular element of its associated map, or at a pseudo-position 93 | *the-end*, and can be queried for the key and value of that element. 94 | 95 | The structure constructor ``map_any_iterator(map)`` evaluates to an iterator 96 | positioned at the the initial element of the specified ``map``, or the-end if 97 | ``map`` is empty, and ``map_any_iterator`` variables are initialized by 98 | assignment from such structure constructor expressions; for example, 99 | 100 | .. code-block:: fortran 101 | 102 | type(map_any) :: map 103 | type(map_any_iterator) :: iter 104 | iter = map_any_iterator(map) 105 | 106 | More generally, scalar assignment is defined for ``map_any_iterator`` objects. 107 | The lhs iterator becomes associated with the same map as the rhs iterator, and 108 | is positioned at the same element. Subsequent changes to one iterator do not 109 | affect the other. 110 | 111 | Type bound subroutine 112 | --------------------- 113 | 114 | ``next()`` 115 | Advance the iterator to the next element in the map, or to the-end if 116 | there are no more elements remaining to be visited. This call has no 117 | effect if the iterator is already positioned at the-end. 118 | 119 | Type bound functions 120 | -------------------- 121 | 122 | ``at_end()`` 123 | Return true if the iterator is positioned at the-end; otherwise false. 124 | 125 | ``key()`` 126 | Return the character string key for the current map element. 127 | The iterator must not be positioned at the-end. 128 | 129 | ``value()`` 130 | Return a ``class(*)`` pointer to the value of the current map element. 131 | The iterator must not be positioned at the-end. 132 | 133 | An example 134 | ========== 135 | 136 | .. code-block:: fortran 137 | 138 | use map_any_type 139 | 140 | type(map_any) :: map, map_copy 141 | type(map_any_iterator) :: iter 142 | class(*), pointer :: value 143 | 144 | type point 145 | real x, y 146 | end type 147 | 148 | !! Maps come into existence well-defined and empty. 149 | if (.not.map%empty()) print *, 'error: map is not empty!' 150 | 151 | !! Insert some elements into the map; note the different types. 152 | call map%insert('page', 3) 153 | call map%insert('size', 1.4) 154 | call map%insert('color', 'black') 155 | call map%insert('origin', point(1.0, 2.0)) 156 | 157 | !! Replace an existing mapping with a new value of different type. 158 | call map%insert('size', 'default') 159 | 160 | !! Remove a mapping. 161 | call map%remove('color') 162 | if (map%mapped('color')) print *, 'error: mapping not removed!' 163 | 164 | !! Retrieve a specific value. 165 | value => map%value('origin') 166 | 167 | !! Write the contents, using an iterator to access all elements. 168 | iter = map_any_iterator(map) 169 | do while (.not.iter%at_end()) 170 | select type (uptr => iter%value()) 171 | type is (integer) 172 | print *, iter%key(), ' = ', uptr 173 | type is (real) 174 | print *, iter%key(), ' = ', uptr 175 | type is (character(*)) 176 | print *, iter%key(), ' = ', uptr 177 | type is (point) 178 | print *, iter%key(), ' = ', uptr 179 | end select 180 | call iter%next 181 | end do 182 | 183 | !! Make a copy of the map. 184 | map_copy = map 185 | 186 | !! Delete the contents of map; map_copy is unchanged. 187 | call map%clear 188 | if (map%size() /= 0) print *, 'error: map size is not 0!' 189 | if (map_copy%empty()) print *, 'error: map_copy is empty!' 190 | -------------------------------------------------------------------------------- /doc/sphinx/json.rst: -------------------------------------------------------------------------------- 1 | .. _json-module: 2 | 3 | =============== 4 | The json module 5 | =============== 6 | 7 | The ``json`` module defines derived data types for representing arbitrary 8 | JSON data, and procedures for instantiating objects of those types from JSON 9 | text read from a file or string. 10 | 11 | This module uses :ref:`yajl_fort ` for parsing the JSON input data. 12 | 13 | .. note:: 14 | 15 | This module is a work-in-progress. While it provides the ability to read 16 | arbitrary JSON data and represent it in memory, it lacks many convenient 17 | methods for working with the data. Needed in particular, are methods for 18 | direct access to values using a "path" type of indexing. 19 | 20 | Usage 21 | ===== 22 | 23 | Refer to http://www.json.org for a detailed description of the JSON syntax. 24 | The derived types and terminology used here adhere closely to that description. 25 | 26 | The abstract type ``json_value`` represents a JSON `value`. The dynamic type 27 | of a polymorphic instance of this class will be one of these extended types: 28 | 29 | :``json_integer``: stores a JSON *number* without fractional part (P) 30 | :``json_real``: stores a JSON *number* with fractional part (P) 31 | :``json_string``: stores a JSON *string* (P) 32 | :``json_boolean``: stores a logical for the JSON literals ``true`` 33 | and ``false`` (P) 34 | :``json_null``: represents the JSON literal ``null`` (P) 35 | :``json_object``: stores a JSON *object* (S) 36 | :``json_array``: stores a JSON *array* (S) 37 | 38 | The primitive types (P) have a public component ``%value`` that stores the 39 | corresponding value (except for ``json_null``). The content of the structure 40 | types (S) are accessed via iterator objects. For ``json_object`` values: 41 | 42 | .. code-block:: fortran 43 | 44 | type(json_object), target :: value 45 | type(json_object_iterator) :: iter 46 | iter = json_object_iterator(value) 47 | do while (.not.iter%at_end()) ! order of object members is insignificant 48 | ! iter%name() is the name of the member 49 | ! iter%value() is a class(json_value) pointer to the value of the member 50 | call iter%next 51 | end do 52 | 53 | For ``json_array`` values: 54 | 55 | .. code-block:: fortran 56 | 57 | type(json_array), target :: value 58 | type(json_array_iterator) :: iter 59 | iter = json_array_iterator(value) 60 | do while (.not.iter%at_end()) ! order of array elements *is* significant 61 | ! iter%value() is a class(json_value) pointer to the value of the element 62 | call iter%next 63 | end do 64 | 65 | The following subroutines allocate and define an allocatable 66 | ``class(json_value)`` variable with JSON text read from a string or logical 67 | unit opened for unformatted stream input. 68 | 69 | .. code-block:: fortran 70 | 71 | call json_from_string(string, value, stat, errmsg) 72 | call json_from_stream(unit, value, stat, errmsg) 73 | character(*), intent(in) :: string 74 | integer, intent(in) :: unit 75 | class(json_value), allocatable, intent(out) :: value 76 | integer, intent(out) :: stat 77 | character(:), allocatable, intent(out) :: errmsg 78 | 79 | The argument ``stat`` returns a nonzero value if an error occurs, and in that 80 | case ``errmsg`` is assigned an explanatory error message. 81 | 82 | Examples 83 | ======== 84 | 85 | Here are some examples that use ``json_from_string``. Examples using 86 | ``json_from_stream`` would be essentially the same. Note that the ``stop`` 87 | statements identify things that should not occur. 88 | 89 | Reading primitive JSON values: 90 | 91 | .. code-block:: fortran 92 | 93 | use json 94 | 95 | class(json_value), allocatable :: val 96 | character(:), allocatable :: errmsg 97 | integer :: stat 98 | 99 | call json_from_string('42', val, stat, errmsg) 100 | select type (val) 101 | type is (json_integer) 102 | if (val%value /= 42) stop 1 103 | class default 104 | stop 2 105 | end select 106 | 107 | call json_from_string('"foo"', val, stat, errmsg) 108 | select type (val) 109 | type is (json_string) 110 | if (val%value /= 'foo') stop 3 111 | class default 112 | stop 4 113 | end select 114 | 115 | call json_from_string('false', val, stat, errmsg) 116 | if (stat /= 0) stop 51 117 | select type (val) 118 | type is (json_boolean) 119 | if (val%value) stop 5 120 | class default 121 | stop 6 122 | end select 123 | 124 | call json_from_string('null', val, stat, errmsg) 125 | select type (val) 126 | type is (json_null) 127 | class default 128 | stop 7 129 | end select 130 | 131 | Reading a JSON array value and iterating through its elements: 132 | 133 | .. code-block:: fortran 134 | 135 | use json 136 | 137 | class(json_value), allocatable :: val 138 | type(json_array_iterator) :: iter 139 | character(:), allocatable :: errmsg 140 | integer :: stat, n 141 | 142 | call json_from_string('[42,"foo",false,null]', val, stat, errmsg) 143 | 144 | select type (val) 145 | type is (json_array) 146 | n = 0 147 | iter = json_array_iterator(val) 148 | do while (.not.iter%at_end()) 149 | n = n + 1 150 | select type (ival => iter%value()) 151 | type is (json_integer) 152 | if (n /= 1) stop 1 153 | if (ival%value /= 42) stop 2 154 | type is (json_string) 155 | if (n /= 2) stop 3 156 | if (ival%value /= 'foo') stop 4 157 | type is (json_boolean) 158 | if (n /= 4) stop 5 159 | if (ival%value) stop 6 160 | type is (json_null) 161 | if (n /= 5) stop 7 162 | class default 163 | stop 8 164 | end select 165 | call iter%next 166 | end do 167 | class default 168 | stop 9 169 | end select 170 | 171 | Reading a JSON object value and iterating through its members: 172 | 173 | .. code-block:: fortran 174 | 175 | use json 176 | 177 | class(json_value), allocatable :: val 178 | type(json_object_iterator) :: iter 179 | character(:), allocatable :: errmsg 180 | integer :: stat 181 | 182 | call json_from_string('{"a":42,"b":"foo","c":false}', val, stat, errmsg) 183 | 184 | select type (val) 185 | type is (json_object) 186 | iter = json_object_iterator(val) 187 | do while (.not.iter%at_end()) 188 | select type (ival => iter%value()) 189 | type is (json_integer) 190 | if (iter%name() /= 'a') stop 1 191 | if (ival%value /= 42) stop 2 192 | type is (json_string) 193 | if (iter%name() /= 'b') stop 3 194 | if (ival%value /= 'foo') stop 4 195 | type is (json_boolean) 196 | if (iter%name() /= 'y') stop 6 197 | if (ival%value) stop 6 198 | class default 199 | stop 7 200 | end select 201 | call iter%next 202 | end do 203 | class default 204 | stop 8 205 | end select 206 | 207 | Error handling with invalid JSON: 208 | 209 | .. code-block:: fortran 210 | 211 | use json 212 | 213 | class(json_value), allocatable :: val 214 | integer :: stat 215 | character(:), allocatable :: errmsg 216 | 217 | call json_from_string('[1,2,foo,3]', val, stat, errmsg) 218 | if (stat == 0) stop 1 ! should have been an error 219 | write(*,*) errmsg 220 | 221 | This produces this error output when run: 222 | 223 | .. code-block:: none 224 | 225 | lexical error: invalid string in json text. 226 | [1,2,foo,3] 227 | (right here) ------^ 228 | -------------------------------------------------------------------------------- /doc/state_history_type.tex: -------------------------------------------------------------------------------- 1 | \documentclass[11pt]{article} 2 | 3 | \usepackage{lmodern} 4 | \usepackage[T1]{fontenc} 5 | 6 | \usepackage{underscore} 7 | \usepackage{verbatim} 8 | \usepackage{enumitem} 9 | 10 | \usepackage[nofancy]{latex2man} 11 | 12 | \usepackage[margin=1.25in,letterpaper]{geometry} 13 | 14 | \setlength{\parindent}{0pt} 15 | \setlength{\parskip}{\smallskipamount} 16 | 17 | \begin{document} 18 | 19 | %%% SET THE DATE 20 | \setDate{July 2013} 21 | \setVersion{1.0} 22 | 23 | \begin{Name}{3}{state_history_type}{Neil N. Carlson}{Petaca}{The state_history_type module} 24 | %%% THE ABSTRACT GOES HERE 25 | The \texttt{state_history_type} module provides a structure for maintaining 26 | the recent history of a solution procedure that is characterized by a (time) 27 | sequence of state vectors, and methods for performing polynomial interpolation 28 | based on that history. 29 | \end{Name} 30 | 31 | \section{Synopsis} 32 | \begin{description}[style=nextline] 33 | \item[Usage] 34 | \texttt{use :: state_history_type} 35 | \item[Derived Types] 36 | \texttt{state_history} 37 | \end{description} 38 | 39 | \section{The state_history derived type} 40 | The derived type \texttt{state_history} implements a scheme for maintaining 41 | the recent history of a solution procedure characterized by a (time) sequence 42 | of state vectors, and provides a method for computing polynomial interpolation 43 | based on that history. ODE integration algorithms often require such a 44 | capability, for example. The sequence of state vectors is stored internally 45 | as a table of divided differences, which is easily updated and which makes 46 | polynomial interpolation particularly simple to express. 47 | 48 | Object of this derived type: 49 | \begin{itemize}\setlength{\itemsep}{0pt} 50 | \item 51 | should not be used in assignment statements; only the default intrinsic 52 | assignment is available, and its semantics are unlikely to be what is 53 | desired. 54 | \item 55 | are properly finalized when the object is deallocated or otherwise 56 | ceases to exist. 57 | \end{itemize} 58 | 59 | The derived type has the following type bound procedures. The state vectors 60 | are implemented as rank-1 real arrays, and all real arguments and function 61 | results are of kind \texttt{real_kind()} (see the type bound function below). 62 | Currently this is \texttt{int64} from the intrinsic \texttt{iso_fortran_env} 63 | module. 64 | 65 | \subsection{Type bound subroutines} 66 | \begin{description}[style=nextline]\setlength{\itemsep}{0pt} 67 | \item[\texttt{init(mvec, \LBr t, x \Lbr,xdot\Rbr | vlen\RBr)}] 68 | initializes the object to maintain up to \texttt{mvec} state vectors. 69 | In the first variant, the vector \texttt{x} with time index \texttt{t} 70 | is recorded as the initial state vector of a new history. If the optional 71 | vector \texttt{xdot} is also specified, it is recorded as the state 72 | vector time derivative at the same time index. It must have the same 73 | size as \texttt{x} and the size of \texttt{x} establishes the expected 74 | size of all further state vector arguments. In the second variant, 75 | \texttt{vlen} specifies the length of the vectors to be maintained but 76 | no state vector is recorded. An object must be initialized before any 77 | of the other methods are invoked. It is permitted to re-initialize an 78 | object. 79 | \item[\texttt{flush(t, x \Lbr,xdot\Rbr)}] 80 | flushes the accumulated state vectors and records the state vector 81 | \texttt{x} with time index \texttt{t} as the initial state vector of 82 | a new history. If \texttt{xdot} is specified, it is also recorded as 83 | the state vector time derivative at the same time index. This differs 84 | from \texttt{init} in that the maximum number of vectors and their 85 | lengths are not changed. 86 | \item[\texttt{record_state(t, x \Lbr,xdot\Rbr)}] 87 | records the vector \texttt{x} with time index \texttt{t} as the most recent 88 | state vector in the history. If the vector \texttt{xdot} is present, it is 89 | recorded as the state vector time derivative at the same time index. The 90 | oldest state vector (or two oldest in the case \texttt{xdot} is present) is 91 | discarded once the history is fully populated with \texttt{mvec} vectors. 92 | Note that when only one of a \texttt{x}/\texttt{xdot} pair of vectors is 93 | discarded, it is effectively the derivative vector that gets discarded. 94 | \item[\texttt{get_last_state_copy(copy)}] 95 | copies the last recorded state vector into the array \texttt{copy}, 96 | whose length should equal \texttt{state_size()}. 97 | \item[\texttt{get_last_state_view(view)}] 98 | associates the array pointer \texttt{view} with the last recorded state 99 | vector. \emph{This should be used with great caution.} The target of 100 | this pointer should never be modified or deallocated. The pointer will 101 | cease to reference the last recorded state vector when the history is 102 | subsequently modified through calls to \texttt{record_state}, \texttt{flush}, 103 | or \texttt{init}. 104 | \item[\texttt{interp_state(t, x \Lbr,first\Rbr \Lbr,order\Rbr)}] 105 | computes the interpolated state vector at time index \texttt{t} from the 106 | set of state vectors maintained by the object, and returns the result in 107 | the user-supplied array \texttt{x}. Polynomial interpolation is used, and 108 | \texttt{order}, if present, specifies the order using the \texttt{order+1} 109 | most recent vectors; 1 for linear interpolation, 2 for quadratic, etc. 110 | It is an error to request an order for which there is insufficient data. 111 | If not specified, the maximal order is used given the available data; once 112 | the history is fully populated, the interpolation order is \texttt{mvec-1}. 113 | Typically the array \texttt{x} would have the same size as the stored state 114 | vectors, but more generally \texttt{x} may return any contiguous segment of 115 | the interpolated state starting at index \texttt{first} (default 1) and 116 | length the size of \texttt{x}. 117 | \item[\texttt{revise(index, x \Lbr,xdot\Rbr)}] 118 | revises the history of a selected state vector component: \texttt{index} 119 | is the component, \texttt{x} is the new most recent value of that component, 120 | and \texttt{xdot}, if present, is the new first divided difference. 121 | All higher-order divided differences for the component are set to zero. 122 | \texttt{Depth()} must be at least 1 (2 if \texttt{xdot} is present) to use 123 | this method. The use-case for this method arises from equation switching. 124 | \end{description} 125 | 126 | \subsection{Type bound functions} 127 | \begin{description}[style=nextline]\setlength{\itemsep}{0pt} 128 | \item[\texttt{real_kind()}] 129 | returns the kind parameter value expected of all real arguments. 130 | \item[\texttt{depth()}] 131 | returns the number of state vectors currently stored. This number will 132 | vary between 0 and \texttt{max_depth()}.. 133 | \item[\texttt{max_depth()}] 134 | returns the maximum number of state vectors that can be stored. This 135 | number is the value of \texttt{mvec} used to initialize the object. 136 | \item[\texttt{state_size()}] 137 | returns the length of the state vectors stored by the object. This number 138 | will equal the size of \texttt{x} or the value of \texttt{vlen} used to 139 | initialize the object. 140 | \item[\texttt{last_time()}] 141 | returns the time index of the last recorded state vector. 142 | \item[\texttt{time_deltas()}] 143 | returns an array containing the time index differences: the first element 144 | is the difference between the last and penultimate times; the second is the 145 | difference between the last and antepenultimate times, and so forth. The 146 | length of the result equals \texttt{depth()-1}. It is an error to call this 147 | method if \texttt{depth()} is less than 2. 148 | \item[\texttt{defined()}] 149 | returns true if the object is well-defined; otherwise it returns false. 150 | Defined means that the data components of the object are properly and 151 | consistently defined. The function should return true at any time after 152 | the \texttt{init} method has been called; it is intended to be used in 153 | debugging situations and is used internally in assertion checks. 154 | \end{description} 155 | 156 | %\section{Example} 157 | %\begin{verbatim} 158 | %%% SOME EXAMPLE CODE 159 | %\end{verbatim} 160 | 161 | \section{Bugs} 162 | Bug reports and improvement suggestions should be directed to 163 | \Email{neil.n.carlson@gmail.com} 164 | 165 | \LatexManEnd 166 | 167 | \end{document} 168 | -------------------------------------------------------------------------------- /modules/tridiagonal-solvers/src/btd_matrix_type.F90: -------------------------------------------------------------------------------- 1 | !! 2 | !! BTD_MATRIX_TYPE 3 | !! 4 | !! A data structure for block tridiagonal matrices with methods for linear 5 | !! equations and matrix-vector products. Supports periodic block tridiagonal 6 | !! matrices as well. Linear equation solution uses direct LU factorization 7 | !! without pivoting and is thus only suitable for classes of matrices not 8 | !! requiring pivoting, such as diagonally-dominant matrices. 9 | !! 10 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 11 | !! 12 | !! Copyright (c) 2013, 2023 Neil N. Carlson 13 | !! 14 | !! Permission is hereby granted, free of charge, to any person obtaining a 15 | !! copy of this software and associated documentation files (the "Software"), 16 | !! to deal in the Software without restriction, including without limitation 17 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 18 | !! and/or sell copies of the Software, and to permit persons to whom the 19 | !! Software is furnished to do so, subject to the following conditions: 20 | !! 21 | !! The above copyright notice and this permission notice shall be included 22 | !! in all copies or substantial portions of the Software. 23 | !! 24 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 25 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 26 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 27 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 28 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 29 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 30 | !! DEALINGS IN THE SOFTWARE. 31 | !! 32 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 33 | 34 | module btd_matrix_type 35 | 36 | use,intrinsic :: iso_fortran_env, only: r8 => real64 37 | implicit none 38 | private 39 | 40 | type, public :: btd_matrix 41 | integer :: nb ! block size 42 | integer :: n ! number of block rows/columns 43 | logical :: periodic = .false. 44 | real(r8), allocatable :: l(:,:,:), d(:,:,:), u(:,:,:) 45 | real(r8), allocatable :: q(:,:,:) ! factorization fill-in (periodic case) 46 | contains 47 | procedure :: init 48 | procedure :: factor 49 | procedure :: solve 50 | procedure :: matvec 51 | ! auxiliary procedures; available to type extensions 52 | procedure :: factor_submatrix 53 | procedure :: solve_submatrix 54 | procedure :: msolve_submatrix 55 | end type 56 | 57 | contains 58 | 59 | subroutine init(this, nb, n, periodic) 60 | class(btd_matrix), intent(out) :: this 61 | integer, intent(in) :: nb, n 62 | logical, intent(in), optional :: periodic 63 | this%n = n 64 | this%nb = nb 65 | if (present(periodic)) this%periodic = periodic 66 | if (nb < 2) error stop 'btd_matrix%init: block size < 2' 67 | if (n < 2) error stop 'btd_matrix%init: matrix size < 2' 68 | if (this%periodic .and. n < 3) error stop 'btd_matrix%init: periodic matrix < 3' 69 | allocate(this%l(nb,nb,n), this%d(nb,nb,n), this%u(nb,nb,n)) 70 | end subroutine 71 | 72 | subroutine factor(this) 73 | class(btd_matrix), intent(inout) :: this 74 | if (this%periodic) then 75 | call factor_periodic(this) 76 | else 77 | call factor_submatrix(this, 1, this%n) 78 | end if 79 | end subroutine 80 | 81 | pure subroutine factor_periodic(this) 82 | use block_solver_procs, only: fct, cmab 83 | class(btd_matrix), intent(inout) :: this 84 | associate (nb => this%nb, n => this%n) 85 | call factor_submatrix(this, 1, n-1) 86 | allocate(this%q(nb,nb,n-1)) 87 | this%q(:,:,1) = this%l(:,:,1) 88 | this%q(:,:,2:n-2) = 0.0_r8 89 | this%q(:,:,n-1) = this%u(:,:,n-1) 90 | call msolve_submatrix(this, 1, n-1, this%q) 91 | call cmab(this%d(:,:,n), this%u(:,:,n), this%q(:,:,1)) 92 | call cmab(this%d(:,:,n), this%l(:,:,n), this%q(:,:,n-1)) 93 | call fct(this%d(:,:,n)) 94 | end associate 95 | end subroutine 96 | 97 | !! This auxiliary subroutine computes the usual LU factorization of the 98 | !! local submatrix composed of rows/columns j1 through j2. The elements 99 | !! of the local submatrix are overwritten with the elements of L and unit 100 | !! upper triangular U. 101 | 102 | pure subroutine factor_submatrix(this, j1, j2) 103 | use block_solver_procs, only: fct, mslv, cmab 104 | class(btd_matrix), intent(inout) :: this 105 | integer, intent(in) :: j1, j2 106 | integer :: j 107 | call fct(this%d(:,:,j1)) 108 | do j = j1+1, j2 109 | call mslv(this%d(:,:,j-1), this%u(:,:,j-1)) 110 | call cmab(this%d(:,:,j), this%l(:,:,j), this%u(:,:,j-1)) 111 | call fct(this%d(:,:,j)) 112 | end do 113 | end subroutine 114 | 115 | subroutine solve(this, b) 116 | class(btd_matrix), intent(in) :: this 117 | real(r8), intent(inout) :: b(:,:) 118 | if (this%periodic) then 119 | call solve_periodic(this, b) 120 | else 121 | call solve_submatrix(this, 1, this%n, b) 122 | end if 123 | end subroutine 124 | 125 | pure subroutine solve_periodic(this, b) 126 | use block_solver_procs, only: slv, ymax 127 | class(btd_matrix), intent(in) :: this 128 | real(r8), intent(inout) :: b(:,:) 129 | integer :: j 130 | associate (n => this%n) 131 | call this%solve_submatrix(1, n-1, b) 132 | call ymax(b(:,n), this%u(:,:,n), b(:,1)) 133 | call ymax(b(:,n), this%l(:,:,n), b(:,n-1)) 134 | call slv(this%d(:,:,n), b(:,n)) 135 | do j = 1, n-1 136 | call ymax(b(:,j), this%q(:,:,j), b(:,n)) 137 | end do 138 | end associate 139 | end subroutine 140 | 141 | !! This auxiliary subroutine solves the linear system Ax = b where A is 142 | !! the submatrix composed of rows/columns j1 through j2. The submatrix 143 | !! must store the LU factorization computed by SERIAL_FACTOR. The RHS b 144 | !! is the subvector of the passed B composed of elements j1 through j2, 145 | !! and the computed solution overwrites those elements. Other elements 146 | !! of B are unmodified. 147 | 148 | pure subroutine solve_submatrix(this, j1, j2, b) 149 | use block_solver_procs, only: slv, ymax 150 | class(btd_matrix), intent(in) :: this 151 | integer, intent(in) :: j1, j2 152 | real(r8), intent(inout) :: b(:,:) 153 | integer :: j 154 | call slv(this%d(:,:,j1), b(:,j1)) 155 | do j = j1+1, j2 156 | call ymax(b(:,j), this%l(:,:,j), b(:,j-1)) 157 | call slv(this%d(:,:,j), b(:,j)) 158 | end do 159 | do j = j2-1, j1, -1 160 | call ymax(b(:,j), this%u(:,:,j), b(:,j+1)) 161 | end do 162 | end subroutine 163 | 164 | !! Similar to SOLVE_SUBMATRIX, this auxiliary subroutine solves the linear 165 | !! system AX = B where A is the submatrix composed of rows/columns j1 166 | !! through j2. The RHS B is the subvector of the passed block vector B 167 | !! composed of elements j1 through j2, and the computed solution overwrites 168 | !! those elements. Other elements of B are unmodified. 169 | 170 | pure subroutine msolve_submatrix(this, j1, j2, b) 171 | use block_solver_procs, only: mslv, cmab 172 | class(btd_matrix), intent(in) :: this 173 | integer, intent(in) :: j1, j2 174 | real(r8), intent(inout) :: b(:,:,:) 175 | integer :: j 176 | call mslv(this%d(:,:,j1), b(:,:,j1)) 177 | do j = j1+1, j2 178 | call cmab(b(:,:,j), this%l(:,:,j), b(:,:,j-1)) 179 | call mslv(this%d(:,:,j), b(:,:,j)) 180 | end do 181 | do j = j2-1, j1, -1 182 | call cmab(b(:,:,j), this%u(:,:,j), b(:,:,j+1)) 183 | end do 184 | end subroutine 185 | 186 | subroutine matvec(this, x, y) 187 | 188 | use block_solver_procs, only: ypax 189 | 190 | class(btd_matrix), intent(in) :: this 191 | real(r8), intent(in) :: x(:,:) 192 | real(r8), intent(out) :: y(:,:) 193 | 194 | integer :: j 195 | 196 | y(:,1) = 0.0_r8 197 | call ypax(y(:,1), this%d(:,:,1), x(:,1)) 198 | call ypax(y(:,1), this%u(:,:,1), x(:,2)) 199 | if (this%periodic) call ypax(y(:,1), this%l(:,:,1), x(:,this%n)) 200 | 201 | do j = 2, this%n-1 202 | y(:,j) = 0.0_r8 203 | call ypax(y(:,j), this%l(:,:,j), x(:,j-1)) 204 | call ypax(y(:,j), this%d(:,:,j), x(:,j)) 205 | call ypax(y(:,j), this%u(:,:,j), x(:,j+1)) 206 | end do 207 | 208 | y(:,j) = 0.0_r8 209 | call ypax(y(:,j), this%l(:,:,j), x(:,j-1)) 210 | call ypax(y(:,j), this%d(:,:,j), x(:,j)) 211 | if (this%periodic) call ypax(y(:,j), this%u(:,:,j), x(:,1)) 212 | 213 | end subroutine 214 | 215 | end module btd_matrix_type 216 | -------------------------------------------------------------------------------- /test/state_history_type/test_state_history_type.F90: -------------------------------------------------------------------------------- 1 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2 | !! 3 | !! Copyright (c) 2011, 2013 Neil N. Carlson 4 | !! 5 | !! Permission is hereby granted, free of charge, to any person obtaining a 6 | !! copy of this software and associated documentation files (the "Software"), 7 | !! to deal in the Software without restriction, including without limitation 8 | !! the rights to use, copy, modify, merge, publish, distribute, sublicense, 9 | !! and/or sell copies of the Software, and to permit persons to whom the 10 | !! Software is furnished to do so, subject to the following conditions: 11 | !! 12 | !! The above copyright notice and this permission notice shall be included 13 | !! in all copies or substantial portions of the Software. 14 | !! 15 | !! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | !! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | !! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 18 | !! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | !! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 20 | !! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 | !! DEALINGS IN THE SOFTWARE. 22 | !! 23 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 24 | 25 | program test_state_history_type 26 | 27 | use,intrinsic :: iso_fortran_env, only: r8 => real64 28 | use state_history_type 29 | implicit none 30 | 31 | integer :: status = 0 32 | 33 | call test_finalization 34 | call test_counts 35 | call test_record_interp 36 | call test_record_xdot 37 | call test_revise 38 | call test_recent 39 | call test_deltas 40 | call test_flush 41 | call test_defined 42 | call test_assignment 43 | 44 | if (status /= 0) stop 1 45 | 46 | contains 47 | 48 | subroutine test_finalization 49 | type(state_history) :: h1 50 | type(state_history), pointer :: h2(:) 51 | allocate(h2(2)) 52 | call h2(1)%init(1,1) 53 | deallocate(h2) 54 | end subroutine test_finalization 55 | 56 | subroutine test_counts 57 | 58 | logical :: pass 59 | type(state_history) :: h 60 | 61 | call h%init (3, 1) 62 | pass = (h%max_depth() == 3) .and. (h%state_size() == 1) 63 | pass = pass .and. (h%depth() == 0) 64 | 65 | call h%record_state (0.0_r8, [0.0_r8]) 66 | pass = pass .and. (h%depth() == 1) 67 | 68 | call h%record_state (1.0_r8, [0.0_r8], [1.0_r8]) 69 | pass = pass .and. (h%depth() == 3) 70 | 71 | call h%record_state (0.0_r8, [0.0_r8]) 72 | pass = pass .and. (h%depth() == 3) 73 | 74 | call h%flush (0.0_r8, [0.0_r8]) 75 | pass = pass .and. (h%depth() == 1) 76 | 77 | call h%init (1, 2) 78 | pass = pass .and. (h%max_depth() == 1) .and. (h%state_size() == 2) 79 | pass = pass .and. (h%depth() == 0) 80 | 81 | call h%record_state (0.0_r8, [0.0_r8, 0.0_r8]) 82 | pass = pass .and. (h%depth() == 1) 83 | 84 | call h%record_state (0.0_r8, [0.0_r8, 0.0_r8]) 85 | pass = pass .and. (h%depth() == 1) 86 | 87 | if (.not.pass) then 88 | status = 1 89 | write(0,*) 'test_counts failed' 90 | end if 91 | 92 | end subroutine test_counts 93 | 94 | subroutine test_record_interp 95 | 96 | integer :: n 97 | logical :: pass 98 | real(r8) :: t, dt, x(5), xref(5) 99 | type(state_history) :: h 100 | real(r8), parameter :: TREF = 2.0_r8 101 | integer, parameter :: MVEC = 5 102 | 103 | xref = poly(TREF) 104 | call h%init(MVEC, size(xref)) 105 | 106 | t = -0.625_r8 107 | dt = 0.375_r8 108 | do n = 1, MVEC 109 | call h%record_state(t, poly(t)) 110 | call h%interp_state(TREF, x) 111 | x = x - xref 112 | pass = all(x(:n) == 0.0_r8) .and. all(x(n+1:) /= 0.0_r8) 113 | if (.not.pass) exit 114 | t = t + dt 115 | end do 116 | 117 | call h%interp_state (t=1.0_r8, x=x(:3)) 118 | call h%interp_state (t=1.0_r8, x=x(4:5), first=4) 119 | xref = poly(1.0_r8) 120 | pass = pass .and. all(xref == x) 121 | 122 | if (.not.pass) then 123 | status = 1 124 | write(0,*) 'test_record_interp failed' 125 | end if 126 | 127 | end subroutine test_record_interp 128 | 129 | subroutine test_record_xdot () 130 | 131 | logical :: pass 132 | real(r8) :: x(1) 133 | type(state_history) :: h 134 | 135 | call h%init (mvec=4, t=0.0_r8, x=[p(0.0_r8)], xdot=[pp(0.0_r8)]) 136 | call h%record_state (t=1.0_r8, x=[p(1.0_r8)], xdot=[pp(1.0_r8)]) 137 | 138 | call h%interp_state (t=0.5_r8, x=x) 139 | pass = (x(1) == p(0.5_r8)) 140 | 141 | if (.not.pass) then 142 | status = 1 143 | write(0,*) 'test_record_xdot failed' 144 | end if 145 | 146 | end subroutine test_record_xdot 147 | 148 | real(r8) function p (t) 149 | real(r8), intent(in) :: t 150 | p = 2 + t*(t*(t-1)-1) 151 | end function p 152 | 153 | real(r8) function pp (t) 154 | real(r8), intent(in) :: t 155 | pp = (3*t - 2)*t - 1 156 | end function pp 157 | 158 | subroutine test_revise 159 | 160 | integer :: n 161 | logical :: pass 162 | real(r8) :: t, dt, x(5) 163 | type(state_history) :: h 164 | integer, parameter :: MVEC = 3 165 | 166 | call h%init(MVEC, size(x)) 167 | 168 | t = -0.625_r8 169 | dt = 0.375_r8 170 | do n = 1, MVEC 171 | call h%record_state(t, poly(t)) 172 | t = t + dt 173 | end do 174 | 175 | call h%revise(2, x=10.0_r8) 176 | call h%revise(3, x=10.0_r8, xdot=1.0_r8) 177 | call h%interp_state (t, x(2:3), first=2) 178 | 179 | pass = (x(2) == 10) .and. (x(3) == 10 + dt) 180 | 181 | if (.not.pass) then 182 | status = 1 183 | write(0,*) 'test_revise failed' 184 | end if 185 | 186 | end subroutine test_revise 187 | 188 | subroutine test_recent () 189 | 190 | logical :: pass 191 | integer :: n 192 | real(r8) :: t, x(1) 193 | type(state_history) :: h 194 | real(r8), pointer :: view(:) 195 | 196 | call h%init (3, 1) 197 | 198 | pass = .true. 199 | t = 1.0_r8 200 | x = 2.0_r8 201 | do n = 1, 4 202 | call h%record_state (t, x) 203 | call h%get_last_state_view (view) 204 | pass = pass .and. (h%last_time() == t) .and. all(view == x) 205 | t = 1.25_r8 * t 206 | x = 1.25_r8 * x 207 | end do 208 | 209 | call h%record_state (t, x, 2*x) 210 | call h%get_last_state_view (view) 211 | pass = pass .and. (h%last_time() == t) .and. all(view == x) 212 | 213 | if (.not.pass) then 214 | status = 1 215 | write(0,*) 'test_recent failed' 216 | end if 217 | 218 | end subroutine test_recent 219 | 220 | subroutine test_deltas () 221 | 222 | integer :: n 223 | logical :: pass 224 | real(r8) :: t(0:4) = [1.0, 1.5, 1.75, 2.125, 3.125] 225 | type(state_history) :: h 226 | 227 | pass = .true. 228 | call h%init (4, t(0), [1.0_r8]) 229 | do n = 1, 3 230 | call h%record_state (t(n), [1.0_r8]) 231 | pass = pass .and. all(t(n)-t(n-1:0:-1) == h%time_deltas()) 232 | end do 233 | call h%record_state (t(4), [1.0_r8]) 234 | pass = pass .and. all(t(4)-t(3:1:-1) == h%time_deltas()) 235 | 236 | if (.not.pass) then 237 | status = 1 238 | write(0,*) 'test_deltas failed' 239 | end if 240 | 241 | end subroutine test_deltas 242 | 243 | subroutine test_flush () 244 | 245 | logical :: pass 246 | real(r8) :: x(1), xref(1) 247 | type(state_history) :: h 248 | real(r8), pointer :: view(:) 249 | 250 | call h%init (4, 0.0_r8, [0.0_r8], [1.0_r8]) 251 | 252 | xref = [-1.0_r8] 253 | call h%flush (1.0_r8, xref) 254 | call h%interp_state (2.0_r8, x) 255 | call h%get_last_state_view (view) 256 | 257 | pass = (h%last_time() == 1.0_r8) .and. & 258 | all(view == xref) .and. & 259 | all(x == xref) 260 | 261 | if (.not.pass) then 262 | status = 1 263 | write(0,*) 'test_flush failed' 264 | end if 265 | 266 | end subroutine test_flush 267 | 268 | subroutine test_defined 269 | 270 | logical :: pass 271 | type(state_history) :: h 272 | 273 | pass = .not. h%defined() 274 | 275 | call h%init (2, 1) 276 | pass = pass .and. h%defined() 277 | 278 | call h%flush (0.0_r8, [1.0_r8]) 279 | pass = pass .and. h%defined() 280 | 281 | if (.not.pass) then 282 | status = 1 283 | write(0,*) 'test_flush failed' 284 | end if 285 | 286 | end subroutine test_defined 287 | 288 | subroutine test_assignment 289 | 290 | integer :: n 291 | logical :: pass 292 | real(r8) :: t, dt, x(5), xref(5) 293 | type(state_history), allocatable :: h 294 | type(state_history) :: hcopy 295 | real(r8), parameter :: TREF = 2.0_r8 296 | integer, parameter :: MVEC = 5 297 | 298 | xref = poly(TREF) 299 | allocate(h) 300 | call h%init(MVEC, size(xref)) 301 | 302 | t = -0.625_r8 303 | dt = 0.375_r8 304 | do n = 1, 3 305 | call h%record_state(t, poly(t)) 306 | hcopy = h 307 | t = t + dt 308 | end do 309 | call h%record_state(t, poly(t+1)) ! pollute the data 310 | deallocate(h) 311 | 312 | call hcopy%interp_state(TREF, x) 313 | x = x - xref 314 | pass = all(x(:3) == 0.0_r8) .and. all(x(4:) /= 0.0_r8) 315 | 316 | if (.not.pass) then 317 | status = 1 318 | write(0,*) 'test_assignment failed' 319 | end if 320 | 321 | end subroutine test_assignment 322 | 323 | function poly (t) result (p) 324 | real(r8), intent(in) :: t 325 | real(r8) :: p(5) 326 | p(1) = 1 327 | p(2) = 1 - t 328 | p(3) = 1 + t*(1 + t) 329 | p(4) = 2 - t*(1 - t*t) 330 | p(5) = 1 + t*t*(1 - t*t) 331 | end function poly 332 | 333 | function poly_deriv (t) result (pp) 334 | real(r8), intent(in) :: t 335 | real(r8) :: pp(5) 336 | pp(1) = 0 337 | pp(2) = -1 338 | pp(3) = 1 + 2*t 339 | pp(4) = -1 + 3*t*t 340 | pp(5) = t*(2 - 4*t*t) 341 | end function poly_deriv 342 | 343 | end program test_state_history_type 344 | -------------------------------------------------------------------------------- /doc/sphinx/timer_tree_type.rst: -------------------------------------------------------------------------------- 1 | ========================== 2 | The timer_tree_type module 3 | ========================== 4 | The ``timer_tree_type`` module implements a lightweight method for creating 5 | and maintaining a nested tree of timers. The tree is automatically generated 6 | via the nested starting and stopping of named timers. Because timers are 7 | distinguished by name and position in the tree, a start/stop pair will give 8 | rise to different timers when the code containing it is executed within 9 | different timer nestings. As a result, the timing of shared code can be easily 10 | and automatically partitioned according to its use. 11 | 12 | Basic usage 13 | =========== 14 | The most basic use of the timers requires no more than calling ``start_timer`` 15 | and ``stop_timer`` in matching pairs with an arbitrary name as in this example: 16 | 17 | .. code-block:: fortran 18 | 19 | use timer_tree_type 20 | 21 | call start_timer ('A') 22 | call start_timer ('B') 23 | call stop_timer ('B') 24 | call start_timer ('C') 25 | call start_timer ('B') 26 | call stop_timer ('B') 27 | call stop_timer ('C') 28 | call stop_timer ('A') 29 | call start_timer ('B') 30 | call start_timer ('X') 31 | call stop_timer ('X') 32 | call start_timer ('Y') 33 | call stop_timer ('Y') 34 | call start_timer ('Z') 35 | call stop_timer ('Z') 36 | call stop_timer ('B') 37 | call start_timer ('A') 38 | call stop_timer ('A') 39 | 40 | call write_timer_tree(unit=6, indent=2) 41 | 42 | The only restriction is that the timers be nested: the timer most recently 43 | started (and still running) is the only one eligible to be stopped. Starting A, 44 | then B, and then stopping A is not allowed, for example. Any incorrect nesting 45 | of timers will be detected by ``stop_timer`` at run time. The calls, of course, 46 | can be in different program units. 47 | 48 | The same name may be used for multiple start/stop pairs, and start/stop 49 | pairs with the same name *and nesting* are regarded as a single timer 50 | and their elapsed time accumulated accordingly. Otherwise they are regarded 51 | as distinct timers. An example of the latter is timer B. It is started and 52 | stopped at three different positions within the call nesting, and this is 53 | reflected in the associated timer tree pictured here: 54 | 55 | .. graphviz:: 56 | 57 | digraph FLATLAND { 58 | 0 -> 1 -> 2; 59 | 1 -> 3 -> 4; 60 | 0 -> 5 -> 6; 61 | 5 -> 7; 62 | 5 -> 8; 63 | 0 [label="root"] 64 | 1 [label=A] 65 | 2 [label=B] 66 | 3 [label=C] 67 | 4 [label=B] 68 | 5 [label=B] 69 | 6 [label=X] 70 | 7 [label=Y] 71 | 8 [label=Z] 72 | } 73 | 74 | Each pair is regarded as a distinct timer. Timer A, on the other hand, is an 75 | example of the former case. It is started and stopped twice, but at the same 76 | position within the call nesting, and thus appears in the timer tree only once. 77 | The elapsed time for each call pair is accumulated in the single timer as 78 | expected. 79 | 80 | Finally, a call to ``write_timer_tree`` (at any time) will write the 81 | time accumulated thus far for each timer, using indentation to express the 82 | nested structure of the timer tree. The output would look something like 83 | this for the code example:: 84 | 85 | A: 4.90000E-02 86 | B: 1.00000E-02 87 | C: 1.90000E-02 88 | B: 9.00000E-03 89 | B: 2.80000E-02 90 | X: 9.00000E-03 91 | Y: 1.00000E-02 92 | Z: 9.00000E-03 93 | 94 | .. \end{Verbatim} 95 | .. \end{minipage} 96 | .. \caption{A sequence of \texttt{start_timer}/\texttt{stop_timer} calls 97 | .. and the corresponding timer tree that it generates. Also a sample 98 | .. of the type of output generated by \texttt{write_timer_tree}.}% 99 | .. \label{fig1} 100 | .. \end{figure} 101 | 102 | Because timers are distinguished by name and position in the tree, a 103 | start/stop pair will give rise to different timers when the code containing 104 | it is executed within different timer nestings. As a result, the timing of 105 | a portion of shared code can be easily and automatically partitioned according 106 | to its use. This is a distinctive feature of this implementation. 107 | 108 | For portability the Fortran intrinsic subroutine ``system_clock`` is used to 109 | get the wall clock time, and the resolution of the timers is thus limited 110 | by the resolution of this subroutine, which can vary significantly between 111 | systems. 112 | 113 | For most cases this covers everything one needs to know to in order to use 114 | the global timer tree managed by the ``timer_tree_type`` module. The next 115 | section describes some additional functionality that may be useful, and in 116 | section that follows it, the ``timer_tree`` derived type that underlies the 117 | implementation is described. 118 | 119 | The global timer tree 120 | ===================== 121 | The following subroutines operate on the global timer tree. 122 | 123 | ``call start_timer(name [,handle])`` 124 | Start the timer with the specified character string ``name`` that is a child 125 | of the current timer. If no such child exists, one is created with this name. 126 | This child timer then becomes the current timer. If the optional integer 127 | argument ``handle`` is specified, it returns a handle to the timer which can 128 | be used as an argument to ``write_timer_tree`` or ``read_timer``. 129 | 130 | ``call stop_timer(name [,stat [,errmsg]])`` 131 | Stop the current timer. The current timer's parent becomes the new current 132 | timer. It is an error if the current timer does not have the specified name. 133 | If the optional integer argument ``stat`` is present, it is assigned the 134 | value 0 if no error was encountered; otherwise it is assigned a non-zero 135 | value. In the latter case, the allocatable deferred-length character string 136 | ``errmsg``, if present, is assigned an explanatory message. If ``stat`` is 137 | not present and an error occurs, the error message is written to the 138 | preconnected error unit and the program exits with a nonzero status. 139 | 140 | ``call write_timer_tree(unit, indent [,handle])`` 141 | Write the accumulated time for each timer to the specified logical ``unit``, 142 | using indentation to express the nested structure of the timer tree. The 143 | incremental number of spaces to indent for successive tree levels is given 144 | by ``indent``. If an optional integer ``handle`` returned by ``start_timer`` 145 | is specified, only the accumulated times for that timer and its decendents 146 | are written. 147 | 148 | ``call read_timer(handle, time)`` 149 | Returns in the default real argument ``time``, the elapsed time for the timer 150 | corresponding to the ``handle`` returned by ``start_timer``. The timer may 151 | be running or stopped. 152 | 153 | ``call reset_timer_tree`` 154 | resets the timer tree to its initial, empty state. 155 | 156 | Accessing the timer tree data 157 | ----------------------------- 158 | Sometimes more direct access to the timer tree data is needed than is provided 159 | by either ``read_timer`` or ``write_timer_tree``. For example, the data may 160 | need to be communicated between processes in a parallel simulation, or it may 161 | need to be written in a format that can be easily read and used to initialize 162 | the timer tree. The following subroutines provide such functionality. 163 | 164 | ``call serialize_timer_tree(tree, name, time)`` 165 | Get the current state of the timer tree in flat arrays. Timers may be 166 | running or stopped and their state is unaltered. The deferred-length, 167 | allocatable character array ``name`` and allocatable default real array 168 | ``time`` return the timer names and elapsed times indexed by tree node 169 | number. The allocatable default integer array ``tree`` returns the structure 170 | of the tree as a sequence of node numbers: node numbers appear in matching 171 | pairs, like opening and closing parentheses, with the intervening sequence 172 | describing the trees of its children, recusively. The nodes are numbered so 173 | that the initial node of the pairs appear in sequential order. This enables 174 | a simple reconstruction of the tree. All three allocatable array arguments 175 | are allocated by the subroutine; they are reallocated if necessary. 176 | 177 | ``call deserialize_timer_tree(tree, name, time)`` 178 | Define the state of the timer tree using the ``tree``, ``name``, and 179 | ``time`` arrays returned by ``serialize_timer_tree``. This can be used to 180 | initialize the timer tree with results from a previous simulation, for 181 | example. Note that timer handles are not preserved. 182 | 183 | Using the data from serialize_timer_tree 184 | """""""""""""""""""""""""""""""""""""""" 185 | This code fragment shows how to use the output of ``serialize_timer_tree`` to 186 | reconstruct the tree by writing a group of nested XML tags that reproduce the 187 | structure of the tree. The integer ``m`` records the high-water mark of the 188 | tree node numbers encountered, which, due of the way the nodes are numbered, 189 | can be used to distinguish the initial and final node of each pair. 190 | 191 | .. code-block:: fortran 192 | 193 | m = 0 ! the high-water mark of node indices encountered 194 | do j = 1, size(tree) 195 | n = tree(j) 196 | if (n > m) then ! first encounter of this node index 197 | print *, '' 198 | m = n 199 | else 200 | print *, '' 201 | end if 202 | end do 203 | 204 | 205 | The timer_tree derived type 206 | =========================== 207 | The timer tree used thus far is in fact a ``type(timer_tree)`` object that is 208 | a private module variable in the ``timer_tree_type`` module (a 'singleton'). 209 | The procedures described above all operate on this single global instance. But 210 | applications can also declare and use their own ``type(timer_tree)`` variables. 211 | 212 | This derived type has the following type bound subroutines which have the same 213 | interface and effect as those described above, except that they operate on the 214 | specific instance rather than the global timer tree. 215 | 216 | ``start(name [,handle])`` 217 | Same interface as ``start_timer``. 218 | ``stop(name [,stat [,errmsg]])`` 219 | Same interface as ``stop_timer``. 220 | ``write(unit, indent [,handle])`` 221 | Same interface as ``write_timer_tree``. 222 | ``read(handle, time)`` 223 | Same interface as ``read_timer``. 224 | ``serialize(tree, name, time)`` 225 | Same interface as ``serialize_timer_tree``. 226 | ``deserialize(tree, name, time)`` 227 | Same interface as ``deserialize_timer_tree``. 228 | 229 | Note that objects of this derived type: 230 | 231 | * are properly finalized when the object ceases to exist. 232 | * should *not* be used in assignment statements; only the default intrinsic 233 | assignment is available, and its semantics are unlikely to be what is wanted. 234 | --------------------------------------------------------------------------------