pax_global_header00006660000000000000000000000064137212464550014523gustar00rootroot0000000000000052 comment=e2aaa0d82a0f082b855add94c8aa5a5b1f2d9560 gFTL-1.2.7/000077500000000000000000000000001372124645500123265ustar00rootroot00000000000000gFTL-1.2.7/.gitattributes000066400000000000000000000000771372124645500152250ustar00rootroot00000000000000*.inc linguist-language=Fortran *.pf linguist-language=Fortran gFTL-1.2.7/.gitignore000066400000000000000000000000031372124645500143070ustar00rootroot00000000000000*~ gFTL-1.2.7/.travis.yml000066400000000000000000000044561372124645500144500ustar00rootroot00000000000000os: - linux - osx dist: bionic osx_image: xcode11.6 language: c arch: - amd64 addons: apt: sources: - ubuntu-toolchain-r-test - sourceline: deb https://apt.kitware.com/ubuntu/ bionic main key_url: https://apt.kitware.com/keys/kitware-archive-latest.asc packages: - gfortran-9 - gfortran-10 - g++-9 - g++-10 - libgfortran5-dbg - libxml2-utils - cmake homebrew: packages: - gcc@9 - cmake update: false env: jobs: - FC='gfortran-9' CC='gcc-9' CXX='g++-9' CACHE_NAME=$TRAVIS_OS_NAME-$TRAVIS_CPU_ARCH-$FC - FC='gfortran-10' CC='gcc-10' CXX='g++-10' CACHE_NAME=$TRAVIS_OS_NAME-$TRAVIS_CPU_ARCH-$FC # caching of the whole `local` directory. Can't cache only the one for this # `env`, because otherwise the different instances will overwrite the cache. # For the first test-run, the build has to be run sequentially (limit parallel # workers to 1) so that the cache can be correctly initialized. Once the cache # is build, parallel workers can be re-enabled. cache: directories: - ${HOME}/local timeout: 600 before_script: # Install cmake on linux (assume osx is good) - | if [ $TRAVIS_OS_NAME != 'osx' ] ; then export cmake_ver=3.18.1 sh ./tools/travis-install-cmake.sh ${cmake_ver} # set up cmake location export PATH=${HOME}/local/cmake/bin:${PATH} export LIBRARY_PATH=${HOME}/local/cmake/lib:${LIBRARY_PATH} export LD_LIBRARY_PATH=${HOME}/local/cmake/lib:${LD_LIBRARY_PATH} # print out version information sudo apt purge --autoremove cmake cmake --version else cmake --version fi # Install GFE dependencies - | ${FC} --version bash ./tools/travis-install-gfe.bash # Now build gFTL - cd ${TRAVIS_BUILD_DIR} - mkdir -p build && cd build - cmake .. -DCMAKE_Fortran_COMPILER=${FC} -DCMAKE_INSTALL_PREFIX=${HOME}/Software/gFTL -DCMAKE_PREFIX_PATH=${HOME}/Software/GFE script: # Build - make -j$(nproc) VERBOSE=1 # Make tests - make -j$(nproc) tests # Run tests - ctest -j $(nproc) --output-on-failure notifications: email: recipients: - matthew.thompson@nasa.gov - tom.clune@nasa.gov gFTL-1.2.7/CMakeLists.txt000066400000000000000000000036531372124645500150750ustar00rootroot00000000000000cmake_minimum_required (VERSION 3.0) if (COMMAND cmake_policy) cmake_policy (SET CMP0003 NEW) endif (COMMAND cmake_policy) project (GFTL VERSION 1.2.7 LANGUAGES Fortran) if (CMAKE_INSTALL_PREFIX_INITIALIZED_TO_DEFAULT) set (CMAKE_INSTALL_PREFIX "${CMAKE_BINARY_DIR}/installed" CACHE PATH "..." FORCE) message("-- Setting default install prefix to ${CMAKE_INSTALL_PREFIX}.") message(" Override with -DCMAKE_INSTALL_PREFIX=.") endif () # For BSD systems use GNU m4 find_program( M4 NAMES "gm4" "m4") if( NOT M4 ) message( SEND_ERROR "m4 program not found" ) endif() add_subdirectory (include) add_subdirectory (examples) find_package (PFUNIT 4.1 QUIET) if (PFUNIT_FOUND) message("-- Detecting pFUnit: ${PFUNIT_DIR}") project (GFTL-TEST VERSION ${GFTL_VERSION} LANGUAGES Fortran ) set (CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${GFTL_SOURCE_DIR}/cmake_utils") include (${CMAKE_Fortran_COMPILER_ID} RESULT_VARIABLE found) include (CheckFortranSource) include (CheckCompilerCapabilities) enable_testing() if (NOT TARGET tests) add_custom_target(tests COMMAND ${CMAKE_CTEST_COMMAND}) endif () add_subdirectory(tests EXCLUDE_FROM_ALL) endif () configure_file(GFTLConfig.cmake.in ${CMAKE_CURRENT_BINARY_DIR}/GFTLConfig.cmake @ONLY) configure_file(GFTLConfig-version.cmake.in ${CMAKE_CURRENT_BINARY_DIR}/GFTLConfig-version.cmake @ONLY) set (top_dir "GFTL-${GFTL_VERSION_MAJOR}.${GFTL_VERSION_MINOR}") install ( FILES ${CMAKE_CURRENT_BINARY_DIR}/GFTLConfig.cmake ${CMAKE_CURRENT_BINARY_DIR}/GFTLConfig-version.cmake DESTINATION "${top_dir}/cmake" ) # The following is needed for external projects using *nix make when # parent project builds gFTL as a subproject. set (GFTL_TOP_DIR "${CMAKE_INSTALL_PREFIX}/${top_dir}" CACHE PATH "") configure_file(GFTL.mk.in ${CMAKE_CURRENT_BINARY_DIR}/GFTL.mk @ONLY) install ( FILES ${CMAKE_CURRENT_BINARY_DIR}/GFTL.mk DESTINATION "${top_dir}/include" ) gFTL-1.2.7/ChangeLog.MD000066400000000000000000000022231372124645500143760ustar00rootroot00000000000000# Change Log ## Unreleased ## [1.2.7] - 2020-08-25 ###Changed - Undoing previous commit. Caused insidious downstream issues with 18.0.5. Better to just kludge the failing test and move on. ## [1.2.6] - 2020-08-24 ### Fixed - Blocked installation of *Foo*.inc include files that are only used for testing. - Reintroduced workarounds for older ifort and gfortran compilers. Annoyingly the workaround for one breaks the other. ## [1.2.5] - 2020-04-06 ### Fixed - eliminated stray in source code; was generating annoying warnings in some compilers ## [1.2.4] - 2019-12-19 - fixes for CMakeList - removed incorrect parens in conditionl - added Fortran to PROJECT - necessary for recent change in pFUnit. ## [1.2.3] - 2020-01-06 - Workaround for PGI compiler - does not like "set" as a derived type name. ## [1.2.2] - 2019-11-15 - bugfix for workaround in v1.2.1; some use cases were not deallocating structure components prior to reallocation. ## [1.2.1] - 2019-11-07 - added workaround for memory leak detected with Intel 18 compiler ## [1.2.0] - 2019-09-01 - updated to use pFUnit 4.0 for tests - started maintaining a change log gFTL-1.2.7/GFTL.mk.in000066400000000000000000000004631372124645500140230ustar00rootroot00000000000000# Include file for external projects using Unix Make instead of cmake. GFTL_INSTALL_PREFIX := @CMAKE_INSTALL_PREFIX@ GFTL_VERSION := @GFTL_VERSION_MAJOR@.@GFTL_VERSION_MINOR@ GFTL_TOP_DIR = $(GFTL_INSTALL_PREFIX)/GFTL-$(GFTL_VERSION) GFTL_INCLUDE_DIR := $(GFTL_TOP_DIR)/include GFTL_LIBRARIES := # none gFTL-1.2.7/GFTLConfig-version.cmake.in000066400000000000000000000012171372124645500173030ustar00rootroot00000000000000# my_library-config-version.cmake - checks version: major must match, minor must be less than or equal set(PACKAGE_VERSION @GFTL_VERSION@) if (PACKAGE_FIND_VERSION_MAJOR EQUAL 0) set(PACKAGE_VERSION_COMPATIBLE TRUE) else() if("${PACKAGE_FIND_VERSION_MAJOR}" EQUAL "@GFTL_VERSION_MAJOR@") if ("${PACKAGE_FIND_VERSION_MINOR}" EQUAL "@GFTL_VERSION_MINOR@") set(PACKAGE_VERSION_EXACT TRUE) elseif("${PACKAGE_FIND_VERSION_MINOR}" LESS "@GFTL_VERSION_MINOR@") set(PACKAGE_VERSION_COMPATIBLE TRUE) else() set(PACKAGE_VERSION_UNSUITABLE TRUE) endif() else() set(PACKAGE_VERSION_UNSUITABLE TRUE) endif() endif() gFTL-1.2.7/GFTLConfig.cmake.in000066400000000000000000000004101372124645500156120ustar00rootroot00000000000000# Package configuration file get_filename_component (SELF_DIR "${CMAKE_CURRENT_LIST_FILE}" PATH) set (PREFIX ${SELF_DIR}/../..) set (GFTL_TOP_DIR ${PREFIX}/GFTL-@GFTL_VERSION_MAJOR@.@GFTL_VERSION_MINOR@ CACHE PATH "") include ("${GFTL_TOP_DIR}/cmake/GFTL.cmake") gFTL-1.2.7/License.txt000066400000000000000000000226651372124645500144640ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: 1. You must give any other recipients of the Work or Derivative Works a copy of this License; and 2. You must cause any modified files to carry prominent notices stating that You changed the files; and 3. You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and 4. If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS gFTL-1.2.7/README.md000066400000000000000000000050451372124645500136110ustar00rootroot00000000000000[![Build Status](https://travis-ci.com/Goddard-Fortran-Ecosystem/gFTL.svg?branch=master)](https://travis-ci.com/Goddard-Fortran-Ecosystem/gFTL) [![License](https://img.shields.io/badge/License-Apache%202.0-blue.svg)](https://opensource.org/licenses/Apache-2.0) # The problem Fortran only provides one type of container: *array*. While Fortran arrays are exemplary for their intended purpose such as numerical algorithms, they are poorly suited in many other contexts. Arrays can be thought of as a particular case of a "container" that holds multiple entities. As a container, arrays are well suited for random access to a fixed number of objects. (Yes, Fortran arrays are technically dynamic, but "growing" an array involves multiple steps.) Many other languages provide additional types of containers that commonly arise in many contexts. E.g., a vector (C++ STL) or List (Java) are _growable_ containers of objects that automatically resize when required to add a new object. Another example is that of Map which allows stores objects as key-value pairs, thereby allowing retrieval of an object by providing it's key. # The solution This package, gFTL, provides a mechanism to easily create robust containers and associated iterators which can be used within Fortran applications. The primary methods are intended to be as close to their C++ STL analogs as possible. We have found that these containers are a powerful productivity multiplier for certain types of software development, and hope that others find them to be just as useful. Currently, the following three types of containers are provided. * Vector (list) * Set * Map (associated array) Contributions of additional containers are very much welcomed. ## Initial developers * Tom Clune * Doron Feldman # Prerequisites * CMake 3.0 * GNU m4 (must be in path as "gm4" or "m4") # Related package It is worth noting that there is a similar package [FTL](https://github.com/robertrueger/ftl) which may be of interest. gFTL was developed independently of FTL, but was not open-sourced in time to claim the cooler name. ## Quick overview of gFTL vs FTL I expect this section to grow a bit more after the authors of the two packages have had time to discuss. It is highly desired that this section be factually correct. ### Similarities * Both packages use the preprocessor that is built-in to essentially all modern Fortran compilers. ### Differences * Naming conventions for gFTL are closer to C++ STL. # Request support If you have any questions, please contact: * Tom Clune (Tom.Clune@nasa.gov) gFTL-1.2.7/cmake_utils/000077500000000000000000000000001372124645500146265ustar00rootroot00000000000000gFTL-1.2.7/cmake_utils/CheckCompilerCapabilities.cmake000066400000000000000000000007571372124645500226630ustar00rootroot00000000000000CHECK_Fortran_SOURCE_COMPILE ( ${CMAKE_CURRENT_LIST_DIR}/pointerToFixedLengthString.F90 SUPPORT_FOR_POINTERS_TO_FIXED_LENGTH_STRINGS ) CHECK_Fortran_SOURCE_RUN ( ${CMAKE_CURRENT_LIST_DIR}/pointerToDeferredLengthString.F90 SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS ) CHECK_Fortran_SOURCE_RUN ( ${CMAKE_CURRENT_LIST_DIR}/supportsInt64.F90 SUPPORT_FOR_INT64 ) CHECK_Fortran_SOURCE_COMPILE ( ${CMAKE_CURRENT_LIST_DIR}/supportsQuadPrecision.F90 SUPPORT_FOR_QUAD_PRECISION ) gFTL-1.2.7/cmake_utils/CheckFortranSource.cmake000066400000000000000000000101761372124645500213670ustar00rootroot00000000000000 #.rst: # CheckFortranSourceCompiles # -------------------------- # # Check if given Fortran source compiles and links into an executable:: # # CHECK_Fortran_SOURCE_COMPILES( [FAIL_REGEX ]) # # The arguments are: # # ```` # Source code to try to compile. It must define a PROGRAM entry point. # ```` # Variable to store whether the source code compiled. # Will be created as an internal cache variable. # ```` # Fail if test output matches this regex. # # The following variables may be set before calling this macro to modify # the way the check is run:: # # CMAKE_REQUIRED_FLAGS = string of compile command line flags # CMAKE_REQUIRED_DEFINITIONS = list of macros to define (-DFOO=bar) # CMAKE_REQUIRED_INCLUDES = list of include directories # CMAKE_REQUIRED_LIBRARIES = list of libraries to link # CMAKE_REQUIRED_QUIET = execute quietly without messages # #============================================================================= # CMake - Cross Platform Makefile Generator # Copyright 2000-2014 Kitware, Inc. # Copyright 2000-2011 Insight Software Consortium # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # * Neither the names of Kitware, Inc., the Insight Software Consortium, # nor the names of their contributors may be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # ============================================================================= # This file was modified my T. Clune to enable directly using add_definition() # based upon the results of the try(). # Two functions are provided: CHECK_Fortran_SOURCE_COMPILE and CHECK_Fortran_SOURCE_RUN) macro (CHECK_Fortran_SOURCE_COMPILE file var) if (NOT CMAKE_REQUIRED_QUIET) message (STATUS "Performing Test ${var}") endif () try_compile ( ${var} ${CMAKE_BINARY_DIR} ${file} ) if (${var}) if (NOT CMAKE_REQUIRED_QUIET) message(STATUS "Performing Test ${var}: SUCCESSS") endif () add_definitions(-D${var}) else () if (NOT CMAKE_REQUIRED_QUIET) message(STATUS "Performing Test ${var}: FAILURE") endif () endif () endmacro (CHECK_Fortran_SOURCE_COMPILE) macro (CHECK_Fortran_SOURCE_RUN file var) if (NOT CMAKE_REQUIRED_QUIET) message (STATUS "Performing Test ${var}") endif () try_run ( code_runs code_compiles ${CMAKE_BINARY_DIR} ${file} ) if (${code_compiles}) if (${code_runs} EQUAL 0) if (NOT CMAKE_REQUIRED_QUIET) message (STATUS "Performing Test ${var}: SUCCESS") endif () add_definitions(-D${var}) set (${var} 1) else () if (NOT CMAKE_REQUIRED_QUIET) message (STATUS "Performing Test ${var}: RUN FAILURE") endif () endif () else () if (NOT CMAKE_REQUIRED_QUIET) message (STATUS "Performing Test ${var}: BUILD FAILURE") endif () endif() endmacro (CHECK_Fortran_SOURCE_RUN) gFTL-1.2.7/cmake_utils/CheckFortranSourceCompiles.cmake000066400000000000000000000124261372124645500230630ustar00rootroot00000000000000 #.rst: # CheckFortranSourceCompiles # -------------------------- # # Check if given Fortran source compiles and links into an executable:: # # CHECK_Fortran_SOURCE_COMPILES( [FAIL_REGEX ]) # # The arguments are: # # ```` # Source code to try to compile. It must define a PROGRAM entry point. # ```` # Variable to store whether the source code compiled. # Will be created as an internal cache variable. # ```` # Fail if test output matches this regex. # # The following variables may be set before calling this macro to modify # the way the check is run:: # # CMAKE_REQUIRED_FLAGS = string of compile command line flags # CMAKE_REQUIRED_DEFINITIONS = list of macros to define (-DFOO=bar) # CMAKE_REQUIRED_INCLUDES = list of include directories # CMAKE_REQUIRED_LIBRARIES = list of libraries to link # CMAKE_REQUIRED_QUIET = execute quietly without messages # #============================================================================= # CMake - Cross Platform Makefile Generator # Copyright 2000-2014 Kitware, Inc. # Copyright 2000-2011 Insight Software Consortium # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # # * Neither the names of Kitware, Inc., the Insight Software Consortium, # nor the names of their contributors may be used to endorse or promote # products derived from this software without specific prior written # permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # ============================================================================= # This file has been modified for inclusion in OpenCoarrays (www.sourceryinstitute.org) macro(CHECK_Fortran_SOURCE_COMPILES SOURCE VAR) if ("${CMAKE_Fortran_COMPILER_ID}" MATCHES "GNU" ) set(CMAKE_REQUIRED_FLAGS "-fcoarray=single") endif() if(NOT DEFINED "${VAR}") set(_FAIL_REGEX) set(_key) foreach(arg ${ARGN}) if("${arg}" MATCHES "^(FAIL_REGEX)$") set(_key "${arg}") elseif(_key) list(APPEND _${_key} "${arg}") else() message(FATAL_ERROR "Unknown argument:\n ${arg}\n") endif() endforeach() set(MACRO_CHECK_FUNCTION_DEFINITIONS "-D${VAR} ${CMAKE_REQUIRED_FLAGS}") if(CMAKE_REQUIRED_LIBRARIES) set(CHECK_Fortran_SOURCE_COMPILES_ADD_LIBRARIES LINK_LIBRARIES ${CMAKE_REQUIRED_LIBRARIES}) else() set(CHECK_Fortran_SOURCE_COMPILES_ADD_LIBRARIES) endif() if(CMAKE_REQUIRED_INCLUDES) set(CHECK_Fortran_SOURCE_COMPILES_ADD_INCLUDES "-DINCLUDE_DIRECTORIES:STRING=${CMAKE_REQUIRED_INCLUDES}") else() set(CHECK_Fortran_SOURCE_COMPILES_ADD_INCLUDES) endif() file(WRITE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/src.F90" "${SOURCE}\n") if(NOT CMAKE_REQUIRED_QUIET) message(STATUS "Performing Test ${VAR}") endif() try_compile(${VAR} ${CMAKE_BINARY_DIR} ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/src.F90 COMPILE_DEFINITIONS ${CMAKE_REQUIRED_DEFINITIONS} ${CHECK_Fortran_SOURCE_COMPILES_ADD_LIBRARIES} CMAKE_FLAGS -DCOMPILE_DEFINITIONS:STRING=${MACRO_CHECK_FUNCTION_DEFINITIONS} "${CHECK_Fortran_SOURCE_COMPILES_ADD_INCLUDES}" OUTPUT_VARIABLE OUTPUT) foreach(_regex ${_FAIL_REGEX}) if("${OUTPUT}" MATCHES "${_regex}") set(${VAR} 0) endif() endforeach() if(${VAR}) set(${VAR} 1 CACHE INTERNAL "Test ${VAR}") if(NOT CMAKE_REQUIRED_QUIET) message(STATUS "Performing Test ${VAR} - Success") endif() file(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log "Performing Fortran SOURCE FILE Test ${VAR} succeded with the following output:\n" "${OUTPUT}\n" "Source file was:\n${SOURCE}\n") else() if(NOT CMAKE_REQUIRED_QUIET) message(STATUS "Performing Test ${VAR} - Failed") endif() set(${VAR} "" CACHE INTERNAL "Test ${VAR}") file(APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log "Performing Fortran SOURCE FILE Test ${VAR} failed with the following output:\n" "${OUTPUT}\n" "Source file was:\n${SOURCE}\n") endif() endif() endmacro() gFTL-1.2.7/cmake_utils/GNU.cmake000066400000000000000000000005471372124645500162670ustar00rootroot00000000000000# Compiler specific flags for Intel Fortran compiler set(no_optimize "-O0") set(check_all "-fcheck=bounds -fcheck=pointer -fcheck=mem ") set(traceback "-fbacktrace") set(cpp "-cpp") set(CMAKE_Fortran_FLAGS_DEBUG "${no_optimize} ${check_all} ${traceback}") set(CMAKE_Fortran_FLAGS_RELEASE "-O3") set(CMAKE_Fortran_FLAGS "-g ${cpp} -ffree-line-length-255") gFTL-1.2.7/cmake_utils/Intel.cmake000066400000000000000000000011401372124645500166770ustar00rootroot00000000000000# Compiler specific flags for Intel Fortran compiler if(WIN32) set(no_optimize "-Od") set(check_all "-check:all") else() set(no_optimize "-O0") set(check_all "-check all,noarg_temp_created") endif() set(disable_warning_for_long_names "-diag-disable 5462") set(traceback "-traceback") set(cpp "-cpp") set(CMAKE_Fortran_FLAGS_DEBUG "${no_optimize} ${check_all} ${traceback} -save-temps") set(CMAKE_Fortran_FLAGS_RELEASE "-O3") set(CMAKE_Fortran_FLAGS "-g ${cpp} ${traceback} ${check_all} ${disable_warning_for_long_names} -save-temps") add_definitions(-D_INTEL) #add_definitions(-D__ifort_18) gFTL-1.2.7/cmake_utils/NAG.cmake000066400000000000000000000005321372124645500162350ustar00rootroot00000000000000# Compiler specific flags for NAG Fortran compiler set (no_optimize "-O0") set (check_all "-C=all -nocheck_modtime") set (cpp "-fpp") set (suppress_fpp_warnings "-w") set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g ${cpp}") set (CMAKE_Fortran_FLAGS_DEBUG "${no_optimize} ${traceback} ${check_all}") set (CMAKE_Fortran_FLAGS_RELEASE "-O3") gFTL-1.2.7/cmake_utils/NAG.mk000066400000000000000000000004161372124645500155650ustar00rootroot00000000000000# Compiler specific flags for Intel Fortran compiler set(no_optimize "-O0") set(check_all "-C=all") set(cpp "-fpp") set(CMAKE_Fortran_FLAGS_DEBUG "${no_optimize}") set(CMAKE_Fortran_FLAGS_RELEASE "-O3") set(CMAKE_Fortran_FLAGS "-g ${cpp} ${traceback} ${check_all}") gFTL-1.2.7/cmake_utils/PGI.cmake000066400000000000000000000004611372124645500162500ustar00rootroot00000000000000# Compiler specific flags for PGI Fortran compiler # (or is this now NVIDIA?) set(traceback "-traceback") set(check_all "-Mbounds -Mchkfpstk -Mchkstk") set(CMAKE_Fortran_FLAGS_DEBUG "-O0") set(CMAKE_Fortran_FLAGS_RELEASE "-O3") set(CMAKE_Fortran_FLAGS "-g ${traceback} ${check_all} -Mallocatable=03") gFTL-1.2.7/cmake_utils/PGI.mk000066400000000000000000000004161372124645500155770ustar00rootroot00000000000000# Compiler specific flags for Intel Fortran compiler set(no_optimize "-O0") set(check_all "-C=all") set(cpp "-fpp") set(CMAKE_Fortran_FLAGS_DEBUG "${no_optimize}") set(CMAKE_Fortran_FLAGS_RELEASE "-O3") set(CMAKE_Fortran_FLAGS "-g ${cpp} ${traceback} ${check_all}") gFTL-1.2.7/cmake_utils/pointerToDeferredLengthString.F90000066400000000000000000000010301372124645500230550ustar00rootroot00000000000000module Foo_mod implicit none type Foo character(len=:), allocatable :: buffer contains procedure :: get end type Foo contains function get(f) result(p) class (Foo), target, intent(in) :: f character(len=:), pointer :: p p => f%buffer end function get end module Foo_mod program main use Foo_mod implicit none character(len=:), pointer :: p type (Foo) :: f f%buffer = 'cat' p => f%get() if (.not. (p == 'cat')) then stop 1 end if end program main gFTL-1.2.7/cmake_utils/pointerToFixedLengthString.F90000066400000000000000000000007231372124645500224040ustar00rootroot00000000000000module Foo_mod implicit none type Foo character(len=17) :: t contains procedure :: get end type Foo contains function get(f) result(p) class (Foo), target, intent(in) :: f character(len=17), pointer :: p p => f%t end function get end module Foo_mod program main use Foo_mod implicit none character(len=17), pointer :: p type (Foo) :: f f%t = 'cat' p => f%get() print*,p end program main gFTL-1.2.7/cmake_utils/supportsInt64.F90000066400000000000000000000001141372124645500176260ustar00rootroot00000000000000program main if (selected_int_kind(18) < 0) stop 1 end program main gFTL-1.2.7/cmake_utils/supportsQuadPrecision.F90000066400000000000000000000001041372124645500214670ustar00rootroot00000000000000program main use iso_fortran_env, only: real128 end program main gFTL-1.2.7/doc/000077500000000000000000000000001372124645500130735ustar00rootroot00000000000000gFTL-1.2.7/doc/Coverage.txt000066400000000000000000000006271372124645500153740ustar00rootroot00000000000000The following cases are covered by unit tests. See footnotes below for per-compiler exceptions and other irregular support. * Vector - integer - real - logical - real(kind=real64) - integer, pointer - integer, allocatable, dimension(:) - integer, allocatable, dimension(:,:) - character(len=17) - character(len=*), allocatable - type (Foo) * VectorIterator * Map * Map Iterator gFTL-1.2.7/doc/FAQ000066400000000000000000000006111372124645500134230ustar00rootroot00000000000000Q) Why am I getting messages about "IMPLICIT statement not positioned correctly within the scoping unit"? A) Of necessity, the template header files include an "IMPLICIT NONE" statement. Users should not put their own "IMPLICIT NONE" statement. Likewise only CPP token/macro/include definitions and Fortran USE statements should appear before the CPP include statement for the template. gFTL-1.2.7/doc/Macros000066400000000000000000000010361372124645500142420ustar00rootroot00000000000000API \item \verb+_entry+ \item \verb+_dim+ \item \verb+_pointer+ \item \verb+_allocatable+ \item \verb+_string+ \item \verb+_LEN+ \item \verb+_logical+ \item \verb+EQUAL_DEFINED+ \item \verb+LESS_THAN_DEFINED+ Items with defaults that users can override. \item \verb+__GET+ \item \verb+__EQ+ \item \verb+__COMPARE+ \item \verb+__SET+ \item \verb+__COMPARE+ Internal \item \verb+__wrapentry+ \item \verb+__ptrentry+ \item \verb+__trgentry+ \item \verb+__ALLOC_SET+ \item \verb+__ptrtype+ \item \verb+__trgtype+ \item \verb+__NEED_COMPARE+ gFTL-1.2.7/doc/variant000066400000000000000000000005701372124645500144640ustar00rootroot00000000000000__TYPE (with kind) __RANK __DERIVED __LEN __LOGICAL __EXTENTS __POINTER __POLYMORPHIC __EQUAL_DEFINED __ELEMENTAL_EQUAL __LESS_THAN Auxiliary gets default values that can be overridden __DECLARE_TYPE __DECLARE_DUMMY Attributes __WRAPPED_TYPE __ALLOCATABLE __DIMS __TARGET Executables __EQUALS __LESS_THAN __COPY_ITEM __MOVE_ITEM __GET_ITEM __SET_ITEM __FREE_ITEM gFTL-1.2.7/examples/000077500000000000000000000000001372124645500141445ustar00rootroot00000000000000gFTL-1.2.7/examples/CMakeLists.txt000066400000000000000000000003641372124645500167070ustar00rootroot00000000000000cmake_minimum_required(VERSION 2.8) if ("${CMAKE_Fortran_COMPILER_ID}" MATCHES "Intel") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -assume realloc_lhs") endif() #add_subdirectory(Map) #add_subdirectory(Vector) ##add_subdirectory(Tracer) gFTL-1.2.7/examples/Map/000077500000000000000000000000001372124645500146615ustar00rootroot00000000000000gFTL-1.2.7/examples/Map/CMakeLists.txt000066400000000000000000000003741372124645500174250ustar00rootroot00000000000000cmake_minimum_required(VERSION 2.8) include_directories("$ENV{FTL}/include") add_executable(CIKey.x CaseInsensitiveKey.F90) add_executable(StringPoly.x StringPoly.F90) add_executable(StringArray.x StringArray.F90) add_executable(mapmap.x Mapsmap.F90) gFTL-1.2.7/examples/Map/CaseInsensitiveKey.F90000066400000000000000000000031131372124645500207040ustar00rootroot00000000000000module CIStringIntegerMap_mod #define _key_string_deferred #define _key_equal_defined #define _KEY_LESS_THAN(x,y) caseInsensitiveLessThan(x,y) #define _value integer #define _value_equal_defined #define _value_less_than_defined #include "templates/map.inc" logical function caseInsensitiveLessThan(x,y) result(less) character(len=*), intent(in) :: x character(len=*), intent(in) :: y integer :: i character(1) :: cx, cy integer, parameter :: UPPER_LOWER_DELTA = iachar('A') - iachar('a') do i = 1, min(len(x),len(y)) cx = x(i:i) cy = y(i:i) if (cx >= 'A' .and. cx <= 'Z') then cx = achar(iachar(cx) - UPPER_LOWER_DELTA) end if if (cy >= 'A' .and. cy <= 'Z') then cy = achar(iachar(cy) - UPPER_LOWER_DELTA) end if less = (cx < cy) if (cx /= cy) then return end if end do less = (len(x) < len(y)) end function caseInsensitiveLessThan end module CIStringIntegerMap_mod program main use CIStringIntegerMap_mod implicit none type (Map) :: m call m%insert('cat', 1) call m%insert('dog', 2) call m%insert('fish', 3) call check('cat', 1) call check('dog', 2) call check('fish', 3) call check('CAT', 1) call check('Cat', 1) call check('caT', 1) contains subroutine check(str, expected) character(len=*), intent(in) :: str integer, intent(in) :: expected print*,"m%at('",str,"') = ",m%at(str),"(should be",expected,")" end subroutine check end program main gFTL-1.2.7/examples/Map/Mapsmap.F90000066400000000000000000000053571372124645500165510ustar00rootroot00000000000000module Base_mod public :: Base type,abstract :: Base character(len=10) :: s contains procedure :: printb end type contains subroutine printb(this) class(Base),intent(in) :: this print*,this%s end subroutine end module Base_mod module Derive1_mod use Base_mod public :: Derive1 type,extends(Base) :: Derive1 end type interface Derive1 module procedure newDerive1 end interface contains function newDerive1(s1) result(d1) character(len=*),intent(in) ::s1 type(Derive1) :: d1 d1%s = trim(s1) end function end module Derive1_mod module Derive2_mod use Base_mod public :: Derive2 type,extends(Base) :: Derive2 end type interface Derive2 module procedure newDerive2 end interface contains function newDerive2(s2) result(d2) character(len=*),intent(in) :: s2 type(Derive2) :: d2 d2%s = trim(s2) end function end module Derive2_mod module StringPoly_mod use Base_mod #define _key_string_deferred #define _key_equal_defined #define _key_less_than_defined #define _value class(Base) #define _value_allocatable #define _alt #include "templates/map.inc" end module StringPoly_mod module tracer_mod use Derive1_mod use Derive2_mod use StringPoly_mod,only : StringPolyMap=>map,StringMapIterator=>MapIterator implicit none type :: Tracer type(StringPolyMap) :: aSmap contains end type end module module TracerMap_mod use Tracer_mod #define _key_string_deferred #define _key_equal_defined #define _Key_less_than_defined #define _value class(Tracer) #define _value_allocatable #define _alt #include "templates/map.inc" end module TracerMap_mod module TracerBundle_mod use Tracer_mod use TracerMap_mod,TracerMap=>Map implicit none type :: TracerBundle type(TracerMap) :: aTmap contains end type end module TracerBundle_mod program main use Derive1_mod use Derive2_mod use StringPoly_mod use Tracer_mod use TracerMap_mod,TracerMapIterator=>MapIterator use TracerBundle_mod implicit none type (StringPolyMap) :: m type (StringMapIterator) :: mp class(Base) ,pointer :: p type(Tracer) :: aTrcer type(Tracer),pointer :: aTp type(TracerBundle) :: aBundle type(TracerMapIterator) :: iter call m%insert('d1',Derive1('1Derive1')) call m%insert('d2',Derive2('1Derive2')) p=>m%at('d1') call p%printb() p=>m%at('d2') call p%printb() mp = m%find('d1') print*,mp%key() call aTrcer%aSmap%insert('d1',Derive1('1Derive1')) call aBundle%aTmap%insert('firstT',aTrcer) iter = aBundle%aTmap%begin() print*,iter%key() aTp=>iter%value() p=>aTp%aSmap%at('d1') call p%printb() end program main gFTL-1.2.7/examples/Map/StringArray.F90000066400000000000000000000036621372124645500174150ustar00rootroot00000000000000module Base_mod public :: Base type,abstract :: Base character(len=10),allocatable :: s(:) contains procedure :: printb end type contains subroutine printb(this) class(Base),intent(in) :: this print*,this%s end subroutine end module Base_mod module Derive1_mod use Base_mod public :: Derive1 type,extends(Base) :: Derive1 end type interface Derive1 module procedure newDerive1 end interface contains function newDerive1(s1) result(d1) character(len=*),intent(in) ::s1(:) type(Derive1) :: d1 integer ::i, d d = size(s1) allocate(d1%s(d)) do i = 1,d d1%s(i) = trim(s1(i)) enddo end function end module Derive1_mod module Derive2_mod use Base_mod public :: Derive2 type,extends(Base) :: Derive2 end type interface Derive2 module procedure newDerive2 end interface contains function newDerive2(s2) result(d2) character(len=*),intent(in) :: s2(:) type(Derive2) :: d2 integer ::i, d d = size(s2) allocate(d2%s(d)) do i = 1,d d2%s(i) = trim(s2(i)) enddo end function end module Derive2_mod module StringPoly_mod use Base_mod #define _key_string_deferred #define _key_equal_defined #define _Key_less_than_defined #define _value class(Base) #define _value_allocatable #include "templates/map.inc" end module StringPoly_mod program main use Derive1_mod use Derive2_mod use StringPoly_mod implicit none type (Map) :: m type (MapIterator) :: iter class(Base) ,pointer :: p character(len=:),pointer :: cp call m%insert('d1',Derive1(['1D First','1DSecond'])) call m%insert('d2',Derive2(['2D1','2D2'])) p=>m%at('d1') call p%printb() p=>m%at('d2') call p%printb() iter=m%begin() cp=>iter%key() print*,cp p=>iter%value() call p%printb() end program main gFTL-1.2.7/examples/Map/StringPoly.F90000066400000000000000000000033341372124645500172560ustar00rootroot00000000000000module Base_mod public :: Base type,abstract :: Base character(len=10) :: s contains procedure :: printb end type contains subroutine printb(this) class(Base),intent(in) :: this print*,this%s end subroutine end module Base_mod module Derive1_mod use Base_mod public :: Derive1 type,extends(Base) :: Derive1 end type interface Derive1 module procedure newDerive1 end interface contains function newDerive1(s1) result(d1) character(len=*),intent(in) ::s1 type(Derive1) :: d1 d1%s = trim(s1) end function end module Derive1_mod module Derive2_mod use Base_mod public :: Derive2 type,extends(Base) :: Derive2 end type interface Derive2 module procedure newDerive2 end interface contains function newDerive2(s2) result(d2) character(len=*),intent(in) :: s2 type(Derive2) :: d2 d2%s = trim(s2) end function end module Derive2_mod module StringPoly_mod use Base_mod #define _key_string_deferred #define _key_equal_defined #define _Key_less_than_defined #define _value class(Base) #define _value_allocatable #include "templates/map.inc" end module StringPoly_mod program main use Derive1_mod use Derive2_mod use StringPoly_mod implicit none type (Map) :: m type (MapIterator) :: iter class(Base) ,pointer :: p character(len=:),pointer :: cp call m%insert('d1',Derive1('1Derive1')) call m%insert('d2',Derive2('1Derive2')) p=>m%at('d1') call p%printb() p=>m%at('d2') call p%printb() iter=m%begin() ! ! error to acess key() ! cp=>iter%key() print*,cp p=>iter%value() call p%printb() end program main gFTL-1.2.7/examples/Tracer/000077500000000000000000000000001372124645500153645ustar00rootroot00000000000000gFTL-1.2.7/examples/Tracer/AbstractValue.F90000066400000000000000000000057111372124645500204100ustar00rootroot00000000000000module AbstractValue_mod implicit none private public :: AbstractValue public :: DP public :: SP public :: MAX_LEN_KEY public :: MAX_LEN_LINE public :: MAX_LEN_ATTRIBUTE_STRING integer, parameter :: DP = selected_real_kind(14) integer, parameter :: SP = selected_real_kind(6) integer, parameter :: MAX_LEN_KEY = 32 integer, parameter :: MAX_LEN_ATTRIBUTE_STRING = 80 integer, parameter :: MAX_LEN_LINE = 1000 type, abstract :: AbstractValue integer :: rank integer,allocatable :: dims(:) character(len=MAX_LEN_KEY) :: name contains procedure(equals), deferred :: equals procedure(print), deferred :: print procedure(toString), deferred :: toString procedure(writeUnformatted), deferred :: writeUnformatted procedure(readUnformatted), deferred :: readUnformatted procedure(clear), deferred :: clear procedure(get0d),deferred :: getScalar procedure(get1d),deferred :: get1DValue generic :: getValue=> getScalar, get1DValue procedure(set0d),deferred :: setScalar procedure(set1d),deferred :: set1DValue generic :: setValue=> setScalar, set1DValue end type AbstractValue abstract interface subroutine get0d(this,value) import AbstractValue class(AbstractValue), intent(in) :: this class(*),intent(inout) :: value end subroutine get0d subroutine get1d(this,value) import AbstractValue class(AbstractValue), intent(in) :: this class(*),intent(inout) :: value(:) end subroutine get1d subroutine set0d(this,value) import AbstractValue class(AbstractValue), intent(inout) :: this class(*),intent(in) :: value end subroutine set0d subroutine set1d(this,value) import AbstractValue class(AbstractValue), intent(inout) :: this class(*),intent(in) :: value(:) end subroutine set1d logical function equals(this, b) import AbstractValue class (AbstractValue), intent(in) :: this class (AbstractValue), intent(in) :: b end function equals function toString(this) result(string) import AbstractValue, MAX_LEN_LINE class (AbstractValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string end function toString subroutine print(this) import AbstractValue class (AbstractValue), intent(in) :: this end subroutine print subroutine writeUnformatted(this, unit) import AbstractValue class (AbstractValue), intent(in) :: this integer, intent(in) :: unit end subroutine writeUnformatted function readUnformatted(this, unit) result(new) import AbstractValue class (AbstractValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new end function readUnformatted subroutine clear(this) import AbstractValue class (AbstractValue), intent(inout) :: this end subroutine clear end interface end module AbstractValue_mod gFTL-1.2.7/examples/Tracer/AttributeMap.F90000066400000000000000000000177471372124645500202650ustar00rootroot00000000000000module FTLAttrMap_mod use AbstractValue_mod #define _key_string_deferred #define _key_equal_defined #define _Key_less_than_defined #define _value class(AbstractValue) #define _value_allocatable #define _alt #include "templates/map.inc" end module FTLAttrMap_mod module AttributeMap_mod use Values_mod use FTLAttrMap_mod, FTLAttrMap=>Map,FTLAttrMapIterator=>MapIterator implicit none private public :: AttributeMap type,extends(FTLAttrMap) :: AttributeMap ! this Value Type map is for IO purpose type(ValueTypeMap) :: vp contains procedure :: initAttrMap procedure :: writeUnformatted procedure :: readUnformatted procedure :: equals generic :: operator(==) =>equals procedure :: insertAttribute0 procedure :: insertAttribute1 generic :: init=>initAttrMap generic :: insertValue=>insertAttribute0,insertAttribute1 procedure :: setAttribute0 procedure :: setAttribute1 generic :: setValue=>setAttribute0,setAttribute1 procedure :: getAttribute0 procedure :: getAttribute1 generic :: getValue=>getAttribute0,getAttribute1 procedure :: copyAP generic :: assignment(=)=>copyAP procedure :: printIt generic :: print=>printIt end type contains subroutine initAttrMap(this) class(AttributeMap),intent(inout) :: this call this%vp%init() end subroutine initAttrMap subroutine insertAttribute0(this,name,value) class(AttributeMap),intent(inout) :: this character(len=*) :: name class(*),intent(in) :: value select type(value) class is (AbstractValue) call this%insert(trim(name),value) type is (integer) call this%insert(trim(name),newValue(value)) type is ( logical ) call this%insert(trim(name),newValue(value)) type is ( real(KIND=DP)) call this%insert(trim(name),newValue(value)) type is (character(len=*)) call this%insert(trim(name),newValue(value)) class default print*, "wrong attribute type insertAttribute0" end select end subroutine insertAttribute0 subroutine insertAttribute1(this,name,value) class(AttributeMap),intent(inout) :: this character(len=*) :: name class(*),intent(in) :: value(:) select type(value) type is (integer) call this%insert(trim(name),newValue(value)) type is ( logical ) call this%insert(trim(name),newValue(value)) type is ( real(KIND=DP)) call this%insert(trim(name),newValue(value)) type is (character(len=*)) call this%insert(trim(name),newValue(value)) class default print*, "wrong attribute type insertAttribute1" end select end subroutine insertAttribute1 function getAttribute0(this,name,value) result(res) class(AttributeMap),intent(inout) :: this character(len=*) :: name class(*),intent(inout) :: value class(AbstractValue),pointer :: AbV logical :: res res = .false. if(this%get(trim(name),Abv)) then call AbV%getValue(value) res = .true. endif end function getAttribute0 function getAttribute1(this,name,value) result(res) class(AttributeMap),intent(inout) :: this character(len=*) :: name class(*),intent(inout) :: value(:) class(AbstractValue),pointer :: AbV character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable:: s1(:) integer :: n logical :: res res = .false. if(this%get(trim(name),Abv)) then select type(value) type is (character(len=*)) ! !this is a work around for gfortran. ! n=size(value) allocate(s1(n)) call AbV%getValue(s1) value = s1 deallocate(s1) class default call AbV%getValue(value) end select res = .true. endif end function getAttribute1 subroutine setAttribute0(this,name,value) class(AttributeMap),intent(inout) :: this character(len=*) :: name class(*),intent(in) :: value select type(value) class is (AbstractValue) call this%set(trim(name),value) type is (integer) call this%set(trim(name),newValue(value)) type is ( logical ) call this%set(trim(name),newValue(value)) type is ( real(KIND=DP)) call this%set(trim(name),newValue(value)) type is (character(len=*)) call this%set(trim(name),newValue(value)) class default print*, "wrong attribute type set0" endselect end subroutine setAttribute0 subroutine setAttribute1(this,name,value) class(AttributeMap),intent(inout) :: this character(len=*) :: name class(*),intent(in) :: value(:) select type(value) type is (integer) call this%set(trim(name),newValue(value)) type is ( logical ) call this%set(trim(name),newValue(value)) type is ( real(KIND=DP)) call this%set(trim(name),newValue(value)) type is (character(len=*)) call this%set(trim(name),newValue(value)) class default print*, "wrong attribute type set 1" endselect end subroutine setAttribute1 subroutine writeUnformatted(this, unit) use ValueTypeMap_mod, FTLValueTypeIterator=>MapIterator use FTLAttrMap_mod,FTLAttrMapIterator=>MapIterator class (AttributeMap), intent(in) :: this integer, intent(in) :: unit type (FTLAttrMapIterator) :: iter type (FTLValueTypeIterator) :: iterb class (AbstractValue), pointer :: p1,p2 write(unit) this%size() iter = this%begin() do while (iter /= this%end()) write(unit) iter%key() p1 => iter%value() write(unit) p1%name !iterb=this%vp%find(trim(p1%name)) !p2=> iterb%value() ! p2=>this%vp%at(trim(p1%name)) ! call p2%writeUnformatted(unit) call iter%next() end do end subroutine writeUnformatted subroutine readUnformatted(this, unit) class (AttributeMap),intent(inout) :: this integer, intent(in) :: unit integer :: n integer :: i class (AbstractValue), pointer :: p1,p2,q character(len=MAX_LEN_KEY) :: key,name read(unit) n do i = 1, n read(unit) key read(unit) name p1 => this%at(trim(key)) p2 => this%vp%at(trim(p1%name)) q =>p2%readUnformatted(unit) call this%insert(trim(key), q) end do end subroutine readUnformatted subroutine copyAP(to,from) class(AttributeMap),intent(inout) :: to class(AttributeMap),intent(in) :: from call to%deepCopy(from) to%vp = from%vp end subroutine copyAP logical function equals(this, b) class (AttributeMap), intent(in) :: this type (AttributeMap), intent(in) :: b type (FTLAttrMapIterator) :: iter type (FTLAttrMapIterator) :: iterb character(LEN=MAX_LEN_KEY),pointer :: sp class (AbstractValue), pointer :: p1 class (AbstractValue), pointer :: p2 equals = .true. if (this%size() /= b%size()) then equals = .false. print*,'different size',this%size(), b%size() return end if iter = this%begin() do while (iter /= this%end()) if ( b%find(iter%key()) == b%end()) then equals = .false. print*,'different key' return end if p1 => iter%value() iterb=b%find(iter%key()) p2 => iterb%value() if (.not. (p1%equals(p2))) then equals = .false. print*,'different value for key <',trim(iter%key()),'>' call p1%print() call p2%print() return end if call iter%next() end do end function equals subroutine printIt(this) use FTLAttrMap_mod,FTLAttrMapIterator=>MapIterator class (AttributeMap), intent(in) :: this type (FTLAttrMapIterator) :: iter class (AbstractValue), pointer :: p iter = this%FTLAttrMap%begin() do while( iter /= this%end()) print*,"Attribute Name: ", iter%key() p=>iter%value() call p%print() call iter%next() end do end subroutine printIt end module AttributeMap_mod gFTL-1.2.7/examples/Tracer/CMakeLists.txt000066400000000000000000000026541372124645500201330ustar00rootroot00000000000000cmake_minimum_required(VERSION 2.8) include_directories("$ENV{FTL}/include") link_directories("$ENV{MODELE}/modelEMaster/model/shared") link_directories("$ENV{MODELE}/modelEMaster/model/MPI_Support") link_directories("$ENV{MODELE}/modelEMaster/model/tracers") link_directories("$ENV{MODELE}/modelEMaster/model/dd2d") link_directories("$ENV{MODELE}/modelEMaster/model/profiler") link_directories("$ENV{NETCDFHOME}/lib") link_directories("$ENV{PNETCDFHOME}/lib") #link_directories("/opt/local/lib") include_directories("$ENV{MODELE}/modelEMaster/model/mod") set(srcs AbstractValue.F90) list(APPEND srcs Values.F90) list(APPEND srcs AttributeMap.F90) list(APPEND srcs Tracer.F90) list(APPEND srcs TracerBundle.F90) set(SOURCES ${srcs}) add_library(mytracer STATIC ${SOURCES}) add_executable(values.x ${SOURCES} TestValues.F90) add_executable(vType.x ${SOURCES} TestValueType.F90) add_executable(attrMap.x ${SOURCES} TestAttributeMap.F90) add_executable(aTracer.x ${SOURCES} TestTracer.F90) add_executable(aBundle.x ${SOURCES} TestTracerBundle.F90) target_link_libraries(values.x tracers shared MPI_Support dd2d profiler netcdf) target_link_libraries(vType.x tracers shared MPI_Support dd2d profiler netcdf) target_link_libraries(attrMap.x tracers shared MPI_Support dd2d profiler netcdf ) target_link_libraries(aTracer.x tracers shared MPI_Support dd2d profiler netcdf ) target_link_libraries(aBundle.x tracers shared MPI_Support dd2d profiler netcdf) gFTL-1.2.7/examples/Tracer/Problem.txt000066400000000000000000000002331372124645500175230ustar00rootroot000000000000001) setValue in values. different rank and dimension? 2) getValue in Values. a function or a subroutine? 3) equals == for values 4) assignment = for values gFTL-1.2.7/examples/Tracer/TestAttributeMap.F90000066400000000000000000000055701372124645500211140ustar00rootroot00000000000000program main use Values_mod use FTLAttrMap_mod, FTLAttrMap=>Map,FTLAttrMapIterator=>MapIterator use AttributeMap_mod implicit none class(AbstractValue),pointer :: vp class(AbstractValue),allocatable :: vp1 type(AttributeMap) :: aMap, bMap type(FTLAttrMapIterator) :: iter integer :: k integer,allocatable :: k1d(:) real(kind=DP) :: r real(kind=DP),allocatable :: r1d(:) logical :: l logical,allocatable :: l1d(:) character(len=MAX_LEN_ATTRIBUTE_STRING) :: s character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1d(:) logical :: getIt call aMap%init() call aMap%insert('i',newValue(1)) call aMap%insert('i1d',newValue([1,2])) call aMap%insert('l',newValue(.true.)) call aMap%insert('l1d',newValue([.false.,.false.])) call aMap%insert('r',newValue(10.0d0)) call aMap%insert('r1d',newValue([20.0d0,30.0d0])) call aMap%insert('s',newValue('string here')) call aMap%insert('s1d',newValue(['string',' there'])) vp=>aMap%at('i') call vp%getValue(k) print*,'k=1: ', k vp=>aMap%at('i1d') allocate(k1d(vp%dims(1))) call vp%getValue(K1d) print*,'should be [1,2]:',K1d vp=>aMap%at('l') call vp%getValue(l) print*,'should be T: ',l vp=>aMap%at('l1d') allocate(l1d(vp%dims(1))) call vp%getValue(l1d) print*,'should be F F : ',l1d vp=>aMap%at('r') call vp%getValue(r) print*,"should be 10.000: ",r vp=>aMap%at('r1d') allocate(r1d(vp%dims(1))) call vp%getValue(r1d) print*,"should be 20.0 30.0:",r1d vp=>aMap%at('s') call vp%getValue(s) print*,"should be string here:",s vp=>aMap%at('s1d') print*, vp%dims(1) allocate(s1d(vp%dims(1))) call vp%getValue(s1d) print*,"should be string there:",s1d deallocate(s1d) print*,"print a map" call aMap%print() ! deepCopy bMap = aMap print*,"print b map" call bMap%print() ! that has problem for iter%key() L=(bMap==aMap) print*,"should be test ==T : ",L print*,"getAttribute" r1d=0.0d0 if( aMap%getValue('r1d',r1d)) then print*,"r1d should be 20.0 30.0",r1d endif allocate(s1d(2)) s1d(1)='5' s1d(2)='6' call aMap%setValue('s1d',s1d) vp=>aMap%at('s1d') print*, vp%dims(1) deallocate(s1d) allocate(s1d(vp%dims(1))) call vp%getValue(s1d) print*,"should be 5,6:",s1d deallocate(s1d) ! !! wrong on gfortran 5.1 , right at 4.9.2 and ifort ! vp=>null() L=aMap%get('s1d',vp) call vp%print() allocate(s1d(2)) call vp%getValue(s1d) if(L)print*,"should be 5,6:",s1d deallocate(s1d) allocate(s1d(2)) if(aMap%getValue('s1d',s1d)) then print*,"should be 5,6:",s1d end if deallocate(s1d) allocate(s1d(3)) s1d=['qq','cc','dd'] call aMap%insertValue('s3d',s1d) s1d=['oo','oo','oo'] if(aMap%getValue('s3d',s1d)) then print*,"should be qq,cc,dd:",s1d end if end program main gFTL-1.2.7/examples/Tracer/TestTracer.F90000066400000000000000000000031361372124645500177270ustar00rootroot00000000000000program main use Values_mod use AttributeMap_mod use Tracer_mod implicit none class(AbstractValue),pointer :: vp type (AttributeMap) :: aMap type (Tracer) :: aTracer,bTracer integer :: k integer,allocatable :: k1d(:) real(kind=DP) :: r real(kind=DP),allocatable :: r1d(:) logical :: l logical,allocatable :: l1d(:) character(len=MAX_LEN_ATTRIBUTE_STRING) :: s character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1d(:) character(len=:), allocatable :: name ! test init and addAttribute call aTracer%init('atrcer') call aTracer%addAttribute('r',1.0d0) call aTracer%addAttribute('l1d',[.true.,.true.,.false.]) call aTracer%addAttribute('s1d',['.true.','.true.','.fals.']) ! test getAttribute . ! vp=>null() ! L=aTracer%getAttribute('l1d',vp) L=aTracer%attributes%get('l1d',vp) call vp%print() ! test setAttribute . allocate(l1d(3)) l1d=[.false.,.false.,.false.] call aTracer%setAttribute('l1d',l1d) l1d=[.true.,.true.,.true.] L= aTracer%getAttribute('l1d',l1d) print*,"should be F F F :",l1d ! test getName name=aTracer%getName() print*,name ! test hasAttribute L= aTracer%hasAttribute('r') print*,"should be T :", L L= aTracer%hasAttribute('rr') print*, "should be F:", L ! test = bTracer = aTracer l1d=[.true.,.true.,.true.] L= bTracer%getAttribute('l1d',l1d) if(L) print*,l1d allocate(s1d(3)) L= bTracer%getAttribute('s1d',s1d) if(L) print*,'should be .true.,.true.,.fals. :',s1d call bTracer%print() ! test clear() call bTracer%clear() end program main gFTL-1.2.7/examples/Tracer/TestTracerBundle.F90000066400000000000000000000037061372124645500210640ustar00rootroot00000000000000program main use Values_mod use AttributeMap_mod use Tracer_mod use TracerBundle_mod implicit none class(AbstractValue),pointer :: vp type (AttributeMap) :: aMap type (Tracer) :: aTracer,bTracer type (TracerBundle) :: aBundle class (Tracer),pointer :: tp integer :: k integer,allocatable :: k1d(:) real(kind=DP) :: r real(kind=DP),allocatable :: r1d(:) logical :: l logical,allocatable :: l1d(:) character(len=MAX_LEN_ATTRIBUTE_STRING) :: s character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1d(:) character(len=:), allocatable :: name character(len=MAX_LEN_KEY),allocatable :: mand(:) ! test init and addAttribute call aTracer%init('atrcer') call aTracer%addAttribute('r',1.0d0) call aTracer%addAttribute('l1d',[.true.,.true.,.false.]) call aTracer%addAttribute('r1d',[0.5d0,5.0d0,10.0d0]) ! test init call aBundle%init() call aBundle%clear() ! test addTracer,addDefaultAttribute,addTracerAttribute allocate(mand(1)) mand(1) = 'r1d' call aBundle%init(mand) call aBundle%addTracer(aTracer) ! test getTracer L=aBundle%getTracer('atrcer',tp) print*,"get tracer : should be T", L call aBundle%addDefaultAttribute('defaultInts',[10,100,1000]) call aBundle%addDefaultAttribute('defaultStr','hello yo') call aBundle%addDefaultAttribute('DStrs',['haha','hehe']) call aBundle%addTracerAttribute('atrcer','addon',[0.1d0,0.2d0]) call aBundle%print() ! test hasTracer L=aBundle%hasTracer('atrcer') print*,"has atrcer should be T:",L ! test get Tracer Attribute allocate(k1d(3)) L=aBundle%getTracerAttribute('atrcer','defaultInts',k1d) if(L) print*, "k1d should be 10,100,1000:",k1d L=aBundle%getTracerAttribute('atrcer','defaultStr',s) if(L) print*, "should be 'hello yo':",s allocate(s1d(2)) L=aBundle%getTracerAttribute('atrcer','DStrs',s1d) if(L) print*, "should be 'haha','hehe':",s1d end program main gFTL-1.2.7/examples/Tracer/TestValueType.F90000066400000000000000000000021211372124645500204160ustar00rootroot00000000000000program main use Values_mod use ValueTypeMap_mod implicit none class(AbstractValue),pointer :: vp type(ValueTypeMap) :: vtMap1,vtMap2 integer :: k integer,allocatable :: k1(:) logical :: L logical,allocatable :: L1(:) real(kind=DP) :: r real(kind=DP),allocatable :: r1(:) character(len=MAX_LEN_ATTRIBUTE_STRING) :: s character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1(:) class(AbstractValue),allocatable :: AbV call vtMap1%init() vp=>vtMap1%at('integer') k= vp print*,k vp=>vtMap1%at('integer1D') k1 = vp print *,k1 vp=>vtMap1%at('logical') L = vp print*,L vp=>vtMap1%at('logical1D') L1=vp print*,L1 vp=>vtMap1%at('realDP') r = vp print*,r vp=>vtMap1%at('realDP1D') r1=vp print*,r1 vp=>vtMap1%at('string') s=vp print*,s vp=>vtMap1%at('string1D') s1 = vp print*,s1 ! test Copy of ValueTypeMap vtMap2 = vtMap1 vp=>vtMap2%at('string1D') call vp%print() L=vtMap1%get('string1D',vp) if(L) then call vp%print() endif end program main gFTL-1.2.7/examples/Tracer/TestValues.F90000066400000000000000000000022461372124645500177470ustar00rootroot00000000000000program main use Values_mod implicit none class(AbstractValue),pointer :: vp integer :: k integer,allocatable :: k1(:) logical :: L logical,allocatable :: L1(:) real(kind=DP) :: r real(kind=DP),allocatable :: r1(:) character(len=MAX_LEN_ATTRIBUTE_STRING) :: s character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1(:) class(AbstractValue),allocatable :: AbV allocate(AbV, source=newValue(1000)) call AbV%getValue(k) print*,k call AbV%setValue(k+1000) call AbV%getValue(k) print*,k deallocate(Abv) allocate(AbV, source=newValue(.false.)) call AbV%getValue(l) print*,l call AbV%setValue(.true.) call AbV%getValue(l) print*,l deallocate(Abv) allocate(AbV,source=newValue([10.0d0,20.0d0,200.0d0])) allocate(r1(Abv%dims(1))) call AbV%getValue(r1) print*,r1 r1(3)= 10000.d0 call AbV%setValue(r1) call AbV%getValue(r1) print*,r1 deallocate(Abv) allocate(AbV,source=newValue(['0.0d0','1.1d0','2.2d0'])) allocate(s1(Abv%dims(1))) call AbV%getValue(s1) print*,s1 s1= '10000.d0' call AbV%setValue(s1) call AbV%getValue(s1) print*,s1 end program main gFTL-1.2.7/examples/Tracer/Tracer.F90000066400000000000000000000260051372124645500170670ustar00rootroot00000000000000module Tracer_mod use Values_mod use AttributeMap_mod use TracerSurfaceSource_mod, only: TracerSurfaceSource use TracerSource_mod, only: TracerSource3D implicit none private public :: Tracer ! derived type public :: clear public :: writeUnformatted public :: readUnformattedTracer public :: findSurfaceSources public :: addSurfaceSource public :: readSurfaceSources public :: NTSURFSRCMAX !@var ntsurfsrcmax maximum number of surface 2D sources/sinks integer, parameter :: NTSURFSRCMAX=16 !@var nt3Dsrcmax maximum number of 3D tracer sources/sinks integer, parameter :: NT3DSRCMAX=7 type :: Tracer !!$ private character(len=MAX_LEN_KEY) :: name integer :: ntSurfSrc = 0 type (TracerSurfaceSource), allocatable, dimension(:) :: surfaceSources type (TracerSource3D), allocatable, dimension(:) :: sources3D type (AttributeMap) :: attributes contains procedure :: initTracer generic :: init=>initTracer procedure :: addAttribute0d procedure :: addAttribute1d generic :: addAttribute=>addAttribute0d,addAttribute1d procedure :: getAttribute0d procedure :: getAttribute1d generic :: getAttribute=>getAttribute0d,getAttribute1d procedure :: setAttribute0d procedure :: setAttribute1d generic :: setAttribute=>setAttribute0d,setAttribute1d procedure :: hasAttribute procedure :: getName procedure :: copyTracer generic :: assignment(=) =>copyTracer procedure :: clearTracer generic :: clear=>clearTracer procedure :: printIt generic :: print => printIt procedure :: equals generic :: operator(==) => equals end type Tracer interface writeUnformatted module procedure writeUnformatted_tracer end interface interface clear module procedure clearTracer end interface contains subroutine initTracer(this,name) class (Tracer),intent(inout) :: this character(len=*) :: name this%name = trim(name) call this%attributes%init() allocate(this%surfaceSources(NTSURFSRCMAX)) allocate(this%sources3D(NT3DSRCMAX)) end subroutine initTracer subroutine addAttribute0d(this,name,value) use AbstractValue_mod class (Tracer),intent(inout) :: this character(len=*),intent(in) :: name class(*),intent(in) :: value call this%attributes%insertValue(name,value) end subroutine addAttribute0d subroutine addAttribute1d(this,name,value) class (Tracer),intent(inout) :: this character(len=*),intent(in) :: name class(*),intent(in) :: value(:) character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1(:) integer :: n ! work around for gfortran select type (value) type is (character(len=*)) n = size(value) allocate(s1(n)) s1=value call this%attributes%insertValue(trim(name),s1) deallocate(s1) return class default end select call this%attributes%insertValue(trim(name),value) end subroutine addAttribute1d function getAttribute0d(this,name,value) result (res) use AbstractValue_mod class (Tracer),intent(inout) :: this character(len=*),intent(in) :: name class(*),intent(inout) :: value logical :: res res = this%attributes%getValue(trim(name),value) end function getAttribute0d function getAttribute1d(this,name,value) result(res) class (Tracer),intent(inout) :: this character(len=*),intent(in) :: name class(*),intent(inout) :: value(:) logical :: res character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1(:) integer :: n ! work around for gfortran select type (value) type is (character(len=*)) n = size(value) allocate(s1(n)) res = this%attributes%getValue(trim(name),s1) value=s1 deallocate(s1) return class default end select res= this%attributes%getValue(trim(name),value) end function getAttribute1d subroutine setAttribute0d(this,name,value) use AbstractValue_mod class (Tracer),intent(inout) :: this character(len=*),intent(in) :: name class(*),intent(in) :: value call this%attributes%setValue(trim(name),value) end subroutine setAttribute0d subroutine setAttribute1d(this,name,value) class (Tracer),intent(inout) :: this character(len=*),intent(in) :: name class(*),intent(in) :: value(:) character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable :: s1(:) integer :: n ! work around for gfortran select type (value) type is (character(len=*)) n = size(value) allocate(s1(n)) s1=value call this%attributes%setValue(trim(name),s1) deallocate(s1) return class default end select call this%attributes%setValue(trim(name),value) end subroutine setAttribute1d function hasAttribute(this,attrName) result(l) class(Tracer),intent(in):: this character(len=*),intent(in) :: attrName logical :: l l=.true. if( this%attributes%find(trim(attrName)) == this%attributes%end()) l=.false. end function hasAttribute subroutine copyTracer(copy,original) class(Tracer),intent(inout) :: copy class(Tracer), intent(in) :: original integer :: n copy%attributes = original%attributes copy%ntSurfSrc = original%ntSurfSrc copy%name = original%name n = size(original%surfaceSources,1) allocate(copy%surfaceSources(1:n), source=original%surfaceSources) n = size(original%sources3D,1) allocate(copy%sources3D(1:n),source = original%sources3D) end subroutine copyTracer function getName(this) result (name) class (Tracer), target, intent(in) :: this character(len=MAX_LEN_ATTRIBUTE_STRING) :: name name=this%name end function getName subroutine writeUnformatted_tracer(this, unit) !@sum Write a tracer to a unit attached to an unformatted sequential file. type (Tracer), intent(in) :: this integer, intent(in) :: unit call this%attributes%writeUnformatted(unit) end subroutine writeUnformatted_tracer subroutine readUnformattedTracer(this, unit) !@sum Read a bundle to a unit attached to an unformatted sequential file. !!$ use Dictionary_mod, only: readUnformatted type (Tracer), intent(inout) :: this integer, intent(in) :: unit call this%attributes%readUnformatted(unit) end subroutine readUnformattedTracer subroutine clearTracer(this) class(Tracer), intent(inout) :: this call this%attributes%clear() !deallocate(this%surfaceSources) !deallocate(this%sources3D) end subroutine clearTracer subroutine findSurfaceSources(trcer, checkname, sect_name) !@sum reads headers from emission files to return !@+ source names and determine the number of sources !@+ from the number of files in the rundeck of the form: !@+ trname_##. Then assigns each source to sector(s), !@+ based on definitions in the rundeck. !@auth Greg Faluvegi use GenericType_mod USE SpecialIO_mod, only: write_parallel use MpiSupport_mod, only: am_i_root implicit none !@var nsrc number of source to define ntsurfsrc(n) type (Tracer), intent(inout) :: trcer logical, intent(in) :: checkName character*10, intent(in):: sect_name(:) integer :: n character*80 :: fname character(len=300) :: out_line logical :: fileExists integer :: nsrc ! loop through potential number of surface sources, checking if ! those files exist. If they do, obtain the source name by reading ! the header. If not, the number of sources for this tracer has ! been reached. nsrc=0 loop_n: do n = 1, ntsurfsrcmax fname = addIntegerSuffix(getName(trcer), n) inquire(file=trim(fname), exist=fileExists) if (am_i_root()) print*,'name: ', trim(fname), fileExists if (fileExists) then nsrc=nsrc+1 call addSourceFromFile(trcer, fname) else exit loop_n endif enddo loop_n ! and make sure there isn't a skip: n=n+1 fname = addIntegerSuffix(getName(trcer), n) inquire(file=fname,exist=fileExists) if (fileExists) then write(out_line,*)'problem in findSurfaceSources.', & & ' Possibly missing source? n=',n-1 call write_parallel(trim(out_line)) call stop_model(trim(out_line),255) endif contains subroutine addSourceFromFile(trcer, fileName) use TracerSurfaceSource_mod, only: initSurfaceSource type (Tracer), intent(inout) :: trcer character(len=*), intent(in) :: fileName trcer%ntSurfSrc = trcer%ntSurfSrc + 1 call initSurfaceSource(trcer%surfaceSources(trcer%ntSurfSrc), & & getName(trcer), fileName, sect_name, checkname) end subroutine addSourceFromFile end subroutine findSurfaceSources ! Use this routine to add a new surface source that ! is manipulated by custom logic elsewhere. ! Optional sourcename is only used by diagnostics subroutine addSurfaceSource(this, sourceName) type (Tracer), intent(inout) :: this character(len=*), intent(in) :: sourceName this%ntSurfSrc = this%ntSurfSrc + 1 this%surfaceSources(this%ntSurfSrc)%sourceName = sourceName end subroutine addSurfaceSource !TODO - move to string utilities function addIntegerSuffix(tracerName, n) result(fullName) character(len=*), intent(in) :: tracerName character(len=len_trim(tracerName)+3) :: fullName integer, intent(in) :: n character(len=2) :: suffix write(suffix,'(I2.2)') n fullName = trim(tracerName) // '_' // suffix end function addIntegerSuffix subroutine readSurfaceSources(trcer, n,nsrc,xyear,xday,checkname,itime,itime_tr0,sfc_src) !@sum reads surface (2D generally non-interactive) sources !@auth Jean Lerner/Greg Faluvegi USE DOMAIN_DECOMP_ATM, only: GRID use TracerSurfaceSource_mod, only: readSurfaceSource type (Tracer), target, intent(inout) :: trcer integer, intent(in) :: nsrc,n integer, intent(in) :: xyear, xday logical, intent(in) :: checkname integer, intent(in) :: itime integer, intent(in) :: itime_tr0 real*8, intent(inout) :: sfc_src(grid%i_strt_halo:,grid%j_strt_halo:,:,:) integer :: ns if (itime < itime_tr0) return if (nsrc <= 0) return do ns=1,nsrc call readSurfaceSource(trcer%surfaceSources(ns), addIntegerSuffix(getName(trcer), ns), checkname, sfc_src(:,:,n,ns), & & xyear, xday) enddo return end subroutine readSurfaceSources subroutine toTracer(pType, pClass) type (Tracer), pointer, intent(out) :: pType class (Tracer), target, intent(in) :: pClass select type (p => pClass) type is (Tracer) pType => p class default call stop_model('Illegal conversion in Tracer_mod.',255) end select end subroutine toTracer subroutine printIt(this) class(Tracer),intent(inout) :: this print*,"Tracer name : ",this%name call this%attributes%print() end subroutine printIt logical function equals( this, b) class(Tracer),intent(in) :: this type(Tracer),intent(in) :: b equals = (this%attributes == b%attributes) end function equals end module Tracer_mod gFTL-1.2.7/examples/Tracer/TracerBundle.F90000066400000000000000000000326711372124645500202270ustar00rootroot00000000000000module TracerMap_mod use Tracer_mod #define _key_string_deferred #define _key_equal_defined #define _Key_less_than_defined #define _value class(Tracer) #define _value_allocatable #define _alt #include "templates/map.inc" end module TracerMap_mod module TracerBundle_mod use AbstractValue_mod use Values_mod use FTLAttrMap_mod, only: AttributeMapIterator=>MapIterator use AttributeMap_mod use Tracer_mod use TracerMap_mod, only :TracerMap=>Map,TracerMapIterator=>MapIterator implicit none type :: TracerBundle character(len=MAX_LEN_KEY),allocatable :: mandatoryAttributes(:) type(AttributeMap) :: defaultValues type(TracerMap) :: tracers contains procedure :: initEmptyBundle procedure :: initBwithMan procedure :: initBwithManDV procedure :: initBwithManDVTracers generic :: init=>initEmptyBundle,initBwithMan,initBwithManDV,initBwithManDVTracers procedure :: addDefaultAttribute0 procedure :: addDefaultAttribute1 generic :: addDefaultAttribute=>addDefaultAttribute0,addDefaultAttribute1 procedure :: addMandatoryAttribute procedure :: addTracer procedure :: getTracer procedure :: setTracer procedure :: hasTracer procedure :: isQualifiedTracer procedure :: addTracerAttribute0 procedure :: addTracerAttribute1 generic :: addTracerAttribute=>addTracerAttribute0,addTracerAttribute1 procedure :: getTracerAttribute0 procedure :: getTracerAttribute1 generic :: getTracerAttribute=>getTracerAttribute0,getTracerAttribute1 procedure :: setTracerAttribute0 procedure :: setTracerAttribute1 generic :: setTracerAttribute=>setTracerAttribute0,setTracerAttribute1 procedure :: clearTracerBundle generic :: clear =>clearTracerBundle procedure :: printIt generic :: print=>printIt end type contains subroutine initEmptyBundle(this) class(TracerBundle), intent(inout) :: this call this%defaultValues%init() allocate(this%mandatoryAttributes(0)) end subroutine initEmptyBundle subroutine initBwithMan(this,mAttr) class(TracerBundle), intent(inout) :: this character(len=MAX_LEN_KEY),intent(in) :: mAttr(:) !allocate(this%mandatoryAttributes(1:size(mAttr,1)), source = mAttr) this%mandatoryAttributes = mAttr call this%defaultValues%init() end subroutine initBwithMan subroutine initBwithManDV(this,mAttr,dValues) class(TracerBundle), intent(inout) :: this character(len=MAX_LEN_KEY),intent(in) :: mAttr(:) type(AttributeMap),intent(in) :: dValues this%mandatoryAttributes = mAttr this%defaultValues = dValues end subroutine initBwithManDV subroutine initBwithManDVTracers(this,mAttr,dValues,tracers) class(TracerBundle), intent(inout) :: this character(len=MAX_LEN_KEY),intent(in) :: mAttr(:) type(AttributeMap),intent(in) :: dValues class(TracerMap),intent(in) :: tracers type(TracerMapIterator) :: iter integer :: i this%mandatoryAttributes = mAttr this%defaultValues = dValues iter = tracers%begin() do while (iter /= tracers%end()) call this%addTracer(iter%value()) call iter%next() enddo end subroutine initBwithManDVTracers subroutine addMandatoryAttribute(this,attrName) class(TracerBundle),intent(inout) :: this character(len=*):: attrName integer :: n type(TracerMapIterator) :: iter type(Tracer),pointer :: tp character(len=MAX_LEN_KEY), allocatable :: oldValues(:) iter = this%tracers%begin() do while (iter /= this%tracers%end()) tp=>iter%value() if(.not. tp%hasAttribute(attrName)) return call iter%next() enddo n = size(this%mandatoryAttributes) call move_alloc(this%mandatoryAttributes,oldValues) allocate(this%mandatoryAttributes(n+1)) this%mandatoryAttributes(1:n)=oldValues this%mandatoryAttributes(n+1) = attrName end subroutine addMandatoryAttribute subroutine addDefaultAttribute0(this,attrName,value) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: attrName class(*),intent(in) :: value type(TracerMapIterator) :: iter type(Tracer),pointer :: tp call this%defaultValues%insertValue(attrName,value) iter = this%tracers%begin() do while (iter /= this%tracers%end()) tp=>iter%value() if(.not. tp%hasAttribute(attrName)) then call tp%attributes%insertValue(attrName,value) endif call iter%next() nullify(tp) enddo end subroutine addDefaultAttribute0 subroutine addDefaultAttribute1(this,attrName,value) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: attrName class(*),intent(in) :: value(:) type(TracerMapIterator) :: iter type(Tracer),pointer :: tp character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable:: s1(:) integer :: n select type (value) type is (character(len=*)) allocate(s1(size(value))) s1=value call this%defaultValues%insertValue(trim(attrName),s1) iter = this%tracers%begin() do while (iter /= this%tracers%end()) tp=>iter%value() if(.not. tp%hasAttribute(trim(attrName))) then call tp%attributes%insertValue(trim(attrName),s1) endif call iter%next() nullify(tp) enddo deallocate(s1) return class default end select call this%defaultValues%insertValue(trim(attrName),value) iter = this%tracers%begin() do while (iter /= this%tracers%end()) tp=>iter%value() if(.not. tp%hasAttribute(trim(attrName))) then call tp%attributes%insertValue(trim(attrName),value) endif call iter%next() nullify(tp) enddo end subroutine addDefaultAttribute1 function isQualifiedTracer(this,trcr) result(res) class(TracerBundle),intent(inout) :: this type(Tracer),intent(in) :: trcr logical :: res type(AttributeMapIterator) :: iter integer :: i ! if there is no mandatory attributes, it is qualified. res = .true. do i = 1,size(this%mandatoryAttributes) res = .false. if(trcr%hasAttribute(trim(this%mandatoryAttributes(i)))) then res = .true. return endif enddo end function isQualifiedTracer subroutine addTracer(this,trcr) class(TracerBundle),intent(inout) :: this type(Tracer),intent(in) :: trcr type(AttributeMapIterator) :: iter type(TracerMapIterator) :: iterT type(Tracer),pointer :: tp class(Tracer),allocatable :: tmpTrcr if( .not. this%isQualifiedTracer(trcr)) return allocate(tmpTrcr,source = trcr) iter = this%defaultValues%begin() do while (iter /= this%defaultValues%end()) if( .not. tmpTrcr%hasAttribute(iter%key())) then call tmpTrcr%addAttribute(iter%key(),iter%value()) endif call iter%next() enddo call this%tracers%insert(tmpTrcr%name,tmpTrcr) end subroutine addTracer subroutine setTracer(this,trcr) class(TracerBundle),intent(inout) :: this type(Tracer),intent(in) :: trcr type(Tracer) :: tmpTracer type(AttributeMapIterator) :: iter integer :: i if( .not. this%isQualifiedTracer(trcr)) return tmpTracer = trcr iter = this%defaultValues%begin() do while (iter /= this%defaultValues%end()) if( .not. tmpTracer%hasAttribute(iter%key())) then call tmpTracer%addAttribute(iter%key(),iter%value()) endif call iter%next() enddo call this%tracers%set(tmpTracer%name,tmpTracer) end subroutine setTracer function getTracer(this,name,trPtr) result(res) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) ::name class(Tracer),pointer,intent(inout) :: trPtr logical :: res res= this%tracers%get(name,trPtr) end function getTracer function hasTracer(this,tName) result (has) class(TracerBundle),intent(in) :: this character(len=*),intent(in) :: tName logical :: has has = ( this%tracers%find(trim(tName)) /= this%tracers%end()) end function subroutine addTracerAttribute0(this,tName,attrName,value) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: tName character(len=*),intent(in) :: attrName class (*), intent(in) :: value type(TracerMapIterator) :: iter type(Tracer),pointer :: tp iter = this%tracers%find(trim(tName)) if ( iter /= this%tracers%end()) then tp=>iter%value() call tp%attributes%insertValue(attrName,value) endif end subroutine subroutine addTracerAttribute1(this,tName,attrName,value) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: tName character(len=*),intent(in) :: attrName class (*), intent(in) :: value(:) type(TracerMapIterator) :: iter type(Tracer),pointer :: tp character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable:: s1(:) iter = this%tracers%find(trim(tName)) if ( iter /= this%tracers%end()) then tp=>iter%value() ! work around for gfortran select type (value) type is (character(len=*)) allocate(s1(size(value))) s1=value call tp%attributes%insertValue(trim(attrName),s1) deallocate(s1) return class default end select call tp%attributes%insertValue(trim(attrName),value) endif end subroutine addTracerAttribute1 subroutine setTracerAttribute0(this,tName,attrName,value) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: tName character(len=*),intent(in) :: attrName class (*), intent(in) :: value type(TracerMapIterator) :: iter type(Tracer),pointer :: tp iter = this%tracers%find(trim(tName)) if ( iter /= this%tracers%end()) then tp=>iter%value() call tp%attributes%setValue(trim(attrName),value) endif end subroutine setTracerAttribute0 subroutine setTracerAttribute1(this,tName,attrName,value) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: tName character(len=*),intent(in) :: attrName class (*), intent(in) :: value(:) type(TracerMapIterator) :: iter type(Tracer),pointer :: tp character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable:: s1(:) iter = this%tracers%find(trim(tName)) if ( iter /= this%tracers%end()) then tp=>iter%value() ! work around for gfortran select type (value) type is (character(len=*)) allocate(s1(size(value))) s1=value call tp%attributes%setValue(trim(attrName),s1) deallocate(s1) return class default end select call tp%attributes%setValue(trim(attrName),value) endif end subroutine setTracerAttribute1 function getTracerAttribute0(this,tName,attrName,value) result(res) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: tName character(len=*),intent(in) :: attrName class (*), intent(inout) :: value type(TracerMapIterator) :: iter type(Tracer),pointer :: tp logical:: res res = .false. iter = this%tracers%find(trim(tName)) if ( iter /= this%tracers%end()) then tp=>iter%value() res = tp%attributes%getValue(trim(attrName),value) endif end function getTracerAttribute0 function getTracerAttribute1(this,tName,attrName,value) result(res) class(TracerBundle),intent(inout) :: this character(len=*),intent(in) :: tName character(len=*),intent(in) :: attrName class (*), intent(inout) :: value(:) type(TracerMapIterator) :: iter type(Tracer),pointer :: tp logical:: res character(len=MAX_LEN_ATTRIBUTE_STRING),allocatable:: s1(:) res = .false. iter = this%tracers%find(trim(tName)) if ( iter /= this%tracers%end()) then tp=>iter%value() ! work around for gfortran select type (value) type is (character(len=*)) allocate(s1(size(value))) res= tp%attributes%getValue(trim(attrName),s1) value=s1 deallocate(s1) return class default end select res = tp%attributes%getValue(trim(attrName),value) endif end function getTracerAttribute1 subroutine clearTracerBundle(this) class(TracerBundle),intent(inout) :: this if(this%tracers%size() /=0) call this%tracers%clear() if(this%defaultValues%size() /=0) call this%defaultValues%clear() deallocate(this%mandatoryAttributes) end subroutine subroutine printIt(this) class(TracerBundle),intent(inout) :: this type(TracerMapIterator) :: iter type(Tracer),pointer :: p print*, "default values: " call this%defaultValues%print() print*, "loop tracers: " iter = this%tracers%begin() do while (iter /= this%tracers%end()) p=>iter%value() call p%print() call iter%next() end do end subroutine printIt end module TracerBundle_mod gFTL-1.2.7/examples/Tracer/Values.F90000066400000000000000000001254321372124645500171120ustar00rootroot00000000000000module integerValue_mod use AbstractValue_mod implicit none private #define TYPE integerValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE integer :: value contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry integer, intent(in) :: value entry%value = value entry%rank = 0 entry%name = "integer" allocate(entry%dims(0)) end function constructor subroutine toType_(value, entry) integer , intent(inout) :: value class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) value = entry%value class default call stop_model('Illegal conversion of integerValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) integer, pointer :: ptr class (AbstractValue), target, intent(in) :: entry integer :: cast select type (q => entry) type is (integerValue) ptr => q%value class default call stop_model('Illegal association of integerValue.',255) end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value select type (value) type is (integer) value=this%value class default call stop_model('should be integer type of value.',255) end select end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) !class(*),intent(out),allocatable :: value(:) call stop_model('value should not be 1D integer',255) end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value select type (value) type is (integer) this%value=value class default call stop_model('should be integer type of value.',255) end select end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) call stop_model('value should not be 1D integer',255) end subroutine set1DValue logical function equals(this, b) class (integerValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (integerValue) if ((this%value == p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (integerValue), intent(in) :: this print*,' Type: ', 'integerValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (integerValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = toStringElemental(this%value) contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (integerValue), intent(in) :: this integer, intent(in) :: unit write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) class (integerValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank integer, pointer :: value allocate(value ) read(unit) value allocate(new, source=newValue(value)) deallocate(value) end function readUnformatted subroutine clear(this) class (integerValue), intent(inout) :: this end subroutine clear end module integerValue_mod #undef TYPE module integer1dValue_mod use AbstractValue_mod use integerValue_mod implicit none private #define TYPE integer1dValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE integer, allocatable :: value (:) contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry integer, intent(in) :: value (:) allocate(entry%value (size(value,1))) entry%value = value entry%rank = 1 entry%name = "integer1D" allocate(entry%dims(1)) entry%dims(1)=size(value,1) end function constructor subroutine toType_(value, entry) integer , allocatable, intent(inout) :: value (:) class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) #ifdef __GFORTRAN__ value = entry%value #else allocate(value, source=entry%value) #endif class default call stop_model('Illegal conversion of integer1dValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) integer, pointer :: ptr (:) class (AbstractValue), target, intent(in) :: entry integer :: cast (:) select type (q => entry) type is (integer1dValue) ptr => q%value class default call stop_model('Illegal association of integer1dValue.',255) print*,'Illegal association of integer1dValue.' end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value call stop_model('value should not be integer scalar',255) end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) select type (value) type is (integer) value=this%value class default call stop_model('should be 1D integer type of value.',255) end select end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value call stop_model('value should not be integer scalar',255) end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) if(this%dims(1) /= size(value,1)) then call stop_model('should not change dimension through setValue call') endif select type (value) type is (integer) this%value=value class default call stop_model('should be 1D integer type of value.',255) end select end subroutine set1DValue logical function equals(this, b) class (integer1dValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (integer1dValue) if (all(this%value == p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (integer1dValue), intent(in) :: this print*,' Type: ', 'integer1dValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (integer1dValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = join(reshape(toStringElemental(this%value),(/size(this%value)/)),', ') contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (integer1dValue), intent(in) :: this integer, intent(in) :: unit write(unit) shape(this%value) write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) class (integer1dValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank integer, pointer :: value (:) integer :: attributeShape(1) read(unit) attributeShape allocate(value(attributeShape(1))) read(unit) value allocate(new, source=newValue(value)) deallocate(value) end function readUnformatted subroutine clear(this) class (integer1dValue), intent(inout) :: this deallocate(this%value) end subroutine clear end module integer1dValue_mod #undef TYPE module logicalValue_mod use AbstractValue_mod implicit none private #define TYPE logicalValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE logical :: value contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry logical, intent(in) :: value entry%value = value entry%rank = 0 entry%name = "logical" allocate(entry%dims(0)) end function constructor subroutine toType_(value, entry) logical , intent(inout) :: value class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) value = entry%value class default call stop_model('Illegal conversion of logicalValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) logical, pointer :: ptr class (AbstractValue), target, intent(in) :: entry logical :: cast select type (q => entry) type is (logicalValue) ptr => q%value class default call stop_model('Illegal association of logicalValue.',255) end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value select type (value) type is (logical) value=this%value class default call stop_model('shaould be logical type of value.',255) end select end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) call stop_model('value should not be 1D logical',255) end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value select type (value) type is (logical) this%value=value class default call stop_model('shaould be logical type of value.',255) end select end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) call stop_model('value should not be 1D logical',255) end subroutine set1DValue logical function equals(this, b) class (logicalValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (logicalValue) if ((this%value .eqv. p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (logicalValue), intent(in) :: this print*,' Type: ', 'logicalValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (logicalValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = toStringElemental(this%value) contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (logicalValue), intent(in) :: this integer, intent(in) :: unit write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) class (logicalValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank logical, pointer :: value allocate(value ) read(unit) value allocate(new, source=newValue(value)) deallocate(value) end function readUnformatted subroutine clear(this) class (logicalValue), intent(inout) :: this end subroutine clear end module logicalValue_mod #undef TYPE module logical1dValue_mod use AbstractValue_mod use logicalValue_mod implicit none private #define TYPE logical1dValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE logical, allocatable :: value (:) contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry logical, intent(in) :: value (:) allocate(entry%value (size(value,1))) entry%value = value entry%rank = 1 entry%name = "logical1D" allocate(entry%dims(1)) entry%dims(1) = size(value,1) end function constructor subroutine toType_(value, entry) logical , allocatable, intent(inout) :: value (:) class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) #ifdef __GFORTRAN__ value = entry%value #else allocate(value, source=entry%value) #endif class default call stop_model('Illegal conversion of logical1dValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) logical, pointer :: ptr (:) class (AbstractValue), target, intent(in) :: entry logical :: cast (:) select type (q => entry) type is (logical1dValue) ptr => q%value class default call stop_model('Illegal association of logical1dValue.',255) print*,'Illegal association of logical1dValue.' end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value call stop_model('value should not be logical scalar',255) end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) select type (value) type is (logical) value=this%value class default call stop_model('should be 1D logical type of value.',255) end select end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value call stop_model('value should not be logical scalar',255) end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) if(this%dims(1) /= size(value,1)) then call stop_model('should not change dimension through setValue call') endif select type (value) type is (logical) this%value = value class default call stop_model('should be 1D logical type of value.',255) end select end subroutine set1DValue logical function equals(this, b) class (logical1dValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (logical1dValue) if (all(this%value .eqv. p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (logical1dValue), intent(in) :: this print*,' Type: ', 'logical1dValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (logical1dValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = join(reshape(toStringElemental(this%value),(/size(this%value)/)),', ') contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (logical1dValue), intent(in) :: this integer, intent(in) :: unit write(unit) shape(this%value) write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) class (logical1dValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank logical, pointer :: value (:) integer :: attributeShape(1) read(unit) attributeShape allocate(value(attributeShape(1))) read(unit) value allocate(new, source=newValue(value)) deallocate(value) end function readUnformatted subroutine clear(this) class (logical1dValue), intent(inout) :: this deallocate(this%value) end subroutine clear end module logical1dValue_mod #undef TYPE module RealDPValue_mod use AbstractValue_mod implicit none private #define TYPE RealDPValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE real(kind=DP) :: value contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry real(kind=DP), intent(in) :: value entry%value = value entry%rank = 0 entry%name = "realDP" allocate(entry%dims(0)) end function constructor subroutine toType_(value, entry) real(kind=DP) , intent(inout) :: value class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) value = entry%value class default call stop_model('Illegal conversion of RealDPValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) real(kind=DP), pointer :: ptr class (AbstractValue), target, intent(in) :: entry real(kind=DP) :: cast select type (q => entry) type is (RealDPValue) ptr => q%value class default call stop_model('Illegal association of RealDPValue.',255) print*,'Illegal association of RealDPValue.' end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value select type (value) type is (real(kind=DP)) value=this%value class default call stop_model('should be real dp type ',255) end select end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) call stop_model('value should not be 1D real',255) end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value select type (value) type is (real(kind=DP)) this%value=value class default call stop_model('should be real dp type ',255) end select end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) call stop_model('value should not be 1D real',255) end subroutine set1DValue logical function equals(this, b) class (RealDPValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (RealDPValue) if ((this%value == p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (RealDPValue), intent(in) :: this print*,' Type: ', 'RealDPValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (RealDPValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = toStringElemental(this%value) contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (RealDPValue), intent(in) :: this integer, intent(in) :: unit write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) class (RealDPValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank real(kind=DP), pointer :: value allocate(value ) read(unit) value allocate(new, source=newValue(value)) deallocate(value) end function readUnformatted subroutine clear(this) class (RealDPValue), intent(inout) :: this end subroutine clear end module RealDPValue_mod #undef TYPE module RealDP1dValue_mod use AbstractValue_mod use RealDPValue_mod implicit none private #define TYPE RealDP1dValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE real(kind=DP), allocatable :: value (:) contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry real(kind=DP), intent(in) :: value (:) allocate(entry%value (size(value,1))) entry%value = value entry%rank = 1 entry%name = "realDP1D" allocate(entry%dims(1)) entry%dims(1)= size(value,1) end function constructor subroutine toType_(value, entry) real(kind=DP) , allocatable, intent(inout) :: value (:) class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) #ifdef __GFORTRAN__ value = entry%value #else allocate(value, source=entry%value) #endif class default call stop_model('Illegal conversion of RealDP1dValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) real(kind=DP), pointer :: ptr (:) class (AbstractValue), target, intent(in) :: entry real(kind=DP) :: cast (:) select type (q => entry) type is (RealDP1dValue) ptr => q%value class default call stop_model('Illegal association of RealDP1dValue.',255) print*,'Illegal association of RealDP1dValue.' end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value call stop_model('value should not be real scalar',255) end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) select type (value) type is (real(KIND=DP)) value=this%value class default call stop_model('should be 1D real DP type of value.',255) end select end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value call stop_model('value should not be real scalar',255) end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) if(this%dims(1) /= size(value,1)) then call stop_model('should not change dimension through setValue call') endif select type (value) type is (real(KIND=DP)) this%value=value class default call stop_model('should be 1D real DP type of value.',255) end select end subroutine set1DValue logical function equals(this, b) class (RealDP1dValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (RealDP1dValue) if (all(this%value == p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (RealDP1dValue), intent(in) :: this print*,' Type: ', 'RealDP1dValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (RealDP1dValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = join(reshape(toStringElemental(this%value),(/size(this%value)/)),', ') contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (RealDP1dValue), intent(in) :: this integer, intent(in) :: unit write(unit) shape(this%value) write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) class (RealDP1dValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank real(kind=DP), pointer :: value (:) integer :: attributeShape(1) read(unit) attributeShape allocate(value(attributeShape(1))) read(unit) value allocate(new, source=newValue(value)) deallocate(value) end function readUnformatted subroutine clear(this) class (RealDP1dValue), intent(inout) :: this deallocate(this%value) end subroutine clear end module RealDP1dValue_mod #undef TYPE module StringValue_mod use AbstractValue_mod implicit none private #define TYPE StringValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE character(len=MAX_LEN_ATTRIBUTE_STRING) :: value contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry character(len=*), intent(in) :: value entry%value = value entry%rank = 0 entry%name = "string" allocate(entry%dims(0)) end function constructor subroutine toType_(value, entry) character(len=MAX_LEN_ATTRIBUTE_STRING) , intent(inout) :: value class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) value = entry%value class default call stop_model('Illegal conversion of StringValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) character(len=MAX_LEN_ATTRIBUTE_STRING), pointer :: ptr class (AbstractValue), target, intent(in) :: entry character(len=MAX_LEN_ATTRIBUTE_STRING) :: cast select type (q => entry) type is (StringValue) ptr => q%value class default call stop_model('Illegal association of StringValue.',255) print*,'Illegal association of StringValue.' end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value select type (value) type is (character(len=*)) value=this%value class default call stop_model('should be type character(*)',255) end select end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) call stop_model('value should not be 1D chars',255) end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value select type (value) type is (character(len=*)) this%value=value class default call stop_model('should be type character(*)',255) end select end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) call stop_model('value should not be 1D chars',255) end subroutine set1DValue logical function equals(this, b) class (StringValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (StringValue) if ((this%value == p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (StringValue), intent(in) :: this print*,' Type: ', 'StringValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (StringValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = toStringElemental(this%value) contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (StringValue), intent(in) :: this integer, intent(in) :: unit write(unit) len_trim(this%value) write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) use StringUtilities_mod, only: forceTrim class (StringValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank character(len=MAX_LEN_ATTRIBUTE_STRING), pointer :: value integer, pointer :: lengths allocate(value , lengths) read(unit) lengths read(unit) value call forceTrim(value,lengths) allocate(new, source=newValue(value)) deallocate(value) deallocate(lengths) end function readUnformatted subroutine clear(this) class (StringValue), intent(inout) :: this end subroutine clear end module StringValue_mod #undef TYPE module String1dValue_mod use AbstractValue_mod use StringValue_mod implicit none private #define TYPE String1dValue public :: TYPE public :: newValue public :: toType public :: toPointer public :: assignment(=) type, extends(AbstractValue) :: TYPE character(len=MAX_LEN_ATTRIBUTE_STRING), allocatable :: value (:) contains procedure :: equals procedure :: clear procedure :: print => printIt ! gfortran workaround procedure :: writeUnformatted procedure :: readUnformatted procedure :: toString procedure :: getScalar procedure :: get1DValue procedure :: setScalar procedure :: set1DValue end type TYPE interface newValue module procedure constructor end interface interface assignment(=) module procedure toType_ end interface interface toType module procedure toType_ end interface interface toPointer module procedure toPointerType end interface toPointer contains function constructor(value) result(entry) type (TYPE) :: entry character(len=*), intent(in) :: value (:) allocate(entry%value (size(value,1))) entry%value = value entry%rank = 1 entry%name = "string1D" allocate(entry%dims(1)) entry%dims(1)= size(value,1) end function constructor subroutine toType_(value, entry) character(len=MAX_LEN_ATTRIBUTE_STRING) , allocatable, intent(inout) :: value (:) class (AbstractValue), intent(in) :: entry integer :: i select type (entry) type is (TYPE) #ifdef __GFORTRAN__ value = entry%value #else allocate(value, source=entry%value) #endif class default call stop_model('Illegal conversion of String1dValue.',255) end select end subroutine toType_ function toPointerType(entry, cast) result(ptr) character(len=MAX_LEN_ATTRIBUTE_STRING), pointer :: ptr (:) class (AbstractValue), target, intent(in) :: entry character(len=MAX_LEN_ATTRIBUTE_STRING) :: cast (:) select type (q => entry) type is (String1dValue) ptr => q%value class default call stop_model('Illegal association of String1dValue.',255) end select end function toPointerType subroutine getScalar(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value call stop_model('value should not be character(*)',255) end subroutine getScalar subroutine get1DValue(this, value) class(TYPE),intent(in) :: this class(*),intent(inout) :: value(:) select type (value) type is (character(len=*)) value=this%value class default call stop_model('should be 1D character(*)',255) end select end subroutine get1DValue subroutine setScalar(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value call stop_model('value should not be character(*)',255) end subroutine setScalar subroutine set1DValue(this, value) class(TYPE),intent(inout) :: this class(*),intent(in) :: value(:) if(this%dims(1) /= size(value,1)) then call stop_model('should not change dimension through setValue call') endif select type (value) type is (character(len=*)) this%value=value class default call stop_model('should be 1D character(*)',255) end select end subroutine set1DValue logical function equals(this, b) class (String1dValue), intent(in) :: this class (AbstractValue), intent(in) :: b select type (p => b) class is (String1dValue) if (all(this%value == p%value)) then equals = .true. else equals = .false. end if class default equals = .false. end select end function equals subroutine printIt(this) class (String1dValue), intent(in) :: this print*,' Type: ', 'String1dValue' print*,' Value: <', this%value,'>' print*,'--------------' end subroutine printIt function toString(this) result(string) use StringUtilities_mod, only: toStringElemental => toString class (String1dValue), intent(in) :: this character(len=MAX_LEN_LINE) :: string string = join(reshape(toStringElemental(this%value),(/size(this%value)/)),', ') contains function join(strArray, separator) result(string) character(len=*), intent(in) :: strArray(:) character(len=*), intent(in) :: separator character(len=MAX_LEN_LINE) :: string integer :: i string = trim(strArray(1)) do i = 2, size(strArray) string = trim(string) // trim(separator) // trim(strArray(i)) end do end function join end function toString subroutine writeUnformatted(this, unit) class (String1dValue), intent(in) :: this integer, intent(in) :: unit write(unit) shape(this%value) write(unit) len_trim(this%value) write(unit) this%value end subroutine writeUnformatted function readUnformatted(this, unit) result(new) use StringUtilities_mod, only: forceTrim class (String1dValue), intent(in) :: this integer, intent(in) :: unit class (AbstractValue), pointer :: new integer :: rank character(len=MAX_LEN_ATTRIBUTE_STRING), pointer :: value (:) integer, pointer :: lengths (:) integer :: attributeShape(1) read(unit) attributeShape allocate(value(attributeShape(1))) allocate(lengths(attributeShape(1))) read(unit) lengths read(unit) value call forceTrim(value,lengths) allocate(new, source=newValue(value)) deallocate(value) deallocate(lengths) end function readUnformatted subroutine clear(this) class (String1dValue), intent(inout) :: this deallocate(this%value) end subroutine clear end module String1dValue_mod #undef TYPE module FTLValueTypeMap_mod use AbstractValue_mod #define _key_string_deferred #define _key_equal_defined #define _Key_less_than_defined #define _value class(AbstractValue) #define _value_allocatable #define _alt #include "templates/map.inc" end module FTLValueTypeMap_mod module ValueTypeMap_mod use AbstractValue_mod use integerValue_mod use integer1dValue_mod use logicalValue_mod use logical1dValue_mod use RealDPValue_mod use RealDP1dValue_mod use StringValue_mod use String1dValue_mod use FTLValueTypeMap_mod implicit none type,extends(Map) :: ValueTypeMap contains procedure :: initValueTypeMap generic :: init=>initValueTypeMap procedure :: copyVmap generic :: assignment(=) => copyVmap end type contains subroutine initValueTypeMap(this) class(ValueTypeMap),intent(inout) :: this call this%insert('integer',newValue(0)) call this%insert('integer1D',newValue([1,2])) call this%insert('logical',newValue(.true.)) call this%insert('logical1D',newValue([.false.,.false.])) call this%insert('realDP',newValue(0.5d0)) call this%insert('realDP1D',newValue([0.6d0,0.7d0])) call this%insert('string',newValue('a')) call this%insert('string1D',newValue(['c','d'])) end subroutine subroutine copyVmap(to,from) class(ValueTypeMap),intent(inout) :: to class(ValueTypeMap),intent(in) :: from call to%deepCopy(from) end subroutine end module ValueTypeMap_mod module Values_mod use AbstractValue_mod use integerValue_mod use integer1dValue_mod use logicalValue_mod use logical1dValue_mod use RealDPValue_mod use RealDP1dValue_mod use StringValue_mod use String1dValue_mod use ValueTypeMap_mod implicit none end module Values_mod gFTL-1.2.7/examples/Vector/000077500000000000000000000000001372124645500154065ustar00rootroot00000000000000gFTL-1.2.7/examples/Vector/CMakeLists.txt000066400000000000000000000006341372124645500201510ustar00rootroot00000000000000cmake_minimum_required(VERSION 2.8) include_directories("$ENV{FTL}/include") #add_executable(VecIntAndReal.x EXCLUDE_FROM_ALL VecIntAndReal.F90) #add_executable(VecMyType.x EXCLUDE_FROM_ALL VecMyType.F90) #add_executable(VecMyPolyPtr.x EXCLUDE_FROM_ALL VecMyPolyPtr.F90) add_executable(VecIntAndReal.x VecIntAndReal.F90) add_executable(VecMyType.x VecMyType.F90) add_executable(VecMyPolyPtr.x VecMyPolyPtr.F90) gFTL-1.2.7/examples/Vector/VecIntAndReal.F90000066400000000000000000000023071372124645500203070ustar00rootroot00000000000000! This is an example for integer and real vector. ! It can be changed to any intrinsic type easliy. ! 1) create a module for each type ! 2) use alias when using different vector types module IntegerVec_mod #include "types/integer.inc" #include "templates/vector.inc" end module IntegerVec_mod module Real64Vec_mod #include "types/real64.inc" #include "templates/vector.inc" end module Real64Vec_mod program main use IntegerVec_mod,only :VectorInt=>Vector use Real64Vec_mod,only :VectorReal64=>Vector use iso_fortran_env implicit none type (VectorInt) :: iv type (VectorReal64) :: rv real(real64) :: r iv=VectorInt() rv=VectorReal64() r = 1.0d0 call iv%push_back(1) call rv%push_back(r) call check(iv,1) call checkr(rv,r) contains subroutine check(iv, expected) type(VectorInt), intent(in) :: iv integer, intent(in) :: expected print*,"iv%at('",1,"') = ",iv%at(1),"(should be",expected,")" end subroutine check subroutine checkr(rv, expected) type(VectorReal64), intent(in) :: rv real(real64), intent(in) :: expected print*,"rv%at('",1,"') = ",rv%at(1),"(should be",expected,")" end subroutine checkr end program main gFTL-1.2.7/examples/Vector/VecMyPolyPtr.F90000066400000000000000000000026211372124645500202440ustar00rootroot00000000000000! This is an example for derived types defined by users module MyBase_mod public :: MyBase type,abstract:: MyBase real :: r contains procedure(equal_),deferred :: equal generic :: operator(==) => equal end type MyBase abstract interface logical function equal_(m1,m2) result(l) import MyBase class(MyBase),intent(in) :: m1 class(MyBase),intent(in) :: m2 end function equal_ end interface end module MyBase_mod module MyType_mod use MyBase_mod type,extends(MyBase) :: MyType contains procedure :: equal end type interface MyType module procedure newMyType end interface contains function newMyType(r) result(m) real,intent(in) :: r type(MyType) :: m m%r = r end function logical function equal(m1,m2) result(l) class(MyType),intent(in) :: m1 class(MyBase),intent(in) :: m2 l = (abs(m1%r- m2%r) <= 1.0e-7) end function equal end module MyType_mod module VecMyPolyPtr_mod use MyBase_mod #define _type class(MyBase) #define _allocatable #define _pointer #define _equal_defined #include "templates/vector.inc" end Module program main use MyType_mod use VecMyPolyPtr_mod implicit none type(MyType) ,target :: mt class(MyBase) ,pointer :: mp type(Vector) :: mv mt= myType(1.0d0) mp=>mt call mv%push_back(mp) end program main gFTL-1.2.7/examples/Vector/VecMyType.F90000066400000000000000000000017561372124645500175640ustar00rootroot00000000000000! This is an example for derived types defined by users module MyType_mod public :: MyType type MyType real :: r contains procedure :: equal generic :: operator(==) => equal end type myType interface MyType module procedure newMyType end interface contains function newMyType(r) result(m) real,intent(in) :: r type(MyType) :: m m%r = r end function logical function equal(m1,m2) result(l) class(MyType),intent(in) :: m1,m2 l = (abs(m1%r- m2%r) <= 1.0e-7) end function equal end module MyType_mod ! Define the vector for the derived type ! It is shown in types/Foo.inc module VecMyType_mod use MyType_mod #define _type type(MyType) #define _equal_defined #define _LESS_THAN(x,y) (x%r < y%r) #include "templates/vector.inc" end module VecMyType_mod program main use MyType_mod use VecMyType_mod implicit none type (Vector) :: mv mv=Vector() call mv%push_back(MyType(2.0)) end program main gFTL-1.2.7/include/000077500000000000000000000000001372124645500137515ustar00rootroot00000000000000gFTL-1.2.7/include/.gitignore000066400000000000000000000000041372124645500157330ustar00rootroot00000000000000*~ gFTL-1.2.7/include/CMakeLists.txt000066400000000000000000000013401372124645500165070ustar00rootroot00000000000000add_library (gftl INTERFACE) set (dest "GFTL-${GFTL_VERSION_MAJOR}.${GFTL_VERSION_MINOR}") target_include_directories (gftl INTERFACE $ # for headers when building $ # for client in install mode ) add_subdirectory (templates) add_subdirectory (types) add_custom_command( OUTPUT GFTL_incs_generated_successfully DEPENDS gftl COMMAND touch fidl_generated_successfully WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} ) add_custom_target (force-generation-of-includes ALL) add_dependencies (force-generation-of-includes gftl) install (TARGETS gftl EXPORT GFTL DESTINATION "${dest}/include") install (EXPORT GFTL DESTINATION "${dest}/cmake") gFTL-1.2.7/include/pointerdef.inc000066400000000000000000000017331372124645500166070ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- function addr(x) implicit none _type, pointer, intent(in) :: x integer :: addr addr=loc(x) return end function addr pure function sameptr(x, y) implicit none _type, pointer, intent(in) :: x _type, target, intent(in) :: y logical :: sameptr sameptr=(.not.associated(x)) .or. associated(x, y) return end function sameptr #undef _type gFTL-1.2.7/include/templates/000077500000000000000000000000001372124645500157475ustar00rootroot00000000000000gFTL-1.2.7/include/templates/.gitignore000066400000000000000000000000041372124645500177310ustar00rootroot00000000000000*~ gFTL-1.2.7/include/templates/CMakeLists.txt000066400000000000000000000024631372124645500205140ustar00rootroot00000000000000set(src ${CMAKE_CURRENT_SOURCE_DIR}) set(bin ${CMAKE_CURRENT_BINARY_DIR}) # Need to create a 2D array of include files. # First axis is {type,key,value} set (template_params type key value) # Second axis is role set (macro_files template_macros template_macros_undefs testing_macros set_use_tokens use_tokens_undef macros_undefs) # Empty list - will append in loop below set(generated_incs) foreach( macro_file ${macro_files} ) foreach( param ${template_params} ) set( infile ${src}/${macro_file}.m4 ) set( outfile ${param}_${macro_file}.inc ) set (outpath ${CMAKE_CURRENT_BINARY_DIR}/${outfile}) add_custom_command ( OUTPUT ${outfile} COMMAND ${M4} -s -Dparam=${param} -I${src}/../templates < ${infile} > ${outfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND generated_incs ${outfile} ) endforeach() endforeach() add_custom_target( generate-template-incs DEPENDS ${generated_incs} ) add_dependencies (gftl generate-template-incs) set_source_files_properties (${generated_incs} PROPERTIES GENERATED TRUE) file (COPY DIRECTORY . DESTINATION . FILES_MATCHING PATTERN "*.inc") install (DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/ DESTINATION "${dest}/include/templates" FILES_MATCHING PATTERN "*.inc" PATTERN CMakeFiles EXCLUDE ) gFTL-1.2.7/include/templates/all_macros_undefs.inc000066400000000000000000000012721372124645500221240ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/type_macros_undefs.inc" #include "templates/key_macros_undefs.inc" #include "templates/value_macros_undefs.inc" gFTL-1.2.7/include/templates/all_template_macros.inc000066400000000000000000000012741372124645500224550ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/type_template_macros.inc" #include "templates/key_template_macros.inc" #include "templates/value_template_macros.inc" gFTL-1.2.7/include/templates/all_template_macros_undefs.inc000066400000000000000000000013211372124645500240120ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/type_template_macros_undefs.inc" #include "templates/key_template_macros_undefs.inc" #include "templates/value_template_macros_undefs.inc" gFTL-1.2.7/include/templates/altSet.inc000066400000000000000000000051551372124645500177040ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/tmplbase.inc" private ! Main container #ifdef _set # define __set _set #else # define __set set #endif #ifdef _iterator # define __siterator _iterator #else # define __siterator __QUOTE(__set)__QUOTE(Iterator) #endif public :: __set public :: __siterator ! Implementation uses a vector of <_type> #define __vector tVector #define __container_prefix tt_ #include "templates/type_set_use_tokens.inc" # include "vector_decl.inc" #include "templates/type_use_tokens_undef.inc" #undef __vector #undef __container_prefix ! Implementation alse uses vector of for ! indices. #define __vector iVector #define __container_prefix ti_ #define __use_type integer(kind=SIZE_KIND) #define __use_equal_defined #define __use_less_than_defined # include "vector_decl.inc" #include "templates/type_use_tokens_undef.inc" #undef __vector #undef __container_prefix ! set <_type> #define __container_prefix s_ #define __iterator __siterator #include "templates/type_set_use_tokens.inc" #include "altSet_decl.inc" #include "templates/type_use_tokens_undef.inc" #undef __iterator #undef __container_prefix #include "unused.inc" #include "error_codes.inc" contains ! vector <_type> #define __vector tVector #define __container_prefix tt_ #include "templates/type_set_use_tokens.inc" #include "vector_impl.inc" #include "templates/type_use_tokens_undef.inc" #undef __vector #undef __container_prefix ! set <_type> #define __container_prefix s_ #define __iterator __siterator #include "templates/type_set_use_tokens.inc" #include "altSet_impl.inc" #include "templates/type_use_tokens_undef.inc" #undef __iterator #undef __container_prefix ! vector #define __vector iVector #define __container_prefix ti_ #define __use_type integer(kind=SIZE_KIND) #define __use_equal_defined #define __use_less_than_defined # include "vector_impl.inc" #include "templates/type_use_tokens_undef.inc" #undef __vector #undef __container_prefix #undef __set #include "templates/tmpltail.inc" #include "templates/all_macros_undefs.inc" gFTL-1.2.7/include/templates/altSet_decl.inc000066400000000000000000000054551372124645500206760ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" integer(kind=SIZE_KIND), parameter :: UNINITIALIZED = -1 integer, parameter :: LEFT = 0, RIGHT = 1 type :: __set private type (Tvector) :: items type (Ivector) :: parents type (Ivector) :: lefts type (Ivector) :: rights type (Ivector) :: heights integer(kind=SIZE_KIND) :: root = UNINITIALIZED integer(kind=SIZE_KIND) :: tsize = 0 integer(kind=SIZE_KIND) :: next_free = 0 contains procedure :: empty => __PROC(empty) procedure :: size => __PROC(size) procedure :: count => __PROC(count) procedure :: find => __PROC(find) procedure :: clear => __PROC(clear) procedure :: insert => __PROC(insert) procedure :: erase_one => __PROC(erase_one) procedure :: erase_multi => __PROC(erase_multi) generic :: erase => erase_one, erase_multi procedure :: remove => __PROC(remove) procedure :: begin => __PROC(begin) procedure :: end => __PROC(end) procedure :: dump => __PROC(dump) procedure :: deepCopy => __PROC(deepCopy) procedure :: equalSets generic :: operator(==) => equalSets procedure :: notEqualSets generic :: operator(/=) => notEqualSets procedure, private :: get_child procedure, private :: set_child procedure, private :: set_parent_child procedure, private :: find_index procedure, private :: update_height procedure, private :: rebalance procedure, private :: erase_nonleaf procedure, private :: advpos procedure, private :: rot end type __set type :: __iterator private type (__set), pointer :: reference => null() integer(kind=SIZE_KIND) :: current = UNINITIALIZED contains procedure :: value => __PROC(value) procedure :: next => __PROC(next) procedure :: prev => __PROC(prev) procedure :: equalIters => __PROC(equalIters) procedure :: notEqualIters => __PROC(notEqualIters) generic :: operator(==) => equalIters generic :: operator(/=) => notEqualIters end type __iterator #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/altSet_impl.inc000066400000000000000000000642031372124645500207240ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" #if defined(_pointer) # define __pointer_declare_result __type_declare_result # define __pointer_declare_dummy __type_declare_dummy # define __need_compare # include "pointerdef.inc" # undef __pointer_declare_result # undef __pointer_declare_dummy #elif (__type_rank > 0) & !defined(_extents) # define __array_declare_dummy __type_declare_dummy # define __ARRAY_EQ_ELEMENT(x,y) __TYPE_EQ_ELEMENT(x,y) # include "array_defs.inc" # undef __ARRAY_EQ_ELEMENT # undef __array_declare_dummy #endif ! ======================= ! exists - a helper function ! ======================= logical function exists(pos) integer(kind=SIZE_KIND), intent(in) :: pos exists = (pos /= UNINITIALIZED) end function exists ! ======================= ! opposite - a helper function ! ======================= integer function opposite(dir) integer, intent(in) :: dir opposite = (1 - dir) end function opposite ! ======================= ! child ! ======================= function get_child(this, pos, dir) result(child) integer(kind=SIZE_KIND) :: child class(__set), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: pos integer, intent(in) :: dir select case (dir) case (LEFT) child = this%lefts%at(pos) case (RIGHT) child = this%rights%at(pos) end select end function get_child ! ======================= ! set_child ! ======================= subroutine set_child(this, pos, dir, child) class(__set), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: pos integer, intent(in) :: dir integer(kind=SIZE_KIND), intent(in) :: child select case (dir) case (LEFT) if (child == 0) then end if call this%lefts%set(pos, child) case (RIGHT) call this%rights%set(pos, child) end select end subroutine set_child ! ======================= ! set_parent_child ! ======================= subroutine set_parent_child(this, parent, pos, other) class(__set), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: parent integer(kind=SIZE_KIND), intent(in) :: pos integer(kind=SIZE_KIND), intent(in) :: other if (this%lefts%at(parent) == pos) then call this%set_child(parent, LEFT, other) else call this%set_child(parent, RIGHT, other) end if end subroutine set_parent_child ! ======================= ! update_height ! ======================= subroutine update_height(this, pos) class (__set), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: pos integer(kind=SIZE_KIND) :: idx integer(kind=SIZE_KIND) :: new_height new_height = 0 idx = this%lefts%at(pos) if (exists(idx)) then new_height = this%heights%at(idx) end if idx = this%rights%at(pos) if (exists(idx)) then new_height = max(new_height, this%heights%at(idx)) end if new_height = new_height + 1 call this%heights%set(pos, new_height) end subroutine update_height !========================================================================= ! ======================= ! empty ! ======================= logical function __PROC(empty)(this) result(empty) class(__set), intent(in) :: this empty = (.not. exists(this%root)) end function __PROC(empty) ! ======================= ! size ! ======================= function __PROC(size)(this) result(size) integer(kind=SIZE_KIND) :: size class(__set), intent(in) :: this size = this%tsize end function __PROC(size) ! ======================= ! find ! ======================= function __PROC(find)(this, value) result(find) class(__set), target, intent(in) :: this __type_declare_dummy, intent(in) :: value type(__iterator) :: find #ifdef _pointer __type_declare_result, pointer :: q #endif find%reference => this associate (c => find%current) c = this%find_index(value, .false.) if (exists(c)) then #ifdef _pointer q => this%items%at(c) if (.not.__PROC(orderEq)( & & q,value)) then c = UNINITIALIZED end if #else if (.not.__PROC(orderEq)( & & this%items%at(c),value)) then c = UNINITIALIZED end if #endif end if end associate end function __PROC(find) logical function __PROC(orderEq)(x, y) result(equal) __type_declare_dummy, intent(in) :: x __type_declare_dummy, intent(in) :: y equal = .not. __PROC(lessThan)(x,y) .and. & & .not. __PROC(lessThan)(y,x) end function __PROC(orderEq) ! ======================= ! count ! ======================= function __PROC(count)(this, value) result(count) integer(kind=SIZE_KIND) :: count class(__set), target, intent(in) :: this __type_declare_dummy, intent(in) :: value type (__iterator) :: i i = this%find(value) if (.not. exists(i%current)) then count = 0 else count = 1 end if end function __PROC(count) ! ======================= ! clear ! ======================= subroutine __PROC(clear)(this) class(__set), intent(inout) :: this call this%items%clear() call this%parents%clear() call this%lefts%clear() call this%rights%clear() call this%heights%clear() this%root = UNINITIALIZED this%tsize=0 end subroutine __PROC(clear) ! ======================= ! insert ! ======================= subroutine __PROC(insert)(this, value, unused, isNew, ref) class(__set), intent(inout) :: this __type_declare_dummy, intent(in) :: value type (Unusable), optional :: unused logical, optional, intent(out) :: isNew integer(kind=SIZE_KIND), optional, intent(out) :: ref integer(kind=SIZE_KIND) :: new integer(kind=SIZE_KIND) :: parent logical :: eq #ifdef _pointer __type_declare_result, pointer :: p, q #endif #if (defined(__vector_debug) && defined(_DEBUG___)) print*,__FILE__,__LINE__ #endif if (present(unused)) print*,shape(unused) if (exists(this%root)) then #ifdef _multi parent = this%find_index(value, .true.) #else parent = this%find_index(value, .false.) #ifdef _pointer p => this%items%at(parent) q => value eq = __PROC(orderEq)(p, q) #else if (exists(parent)) then eq = __PROC(orderEq)(this%items%at(parent), value) else eq = .false. end if #endif if (eq) then if (present(ref)) then ref = parent else call this%items%set(parent, value) endif if (present(isNew)) then isNew = .false. end if return endif #endif if (present(isNew)) then isNew = .true. end if #if (defined(__vector_debug) && defined(_DEBUG___)) print*,__FILE__,__LINE__, this%next_free #endif if (this%next_free == 0) then #if (defined(__vector_debug) && defined(_DEBUG___)) print*,__FILE__,__LINE__ #endif call this%items%push_back(value) new = this%items%size() call this%heights%push_back(1_SIZE_KIND) call this%lefts%push_back(UNINITIALIZED) call this%rights%push_back(UNINITIALIZED) call this%parents%push_back(parent) else new = this%next_free this%next_free = this%parents%at(new) call this%items%set(new, value) call this%heights%set(new, 1_SIZE_KIND) call this%lefts%set(new, UNINITIALIZED) call this%rights%set(new, UNINITIALIZED) call this%parents%set(new, parent) end if if (present(ref)) ref=new #ifdef _pointer p => value q => this%items%at(parent) if (__PROC(lessThan)(p,q)) then call this%lefts%set(parent, new) else call this%rights%set(parent,new) end if #else #if (defined(__vector_debug) && defined(_DEBUG___)) print*,__FILE__,__LINE__ #endif if (__PROC(lessThan)(value, this%items%at(parent))) then call this%lefts%set(parent, new) else call this%rights%set(parent,new) end if #endif call this%rebalance(parent, .true.) else ! new root #if (defined(__vector_debug) && defined(_DEBUG___)) print*,__FILE__,__LINE__, this%next_free #endif if (this%next_free == 0) then call this%items%push_back(value) new = this%items%size() call this%heights%push_back(1_SIZE_KIND) call this%lefts%push_back(UNINITIALIZED) call this%rights%push_back(UNINITIALIZED) call this%parents%push_back(UNINITIALIZED) else new = this%next_free this%next_free = this%parents%at(new) call this%items%set(new, value) call this%heights%set(new, 1_SIZE_KIND) call this%lefts%set(new, UNINITIALIZED) call this%rights%set(new, UNINITIALIZED) call this%parents%set(new, UNINITIALIZED) end if this%root = new if (present(ref)) ref = this%root if (present(isNew)) then isNew = .true. end if endif this%tsize = this%tsize + 1 end subroutine __PROC(insert) logical function __PROC(lessThan)(x, y) result(less) __type_declare_dummy, intent(in) :: x __type_declare_dummy, intent(in) :: y less = __TYPE_LESS_THAN(x,y) contains ! TODO: possibly this procedure should be inside some sort of #ifdef logical function dictionaryLessThan1d(x, y) result(less) integer, intent(in) :: x(:) integer, intent(in) :: y(:) integer(kind=SIZE_KIND) :: i, n n = min(size(x),size(y)) do i = 1, n less = (x(i) < y(i)) if (.not. x(i) == y(i)) return end do less = (size(x) < size(y)) end function dictionaryLessThan1d #if defined(__type_needs_default_compare) # if !defined(__compare_type) # define __compare_declare_dummy __type_declare_dummy # define __compare_declare_component __type_declare_component # define __COMPARE_ASSIGN(x,y) __TYPE_ASSIGN(x,y) # define __COMPARE_FREE(x) __TYPE_FREE(x) # endif logical function defaultLessThan(x, y) result(less) __compare_declare_dummy, intent(in) :: x __compare_declare_dummy, intent(in) :: y # if defined(_pointer) type LocalWrapper __compare_declare_component :: item end type LocalWrapper type (LocalWrapper) :: wrapX, wrapY # define __xx wrapX # define __yy wrapY __COMPARE_ASSIGN(wrapX%item, x) __COMPARE_ASSIGN(wrapY%item, y) # else # define __xx x # define __yy y # endif associate( wx => transfer(__xx,[1]), & & wy => transfer(__yy,[1]) ) less = dictionaryLessThan1d(wx, wy) end associate # if defined(_pointer) __COMPARE_FREE(wrapX%item) __COMPARE_FREE(wrapY%item) # endif # undef __xx # undef __yy # if !defined(__compare_type) # undef __compare_declare_dummy # undef __compare_declare_component # undef __COMPARE_ASSIGN # undef __COMPARE_FREE # endif end function defaultLessThan #endif end function __PROC(lessThan) ! ======================= ! erase ! ======================= subroutine __PROC(erase_one)(this, iter) class(__set), intent(inout) :: this type(__iterator), intent(inout) :: iter type (__iterator) :: last last = iter call last%next() call this%erase(iter, last) end subroutine __PROC(erase_one) ! ======================= ! erase_multi ! ======================= subroutine __PROC(erase_multi)(this, first, last) class(__set), intent(inout) :: this type(__iterator), intent(inout) :: first type(__iterator), intent(in) :: last integer(kind=SIZE_KIND) :: parent integer(kind=SIZE_KIND) :: pos type (__iterator) :: iter iter = first do while (iter /= last) pos = iter%current call iter%next() if (exists(this%rights%at(pos))) then call this%erase_nonleaf(pos, 1) else if (exists(this%lefts%at(pos))) then call this%erase_nonleaf(pos, 0) else parent = this%parents%at(pos) if (exists(parent)) then call this%set_parent_child(parent, pos, UNINITIALIZED) call this%rebalance(parent, .false.) else this%root = UNINITIALIZED endif ! declare this space available call this%parents%set(pos, this%next_free) this%next_free = pos endif this%tsize = this%tsize - 1 end do first = last return end subroutine __PROC(erase_multi) ! ======================= ! remove ! ======================= subroutine __PROC(remove)(this, value) class(__set), target, intent(inout) :: this __type_declare_dummy, intent(in) :: value type(__iterator) :: it it=this%find(value) if (it/=this%end()) call this%erase(it) end subroutine __PROC(remove) ! ======================= ! begin ! ======================= function __PROC(begin)(this) result(begin) class(__set), target, intent(in) :: this type(__iterator) :: begin begin%reference=>this call begin%next() end function __PROC(begin) ! ======================= ! end ! ======================= function __PROC(end)(this) result(end_) class(__set), target, intent(in) :: this type(__iterator) :: end_ end_%reference=>this end function __PROC(end) ! ======================= ! dump ! ======================= recursive subroutine __PROC(dump)(this) class(__set), intent(in) :: this integer(kind=SIZE_KIND) :: i #ifdef _DEBUG write(*,'(2x,6(1x,a3,2x))') ' # ','val','par','lft','rht',' at ' #else write(*,'(2x,5(1x,a3,2x))') ' # ', 'par', 'lft', 'rht', ' at ' #endif do i = 1, this%items%size() #ifdef _DEBUG write(*,'(6(i5,1x))') i, & & this%items%at(i), & & this%parents%at(i), & & this%lefts%at(i), this%rights%at(i), & & this%heights%at(i) #else write(*,'(5(i5,1x))') i, & & this%parents%at(i), & & this%lefts%at(i), this%rights%at(i), & & this%heights%at(i) #endif end do end subroutine __PROC(dump) ! ======================= ! find_index ! ======================= function find_index(this, value, last) result(idx) integer(kind=SIZE_KIND) :: idx class(__set), target, intent(in) :: this __type_declare_dummy, intent(in) :: value logical, intent(in) :: last integer (kind=SIZE_KIND) :: child #ifdef _pointer __type_declare_result, pointer :: p, q #endif idx = this%root if (exists(idx)) then do #ifdef _pointer q => this%items%at(idx) if (.not. last .and. ( & & __PROC(orderEq)(q,value))) return #else if (.not. last .and. ( & & __PROC(orderEq)(this%items%at(idx),value))) return #endif #ifdef _pointer p => value q => this%items%at(idx) child=merge(this%lefts%at(idx), this%rights%at(idx), & & __PROC(lessThan)(p, q)) #else child=merge(this%lefts%at(idx), this%rights%at(idx), & & __PROC(lessThan)(value, this%items%at(idx))) #endif if (.not. exists(child)) return idx = child end do end if end function find_index ! ======================= ! rebalance ! ======================= subroutine rebalance(this, pos, once) class(__set), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: pos logical, intent(in) :: once integer(kind=SIZE_KIND) :: curr, child integer :: hl, hr, chl, chr, side, childside logical :: unbalanced integer(kind=SIZE_KIND), pointer :: pLeft, pRight curr = pos do while (exists(curr)) hl = 0 hr = 0 pLeft => this%lefts%at(curr) if (exists(pLeft)) hl = this%heights%at(pLeft) pRight => this%rights%at(curr) if (exists(pRight)) hr = this%heights%at(pRight) unbalanced = (abs(hl-hr) > 1) if (unbalanced) then side = merge(LEFT, RIGHT, hl>hr) child = this%get_child(curr, side) chl=0 chr=0 pLeft => this%lefts%at(child) if (exists(pLeft)) chl = this%heights%at(pLeft) pRight => this%rights%at(child) if (exists(pRight)) chr = this%heights%at(pRight) if (chr /= chl) then childside=merge(0, 1, chl>chr) if (side/=childside) & & call this%rot(child,opposite(childside)) call this%rot(curr, opposite(side)) endif endif call this%update_height(curr) if (unbalanced.and.once) exit curr = this%parents%at(curr) end do end subroutine rebalance ! ======================= ! erase_nonleaf ! ======================= subroutine erase_nonleaf(this, pos, side) class(__set), intent(inout) :: this integer(kind=SIZE_KIND), intent(inout) :: pos integer, intent(in) :: side integer(kind=SIZE_KIND) :: parent, other, child0, child1, & & otherchild, otherparent parent = this%parents%at(pos) other = pos call this%advpos(other, side) if (side == 0) then child0 = this%lefts%at(pos) child1 = this%rights%at(pos) otherchild = this%lefts%at(other) else child0 = this%rights%at(pos) child1 = this%lefts%at(pos) otherchild = this%rights%at(other) end if otherparent = this%parents%at(other) call this%parents%set(other, parent) if (exists(parent)) then call this%set_parent_child(parent, pos, other) else this%root = other endif call this%set_child(other, 1-side, child1) if (exists(child1)) call this%parents%set(child1, other) if (other == child0) then call this%rebalance(other, .false.) else call this%set_child(other, side, child0) call this%parents%set(child0, other) call this%set_child(otherparent, 1-side, otherchild) if (exists(otherchild)) then call this%parents%set(otherchild, otherparent) end if call this%rebalance(otherparent, .false.) endif ! declare this space available call this%parents%set(pos, this%next_free) this%next_free = pos pos = UNINITIALIZED end subroutine erase_nonleaf ! ======================= ! advpos ! ======================= subroutine advpos(this, pos, dir) class(__set), target, intent(in) :: this integer(kind=SIZE_KIND), intent(inout) :: pos integer, intent(in) :: dir ! dir=1 forward, dir=0 backward integer(kind=SIZE_KIND) :: prev integer(kind=SIZE_KIND) :: child if (.not. exists(pos)) then if (.not. exists(this%root)) then return else pos = this%root do child = this%get_child(pos, 1-dir) if (exists(child)) then pos = child else exit end if end do end if else child = this%get_child(pos, dir) if (exists(child)) then pos = child do child = this%get_child(pos, opposite(dir)) if (exists(child)) then pos = child else exit end if end do else prev = pos pos = this%parents%at(pos) do while (exists(pos)) child = this%get_child(pos, dir) if (child /= prev) exit prev = pos pos = this%parents%at(pos) end do endif end if end subroutine advpos ! ======================= ! rot - swap pos with one of its children ! ======================= subroutine rot(this, pos, dir) class(__set), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: pos integer, intent(in) :: dir integer(kind=SIZE_KIND) :: parent, child, grandchild parent = this%parents%at(pos) child = this%get_child(pos, opposite(dir)) if (exists(child)) then grandchild = this%get_child(child, dir) else grandchild = UNINITIALIZED end if if (exists(parent)) then call this%set_parent_child(parent, pos, child) else ! pos must be root; make the child root instead this%root = child endif ! 'child' is now my parent call this%parents%set(pos, child) ! 'grandchild' becomes now my child call this%set_child(pos, opposite(dir), grandchild) ! fix up child if (exists(child)) then call this%parents%set(child, parent) call this%set_child(child, dir, pos) ! and fix up grandchild if (exists(grandchild)) then call this%parents%set(grandchild, pos) end if end if call this%update_height(pos) if (exists(child)) call this%update_height(child) end subroutine rot !========================================================================= ! ======================= ! value ! ======================= function __PROC(value)(this) result(value) class(__iterator), target, intent(in) :: this __type_declare_result, pointer :: value if (this%current == UNINITIALIZED) then value => null() else value=>this%reference%items%at(this%current) end if end function __PROC(value) ! ======================= ! next ! ======================= subroutine __PROC(next)(this) class(__iterator), intent(inout) :: this call this%reference%advpos(this%current, 1) end subroutine __PROC(next) ! ======================= ! prev ! ======================= subroutine __PROC(prev)(this) class(__iterator), intent(inout) :: this call this%reference%advpos(this%current,0) end subroutine __PROC(prev) ! ======================= ! equalIters ! ======================= logical function __PROC(equalIters)(this, other) class(__iterator), intent(in) :: this, other __PROC(equalIters) = this%current == other%current end function __PROC(equalIters) ! ======================= ! nequal ! ======================= logical function __PROC(notEqualIters)(this, other) implicit none class(__iterator), intent(in) :: this, other __PROC(notEqualIters) = .not. (this == other) end function __PROC(notEqualIters) ! ======================= ! equalSets ! ======================= logical function equalSets(this, other) class(__set), target, intent(in) :: this class(__set), target, intent(in) :: other type (__iterator) :: iter __type_declare_result, pointer :: ptr equalSets = .false. ! unless #if !defined(__INTEL_COMPILER) | !(defined(_string) & !defined(_string_deferred)) if (this%size() /= other%size()) return iter = this%begin() do while (iter /= this%end()) ptr => iter%value() if (other%count(ptr) == 0) then return end if call iter%next() end do equalSets = .true. #endif end function equalSets ! ======================= ! notEqualSets ! ======================= logical function notEqualSets(this, other) class(__set), intent(in) :: this, other notEqualSets = .not. (this == other) end function notEqualSets ! ======================= ! deepCopy (assignment) ! ======================= subroutine __PROC(deepCopy)(this, other) class (__set), target, intent(out) :: this class (__set), target, intent(in) :: other type (__iterator) :: iter __type_declare_result, pointer :: ptr iter = other%begin() do while (iter /= other%end()) ptr => iter%value() call this%insert(ptr) call iter%next() end do this%tsize = other%tsize end subroutine __PROC(deepCopy) #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/array_defs.inc000066400000000000000000000017011372124645500205600ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- ! Must define: ! __array_declare_dummy ! __ARRAY_EQ_ELEMENT logical function __PROC(eqArray)(x, y) result(equal) __array_declare_dummy, intent(in) :: x __array_declare_dummy, intent(in) :: y if (.not. all(shape(x) == shape(y))) then equal = .false. return end if equal = all(__ARRAY_EQ_ELEMENT(x,y)) end function __PROC(eqArray) gFTL-1.2.7/include/templates/avltree.inc000066400000000000000000000012561372124645500201100ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "tmplhead.inc" #include "avltree_decl.inc" contains #include "avltree_impl.inc" #include "tmpltail.inc" gFTL-1.2.7/include/templates/avltree_decl.inc000066400000000000000000000042161372124645500210760ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #ifndef __COMPARE # define __COMPARE(x, y) xnull() type(node), pointer :: left=>null() type(node), pointer :: right=>null() integer :: height=1 #ifdef _wrapentry _wrapentry :: value #else _entry :: value #endif contains final :: kill_node procedure :: child procedure :: whichchild procedure :: setchild procedure, private :: updateheight end type node type, public :: tree private type(node), pointer :: root=>null() integer :: tsize=0 contains final :: kill_tree procedure :: empty procedure :: getsize procedure :: find procedure :: clear procedure :: insert procedure :: erase procedure :: remove procedure :: ibegin procedure :: iend #ifdef _DUMP_TREE procedure :: dump #endif procedure, private :: findnode procedure, private :: rebalance procedure, private :: erasenonleaf procedure, private :: advpos procedure, private :: rot end type tree type, public :: iter private type(tree), pointer :: tree=>null() type(node), pointer :: node=>null() contains procedure :: good procedure :: value procedure :: next procedure :: prev procedure :: equal procedure :: nequal generic :: operator(==) => equal generic :: operator(/=) => nequal final :: kill_iter end type iter gFTL-1.2.7/include/templates/avltree_impl.inc000066400000000000000000000344201372124645500211300ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #ifdef _pointer #define _type _entry #include "pointerdef.inc" #endif ! ======================= ! kill_node ! ======================= subroutine kill_node(this) implicit none type(node), intent(inout) :: this if (associated(this%left)) deallocate(this%left) if (associated(this%right)) deallocate(this%right) return end subroutine kill_node ! ======================= ! child ! ======================= function child(this, idx) implicit none class(node), intent(in) :: this integer :: idx type(node), pointer :: child if (idx==0) child=>this%left if (idx==1) child=>this%right return end function child ! ======================= ! whichchild ! ======================= function whichchild(this, child) implicit none class(node), intent(in) :: this type(node), target, intent(in) :: child integer :: whichchild whichchild=merge(0, 1, associated(this%left, target=child)) return end function whichchild ! ======================= ! setchild ! ======================= subroutine setchild(this, idx, child) implicit none class(node), intent(inout) :: this integer, intent(in) :: idx type(node), pointer, intent(in) :: child if (idx==0) this%left=>child if (idx==1) this%right=>child return end subroutine setchild ! ======================= ! updateheight ! ======================= subroutine updateheight(this) implicit none class(node), target, intent(inout) :: this type(node), pointer :: p integer :: h0, h1 h0=0 h1=0 if (associated(this%left)) h0=this%left%height if (associated(this%right)) h1=this%right%height this%height=max(h0, h1)+1 return end subroutine updateheight !========================================================================= ! ======================= ! kill_tree ! ======================= subroutine kill_tree(this) implicit none type(tree), intent(inout) :: this if (associated(this%root)) deallocate(this%root) return end subroutine kill_tree ! ======================= ! empty ! ======================= function empty(this) implicit none class(tree), intent(in) :: this logical :: empty empty=.not.associated(this%root) return end function empty ! ======================= ! getsize ! ======================= function getsize(this) implicit none class(tree), intent(in) :: this integer :: getsize getsize=this%tsize return end function getsize ! ======================= ! find ! ======================= function find(this, value) implicit none class(tree), target, intent(in) :: this _entry, target, intent(in) :: value type(iter) :: find integer :: side find%tree=>this find%node=>this%findnode(value, .false.) if (.not.(__EQ(find%node%value, value))) find%node=>null() return end function find ! ======================= ! clear ! ======================= subroutine clear(this) implicit none class(tree), intent(inout) :: this if (associated(this%root)) deallocate(this%root) this%tsize=0 return end subroutine clear ! ======================= ! insert ! ======================= subroutine insert(this, value, ref) implicit none class(tree), intent(inout) :: this _entry, target, intent(in) :: value type(node), pointer, optional, intent(out) :: ref type(node), pointer :: new, parent if (associated(this%root)) then #ifdef _multi parent=>this%findnode(value, .true.) #else parent=>this%findnode(value, .false.) if (__EQ(parent%value, value)) then if (present(ref)) then ref=>parent else __SET(parent%value, value) endif return endif #endif allocate(new) if (present(ref)) ref=>new new%parent=>parent __SET(new%value, value) call parent%setchild(merge(0, 1, & & __COMPARE(value, parent%value)), new) call this%rebalance(parent, .true.) else allocate(this%root) if (present(ref)) ref=>this%root __SET(this%root%value, value) endif this%tsize=this%tsize+1 return end subroutine insert ! ======================= ! erase ! ======================= subroutine erase(this, it) implicit none class(tree), intent(inout) :: this type(iter), intent(inout) :: it type(node), pointer :: pos, parent pos=>it%node call it%next if (associated(pos%right)) then call this%erasenonleaf(pos, 1) else if (associated(pos%left)) then call this%erasenonleaf(pos, 0) else parent=>pos%parent if (associated(parent)) then call parent%setchild(parent%whichchild(pos), null()) call this%rebalance(parent, .false.) else this%root=>null() endif deallocate(pos) endif this%tsize=this%tsize-1 return end subroutine erase ! ======================= ! remove ! ======================= subroutine remove(this, value) implicit none class(tree), intent(inout) :: this _entry, target, intent(in) :: value type(iter) :: it it=this%find(value) if (it/=this%iend()) call this%erase(it) return end subroutine remove ! ======================= ! ibegin ! ======================= function ibegin(this) implicit none class(tree), target, intent(in) :: this type(iter) :: ibegin ibegin%tree=>this call ibegin%next() return end function ibegin ! ======================= ! iend ! ======================= function iend(this) implicit none class(tree), target, intent(in) :: this type(iter) :: iend iend%tree=>this return end function iend #ifdef _DUMP_TREE ! ======================= ! dump ! ======================= recursive subroutine dump(this, pos) implicit none class(tree), intent(in) :: this type(node), pointer, intent(in), optional :: pos if (present(pos)) then if (associated(pos%left)) call this%dump(pos%left) write(*, *)pos%value, loc(pos), loc(pos%parent), loc(pos%left), & & loc(pos%right), pos%height if (associated(pos%right)) call this%dump(pos%right) else write(*, *)'size=',this%getsize() write(*, *)'root=',loc(this%root) call this%dump(this%root) endif return end subroutine dump #endif ! ======================= ! findnode ! ======================= function findnode(this, value, last) implicit none class(tree), target, intent(in) :: this _entry, target, intent(in) :: value logical, intent(in) :: last type(node), pointer :: findnode type(node), pointer :: child integer :: side findnode=>this%root if (associated(findnode)) then do if (.not.last.and.( & & (findnode%value== value))) return side=merge(0, 1, __COMPARE(value, findnode%value)) child=>findnode%child(side) if (.not.associated(findnode%child(side))) return findnode=>findnode%child(side) end do end if return end function findnode ! ======================= ! rebalance ! ======================= subroutine rebalance(this, pos, once) implicit none class(tree), intent(inout) :: this type(node), pointer, intent(in) :: pos logical, intent(in) :: once type(node), pointer :: curr, child integer :: hl, hr, chl, chr, side, childside logical :: unbalanced curr=>pos do while (associated(curr)) hl=0 hr=0 if (associated(curr%left)) hl=curr%left%height if (associated(curr%right)) hr=curr%right%height unbalanced=abs(hl-hr)>1 if (unbalanced) then side=merge(0, 1, hl>hr) child=>curr%child(side) chl=0 chr=0 if (associated(child%left)) chl=child%left%height if (associated(child%right)) chr=child%right%height if (chr/=chl) then childside=merge(0, 1, chl>chr) if (side/=childside) call this%rot(child, 1-childside) call this%rot(curr, 1-side) endif endif call curr%updateheight if (unbalanced.and.once) return curr=>curr%parent end do return end subroutine rebalance ! ======================= ! erasenonleaf ! ======================= subroutine erasenonleaf(this, pos, side) implicit none class(tree), intent(inout) :: this type(node), pointer, intent(inout) :: pos integer, intent(in) :: side type(node), pointer :: parent, other, child0, child1, & & otherchild, otherparent parent=>pos%parent other=>pos call this%advpos(other, side) child0=>pos%child(side) child1=>pos%child(1-side) otherchild=>other%child(side) otherparent=>other%parent other%parent=>parent if (associated(parent)) then call parent%setchild(parent%whichchild(pos), other) else this%root=>other endif call other%setchild(1-side, child1) if (associated(child1)) child1%parent=>other if (associated(other, target=child0)) then call this%rebalance(other, .false.) else call other%setchild(side, child0) child0%parent=>other call otherparent%setchild(1-side, otherchild) if (associated(otherchild)) otherchild%parent=>otherparent call this%rebalance(otherparent, .false.) endif pos%left=>null() pos%right=>null() deallocate(pos) return end subroutine erasenonleaf ! ======================= ! advpos ! ======================= subroutine advpos(this, pos, dir) implicit none class(tree), intent(in) :: this type(node), pointer, intent(inout) :: pos integer, intent(in) :: dir ! dir=1 forward, dir=0 backward type(node), pointer :: prev if (.not.associated(pos)) then if (.not.associated(this%root)) return pos=>this%root do while (associated(pos%child(1-dir))) pos=>pos%child(1-dir) end do else if (associated(pos%child(dir))) then pos=>pos%child(dir) do while (associated(pos%child(1-dir))) pos=>pos%child(1-dir) end do else prev=>pos pos=>pos%parent do while (associated(pos)) if (.not.associated(pos%child(dir), prev)) exit prev=>pos pos=>pos%parent end do endif return end subroutine advpos ! ======================= ! rot ! ======================= subroutine rot(this, pos, dir) implicit none class(tree), intent(inout) :: this type(node), pointer, intent(in) :: pos integer, intent(in) :: dir type(node), pointer :: parent, child, grandchild=>null() parent=>pos%parent child=>pos%child(1-dir) if (associated(child)) grandchild=>child%child(dir) if (associated(parent)) then call parent%setchild(parent%whichchild(pos), child) else this%root=>child endif pos%parent=>child call pos%setchild(1-dir, grandchild) if (associated(child)) then child%parent=>parent call child%setchild(dir, pos) if (associated(grandchild)) grandchild%parent=>pos endif call pos%updateheight if (associated(child)) call child%updateheight return end subroutine rot !========================================================================= ! ======================= ! kill_iter ! ======================= ! doesn't do anything, needed because of internal compiler error in gfortran 4.9.1 subroutine kill_iter(this) implicit none type(iter), intent(inout) :: this return end subroutine kill_iter ! ======================= ! good ! ======================= function good(this) implicit none class(iter), intent(in) :: this logical :: good good=associated(this%node) return end function good ! ======================= ! value ! ======================= function value(this) implicit none class(iter), intent(in) :: this _retentry, pointer :: value value=>this%node%value return end function value ! ======================= ! next ! ======================= subroutine next(this) implicit none class(iter), intent(inout) :: this call this%tree%advpos(this%node, 1) return end subroutine next ! ======================= ! prev ! ======================= subroutine prev(this) implicit none class(iter), intent(inout) :: this call this%tree%advpos(this%node, 0) return end subroutine prev ! ======================= ! equal ! ======================= function equal(this, other) implicit none class(iter), intent(in) :: this, other logical :: equal equal=associated(this%tree, target=other%tree).and. & ((.not.associated(this%node).and..not.associated(other%node)) & & .or.associated(this%node, target=other%node)) return end function equal ! ======================= ! nequal ! ======================= function nequal(this, other) implicit none class(iter), intent(in) :: this, other logical :: nequal nequal=.not.equal(this, other) return end function nequal gFTL-1.2.7/include/templates/error_codes.inc000066400000000000000000000015411372124645500207510ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- ! Error codes integer, parameter :: SUCCESS = 0 integer, parameter :: OUT_OF_RANGE = 1 integer, parameter :: BAD_ALLOC = 2 integer, parameter :: ILLEGAL_INPUT = 3 ! private type for separating RC type :: KeywordEnforcer end type KeywordEnforcer gFTL-1.2.7/include/templates/header.m4000066400000000000000000000015301372124645500174400ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- changecom() define(_param,_`'param()) define(__param,__`'param()) define(_PARAM,_`'translit(param(),`a-z',`A-Z')) define(__PARAM,__`'translit(param(),`a-z',`A-Z')) ifelse(param,type,`define(`_base',)',`define(`_base',_param())') ifelse(param,type,`define(`_BASE',)',`define(`_BASE',_PARAM())') gFTL-1.2.7/include/templates/macros_undefs.m4000066400000000000000000000020211372124645500210340ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- include(header.m4) define(`cpp_undef', #ifdef `$1' # undef `$1' #endif ) cpp_undef(_param()) cpp_undef(_base()_rank) cpp_undef(_base()_extents) cpp_undef(_base()_string) cpp_undef(_base()_string_deferred) cpp_undef(_base()_logical) cpp_undef(_base()_pointer) cpp_undef(_base()_allocatable) cpp_undef(_base()_procedure) cpp_undef(_BASE()_EQ) cpp_undef(_BASE()_EQ_ELEMENT) cpp_undef(_BASE()_LESS_THAN) cpp_undef(_BASE()_ASSIGN) cpp_undef(_BASE()_MOVE) cpp_undef(_BASE()_FREE) gFTL-1.2.7/include/templates/map.inc000066400000000000000000000117101372124645500172170ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/tmplbase.inc" private #ifdef _map # define __map _map #else # define __map map #endif #ifdef _iterator # define __miterator _iterator #else # define __miterator __QUOTE(__map)__QUOTE(Iterator) #endif #define __siterator s_iterator #define __set set2 #ifdef _pair # define __pair _pair #else # define __pair pair #endif public :: __map public :: __miterator public :: __pair #ifdef _alt ! Implementation alse uses vector of for ! indices. # define __vector iVector # define __container_prefix ti_ # define __use_type integer(kind=SIZE_KIND) # include "vector_decl.inc" # include "templates/type_use_tokens_undef.inc" # undef __vector # undef __container_prefix # endif #include "templates/key_set_use_tokens.inc" #include "templates/value_set_use_tokens.inc" #define __container_prefix m_ #include "pair_decl.inc" #undef __container_prefix #define _type type(__pair) #include "templates/type_set_use_tokens.inc" #ifdef _alt ! Implementation uses a vector of <_type> # define __vector tVector # define __container_prefix tt_ # include "vector_decl.inc" # undef __vector # undef __container_prefix # endif #include "templates/type_use_tokens_undef.inc" ! Set/Map rely on additional comparison properties. #define _equal_defined #define _EQ(x,y) (x .sameKey. y) #define _LESS_THAN(x,y) __KEY_LESS_THAN(x%key,y%key) #include "templates/key_template_macros.inc" #ifdef __key_needs_default_compare # define __set_needs_default_compare #endif #include "templates/key_template_macros_undefs.inc" #include "templates/type_set_use_tokens.inc" #define __container_prefix s_ #define __iterator __siterator #ifdef __set_needs_default_compare # define __type_needs_default_compare #endif #ifdef _alt # include "altSet_decl.inc" #else # include "set_decl.inc" #endif #undef __iterator #undef __container_prefix #define __container_prefix m_ #define __iterator __miterator #include "map_decl.inc" #undef __iterator #undef __container_prefix #include "unused.inc" #include "error_codes.inc" contains ! Token is cleared out with the above include. Need to redefine. #include "templates/key_set_use_tokens.inc" #include "templates/value_set_use_tokens.inc" #include "templates/type_set_use_tokens.inc" #define __compare_type __key_type #define __compare_declare_dummy __key_declare_dummy #define __compare_declare_component __key_declare_component #define __COMPARE_ASSIGN(x,y) __KEY_ASSIGN(x,y) #define __COMPARE_FREE(x) __KEY_FREE(x) #ifdef __set_needs_default_compare # define __type_needs_default_compare #endif #define __container_prefix s_ #define __iterator __siterator # ifdef _alt # include "altSet_impl.inc" # else # include "set_impl.inc" # endif #undef __container_prefix #undef __iterator #undef _equal_defined #undef _EQ #undef _LESS_THAN #define __container_prefix m_ #define __iterator __miterator #include "pair_impl.inc" #include "map_impl.inc" #undef __container_prefix #undef __iterator #include "templates/type_use_tokens_undef.inc" #include "templates/type_set_use_tokens.inc" #ifdef __PAIR_ASSIGN # define __USE_ASSIGN(dest,src) __PAIR_ASSIGN(dest,src) #else # define __USE_ASSIGN(dest,src) __KEY_ASSIGN(dest%key,src%key);__VALUE_ASSIGN(dest%value,src%value) #endif #define __USE_MOVE(dest,src) __KEY_MOVE(dest%key,src%key);__VALUE_MOVE(dest%value,src%value) #ifdef __PAIR_FREE # define __USE_FREE(x) __PAIR_FREE(x) #else ! FREE can be an empty string, but Fortran does not allow a bare ";". ! The kludge is to put in a conditional that is always true. # define __USE_FREE(x) if(.true.)then;__KEY_FREE(x%key); __VALUE_FREE(x%value);endif !# define __USE_FREE(x) #endif #ifdef _alt ! vector<_type> # define __vector tVector # define __container_prefix tt_ # include "vector_impl.inc" # undef __vector # undef __container_prefix #endif #include "templates/key_use_tokens_undef.inc" #include "templates/value_use_tokens_undef.inc" #include "templates/type_use_tokens_undef.inc" #ifdef _alt ! vector # define __vector iVector # define __container_prefix ti_ # define __use_type integer(kind=SIZE_KIND) # include "vector_impl.inc" # include "templates/type_use_tokens_undef.inc" # undef __vector # undef __container_prefix #endif #undef __miterator #undef __map #undef __set #undef __siterator #undef __set_needs_default_compare #include "templates/tmpltail.inc" #include "templates/all_macros_undefs.inc" gFTL-1.2.7/include/templates/map_decl.inc000066400000000000000000000046211372124645500202110ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" type :: __map private type(__set) :: tree contains procedure :: empty => __PROC(empty) procedure :: size => __PROC(size) procedure, nopass :: max_size => __PROC(max_size) procedure :: insert_key_value => __PROC(insert_key_value) procedure :: insert_pair => __PROC(insert_pair) generic :: insert => insert_key_value generic :: insert => insert_pair procedure :: of => __PROC(of) ! [] operator procedure :: at => __PROC(at) procedure :: erase_one => __PROC(erase_one) generic :: erase => erase_one procedure :: clear => __PROC(clear) procedure :: get => __PROC(get) procedure :: set => __PROC(set) procedure :: begin => __PROC(begin) procedure :: end => __PROC(end) procedure :: find => __PROC(find) procedure :: count => __PROC(count) procedure :: deepCopy => __PROC(deepCopy) #ifdef _DUMP_MAP procedure :: dump => mapdump #endif end type __map type :: __iterator private type(__siterator) :: setIter class(__map), pointer :: reference contains procedure :: value => __PROC(value) procedure :: key => __PROC(key) procedure :: next => __PROC(next) procedure :: previous => __PROC(previous) procedure :: equal => __PROC(iter_equal) generic :: operator(==) => equal procedure :: notEqual => __PROC(iter_not_equal) generic :: operator(/=) => notEqual end type __iterator #ifdef _alt interface __map module procedure __PROC(new_map_empty) module procedure __PROC(new_map_from_pair_array) end interface __map #endif #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/map_impl.inc000066400000000000000000000241151372124645500202430ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" ! This constructor is needed in situations where an empty dictionary needs to be ! passed to a procedure. Prevents the need of declaring a local variable. function __PROC(new_map_empty)() result(m) type (__map) :: m if (.false.) print*,shape(m) ! avoid compiler warnings about unused end function __PROC(new_map_empty) #ifdef _alt function __PROC(new_map_from_pair_array)(pairs) result(m) type (__map) :: m type (__pair), intent(in) :: pairs(:) integer :: i do i = 1, size(pairs) call m%insert(pairs(i)) end do end function __PROC(new_map_from_pair_array) #endif ! ======================= ! empty ! ======================= logical function __PROC(empty)(this) result(isEmpty) class (__map), intent(in) :: this isEmpty = this%tree%empty() end function __PROC(empty) ! ======================= ! size ! ======================= function __PROC(size)(this) result(size) integer(kind=SIZE_kind) :: size class (__map), intent(in) :: this size = this%tree%size() end function __PROC(size) ! ======================= ! max_size ! ======================= ! limited by 32 bit integer in terms of result function __PROC(max_size)() result(max_size) integer(kind=SIZE_KIND) :: max_size max_size = huge(1_SIZE_KIND) end function __PROC(max_size) ! ======================= ! insert ! ======================= subroutine __PROC(insert_key_value)(this, key, value) class (__map), intent(inout) :: this __key_declare_dummy, intent(in) :: key __value_declare_dummy, intent(in) :: value type (__pair) :: p __KEY_ASSIGN(p%key, key) __VALUE_ASSIGN(p%value, value) call this%tree%insert(p) end subroutine __PROC(insert_key_value) subroutine __PROC(insert_pair)(this, p) class (__map), intent(inout) :: this type (__pair), intent(in) :: p call this%tree%insert(p) end subroutine __PROC(insert_pair) ! ======================= ! get ! ======================= function __PROC(get)(this, key, value) result(res) class(__map), target, intent(in) :: this __key_declare_dummy :: key __value_declare_result, pointer, intent(out) :: value logical :: res type(__pair) :: p type(__siterator) :: it #ifdef _alt type(__pair), pointer :: q #endif __KEY_ASSIGN(p%key, key) it=this%tree%find(p) res= (it/=this%tree%end()) #ifdef _alt if (res) then q => it%value() value => q%value end if #else if (res) value=>it%node%value%value #endif return end function __PROC(get) ! ======================= ! set ! ======================= subroutine __PROC(set)(this, key, value) class(__map), intent(inout) :: this __key_declare_dummy, intent(in) :: key __value_declare_dummy, intent(in) :: value type(__pair) :: p __KEY_ASSIGN(p%key, key) __VALUE_ASSIGN(p%value, value) call this%tree%insert(p) return end subroutine __PROC(set) ! ======================= ! of - grows map if key does not exist ! Analog of C++ [] operator. ! ======================= function __PROC(of)(this, key) result(res) class(__map), target, intent(inout) :: this __key_declare_dummy, intent(in) :: key #ifdef _value_deferred character(len=:), allocatable :: res ! bug in gfortran 4.9.1 #else __value_declare_result, pointer :: res #endif type(__pair) :: p #ifdef _alt integer(kind=SIZE_KIND) :: ref #else type(node), pointer :: ref #endif logical :: isNew #ifdef _alt type(__pair), pointer :: q #endif __KEY_ASSIGN(p%key, key) call this%tree%insert(p, ref=ref, isNew=isNew) if (.not. isNew) then #ifdef _alt q => this%tree%items%at(ref) # ifdef _value_string res= q%value # else res=>q%value # endif #else # ifdef _value_string res=ref%value%value # else res=>ref%value%value # endif #endif else res => null() end if return end function __PROC(of) ! ======================= ! at ! ======================= function __PROC(at)(this, key) result(res) class(__map), target, intent(in) :: this __key_declare_dummy, intent(in) :: key #ifdef _value_deferred character(len=:), allocatable :: res ! bug in gfortran 4.9.1 #else __value_declare_result, pointer :: res #endif type (__iterator) :: iter iter = this%find(key) #ifdef _alt if (iter%setIter%current == UNINITIALIZED) then ! throw exception res => null() return end if #else if (.not. associated(iter%setIter%node)) then ! throw exception res => null() return end if #endif # ifdef _value_string res= iter%value() # else res=> iter%value() # endif return end function __PROC(at) ! ======================= ! erase ! ======================= subroutine __PROC(erase_one)(this, iter) class(__map), intent(inout) :: this type(__iterator), intent(inout) :: iter call this%tree%erase(iter%setIter) end subroutine __PROC(erase_one) ! ======================= ! clear ! ======================= subroutine __PROC(clear)(this) class(__map), intent(inout) :: this call this%tree%clear() end subroutine __PROC(clear) ! ======================= ! begin ! ======================= function __PROC(begin)(this) result(iter) class(__map), target, intent(in) :: this type (__iterator) :: iter iter%reference => this iter%setIter = this%tree%begin() end function __PROC(begin) ! ======================= ! end ! ======================= function __PROC(end)(this) result(iter) class(__map), target, intent(in) :: this type (__iterator) :: iter iter%reference => this iter%setIter = this%tree%end() end function __PROC(end) ! ======================= ! find ! ======================= function __PROC(find)(this, key) result(iter) type (__iterator) :: iter class(__map), target, intent(in) :: this __key_declare_dummy, intent(in) :: key type (__pair) :: p __KEY_ASSIGN(p%key, key) iter%reference => this iter%setIter = this%tree%find(p) end function __PROC(find) ! ======================= ! count ! ======================= function __PROC(count)(this, key) result(count) integer(kind=SIZE_KIND) :: count class(__map), intent(in) :: this __key_declare_dummy, intent(in) :: key type (__pair) :: p __KEY_ASSIGN(p%key, key) count = this%tree%count(p) end function __PROC(count) ! ======================= ! copyFrom ! ======================= subroutine __PROC(deepCopy)(this, original) class(__map), intent(out) :: this class(__map), intent(in) :: original call this%tree%deepCopy(original%tree) end subroutine __PROC(deepCopy) ! ======================= ! value ! ======================= function __PROC(value)(this) result(res) class(__iterator), target, intent(in) :: this __value_declare_result, pointer :: res type(__pair), pointer :: p p => this%setIter%value() if (associated(p)) then res => p%value else res => null() end if end function __PROC(value) ! ======================= ! key ! ======================= function __PROC(key)(this) result(res) class(__iterator), target, intent(in) :: this __key_declare_result, pointer :: res type(__pair), pointer :: p p => this%setIter%value() res => p%key end function __PROC(key) ! ======================= ! operator(==) ! ======================= logical function __PROC(iter_equal)(this, other) result(equal) class(__iterator), intent(in) :: this type(__iterator), intent(in) :: other equal = (this%setIter == other%setIter) end function __PROC(iter_equal) ! ======================= ! operator(/=) ! ======================= logical function __PROC(iter_not_equal)(this, other) & & result(not_equal) class(__iterator), intent(in) :: this type(__iterator), intent(in) :: other not_equal = .not. (this == other) end function __PROC(iter_not_equal) ! ======================= ! next ! ======================= subroutine __PROC(next)(this) class(__iterator), intent(inout) :: this call this%setIter%next() end subroutine __PROC(next) ! ======================= ! previous ! ======================= subroutine __PROC(previous)(this) class(__iterator), intent(inout) :: this call this%setIter%prev() end subroutine __PROC(previous) #ifdef _DUMP_MAP ! ======================= ! mapdump ! ======================= subroutine mapdump(this) class(__map), intent(inout) :: this type(__siterator) :: it type(__pair), pointer :: p it=this%tree%begin() do while (it%good()) p=>it%value() write(*, *)p%key, '=>',p%value,'+' call it%next end do return end subroutine mapdump #endif #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/pair_decl.inc000066400000000000000000000022051372124645500203630ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/key_template_macros.inc" #include "templates/value_template_macros.inc" type :: __pair __key_declare_component :: key __value_declare_component :: value contains procedure :: pairEqual generic :: operator(==) => pairEqual procedure :: pairSameKey generic :: operator(.sameKey.) => pairSameKey end type __pair interface __pair module procedure __PROC(newPair) end interface __pair #include "templates/key_template_macros_undefs.inc" #include "templates/value_template_macros_undefs.inc" gFTL-1.2.7/include/templates/pair_impl.inc000066400000000000000000000103461372124645500204220ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" function __PROC(newPair)(key, value) result(p) type (__pair) :: p __key_declare_dummy, intent(in) :: key __value_declare_dummy, intent(in) :: value __KEY_ASSIGN(p%key, key) __VALUE_ASSIGN(p%value, value) end function __PROC(newPair) ! ======================= ! pairEqual ! ======================= function pairEqual(this, other) result(equal) class(__pair), intent(in) :: this, other logical :: equal equal = this%pairSameKey(other) end function pairEqual ! ======================= ! pairSameKey ! ======================= function pairSameKey(this, other) result(sameKey) class (__pair), intent(in) :: this class (__pair), intent(in) :: other logical :: sameKey sameKey = .not. (__KEY_LESS_THAN(this%key, other%key)) .and. & & .not. (__KEY_LESS_THAN(other%key, this%key)) contains ! TODO: possibly this procedure should be inside some sort of #ifdef logical function dictionaryLessThan1d(x, y) result(less) integer, intent(in) :: x(:) integer, intent(in) :: y(:) integer(kind=SIZE_KIND) :: i, n n = min(size(x),size(y)) do i = 1, n less = (x(i) < y(i)) if (.not. x(i) == y(i)) return end do less = (size(x) < size(y)) end function dictionaryLessThan1d #if defined(__key_needs_default_compare) # if !defined(__compare_type) # define __compare_declare_dummy __key_declare_dummy # define __compare_declare_component __key_declare_component # define __COMPARE_ASSIGN(x,y) __KEY_ASSIGN(x,y) # define __COMPARE_FREE(x) __KEY_FREE(x) # endif logical function defaultLessThan(x, y) result(less) __compare_declare_dummy, intent(in) :: x __compare_declare_dummy, intent(in) :: y # if defined(_pointer) type LocalWrapper __compare_declare_component :: item end type LocalWrapper type (LocalWrapper) :: wrapX, wrapY # define __xx wrapX # define __yy wrapY __COMPARE_ASSIGN(wrapX%item, x) __COMPARE_ASSIGN(wrapY%item, y) # else # define __xx x # define __yy y # endif associate( wx => transfer(__xx,[1]), & & wy => transfer(__yy,[1]) ) less = dictionaryLessThan1d(wx, wy) end associate # if defined(_pointer) __COMPARE_FREE(wrapX%item) __COMPARE_FREE(wrapY%item) # endif # undef __xx # undef __yy # if !defined(__compare_type) # undef __compare_declare_dummy # undef __compare_declare_component # undef __COMPARE_ASSIGN # undef __COMPARE_FREE # endif end function defaultLessThan #endif end function pairSameKey #if !defined(_value_pointer) # if (__value_rank > 0) & !defined(_value_extents) # define __array_declare_dummy __value_declare_dummy # define __ARRAY_EQ_ELEMENT(x,y) __VALUE_EQ_ELEMENT(x,y) # include "array_defs.inc" # define __already_did_it # undef __ARRAY_EQ_ELEMENT # undef __array_declare_dummy # endif #endif #if !defined(_key_pointer) # if (__key_rank > 0) & !defined(_key_extents) # ifndef __already_did_it # define __array_declare_dummy __key_declare_dummy # define __ARRAY_EQ_ELEMENT(x,y) __KEY_EQ_ELEMENT(x,y) # include "array_defs.inc" # undef __ARRAY_EQ_ELEMENT # undef __array_declare_dummy # endif # endif #endif #undef __already_did_it #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/pointerdef.inc000066400000000000000000000020571372124645500206050ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- ! Encompassing code must set define the following tokens/Macros: ! __pointer_declare_result ! __pointer_declare_dummy function __PROC(sameptr)(x, y) result(same) __pointer_declare_result, pointer, intent(in) :: x __pointer_declare_dummy :: y logical :: same __pointer_declare_result, pointer :: p p => y same = (.not. associated(x) .and. .not. associated(p)) .or. & & associated(x, p) end function __PROC(sameptr) #undef __need_compare gFTL-1.2.7/include/templates/set.inc000066400000000000000000000022101372124645500172300ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/tmplbase.inc" private #ifdef _set # define __set _set #else # define __set set #endif #define __container_prefix s_ #ifdef _iterator # define __iterator _iterator #else # define __iterator __QUOTE(__set)__QUOTE(Iterator) #endif public :: __set public :: __iterator #include "templates/type_set_use_tokens.inc" #include "set_decl.inc" #include "unused.inc" #include "error_codes.inc" contains #include "set_impl.inc" #include "templates/type_use_tokens_undef.inc" #include "templates/tmpltail.inc" #include "templates/all_macros_undefs.inc" gFTL-1.2.7/include/templates/set_decl.inc000066400000000000000000000061421372124645500202270ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" type :: node type(node), pointer :: parent=>null() type(node), pointer :: left=>null() type(node), pointer :: right=>null() integer :: height=1 __type_declare_component :: value contains final :: __PROC(kill_node) procedure :: child => __PROC(child) procedure :: whichchild => __PROC(whichchild) procedure :: setchild => __PROC(setchild) procedure, private :: updateheight => __PROC(updateheight) end type node type :: __set private type(node), pointer :: root=>null() integer(kind=SIZE_KIND) :: tsize=0 contains final :: __PROC(kill_tree) procedure :: empty => __PROC(empty) procedure :: size => __PROC(size) procedure :: count => __PROC(count) procedure :: find => __PROC(find) procedure :: clear => __PROC(clear) procedure :: insert => __PROC(insert) procedure :: erase_one => __PROC(erase_one) procedure :: erase_multi => __PROC(erase_multi) generic :: erase => erase_one, erase_multi procedure :: remove => __PROC(remove) procedure :: begin => __PROC(begin) procedure :: end => __PROC(end) #ifdef _DUMP_TREE procedure :: dump => __PROC(dump) #endif procedure :: deepCopy => __PROC(deepCopy) generic :: assignment(=) => deepCopy procedure :: equalSets generic :: operator(==) => equalSets procedure :: notEqualSets generic :: operator(/=) => notEqualSets procedure, private :: findnode procedure, private :: rebalance procedure, private :: erasenonleaf procedure, private :: advpos procedure, private :: rot end type __set type :: __iterator private type(__set), pointer :: tree=>null() type(node), pointer :: node=>null() #ifdef __GFORTRAN__ ! This workaround prevents the need for an empty ! FINAL procedure ! Bug should be submitted to GNU integer, allocatable :: a(:) #endif contains procedure :: good => __PROC(good) procedure :: value => __PROC(value) procedure :: next => __PROC(next) procedure :: prev => __PROC(prev) procedure :: equalIters => __PROC(equalIters) procedure :: notEqualIters => __PROC(notEqualIters) generic :: operator(==) => equalIters generic :: operator(/=) => notEqualIters end type __iterator #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/set_impl.inc000066400000000000000000000517011372124645500202620ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/all_template_macros.inc" #if defined(_pointer) # define __pointer_declare_result __type_declare_result # define __pointer_declare_dummy __type_declare_dummy # define __need_compare # include "pointerdef.inc" # undef __pointer_declare_result # undef __pointer_declare_dummy #elif (__type_rank > 0) & !defined(_extents) # define __array_declare_dummy __type_declare_dummy # define __ARRAY_EQ_ELEMENT(x,y) __TYPE_EQ_ELEMENT(x,y) # include "array_defs.inc" # undef __ARRAY_EQ_ELEMENT # undef __array_declare_dummy #endif ! ======================= ! kill_node ! ======================= recursive subroutine __PROC(kill_node)(this) type(node), intent(inout) :: this if (associated(this%left)) deallocate(this%left) if (associated(this%right)) deallocate(this%right) return end subroutine __PROC(kill_node) ! ======================= ! child ! ======================= function __PROC(child)(this, idx) result(child) class(node), target, intent(in) :: this integer :: idx type(node), pointer :: child if (idx==0) child=>this%left if (idx==1) child=>this%right end function __PROC(child) ! ======================= ! whichchild ! ======================= function __PROC(whichchild)(this, child) result(whichchild) class(node), intent(in) :: this type(node), target, intent(in) :: child integer :: whichchild whichchild=merge(0, 1, associated(this%left, target=child)) end function __PROC(whichchild) ! ======================= ! setchild ! ======================= subroutine __PROC(setchild)(this, idx, child) class(node), intent(inout) :: this integer, intent(in) :: idx type(node), pointer, intent(in) :: child if (idx==0) this%left=>child if (idx==1) this%right=>child return end subroutine __PROC(setchild) ! ======================= ! updateheight ! ======================= subroutine __PROC(updateheight)(this) class(node), target, intent(inout) :: this integer :: h0, h1 h0=0 h1=0 if (associated(this%left)) h0=this%left%height if (associated(this%right)) h1=this%right%height this%height=max(h0, h1)+1 return end subroutine __PROC(updateheight) !========================================================================= ! ======================= ! kill_tree ! ======================= recursive subroutine __PROC(kill_tree)(this) type(__set), intent(inout) :: this if (associated(this%root)) deallocate(this%root) return end subroutine __PROC(kill_tree) ! ======================= ! empty ! ======================= logical function __PROC(empty)(this) result(empty) class(__set), intent(in) :: this empty = .not. associated(this%root) end function __PROC(empty) ! ======================= ! size ! ======================= function __PROC(size)(this) result(size) integer(kind=SIZE_KIND) :: size class(__set), intent(in) :: this size = this%tsize end function __PROC(size) ! ======================= ! find ! ======================= function __PROC(find)(this, value) result(find) class(__set), target, intent(in) :: this __type_declare_dummy, intent(in) :: value type(__iterator) :: find find%tree=>this find%node=>this%findnode(value, .false.) if (associated(find%node)) then if (.not.__PROC(orderEq)( & & find%node%value,value)) then find%node=>null() end if end if return end function __PROC(find) logical function __PROC(orderEq)(x, y) result(equal) __type_declare_dummy, intent(in) :: x __type_declare_dummy, intent(in) :: y equal = .not. __PROC(lessThan)(x,y) .and. & & .not. __PROC(lessThan)(y,x) end function __PROC(orderEq) ! ======================= ! count ! ======================= function __PROC(count)(this, value) result(count) integer(kind=SIZE_KIND) :: count class(__set), target, intent(in) :: this __type_declare_dummy, intent(in) :: value type (__iterator) :: i i = this%find(value) if (associated(i%node)) then count = 1 else count = 0 end if end function __PROC(count) ! ======================= ! clear ! ======================= subroutine __PROC(clear)(this) class(__set), intent(inout) :: this if (associated(this%root)) deallocate(this%root) this%tsize=0 return end subroutine __PROC(clear) ! ======================= ! insert ! ======================= subroutine __PROC(insert)(this, value, unused, isNew, ref) class(__set), intent(inout) :: this __type_declare_dummy, intent(in) :: value type (Unusable), optional :: unused logical, optional, intent(out) :: isNew type(node), pointer, optional, intent(out) :: ref type(node), pointer :: new type(node), pointer :: parent type (node), pointer :: r #ifdef _pointer __type_declare_result, pointer :: p #endif if (present(unused)) print*,shape(unused) if (associated(this%root)) then #ifdef _multi parent=>this%findnode(value, .true.) #else parent=>this%findnode(value, .false.) if (__PROC(orderEq)(parent%value, value)) then if (present(ref)) then ref=>parent else __TYPE_FREE(parent%value) __TYPE_ASSIGN(parent%value, value) endif if (present(isNew)) then isNew = .false. end if return endif #endif if (present(isNew)) then isNew = .true. end if allocate(new) if (present(ref)) ref=>new new%parent=>parent __TYPE_ASSIGN(new%value, value) #ifdef _pointer p => value call parent%setchild(merge(0, 1, & & __PROC(lessThan)(p, parent%value)),new) #else call parent%setchild(merge(0, 1, & & __PROC(lessThan)(value, parent%value)),new) #endif call this%rebalance(parent, .true.) else allocate(this%root) if (present(ref)) ref=>this%root r => this%root __TYPE_ASSIGN(r%value, value) if (present(isNew)) then isNew = .true. end if endif this%tsize = this%tsize + 1 return end subroutine __PROC(insert) logical function __PROC(lessThan)(x, y) result(less) __type_declare_dummy, intent(in) :: x __type_declare_dummy, intent(in) :: y less = __TYPE_LESS_THAN(x,y) contains ! TODO: possibly this procedure should be inside some sort of #ifdef logical function dictionaryLessThan1d(x, y) result(less) integer, intent(in) :: x(:) integer, intent(in) :: y(:) integer(kind=SIZE_KIND) :: i, n n = min(size(x),size(y)) do i = 1, n less = (x(i) < y(i)) if (.not. x(i) == y(i)) return end do less = (size(x) < size(y)) end function dictionaryLessThan1d #if defined(__type_needs_default_compare) # if !defined(__compare_type) # define __compare_declare_dummy __type_declare_dummy # define __compare_declare_component __type_declare_component # define __COMPARE_ASSIGN(x,y) __TYPE_ASSIGN(x,y) # define __COMPARE_FREE(x) __TYPE_FREE(x) # endif logical function defaultLessThan(x, y) result(less) __compare_declare_dummy, intent(in) :: x __compare_declare_dummy, intent(in) :: y # if defined(_pointer) type LocalWrapper __compare_declare_component :: item end type LocalWrapper type (LocalWrapper) :: wrapX, wrapY # define __xx wrapX # define __yy wrapY __COMPARE_ASSIGN(wrapX%item, x) __COMPARE_ASSIGN(wrapY%item, y) # else # define __xx x # define __yy y # endif associate( wx => transfer(__xx,[1]), & & wy => transfer(__yy,[1]) ) less = dictionaryLessThan1d(wx, wy) end associate # if defined(_pointer) __COMPARE_FREE(wrapX%item) __COMPARE_FREE(wrapY%item) # endif # undef __xx # undef __yy # if !defined(__compare_type) # undef __compare_declare_dummy # undef __compare_declare_component # undef __COMPARE_ASSIGN # undef __COMPARE_FREE # endif end function defaultLessThan #endif end function __PROC(lessThan) ! ======================= ! erase ! ======================= subroutine __PROC(erase_one)(this, iter) class(__set), intent(inout) :: this type(__iterator), intent(inout) :: iter type (__iterator) :: last last = iter call last%next() call this%erase(iter, last) end subroutine __PROC(erase_one) ! ======================= ! erase_multi ! ======================= subroutine __PROC(erase_multi)(this, first, last) class(__set), intent(inout) :: this type(__iterator), intent(inout) :: first type(__iterator), intent(in) :: last type(node), pointer :: pos, parent type (__iterator) :: iter iter = first do while (iter /= last) pos=>iter%node call iter%next() if (associated(pos%right)) then call this%erasenonleaf(pos, 1) else if (associated(pos%left)) then call this%erasenonleaf(pos, 0) else parent=>pos%parent if (associated(parent)) then call parent%setchild(parent%whichchild(pos), null()) call this%rebalance(parent, .false.) else this%root=>null() endif deallocate(pos) endif this%tsize=this%tsize-1 end do first = last return end subroutine __PROC(erase_multi) ! ======================= ! remove ! ======================= subroutine __PROC(remove)(this, value) class(__set), target, intent(inout) :: this __type_declare_dummy, intent(in) :: value type(__iterator) :: it it=this%find(value) if (it/=this%end()) call this%erase(it) return end subroutine __PROC(remove) ! ======================= ! begin ! ======================= function __PROC(begin)(this) result(begin) class(__set), target, intent(in) :: this type(__iterator) :: begin begin%tree=>this call begin%next() return end function __PROC(begin) ! ======================= ! end ! ======================= function __PROC(end)(this) result(end_) class(__set), target, intent(in) :: this type(__iterator) :: end_ end_%tree=>this return end function __PROC(end) #ifdef _DUMP_TREE ! ======================= ! dump ! ======================= recursive subroutine __PROC(dump)(this, pos) class(__set), intent(in) :: this type(node), pointer, intent(in), optional :: pos if (present(pos)) then if (associated(pos%left)) call this%dump(pos%left) write(*, *)pos%value, loc(pos), loc(pos%parent), loc(pos%left), & & loc(pos%right), pos%height if (associated(pos%right)) call this%dump(pos%right) else write(*, *)'size=',this%getsize() write(*, *)'root=',loc(this%root) call this%dump(this%root) endif return end subroutine __PROC(dump) #endif ! ======================= ! findnode ! ======================= function findnode(this, value, last) class(__set), target, intent(in) :: this __type_declare_dummy, intent(in) :: value #ifndef _pointer !!$ target :: value #endif logical, intent(in) :: last type(node), pointer :: findnode integer :: side #ifdef _pointer __type_declare_result, pointer :: p #endif findnode=>this%root if (associated(findnode)) then do if (.not. last .and. ( & & (__PROC(orderEq)(findnode%value,value)))) return #ifdef _pointer p => value side=merge(0, 1, __PROC(lessThan)(p, findnode%value)) #else side=merge(0, 1, __PROC(lessThan)(value, findnode%value)) #endif if (.not.associated(findnode%child(side))) return findnode=>findnode%child(side) end do end if return end function findnode ! ======================= ! rebalance ! ======================= subroutine rebalance(this, pos, once) class(__set), intent(inout) :: this type(node), pointer, intent(in) :: pos logical, intent(in) :: once type(node), pointer :: curr, child integer :: hl, hr, chl, chr, side, childside logical :: unbalanced curr=>pos do while (associated(curr)) hl=0 hr=0 if (associated(curr%left)) hl=curr%left%height if (associated(curr%right)) hr=curr%right%height unbalanced=abs(hl-hr)>1 if (unbalanced) then side=merge(0, 1, hl>hr) child=>curr%child(side) chl=0 chr=0 if (associated(child%left)) chl=child%left%height if (associated(child%right)) chr=child%right%height if (chr/=chl) then childside=merge(0, 1, chl>chr) if (side/=childside) call this%rot(child, 1-childside) call this%rot(curr, 1-side) endif endif call curr%updateheight if (unbalanced.and.once) return curr=>curr%parent end do return end subroutine rebalance ! ======================= ! erasenonleaf ! ======================= subroutine erasenonleaf(this, pos, side) class(__set), intent(inout) :: this type(node), pointer, intent(inout) :: pos integer, intent(in) :: side type(node), pointer :: parent, other, child0, child1, & & otherchild, otherparent parent=>pos%parent other=>pos call this%advpos(other, side) child0=>pos%child(side) child1=>pos%child(1-side) otherchild=>other%child(side) otherparent=>other%parent other%parent=>parent if (associated(parent)) then call parent%setchild(parent%whichchild(pos), other) else this%root=>other endif call other%setchild(1-side, child1) if (associated(child1)) child1%parent=>other if (associated(other, target=child0)) then call this%rebalance(other, .false.) else call other%setchild(side, child0) child0%parent=>other call otherparent%setchild(1-side, otherchild) if (associated(otherchild)) otherchild%parent=>otherparent call this%rebalance(otherparent, .false.) endif pos%left=>null() pos%right=>null() deallocate(pos) return end subroutine erasenonleaf ! ======================= ! advpos ! ======================= subroutine advpos(this, pos, dir) class(__set), target, intent(in) :: this type(node), pointer, intent(inout) :: pos integer, intent(in) :: dir ! dir=1 forward, dir=0 backward type(node), pointer :: prev if (.not.associated(pos)) then if (.not.associated(this%root)) return pos=>this%root do while (associated(pos%child(1-dir))) pos=>pos%child(1-dir) end do else if (associated(pos%child(dir))) then pos=>pos%child(dir) do while (associated(pos%child(1-dir))) pos=>pos%child(1-dir) end do else prev=>pos pos=>pos%parent do while (associated(pos)) if (.not.associated(pos%child(dir), prev)) exit prev=>pos pos=>pos%parent end do endif return end subroutine advpos ! ======================= ! rot ! ======================= subroutine rot(this, pos, dir) class(__set), intent(inout) :: this type(node), pointer, intent(in) :: pos integer, intent(in) :: dir type(node), pointer :: parent, child, grandchild=>null() parent=>pos%parent child=>pos%child(1-dir) if (associated(child)) grandchild=>child%child(dir) if (associated(parent)) then call parent%setchild(parent%whichchild(pos), child) else this%root=>child endif pos%parent=>child call pos%setchild(1-dir, grandchild) if (associated(child)) then child%parent=>parent call child%setchild(dir, pos) if (associated(grandchild)) grandchild%parent=>pos endif call pos%updateheight if (associated(child)) call child%updateheight return end subroutine rot !========================================================================= ! ======================= ! good ! ======================= function __PROC(good)(this) result(good) class(__iterator), intent(in) :: this logical :: good good=associated(this%node) end function __PROC(good) ! ======================= ! value ! ======================= function __PROC(value)(this) result(value) class(__iterator), intent(in) :: this __type_declare_result, pointer :: value if (associated(this%node)) then value =>this%node%value else value => null() end if end function __PROC(value) ! ======================= ! next ! ======================= subroutine __PROC(next)(this) class(__iterator), intent(inout) :: this call this%tree%advpos(this%node, 1) end subroutine __PROC(next) ! ======================= ! prev ! ======================= subroutine __PROC(prev)(this) class(__iterator), intent(inout) :: this call this%tree%advpos(this%node, 0) end subroutine __PROC(prev) ! ======================= ! equalIters ! ======================= logical function __PROC(equalIters)(this, other) class(__iterator), intent(in) :: this, other __PROC(equalIters) = & & associated(this%tree, target=other%tree) .and. & & ((.not.associated(this%node) .and. .not.associated(other%node)) & & .or.associated(this%node, target=other%node)) end function __PROC(equalIters) ! ======================= ! nequal ! ======================= logical function __PROC(notEqualIters)(this, other) implicit none class(__iterator), intent(in) :: this, other __PROC(notEqualIters) = .not. (this == other) end function __PROC(notEqualIters) ! ======================= ! equalSets ! ======================= logical function equalSets(this, other) class(__set), target, intent(in) :: this class(__set), target, intent(in) :: other type (__iterator) :: iter __type_declare_result, pointer :: ptr equalSets = .false. ! unless #if !defined(__INTEL_COMPILER) | !(defined(_string) & !defined(_string_deferred)) if (this%size() /= other%size()) return iter = this%begin() do while (iter /= this%end()) ptr => iter%value() if (other%count(ptr) == 0) then return end if call iter%next() end do equalSets = .true. #endif end function equalSets ! ======================= ! notEqualSets ! ======================= logical function notEqualSets(this, other) class(__set), intent(in) :: this, other notEqualSets = .not. (this == other) end function notEqualSets ! ======================= ! deepCopy (assignment) ! ======================= subroutine __PROC(deepCopy)(this, other) class (__set), target, intent(out) :: this class (__set), target, intent(in) :: other type (__iterator) :: iter __type_declare_result, pointer :: ptr #if !defined(__INTEL_COMPILER) | !(defined(_string) & !defined(_string_deferred)) iter = other%begin() do while (iter /= other%end()) ptr => iter%value() call this%insert(ptr) call iter%next() end do #endif this%tsize = other%tsize end subroutine __PROC(deepCopy) #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/set_use_tokens.m4000066400000000000000000000031731372124645500212470ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- changecom() define(_param,_`'param()) define(__param,__`'param()) define(_PARAM,_`'translit(param(),`a-z',`A-Z')) define(__PARAM,__`'translit(param(),`a-z',`A-Z')) ifelse(param,type,`define(`_base',)',`define(`_base',_param())') ifelse(param,type,`define(`_BASE',)',`define(`_BASE',_PARAM())') ifelse(param,type,`define(`_use',__use)',`define(`_use',__use`'_param())') ifelse(param,type,`define(`_USE',__USE)',`define(`_USE',__USE`'_PARAM())') define(default,`ifelse(`$1',,`_param()',)') define(`use_define', #ifdef _base()`$1' # define _use()`$1' _base()`$1' #endif ) define(`USE_define', #ifdef _BASE()`$1' # define _USE()`$1'`$2' _BASE()`$1'`$2' #endif ) use_define(default(_base())) use_define(_rank) use_define(_extents) use_define(_string) use_define(_string_deferred) use_define(_logical) use_define(_pointer) use_define(_allocatable) use_define(_procedure) use_define(_equal_defined) use_define(_less_than_defined) USE_define(_ASSIGN,(dest,src)) USE_define(_MOVE,(dest,src)) USE_define(_FREE,(x)) USE_define(_LESS_THAN,(x,y)) USE_define(_EQ_ELEMENT,(x,y)) USE_define(_EQ,(x,y)) gFTL-1.2.7/include/templates/template_macros.m4000066400000000000000000000220041372124645500213660ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- changecom() define(_param,__use_`'param()) define(__param,__`'param()) define(_PARAM,__USE_`'translit(param(),`a-z',`A-Z')) define(__PARAM,__`'translit(param(),`a-z',`A-Z')) ifelse(param,type,`define(`_base',__use)',`define(`_base',_param())') ifelse(param,type,`define(`_BASE',__USE)',`define(`_BASE',`'_PARAM())') ! Althoug the code below could be compressed to some degree, ! maintainability is enhanced by isolating each complication in ! its own decision block. ! ! User settable tokens: ! (a) _param() ! (b) _base()_rank and _base()_extents ! (c) _base()_string and _base()_string_deferred ! (d) _base()_logical ! (e) _base()_pointer ! (f) _base()_allocatable ! (g) _base()_procedure (not complete) ! ! _BASE()_EQ ! ! Output macros ! ! (a) __PARAM()_ASSIGN(dest,src) ! Set dest to have value src ! (b) __PARAM()_MOVE(dest,src) ! If allocatable, move memory for src to variable dest ! ! otherwise, behave as __PARAM()_ASSIGN(dest,src) ! (c) __PARAM()_FREE(x) ! Release memory associated with x (if allocatable) ! ! Output tokens ! ! (a) __param()_declare_component ! (b) __param()_declare_target ! (c) __param()_declare_dummy ! (d) __param()_declare_result ! (e) __param()_interface ! unused - keeping for later use with procedure pointers ! ! Other tokens are for internal use in this file and should be undefined at the end. !------------------------------------------------------------------------------- ! 1) Declared type #if defined(_base()_string) | defined(_base()_string_deferred) # define __param()_target_type character(len=*) # if defined(_base()_string) # define __param()_declare_type character(len=_base()_string) # else # define __param()_declare_type character(len=:) # endif #else # define __param()_declare_type _param() # if defined(_base()_procedure) # define __param()_interface # define __param()_target_type __param()_declare_type # else # define __param()_target_type __param()_declare_type # endif #endif !------------------------------------------------------------------------------- ! 2) Dimensions ! (a) There are two cases to consider: deferred shape and non-deferred shape. ! (b) Return pointers are always deferred shape. #if defined (_base()_rank) # define __param()_rank _base()_rank #else # define __param()_rank 0 #endif #if __param()_rank == 0 # define __param()_deferred_dim_attr #elif (__param()_rank == 1) # define __param()_deferred_dim_attr , dimension(:) #elif (__param()_rank == 2) # define __param()_deferred_dim_attr , dimension(:,:) #elif (__param()_rank == 3) # define __param()_deferred_dim_attr , dimension(:,:,:) #elif (__param()_rank == 4) # define __param()_deferred_dim_attr , dimension(:,:,:,:) #elif (__param()_rank == 5) # define __param()_deferred_dim_attr , dimension(:,:,:,:,:) #endif #ifdef _base()_extents # define __param()_dimension_attr , dimension _base()_extents #else # define __param()_dimension_attr __param()_deferred_dim_attr #endif #define __param()_result_dimension_attr __param()_deferred_dim_attr !------------------------------------------------------------------------------- ! 3) Does the type need to be wrapped #if defined(_base()_pointer) # define __param()_wrapped #elif defined(_base()_allocatable) # define __param()_wrapped #elif defined(_base()_string_deferred) # define __param()_wrapped #elif __param()_rank > 0 # define __param()_wrapped #endif !------------------------------------------------------------------------------- ! 4) Attributes for component declaration #if defined(_base()_pointer) # if defined(_base()_procedure) # define __param()_component_attrs , pointer, nopass # else # define __param()_component_attrs __param()_dimension_attr, pointer # endif #elif defined(_base()_allocatable) | defined(_base()_string_deferred) # define __param()_component_attrs __param()_dimension_attr, allocatable #elif (__param()_rank > 0) # if defined(_base()_extents) # define __param()_component_attrs __param()_dimension_attr # else # define __param()_component_attrs __param()_dimension_attr, allocatable # endif #else # define __param()_component_attrs #endif ! macros for testing equality #ifdef _BASE()_EQ # define __PARAM()_EQ _BASE()_EQ #else # ifdef _base()_pointer # define __PARAM()_EQ(x,y) associated(x,y) # else # ifdef _BASE()_EQ_ELEMENT # define __PARAM()_EQ_ELEMENT(x,y) _BASE()_EQ_ELEMENT(x,y) # else # ifdef _base()_logical # define __PARAM()_EQ_ELEMENT(x,y) (x .eqv. y) # else # define __PARAM()_EQ_ELEMENT(x,y) (x == y) # endif # endif ! Array support # if (_base()_rank > 0) # ifdef _base()_extents ! Assumes that _BASE()_EQ_ELEMENT is an elemental function. If not ! then the user must define their own __PARAM()_EQ(x,y). # define __PARAM()_EQ(x,y) all(__PARAM()_EQ_ELEMENT(x,y)) # else # define __PARAM()_EQ(x,y) __PROC(eqArray)(x,y) # endif # else # define __PARAM()_EQ(x,y) __PARAM()_EQ_ELEMENT(x,y) # endif # endif #endif ! macros for comparing order ! User can specify (or override): #define __param()_compare_well_defined #ifdef _BASE()_LESS_THAN # define __PARAM()_LESS_THAN(x,y) _BASE()_LESS_THAN(x,y) #else # if defined(_base()_string) | defined(_base()_string_deferred) # define __PARAM()_LESS_THAN(x,y) (x)<(y) # elif defined(_base()_less_than_defined) # define __PARAM()_LESS_THAN(x,y) (x)<(y) # else # undef __param()_compare_well_defined ! In most cases, we can provide a compare operator. Not recommended for vector, ! but useful for set and keys for map: # if !(defined(_base()_allocatable) & !defined(_base()_pointer)) # define __PARAM()_LESS_THAN(x,y) defaultLessThan(x,y) # define __param()_needs_default_compare # endif # endif #endif !------------------------------------------------------------------------------- ! 5) Attributes for target and dummy declaration #if defined(_base()_pointer) # if defined(_base()_procedure) # define __param()_target_attrs # define __param()_dummy_attrs __param()_target_attrs # else # define __param()_target_attrs __param()_dimension_attr, target # define __param()_dummy_attrs __param()_dimension_attr, target # endif #else # define __param()_target_attrs __param()_dimension_attr # define __param()_dummy_attrs __param()_dimension_attr #endif !------------------------------------------------------------------------------- ! 6) Attributes for function result declaration ! Always used deferred shape here as pointer cannot work ! with non-deferred shape. #define __param()_result_attrs __param()_deferred_dim_attr !------------------------------------------------------------------------------- ! 8) Assembly #define __param()_declare_component __param()_declare_type __param()_component_attrs #define __param()_declare_target __param()_target_type __param()_target_attrs #define __param()_declare_dummy __param()_target_type __param()_dummy_attrs #define __param()_declare_result __param()_declare_type __param()_result_attrs !------------------------------------------------------------------------------- ! 9) Macros that manipulate storage #ifdef _BASE()_ASSIGN # define __PARAM()_ASSIGN(dest,src) _BASE()_ASSIGN(dest,src) # define __PARAM()_MOVE(dest,src) _BASE()_MOVE(dest,src) # define __PARAM()_FREE(x) _BASE()_FREE(x) #else # ifdef _base()_pointer # define __PARAM()_ASSIGN(dest,src) dest=>src # define __PARAM()_MOVE(dest,src) dest=>src !# define __PARAM()_FREE(x) nullify(x) # define __PARAM()_FREE(x) # elif defined(_base()_allocatable) # define __PARAM()_ASSIGN(dest,src) allocate(dest, source=src) # define __PARAM()_MOVE(dest,src) call move_alloc(from=src, to=dest) # define __PARAM()_FREE(x) deallocate(x) # elif defined (_base()_rank) & (_base()_rank > 0) & !defined(_base()_extents) # define __PARAM()_ASSIGN(dest,src) __ASSIGN_DIM(dest,src) # define __PARAM()_MOVE(dest,src) call move_alloc(from=src, to=dest) # define __PARAM()_FREE(x) deallocate(x) #elif defined (_base()_string_deferred) # define __PARAM()_ASSIGN(dest,src) dest=src # ifdef __GFORTRAN__ # define __PARAM()_MOVE(dest,src) dest=src;deallocate(src) # else # define __PARAM()_MOVE(dest,src) call move_alloc(from=src, to=dest) # endif # define __PARAM()_FREE(x) deallocate(x) #else # define __PARAM()_ASSIGN(dest,src) dest=src # define __PARAM()_MOVE(dest,src) dest=src # define __PARAM()_FREE(x) # endif #endif gFTL-1.2.7/include/templates/template_macros_undefs.m4000066400000000000000000000030241372124645500227330ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- changecom() define(_param,__use_`'param()) define(__param,__`'param()) define(_PARAM,__use_`'translit(param(),`a-z',`A-Z')) define(__PARAM,__`'translit(param(),`a-z',`A-Z')) ifelse(param,type,`define(`_base',__use)',`define(`_base',_param())') ifelse(param,type,`define(`_BASE',__USE)',`define(`_BASE',_PARAM())') #undef __param()_target_type #undef __param()_rank #undef __param()_deferred_dim_attr #undef __param()_dimension_attr #undef __param()_target_attrs #undef __param()_dummy_attrs #undef __param()_result_attrs #undef __param()_wrapped #undef __param()_declare_type #undef __param()_declare_target #undef __param()_declare_dummy #undef __param()_declare_result #undef __param()_declare_element_type #undef __param()_component_attrs #undef __param()_interface #undef __PARAM()_ASSIGN #undef __PARAM()_MOVE #undef __PARAM()_FREE #undef __PARAM()_EQ #undef __PARAM()_EQ_ELEMENT #undef __PARAM()_LESS_THAN #undef __param()_needs_default_compare #undef __param()_compare_well_defined gFTL-1.2.7/include/templates/template_undefs.inc000066400000000000000000000015261372124645500216250ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #undef __QUOTE #undef __ALLOC_SET #undef _pointer #undef _dim #undef _string #undef _logical #undef _entry #undef _bufentry #undef _wrapentry #undef _ptrentry #undef _trgentry #undef __GET #undef __SET #undef __EQ_ONE #undef __EQ #undef _wrapper #undef EQUAL_DEFINED #undef __tmplbase_inc gFTL-1.2.7/include/templates/testing_macros.m4000066400000000000000000000046101372124645500212330ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- changecom() define(_param,_`'param()) define(__param,__`'param()) define(_PARAM,_`'translit(param(),`a-z',`A-Z')) define(__PARAM,__`'translit(param(),`a-z',`A-Z')) ifelse(param,type,`define(`_base',)',`define(`_base',_param())') ifelse(param,type,`define(`_BASE',)',`define(`_BASE',_PARAM())') ! These macros are used in tests, but are not needed for the container ! templates. #ifdef _base()_pointer # if defined(_base()_allocatable) # define __param()_allocatable_target # define __PARAM()_INIT_TARGET(trg, val) allocate(trg, source=val) # elif defined (_base()_rank) & (_base()_rank > 0) & !defined(_base()_extents) ! The Intel compiler requires a flag to use F2003 allocate-on-assignment ! semantics. To avoid assuming that users have that flag set, ! we use the more verbose option here. Unfortunately, gfortran does not ! support this variant for arrays, so we do use the allocate-on-assignment ! for that compiler. # define __param()_allocatable_target # ifdef __INTEL_COMPILER # define __PARAM()_INIT_TARGET(trg, val) allocate(trg, source=val) # else # define __PARAM()_INIT_TARGET(trg, val) trg = val # endif # elif defined(_base()_len) & (_base()_len < 0) # define __param()_allocatable_target # define __PARAM()_INIT_TARGET(trg, val) allocate(trg, source=val) # else # define __PARAM()_INIT_TARGET(trg, val) trg = val # endif #endif #ifdef _base()_pointer # ifdef _base()_procedure # define __PARAM()_INIT(var, val, trg) var => val # define __param()_declare_local __param()_declare_type, pointer # else # define __PARAM()_INIT(var, val, trg) __PARAM()_INIT_TARGET(trg, val); var => trg # endif #else # define __PARAM()_INIT(var, val, trg) __PARAM()_ASSIGN(var,val) #endif #ifndef __param()_declare_local # define __param()_declare_local __param()_declare_component #endif gFTL-1.2.7/include/templates/tmplbase.inc000066400000000000000000000036621372124645500202600ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #ifndef __tmplbase_inc # define __tmplbase_inc # define __QUOTE(x) x # define __PROC(x) __QUOTE(__container_prefix)__QUOTE(x) ! The Intel compiler requires a flag to use F2003 allocate-on-assignment ! semantics. To avoid assuming that users have that flag set, ! we use the more verbose option here. Unfortunately, gfortran does not ! support this variant for arrays, so we do use the allocate-on-assignment ! for that compiler. # ifdef __INTEL_COMPILER # define __ASSIGN_DIM(dest, src) allocate(dest,source=src) # else # define __ASSIGN_DIM(dest, src) dest=src # endif #ifndef __GFORTRAN # define __IMPURE_ELEMENTAL #else # define __IMPURE_ELEMENTAL impure elemental #endif ! 64 bit integers are necessary to support containers with > 2**32 items. ! While F2008 makes INT64 standard, vendors are permitted to give it a negative ! value and not support integers of that kind. We switch to 32 bit ! integers in that case. implicit none integer, parameter :: SIZE_KIND = & & max(kind(1),selected_int_kind(18)) ! Private type used to force keyword access for ! optional arguments. type Unusable end type Unusable ! Assume 64 bit is supported by default #ifndef SUPPORT_FOR_INT64 # ifndef NO_SUPPORT_FOR_INT64 # define SUPPORT_FOR_INT64 # endif #endif #endif /* #ifndef __tmplbase_inc */ gFTL-1.2.7/include/templates/tmpltail.inc000066400000000000000000000012771372124645500202770ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #undef __QUOTE #undef __ASSIGN_DIM #undef IMPURE_ELEMENTAL #ifdef SUPPORT_FOR_INT64 # undef SUPPORT_FOR_INT64 #endif #undef __tmplbase_inc gFTL-1.2.7/include/templates/unused.inc000066400000000000000000000011601372124645500177430ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #define _UNUSED_DUMMY(dummy) if (.false.) print*,shape(dummy) gFTL-1.2.7/include/templates/use_tokens_undef.m4000066400000000000000000000030311372124645500215460ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- changecom() define(_param,_`'param()) define(__param,__`'param()) define(_PARAM,_`'translit(param(),`a-z',`A-Z')) define(__PARAM,__`'translit(param(),`a-z',`A-Z')) ifelse(param,type,`define(`_base',)',`define(`_base',_param())') ifelse(param,type,`define(`_BASE',)',`define(`_BASE',_PARAM())') ifelse(param,type,`define(`_use',__use)',`define(`_use',__use`'_param())') ifelse(param,type,`define(`_USE',__USE)',`define(`_USE',__USE`'_PARAM())') define(default,`ifelse(`$1',,`_param()',)') define(`use_undef', #ifdef _use()`$1' # undef _use()`$1' #endif ) define(`USE_undef', #ifdef _USE()`$1' # undef _USE()`$1' #endif ) use_undef(default(_base())) use_undef(_rank) use_undef(_extents) use_undef(_string) use_undef(_string_deferred) use_undef(_logical) use_undef(_pointer) use_undef(_allocatable) use_undef(_procedure) use_undef(_equal_defined) use_undef(_less_than_defined) USE_undef(_ASSIGN) USE_undef(_MOVE) USE_undef(_FREE) USE_undef(_LESS_THAN) USE_undef(_EQ_ELEMENT) USE_undef(_EQ) gFTL-1.2.7/include/templates/vector.inc000066400000000000000000000026411372124645500177470ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #include "templates/tmplbase.inc" private #ifdef _vector # define __vector _vector #else # define __vector vector #endif #define __container_prefix v_ #ifdef _iterator # define __iterator _iterator #else # define __iterator __QUOTE(__vector)__QUOTE(Iterator) #endif #ifdef _riterator # define __riterator _riterator #else # define __riterator __QUOTE(__vector)__QUOTE(RIterator) #endif public :: __vector public :: __iterator public :: __riterator public :: swap #include "templates/type_set_use_tokens.inc" #include "vector_decl.inc" #include "unused.inc" #include "error_codes.inc" contains #include "vector_impl.inc" #include "templates/type_use_tokens_undef.inc" #undef __vector #undef __iterator #undef __riterator #undef __container_prefix #include "templates/tmpltail.inc" #include "templates/all_macros_undefs.inc" gFTL-1.2.7/include/templates/vectorIterator_decl.inc000066400000000000000000000045011372124645500224450ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- type __iterator private __declare_element_type, dimension(:), pointer :: elements integer(kind=SIZE_KIND) :: currentIndex = -1 ! intentionally invalid value contains procedure :: get => __PROC(iter_get) procedure :: next => __PROC(iter_next) procedure :: previous => __PROC(iter_previous) procedure :: __PROC(iter_atDefault) generic :: at => __PROC(iter_atDefault) procedure :: __PROC(iter_atOffset) generic :: at => __PROC(iter_atOffset) #ifdef SUPPORT_FOR_INT64 procedure :: __PROC(iter_atOffset_32) generic :: at => __PROC(iter_atOffset_32) #endif procedure :: __PROC(iter_equal) procedure :: __PROC(not_iter_equal) generic :: operator(==) => __PROC(iter_equal) generic :: operator(/=) => __PROC(not_iter_equal) procedure :: __PROC(iter_less) procedure :: __PROC(iter_less_equal) procedure :: __PROC(iter_greater) procedure :: __PROC(iter_greater_equal) generic :: operator(<) => __PROC(iter_less) generic :: operator(<=) => __PROC(iter_less_equal) generic :: operator(>) => __PROC(iter_greater) generic :: operator(>=) => __PROC(iter_greater_equal) procedure :: __PROC(iter_add) procedure :: __PROC(iter_subtract) generic :: operator(+) => __PROC(iter_add) generic :: operator(-) => __PROC(iter_subtract) #ifdef SUPPORT_FOR_INT64 procedure :: __PROC(iter_add_32) procedure :: __PROC(iter_subtract_32) generic :: operator(+) => __PROC(iter_add_32) generic :: operator(-) => __PROC(iter_subtract_32) #endif end type __iterator gFTL-1.2.7/include/templates/vectorIterator_impl.inc000066400000000000000000000121401372124645500224750ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- function __PROC(iter_get)(this) result (item) class (__iterator), intent(in) :: this __type_declare_result, pointer :: item item => __GET(this%elements(this%currentIndex)) end function __PROC(iter_get) subroutine __PROC(iter_next)(this) class (__iterator), intent(inout) :: this this%currentIndex = this%currentIndex + 1 end subroutine __PROC(iter_next) subroutine __PROC(iter_previous)(this) class (__iterator), intent(inout) :: this this%currentIndex = this%currentIndex - 1 end subroutine __PROC(iter_previous) logical function __PROC(iter_equal)(this, other) result(eq) class (__iterator), intent(in) :: this class (__iterator), intent(in) :: other eq = (this%currentIndex == other%currentIndex) end function __PROC(iter_equal) logical function __PROC(not_iter_equal)(this, other) result(ne) class (__iterator), intent(in) :: this class (__iterator), intent(in) :: other ne = .not. (this == other) end function __PROC(not_iter_equal) ! Illegal to use these unless both arguments reference the ! same vector. logical function __PROC(iter_less)(this, other) result(less) class (__iterator), intent(in) :: this class (__iterator), intent(in) :: other less = (this%currentIndex < other%currentIndex) end function __PROC(iter_less) function __PROC(iter_less_equal)(this,other) result(le) logical :: le class (__iterator), intent(in) :: this class (__iterator), intent(in) :: other le = (this%currentIndex <= other%currentIndex) end function __PROC(iter_less_equal) ! ======================= ! greaterThanIter ! ======================= logical function __PROC(iter_greater)(this, other) result(gt) class (__iterator), intent(in) :: this class (__iterator), intent(in) :: other gt = (this%currentIndex > other%currentIndex) end function __PROC(iter_greater) function __PROC(iter_greater_equal)(this,other) result(gte) logical :: gte class (__iterator), intent(in) :: this class (__iterator), intent(in) :: other gte = (this%currentIndex >= other%currentIndex) end function __PROC(iter_greater_equal) function __PROC(iter_atDefault)(this) result(ptr) __type_declare_result, pointer :: ptr class (__iterator), intent(in) :: this ptr => __GET(this%elements(this%currentIndex)) end function __PROC(iter_atDefault) function __PROC(iter_atOffset)(this, i) result(ptr) __type_declare_result, pointer :: ptr class (__iterator), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: i ptr => __GET(this%elements(this%currentIndex + i)) end function __PROC(iter_atOffset) #ifdef SUPPORT_FOR_INT64 function __PROC(iter_atOffset_32)(this, i) result(ptr) __type_declare_result, pointer :: ptr class (__iterator), intent(in) :: this integer, intent(in) :: i !!$ ptr => this%at(int(i,kind=SIZE_KIND)) ! workaround for ifort 15.0.3 - no reproducer submitted ptr => __GET(this%elements(this%currentIndex + i)) end function __PROC(iter_atOffset_32) #endif function __PROC(iter_add)(this, n) result(newIter) type (__iterator) :: newIter class (__iterator), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: n newIter%currentIndex = this%currentIndex + n newIter%elements => this%elements end function __PROC(iter_add) function __PROC(iter_subtract)(this, n) result(newIter) type (__iterator) :: newIter class (__iterator), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: n newIter%currentIndex = this%currentIndex - n newIter%elements => this%elements end function __PROC(iter_subtract) #ifdef SUPPORT_FOR_INT64 function __PROC(iter_add_32)(this, n) result(newIter) type (__iterator) :: newIter class (__iterator), intent(in) :: this integer, intent(in) :: n newIter = this + int(n,kind=SIZE_KIND) end function __PROC(iter_add_32) function __PROC(iter_subtract_32)(this, n) result(newIter) type (__iterator) :: newIter class (__iterator), intent(in) :: this integer, intent(in) :: n newIter = this - int(n,kind=SIZE_KIND) end function __PROC(iter_subtract_32) #endif gFTL-1.2.7/include/templates/vectorRIterator_decl.inc000066400000000000000000000045501372124645500225730ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- type __riterator private __declare_element_type, dimension(:), pointer :: elements integer(kind=SIZE_KIND) :: currentIndex = -1 ! intentionally invalid value contains procedure :: get => __PROC(riter_get) procedure :: next => __PROC(riter_next) procedure :: previous => __PROC(riter_previous) procedure :: __PROC(riter_atDefault) generic :: at => __PROC(riter_atDefault) procedure :: __PROC(riter_atOffset) generic :: at => __PROC(riter_atOffset) #ifdef SUPPORT_FOR_INT64 procedure :: __PROC(riter_atOffset_32) generic :: at => __PROC(riter_atOffset_32) #endif procedure :: __PROC(riter_equal) procedure :: __PROC(riter_not_equal) generic :: operator(==) => __PROC(riter_equal) generic :: operator(/=) => __PROC(riter_not_equal) procedure :: __PROC(riter_less) procedure :: __PROC(riter_less_equal) procedure :: __PROC(riter_greater) procedure :: __PROC(riter_greater_equal) generic :: operator(<) => __PROC(riter_less) generic :: operator(<=) => __PROC(riter_less_equal) generic :: operator(>) => __PROC(riter_greater) generic :: operator(>=) => __PROC(riter_greater_equal) procedure :: __PROC(riter_add) procedure :: __PROC(riter_subtract) generic :: operator(+) => __PROC(riter_add) generic :: operator(-) => __PROC(riter_subtract) #ifdef SUPPORT_FOR_INT64 procedure :: __PROC(riter_add_32) procedure :: __PROC(riter_subtract_32) generic :: operator(+) => __PROC(riter_add_32) generic :: operator(-) => __PROC(riter_subtract_32) #endif end type __riterator gFTL-1.2.7/include/templates/vectorRiterator_impl.inc000066400000000000000000000116611372124645500226660ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- function __PROC(riter_get)(this) result (item) class (__riterator), intent(in) :: this __type_declare_result, pointer :: item item => __GET(this%elements(this%currentIndex)) end function __PROC(riter_get) subroutine __PROC(riter_next)(this) class (__riterator), intent(inout) :: this this%currentIndex = this%currentIndex - 1 end subroutine __PROC(riter_next) subroutine __PROC(riter_previous)(this) class (__riterator), intent(inout) :: this this%currentIndex = this%currentIndex + 1 end subroutine __PROC(riter_previous) logical function __PROC(riter_equal)(this, other) result(eq) class (__riterator), intent(in) :: this class (__riterator), intent(in) :: other eq = (this%currentIndex == other%currentIndex) end function __PROC(riter_equal) logical function __PROC(riter_not_equal)(this,other)result(neq) class (__riterator), intent(in) :: this class (__riterator), intent(in) :: other neq = .not. (this == other) end function __PROC(riter_not_equal) ! same vector. function __PROC(riter_less)(this, other) result(lt) logical :: lt class (__riterator), intent(in) :: this class (__riterator), intent(in) :: other lt = (this%currentIndex > other%currentIndex) end function __PROC(riter_less) function __PROC(riter_less_equal)(this, other) result (lte) logical :: lte class (__riterator), intent(in) :: this class (__riterator), intent(in) :: other lte = (this%currentIndex >= other%currentIndex) end function __PROC(riter_less_equal) function __PROC(riter_greater)(this, other) result(gt) logical :: gt class (__riterator), intent(in) :: this class (__riterator), intent(in) :: other gt = (this%currentIndex < other%currentIndex) end function __PROC(riter_greater) function __PROC(riter_greater_equal)(this, other) result(gte) logical :: gte class (__riterator), intent(in) :: this class (__riterator), intent(in) :: other gte = (this%currentIndex <= other%currentIndex) end function __PROC(riter_greater_equal) function __PROC(riter_atDefault)(this) result(ptr) __type_declare_result, pointer :: ptr class (__riterator), intent(in) :: this ptr => __GET(this%elements(this%currentIndex)) end function __PROC(riter_atDefault) function __PROC(riter_atOffset)(this, i) result(ptr) __type_declare_result, pointer :: ptr class (__riterator), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: i ptr => __GET(this%elements(this%currentIndex - i)) end function __PROC(riter_atOffset) #ifdef SUPPORT_FOR_INT64 function __PROC(riter_atOffset_32)(this, i) result(ptr) __type_declare_result, pointer :: ptr class (__riterator), intent(in) :: this integer, intent(in) :: i ptr => __GET(this%elements(this%currentIndex - i)) end function __PROC(riter_atOffset_32) #endif function __PROC(riter_add)(this, n) result(newIter) type (__riterator) :: newIter class (__riterator), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: n newIter%currentIndex = this%currentIndex - n newIter%elements => this%elements end function __PROC(riter_add) function __PROC(riter_subtract)(this, n) result(newIter) type (__riterator) :: newIter class (__riterator), intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: n newIter%currentIndex = this%currentIndex + n newIter%elements => this%elements end function __PROC(riter_subtract) #ifdef SUPPORT_FOR_INT64 function __PROC(riter_add_32)(this, n) result(newIter) type (__riterator) :: newIter class (__riterator), intent(in) :: this integer, intent(in) :: n newIter = this + int(n, kind=SIZE_KIND) end function __PROC(riter_add_32) function __PROC(riter_subtract_32)(this, n) result(newIter) type (__riterator) :: newIter class (__riterator), intent(in) :: this integer, intent(in) :: n newIter = this - int(n, kind=SIZE_KIND) end function __PROC(riter_subtract_32) #endif gFTL-1.2.7/include/templates/vector_decl.inc000066400000000000000000000122751372124645500207420ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- ! Main container file must define ! __vector ! __container_prefix ! Maiy also define ! __iterator ! __riterator #include "templates/all_template_macros.inc" #ifdef __type_wrapped # define __declare_element_type type(__PROC(Wrapper)) type :: __PROC(Wrapper) __type_declare_component :: item end type __PROC(Wrapper) #else # define __declare_element_type __type_declare_type #endif type :: __vector private __declare_element_type, allocatable :: elements(:) integer(kind=SIZE_KIND) :: vsize = 0 contains procedure :: size => __PROC(size) procedure :: capacity => __PROC(capacity) procedure :: empty => __PROC(empty) procedure :: at_size_kind => __PROC(at_size_kind) generic :: at => at_size_kind #ifdef SUPPORT_FOR_INT64 procedure :: at_32 => __PROC(at_32) generic :: at => at_32 #endif procedure :: of => __PROC(of) procedure :: get_size_kind => __PROC(get_size_kind) generic :: get => get_size_kind #ifdef SUPPORT_FOR_INT64 procedure :: get_32 => __PROC(get_32) generic :: get => get_32 #endif #ifndef __type_wrapped procedure :: get_data => __PROC(get_data) #endif procedure :: back => __PROC(back) procedure :: front => __PROC(front) procedure :: set_size_kind => __PROC(set_size_kind) generic :: set => set_size_kind #ifdef SUPPORT_FOR_INT64 procedure :: set_32 => __PROC(set_32) generic :: set => set_32 #endif #ifndef __type_wrapped procedure :: copyFromArray => __PROC(copyfromarray) #ifndef __ifort_18 generic :: assignment(=) => copyFromArray #endif #endif procedure :: push_back => __PROC(push_back) procedure :: pop_back => __PROC(pop_back) procedure :: insert_size_kind => __PROC(insert_size_kind) generic :: insert => insert_size_kind #ifdef SUPPORT_FOR_INT64 procedure :: insert_32 => __PROC(insert_32) generic :: insert => insert_32 #endif procedure :: resize_size => __PROC(resize_size) generic :: resize => resize_size #ifdef SUPPORT_FOR_INT64 procedure :: resize_32 => __PROC(resize_32) generic :: resize => resize_32 #endif procedure :: clear => __PROC(clear) procedure :: shrink_to_fit => __PROC(shrink_to_fit) #ifdef __iterator procedure :: __PROC(erase_one) procedure :: __PROC(erase_range) generic :: erase => __PROC(erase_one), __PROC(erase_range) #endif procedure :: reserve_size_kind => __PROC(reserve_size_kind) generic :: reserve => reserve_size_kind #ifdef SUPPORT_FOR_INT64 procedure :: reserve_32 => __PROC(reserve_32) generic :: reserve => reserve_32 #endif procedure :: swap => __PROC(swap) procedure :: reset => __PROC(reset) #ifdef __use_equal_defined procedure :: get_index => __PROC(get_index) procedure :: equal => __PROC(equal) procedure :: not_equal => __PROC(not_equal) generic :: operator(==) => equal generic :: operator(/=) => not_equal #endif #ifdef __type_compare_well_defined procedure, private :: diff=>__PROC(diff) procedure :: less_than => __PROC(less_than) procedure :: greater_than_or_equal_to => & & __PROC(greater_than_or_equal_to) generic :: operator(<) => less_than generic :: operator(>=) => greater_than_or_equal_to procedure :: greater_than => __PROC(greater_than) procedure :: less_than_or_equal_to => & & __PROC(less_than_or_equal_to) generic :: operator(>) => greater_than generic :: operator(<=) => less_than_or_equal_to #endif #ifdef __iterator ! Iterator constructors procedure :: begin => __PROC(begin) procedure :: end => __PROC(end) #endif #ifdef __iterator procedure :: rbegin => __PROC(rbegin) procedure :: rend => __PROC(rend) #endif procedure, private :: set_capacity => __PROC(set_capacity) procedure, private :: grow_to => __PROC(grow_to) procedure, private :: downsize=>__PROC(downsize) end type __vector interface __vector module procedure __PROC(new_empty) end interface __vector interface swap module procedure __PROC(swap) end interface swap #ifdef __iterator # include "vectorIterator_decl.inc" #endif #ifdef __riterator # include "vectorRIterator_decl.inc" #endif #undef __declare_element_type #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/templates/vector_impl.inc000066400000000000000000000576231372124645500210020ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- ! Main container file must define ! __vector ! __iterator ! __riterator ! __container_prefix #include "templates/all_template_macros.inc" #ifdef __type_wrapped # define __declare_element_type type(__PROC(Wrapper)) # define __GET(x) x%item #else # define __declare_element_type __type_declare_type # define __GET(x) x ! hello __declare_element_type __PROC(x) #endif function __PROC(new_empty)() result(v) type (__vector) :: v logical, parameter :: flag = .false. if (flag) print*,shape(v) ! avoid warning about unused return value return end function __PROC(new_empty) ! ======================= ! size ! ======================= pure function __PROC(size)(this) result(res) class(__vector), intent(in) :: this integer(kind=SIZE_KIND) :: res res=this%vsize return end function __PROC(size) ! ======================= ! capacity ! ======================= pure function __PROC(capacity)(this) result(capacity) integer(kind=SIZE_KIND) :: capacity class (__vector), intent(in) :: this if (allocated(this%elements)) then capacity = size(this%elements) else capacity = 0 end if end function __PROC(capacity) ! ======================= ! empty ! ======================= pure logical function __PROC(empty)(this) result(empty) class(__vector), intent(in) :: this empty = this%vsize==0 end function __PROC(empty) ! ======================= ! at ! ======================= function __PROC(at_size_kind)(this, i, unused, rc) result(res) class(__vector), target, intent(in) :: this integer(KIND=SIZE_KIND), intent(in) :: i type (KeywordEnforcer), optional, intent(in) :: unused integer, optional, intent(out) :: rc __type_declare_result, pointer :: res _UNUSED_DUMMY(unused) if ((i<=0).or.(i>this%vsize)) then if (present(rc)) rc = OUT_OF_RANGE return end if res=>__GET(this%elements(i)) return end function __PROC(at_size_kind) #ifdef SUPPORT_FOR_INT64 function __PROC(at_32)(this, i, unused, rc) result(res) class(__vector), target, intent(in) :: this integer, intent(in) :: i __type_declare_result, pointer :: res type (KeywordEnforcer), optional, intent(in) :: unused integer, optional, intent(out) :: rc _UNUSED_DUMMY(unused) res => this%at_size_kind(int(i,kind=SIZE_KIND),rc=rc) end function __PROC(at_32) #endif ! ======================= ! of ! ======================= function __PROC(of)(this, i) result(res) class(__vector), target, intent(in) :: this integer, intent(in) :: i __type_declare_result, pointer :: res res=>__GET(this%elements(i)) return end function __PROC(of) ! ======================= ! get ! ======================= function __PROC(get_size_kind)(this, i) result(res) class(__vector), target, intent(in) :: this integer(kind=SIZE_KIND), intent(in) :: i __type_declare_component :: res integer(kind=SIZE_KIND) :: idx idx=merge(i, this%vsize+i, i>0) __TYPE_ASSIGN(res, __GET(this%elements(idx))) end function __PROC(get_size_kind) #ifdef SUPPORT_FOR_INT64 function __PROC(get_32)(this, i) result(res) class(__vector), target, intent(in) :: this integer, intent(in) :: i __type_declare_component :: res ! This should call get_size_kind(), but there is an ICE for ! gfortran 5.1 integer(kind=SIZE_KIND) :: idx integer(kind=SIZE_KIND) :: i64 i64 = int(i,kind=SIZE_KIND) idx=merge(i64, this%vsize+i64, i64>0) __TYPE_ASSIGN(res, __GET(this%elements(idx))) end function __PROC(get_32) #endif #ifndef __type_wrapped ! ======================= ! get_data ! ======================= function __PROC(get_data)(this) result(res) class(__vector), target, intent(in) :: this __declare_element_type, dimension(:), pointer :: res res=>this%elements(:this%vsize) return end function __PROC(get_data) #endif ! ======================= ! back ! ======================= function __PROC(back)(this) result(res) class(__vector), target, intent(in) :: this __type_declare_result, pointer :: res res=>__GET(this%elements(this%vsize)) return end function __PROC(back) ! ======================= ! front ! ======================= function __PROC(front)(this) result(res) class(__vector), target, intent(in) :: this __type_declare_result, pointer :: res res=>__GET(this%elements(1)) return end function __PROC(front) ! ======================= ! set ! ======================= subroutine __PROC(set_size_kind)(this, i, value) class(__vector), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: i __type_declare_dummy, intent(in) :: value integer(kind=SIZE_KIND) :: idx idx=merge(i, this%vsize+i, i>0) __TYPE_FREE(__GET(this%elements(idx))) __TYPE_ASSIGN(__GET(this%elements(idx)), value) return end subroutine __PROC(set_size_kind) subroutine __PROC(set_32)(this, i, value) class(__vector), intent(inout) :: this integer, intent(in) :: i __type_declare_dummy, intent(in) :: value call this%set(int(i,kind=SIZE_KIND), value) end subroutine __PROC(set_32) ! ======================= ! reset ! ======================= subroutine __PROC(reset)(this) class(__vector), intent(inout) :: this if (allocated(this%elements)) then deallocate(this%elements) end if this%vsize=0 return end subroutine __PROC(reset) #ifndef __type_wrapped ! ======================= ! copyFromArray ! ======================= subroutine __PROC(copyFromArray)(this, array) class(__vector), intent(inout) :: this __declare_element_type, target, intent(in) :: array(:) integer(kind=SIZE_KIND) :: n n = size(array) call this%reserve(n) this%elements(1:n) = array(1:n) this%vsize=n return end subroutine __PROC(copyFromArray) #endif #ifdef __use_equal_defined ! ======================= ! get_index ! ======================= function __PROC(get_index)(this, value) result(i) class(__vector), target, intent(in) :: this __type_declare_dummy, intent(in) :: value integer(kind=SIZE_KIND) :: i do i=1, this%vsize if (__TYPE_EQ(__GET(this%elements(i)), value)) return end do i=0 return end function __PROC(get_index) ! ======================= ! equal ! ======================= __IMPURE_ELEMENTAL function & & __PROC(equal)(this, other) result(equal) logical :: equal class(__vector), intent(in) :: this, other integer :: i equal = (this%vsize == other%vsize) if (equal) then equal = .false. do i = 1, this%vsize if (.not. & & __TYPE_EQ(__GET(this%elements(i)),__GET(other%elements(i)))) & & return end do equal = .true. endif end function __PROC(equal) ! ======================= ! not_equal ! ======================= __IMPURE_ELEMENTAL function & & __PROC(not_equal)(this, other) result (not_equal) logical :: not_equal class(__vector), intent(in) :: this, other not_equal = .not. (this == other) return end function __PROC(not_equal) #endif /* __use_equal_defined */ #ifdef __type_compare_well_defined __IMPURE_ELEMENTAL function & & __PROC(diff)(a, b, less) result(diff) class(__vector), intent(in) :: a class(__vector), intent(in) :: b logical, intent(in) :: less logical :: diff integer :: i, n __type_declare_result, pointer :: ai, bi n=min(a%size(), b%size()) do i=1, n ai => a%of(i) bi => b%of(i) if (__TYPE_LESS_THAN(ai,bi)) then diff=less return else if (__TYPE_LESS_THAN(bi,ai)) then diff=.not.less return endif end do diff=merge(a%size()oldsize)) then do i = oldSize + 1, newSize __TYPE_ASSIGN(__GET(this%elements(i)), value) end do endif return end subroutine __PROC(resize_size) #ifdef SUPPORT_FOR_INT64 subroutine __PROC(resize_32)(this, newsize, value, unused, rc) class(__vector), intent(inout) :: this integer, intent(in) :: newsize __type_declare_dummy, optional, intent(in) :: value type (KeywordEnforcer), optional, intent(in) :: unused integer, optional, intent(out) :: rc _UNUSED_DUMMY(unused) call this%resize(int(newsize,kind=SIZE_KIND), value, rc=rc) end subroutine __PROC(resize_32) #endif ! ======================= ! downsize ! ======================= subroutine __PROC(downsize)(this, newsize) class(__vector), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: newsize ! assumes newsize<=size() integer(kind=SIZE_KIND) :: i if (newsize this%elements(i-delta),b =>this%elements(i)) __TYPE_MOVE(__GET(a),__GET(b)) end associate end do do i = this%vsize - delta + 1, last%currentIndex - 1 __TYPE_FREE(__GET(this%elements(i))) end do this%vsize=this%vsize-delta return end subroutine __PROC(erase_range) #endif ! ======================= ! reserve ! ======================= subroutine __PROC(reserve_size_kind)(this, capacity) class(__vector), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: capacity if (capacity>this%capacity()) then call this%set_capacity(capacity) endif return end subroutine __PROC(reserve_size_kind) #ifdef SUPPORT_FOR_INT64 subroutine __PROC(reserve_32)(this, capacity) class(__vector), intent(inout) :: this integer, intent(in) :: capacity call this%reserve(int(capacity,kind=SIZE_KIND)) return end subroutine __PROC(reserve_32) #endif ! ======================= ! set_capacity ! ======================= subroutine __PROC(set_capacity)(this, capacity) class(__vector), target, intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: capacity ! capacity must be >=0 __declare_element_type,dimension(:),allocatable,target :: temp integer(kind=SIZE_KIND) :: i if (capacity>0) then ! capacity>0 if (.not.allocated(this%elements)) then ! not allocated allocate(this%elements(capacity)) else ! allocated allocate(temp(capacity)) do i=1, this%vsize __TYPE_MOVE(__GET(temp(i)), __GET(this%elements(i))) end do deallocate(this%elements) call move_alloc(temp, this%elements) endif else if (allocated(this%elements)) then ! capacity==0 ! Note: vsize must be 0 to reach this point. deallocate(this%elements) endif return end subroutine __PROC(set_capacity) ! ======================= ! grow_to ! ======================= subroutine __PROC(grow_to)(this, capacity) class(__vector), intent(inout) :: this integer(kind=SIZE_KIND), intent(in) :: capacity if (capacity>this%capacity()) then call this%set_capacity(max(2*this%vsize, capacity)) ! gives O(n) algorithm for growing vector with push. endif return end subroutine __PROC(grow_to) ! ======================= ! swap ! ======================= subroutine __PROC(swap)(this, other) class(__vector), target, intent(inout) :: this type(__vector), target, intent(inout) :: other __declare_element_type, & & dimension(:), allocatable :: tmpelementsfer integer :: tmpsize call move_alloc(this%elements, tmpelementsfer) call move_alloc(other%elements, this%elements) call move_alloc(tmpelementsfer, other%elements) tmpsize=this%vsize this%vsize=other%vsize other%vsize=tmpsize return end subroutine __PROC(swap) #ifdef __iterator ! ======================= ! begin - create an iterator ! ======================= function __PROC(begin)(this) result(iter) type (__iterator) :: iter class (__vector), target, intent(in) :: this iter%currentIndex = 1 if (allocated(this%elements)) then iter%elements => this%elements else iter%elements => null() end if end function __PROC(begin) ! ======================= ! end_ ! Construct forward iterator, initially set to just ! after last element of vector. ! ======================= function __PROC(end)(this) result(iter) class (__vector), target, intent(in) :: this type (__iterator) :: iter iter%currentIndex = this%size() + 1 ! past the end if (allocated(this%elements)) then iter%elements => this%elements else iter%elements => null() end if end function __PROC(end) #endif #ifdef __riterator ! ======================= ! rbegin - create a reverse iterator ! ======================= function __PROC(rbegin)(this) result(iter) type (__riterator) :: iter class (__vector), target, intent(in) :: this iter%currentIndex = this%vsize if (allocated(this%elements)) then iter%elements => this%elements else iter%elements => null() end if end function __PROC(rbegin) ! ======================= ! rend ! Construct reverse iterator, initially set to just ! before first element of vector ! ======================= function __PROC(rend)(this) result(iter) class (__vector), target, intent(in) :: this type (__riterator) :: iter iter%currentIndex = 0 ! before beginning if (allocated(this%elements)) then iter%elements => this%elements else iter%elements => null() end if end function __PROC(rend) #endif #ifdef __use_pointer # define __pointer_declare_result __type_declare_result # define __pointer_declare_dummy __type_declare_dummy # include "pointerdef.inc" # undef __pointer_declare_result # undef __pointer_declare_dummy #elif (__type_rank > 0) & !defined(_extents) # define __array_declare_dummy __type_declare_dummy # define __ARRAY_EQ_ELEMENT(x,y) __TYPE_EQ_ELEMENT(x,y) # include "array_defs.inc" # undef __ARRAY_EQ_ELEMENT # undef __array_declare_dummy #endif #ifdef __iterator # include "vectorIterator_impl.inc" #endif #ifdef __riterator # include "vectorRiterator_impl.inc" #endif #undef __declare_element_type #undef __GET #include "templates/all_template_macros_undefs.inc" gFTL-1.2.7/include/tmplhead.inc000066400000000000000000000033771372124645500162540ustar00rootroot00000000000000!-------------------------------------------------------------------- ! Copyright © 2017 United States Government as represented by the | ! Administrator of the National Aeronautics and Space | ! Administration. No copyright is claimed in the United States | ! under Title 17, U.S. Code. All Other Rights Reserved. | ! | ! Licensed under the Apache License, Version 2.0. | !-------------------------------------------------------------------- #define __QUOTE(x) x #if (defined _pointer) # define _sfx ,pointer # define _allocsfx ,pointer #else # define _sfx # define _allocsfx ,allocatable #endif #if (defined _dim) # define _bufentry type(wrapper) # define _wrapentry _entry _allocsfx # ifdef __INTEL_COMPILER # define __SET(x, y) allocate(x, source=y) # endif #elif (defined _string) # define _bufentry type(wrapper) # define _entry character(len=*) # define _wrapentry character(len=:) _allocsfx # define _retentry character(len=:) #elif (defined _pointer) # define _bufentry type(wrapper) # define _wrapentry _entry, pointer #endif #if (defined _pointer) # define __SET(x, y) x=>y # define __EQ(x, y) sameptr(x, y) # ifndef __COMPARE # define __COMPARE(x, y) addr(x) ${outfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND generated_incs ${outfile} ) endforeach () endforeach () add_custom_target (generate-type-incs DEPENDS ${generated_incs} ) add_dependencies (gftl generate-type-incs) set_source_files_properties (${generated_incs} PROPERTIES GENERATED TRUE) install (DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/ DESTINATION "${dest}/include/types" FILES_MATCHING PATTERN "*.inc" PATTERN CMakeFiles EXCLUDE PATTERN "*Foo*" EXCLUDE ) gFTL-1.2.7/include/types/Foo.m4000066400000000000000000000002251372124645500161010ustar00rootroot00000000000000include(header.m4) use Foo_mod, only: Foo #define _param() type(Foo) #define _base()_equal_defined #define _BASE()_LESS_THAN(x,y) (x%i < y%i) gFTL-1.2.7/include/types/FooPoly.m4000066400000000000000000000002611372124645500167450ustar00rootroot00000000000000include(header.m4) use Foo_mod, only: Foo #define _param() class(Foo) #define _base()_allocatable #define _base()_equal_defined #define _BASE()_LESS_THAN(x,y) (x%i ${pfunitfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${CMAKE_CURRENT_BINARY_DIR}/${pfunitfile} ) set (pfunitfile Test_${key}${value}altMap.pf) # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${pfunitfile} COMMAND ${M4} -s -DKEY=${key} -DVALUE=${value} -DALT=alt -Dformat=${format} -I${GFTL_SOURCE_DIR}/include/templates < ${infile} > ${pfunitfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${CMAKE_CURRENT_BINARY_DIR}/${pfunitfile} ) endforeach () list (APPEND SRCS AuxTest.pf Test_map_Allocatable.pf Test_map_double_assign.pf) add_pfunit_ctest (map_tests TEST_SOURCES ${SRCS} LINK_LIBRARIES mapSUT ) target_include_directories (map_tests PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/include) target_include_directories (map_tests PRIVATE ${GFTL_SOURCE_DIR}/include) add_dependencies (tests map_tests) gFTL-1.2.7/tests/Map/SUT/000077500000000000000000000000001372124645500146605ustar00rootroot00000000000000gFTL-1.2.7/tests/Map/SUT/CMakeLists.txt000066400000000000000000000042551372124645500174260ustar00rootroot00000000000000set(src ${CMAKE_CURRENT_SOURCE_DIR}) set(bin ${CMAKE_CURRENT_BINARY_DIR}) set (instantiations # vary value type "integer\;integer\;free" "integer\;real\;free" "integer\;logical\;free" "integer\;complex\;free" "integer\;deferredLengthString\;free" "integer\;Foo\;free" "integer\;FooPoly\;free" "integer\;integerAlloc\;free" "integer\;integerPtr\;free" "integer\;integer1d\;free" "integer\;integer2d_fixedExtents\;free" "integer\;integer2dPtr\;free" # vary key type "real32\;integer\;free" "complex\;integer\;free" "deferredLengthString\;integer\;free" "Foo\;integer\;free" "integerAlloc\;integer\;free" "integerPtr\;integer\;free" "integer1d\;integer\;free" "integer2dPtr\;integer\;free" "deferredLengthString\;unlimitedPoly\;free" # duplication combos "integerPtr\;integerPtr\;free" "integer1d\;integer1d\;free" "deferredLengthString\;deferredLengthString\;free" ) set (SRCS) set (altSRCS) set (infile ${src}/Map.m4) # Empty list - will append in loop below foreach (instantiation ${instantiations}) list (GET instantiation 0 key) list (GET instantiation 1 value) list (GET instantiation 2 format) if (format STREQUAL "free") set (outfile ${key}${value}Map.F90) else () set (outfile ${key}${value}Map.F) endif () add_custom_command ( OUTPUT ${outfile} COMMAND ${M4} -s -Dkey=${key} -DALT -Dvalue=${value} -Dformat=${format} < ${infile} > ${outfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${outfile} ) if (format STREQUAL "free") set (outfile ${key}${value}altMap.F90) else () set (outfile ${key}${value}altMap.F) endif () add_custom_command ( OUTPUT ${outfile} COMMAND ${M4} -s -Dkey=${key} -DALT=alt -Dvalue=${value} -Dformat=${format} < ${infile} > ${outfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND altSRCS ${outfile} ) endforeach () list (APPEND SRCS MultiModule.F90) add_library(mapSUT STATIC EXCLUDE_FROM_ALL ${SRCS} ${altSRCS}) target_include_directories (mapSUT PUBLIC ${CMAKE_CURRENT_BINARY_DIR}) target_include_directories (mapSUT PRIVATE ${PFUNIT_TOP_DIR}/include) target_link_libraries(mapSUT type_test_values shared gftl) gFTL-1.2.7/tests/Map/SUT/Map.m4000066400000000000000000000005401372124645500156360ustar00rootroot00000000000000changecom() define(`suffix',ifelse(format(),free,,_fixedFormat)) ifelse(ALT,alt, ` #define _alt ') module key()`'value()`'ALT()Map`'suffix()_mod #include "types/key_`'key().inc" #include "types/value_`'value().inc" #include "templates/map.inc" #include "templates/all_macros_undefs.inc" end module key()`'value()`'ALT()Map`'suffix()_mod gFTL-1.2.7/tests/Map/SUT/MultiModule.F90000066400000000000000000000004021372124645500173740ustar00rootroot00000000000000module map_one #include #include #include end module map_one module map_two #include #include #include end module map_two gFTL-1.2.7/tests/Map/Test_Map.m4000066400000000000000000000144171372124645500161720ustar00rootroot00000000000000changecom() #line 2 "tests/Map/Test_Map.m4" module Test_`'KEY()`'VALUE()`'ALT()Map #include "types/key_`'KEY().inc" #include "types/value_`'VALUE().inc" #include "type_test_values/key_`'KEY().inc" #include "type_test_values/value_`'VALUE().inc" use funit, only: assertTrue, assertFalse use funit, only: TestSuite, TestSuite use funit, only: TestMethod use funit, only: SourceLocation use funit, only: anyExceptions use funit, only: assertEqual use KEY()`'VALUE()`'ALT()Map_mod #include "templates/tmplbase.inc" #include "templates/key_set_use_tokens.inc" #include "templates/key_template_macros.inc" #include "templates/key_testing_macros.inc" #include "templates/value_set_use_tokens.inc" #include "templates/value_template_macros.inc" #include "templates/value_testing_macros.inc" #include "genericItems_decl.inc" contains #include "genericSetUpTearDown.inc" @before subroutine setUp() call genericSetUp() end subroutine setUp @after subroutine tearDown() call genericTearDown() end subroutine tearDown @test subroutine test_empty() type (Map) :: m @assertTrue(m%empty()) call m%insert(KEY1, ONE) @assertFalse(m%empty()) end subroutine test_empty @test subroutine test_size() type (Map) :: m @assertEqual(0, m%size()) call m%insert(KEY1, ONE) @assertEqual(1, m%size()) call m%insert(KEY2, ONE) @assertEqual(2, m%size()) end subroutine test_size @test subroutine test_count() type (Map) :: m call m%insert(KEY1, ONE) call m%insert(KEY2, ONE) @assertEqual(1, m%count(KEY1)) @assertEqual(1, m%count(KEY2)) @assertEqual(0, m%count(KEY3)) end subroutine test_count @test subroutine test_max_size() type (Map) :: m @assertEqual(huge(1_SIZE_KIND), m%max_size()) end subroutine test_max_size @test subroutine test_at() type (Map) :: m __value_declare_result, pointer :: val call m%insert(KEY1, ONE) call m%insert(KEY2, TWO) val => m%at(KEY1) @assertEqual(ONE, val) val => m%at(KEY2) @assertEqual(TWO, val) end subroutine test_at @test subroutine test_value_empty_is_null() type (Map), target :: m type (MapIterator) :: iter iter = m%find(KEY1) @assertFalse(associated(iter%value())) end subroutine test_value_empty_is_null @test subroutine test_find() type (Map), target :: m type (MapIterator) :: iter call m%insert(KEY2, TWO) iter = m%find(KEY2) @assertEqual(TWO, iter%value()) iter = m%find(KEY1) @assertTrue(iter == m%end()) iter = m%find(KEY3) @assertTrue(iter == m%end()) end subroutine test_find @test subroutine test_erase() type (Map), target :: m type (MapIterator) :: iter call m%insert(KEY1, ONE) iter = m%begin() call m%erase(iter) @assertEqual(0, m%size()) end subroutine test_erase @test subroutine test_next() type (Map), target :: m type (MapIterator) :: iter __value_declare_result, pointer :: q1, q2, q3 call m%insert(KEY1, ONE) call m%insert(KEY2, TWO) call m%insert(KEY3, THREE) iter = m%begin() q1 => iter%value() call iter%next() q2 => iter%value() call iter%next() q3 => iter%value() @assertFalse(associated(q1,q2)) @assertFalse(associated(q1,q3)) @assertFalse(associated(q2,q3)) end subroutine test_next @test subroutine test_previous() type (Map), target :: m type (MapIterator) :: iter __value_declare_result, pointer :: q1, q2, q3 call m%insert(KEY1, ONE) call m%insert(KEY2, TWO) call m%insert(KEY3, THREE) iter = m%end() call iter%previous() q3 => iter%value() call iter%previous() q2 => iter%value() call iter%previous() q1 => iter%value() @assertFalse(associated(q1,q2)) @assertFalse(associated(q1,q3)) @assertFalse(associated(q2,q3)) end subroutine test_previous @test subroutine test_iterGetValue() type (Map), target :: m type (MapIterator) :: iter __value_declare_result, pointer :: q1, q2, q3 call m%insert(KEY1, ONE) call m%insert(KEY2, TWO) call m%insert(KEY3, THREE) iter = m%begin() q1 => iter%value() call iter%next() q2 => iter%value() call iter%next() q3 => iter%value() @assertFalse(associated(q1,q2)) @assertFalse(associated(q1,q3)) @assertFalse(associated(q2,q3)) end subroutine test_iterGetValue @test subroutine testIsSet() type (Map) :: m logical :: f __value_declare_result, pointer :: val call m%set(KEY1,ONE) f = m%get(KEY1, val) @assertTrue(f) end subroutine testIsSet @test subroutine testNotSet() type (Map) :: m logical :: f __value_declare_result, pointer :: val call m%set(KEY1,ONE) f = m%get(KEY2, val) @assertFalse(f) end subroutine testNotSet @test subroutine testGet() type (Map), target :: m logical :: f __value_declare_result, pointer :: val call m%set(KEY1,ONE) call m%set(KEY2,TWO) f = m%get(KEY1, val) @assertTrue(f) @assertEqual(ONE, val) f = m%get(KEY2, val) @assertTrue(f) @assertEqual(TWO, val) end subroutine testGet ! The following test crashes under gfortran 4.9 and 5.0. ! The theory is that a temp copy is incorrectly interacting ! with the FINAL method for SET. @test(ifdef=include_broken) subroutine deepCopy() type (Map) :: m1, m2 call m1%insert(KEY1, ONE) m2 = m1 end subroutine deepCopy #ifdef _alt @test(ifdef=_alt) subroutine test_make_from_array_of_pairs() type (Map) :: m __value_declare_result, pointer :: val m = Map([mapPair(KEY1,ONE), mapPair(KEY2,TWO), mapPair(KEY3,THREE)]) @assertEqual(3, m%size()) call m%insert(KEY1, ONE) call m%insert(KEY2, TWO) val => m%at(KEY1) @assertEqual(ONE, val) val => m%at(KEY2) @assertEqual(TWO, val) end subroutine test_make_from_array_of_pairs #endif #include "templates/type_use_tokens_undef.inc" end module Test_`'KEY()`'VALUE()`'ALT()Map #include "templates/tmpltail.inc" gFTL-1.2.7/tests/Map/Test_map_Allocatable.pf000066400000000000000000000027751372124645500206060ustar00rootroot00000000000000! If a container is for allocatable entities, then gFTL should enable ! external pointers into the structure to persist even when the ! container is modified. This relies on Fortran's move_alloc() ! behavior, and thus cannot be supported for non allocatable container ! elements. module MyMap_mod use Foo_mod #include "types/key_deferredLengthString.inc" #include "types/value_FooPoly.inc" #define _alt #include "templates/map.inc" end module MyMap_mod module Test_map_Allocatable use funit use MyMap_mod use Foo_mod @suite(name='Test_map_allocatable_suite') contains @test subroutine test_insert() type (Map), target :: m class (Foo), pointer :: pa, pb, pc ! Try to insert in non canonical order so that things must move ! But in the worst case, the fact that we have 5 elements should ! cause some move_alloc() when internals are copied. call m%insert('c',Foo(3)) pc => m%at('c') @assertEqual(3, pc%i) call m%insert('b',Foo(2)) pb => m%at('b') @assertEqual(2, pb%i) call m%insert('a',Foo(1)) pa => m%at('a') @assertEqual(1, pa%i) ! Sanity checks @assertEqual(1, pa%i) @assertEqual(2, pb%i) @assertEqual(3, pc%i) call m%insert('A',Foo(4)) call m%insert('B',Foo(5)) call m%insert('C',Foo(6)) ! Pointers still valid? @assertEqual(1, pa%i) @assertEqual(2, pb%i) @assertEqual(3, pc%i) end subroutine test_insert end module Test_map_Allocatable gFTL-1.2.7/tests/Map/Test_map_double_assign.pf000066400000000000000000000047771372124645500212250ustar00rootroot00000000000000! Test for use fArgParse use case that fails with ifort-19. Issue is ! apparently related to copying of StringUnlimited maps at multiple ! levels. In the use case a function is used to return a map, and the ! retun value is itself a function return at the level above. module String_mod implicit none private public :: String type :: String character(:), allocatable :: string end type String end module String_mod module UnlimitedMap_mod #include "types/key_deferredLengthString.inc" #include "types/value_unlimitedPoly.inc" #define _alt #include "templates/map.inc" end module UnlimitedMap_mod module Test_map_double_assign use String_mod use funit use UnlimitedMap_mod @suite(name='Test_map_double_assign_suite') type :: ArgParser class(*), allocatable :: default end type ArgParser contains subroutine get_defaults(this, option_values) type (Map), intent(out) :: option_values class (ArgParser), target, intent(inout) :: this class(*), pointer :: q this%default = 'TestRunner' q => this%default select type (q) type is (character(*)) call option_values%insert('runner', String(q)) end select end subroutine get_defaults #ifdef __INTEL_COMPILER @test(ifdef=__INTEL_COMPILER) @disable subroutine test_unlimited type (Map) :: m type (ArgParser) :: p class(*), pointer :: opt call get_defaults(p, m) opt => m%at('runner') select type (opt) class is (String) @assertEqual('TestRunner', opt%string) class default @assertFalse(.true.,message='should not get here') end select end subroutine test_unlimited #else @test(ifndef=__INTEL_COMPILER) @disable subroutine test_unlimited type (Map) :: m type (ArgParser) :: p class(*), pointer :: opt call get_defaults(p, m) opt => m%at('runner') select type (opt) class is (String) @assertEqual('TestRunner', opt%string) class default @assertFalse(.true.,message='should not get here') end select end subroutine test_unlimited #endif ! Reproducer for bug introduced in 1.2.1 ! Issue #86 @test subroutine test_set_twice() use Foo_mod use integerFooPolyaltMap_mod type (Map), target :: m class (Foo), pointer :: p1, p2 call m%insert(1, Foo(1)) call m%set(1, Foo(2)) ! set() must first deallocate end subroutine test_set_twice end module Test_map_double_assign gFTL-1.2.7/tests/Map/altMapTestSuites.inc000066400000000000000000000027361372124645500201630ustar00rootroot00000000000000! Vary value type ADD_TEST_SUITE(Test_integerintegeraltMap_mod_suite) ADD_TEST_SUITE(Test_integerrealaltMap_mod_suite) ADD_TEST_SUITE(Test_integerlogicalaltMap_mod_suite) ADD_TEST_SUITE(Test_integercomplexaltMap_mod_suite) ADD_TEST_SUITE(Test_integerFooaltMap_mod_suite) ADD_TEST_SUITE(Test_integerFooPolyaltMap_mod_suite) ADD_TEST_SUITE(Test_integerintegerAllocaltMap_mod_suite) ADD_TEST_SUITE(Test_integerintegerPtraltMap_mod_suite) ADD_TEST_SUITE(Test_integerinteger1daltMap_mod_suite) ADD_TEST_SUITE(Test_integerinteger2d_fixedExtentsaltMap_mod_suite) ADD_TEST_SUITE(Test_integerinteger2dPtraltMap_mod_suite) ! Vary key type ADD_TEST_SUITE(Test_real32IntegeraltMap_mod_suite) ADD_TEST_SUITE(Test_complexIntegeraltMap_mod_suite) ADD_TEST_SUITE(Test_deferredLengthStringintegeraltMap_mod_suite) ADD_TEST_SUITE(Test_integerPtrIntegeraltMap_mod_suite) ADD_TEST_SUITE(Test_integerAllocIntegeraltMap_mod_suite) ADD_TEST_SUITE(Test_integer1dIntegeraltMap_mod_suite) ADD_TEST_SUITE(Test_integer2dPtrIntegeraltMap_mod_suite) ! duplicates ADD_TEST_SUITE(Test_integerPtrintegerPtraltMap_mod_suite) ADD_TEST_SUITE(Test_integer1dinteger1daltMap_mod_suite) #ifdef SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS ADD_TEST_SUITE(Test_integerdeferredLengthStringaltMap_mod_suite) ADD_TEST_SUITE(Test_deferredLengthStringdeferredLengthStringaltMap_mod_suite) #endif ! Test for robust pointers to allocatable components ADD_TEST_SUITE(Test_map_Allocatable_suite) ADD_TEST_SUITE(Test_map_double_assign_suite) gFTL-1.2.7/tests/Map/include/000077500000000000000000000000001372124645500156305ustar00rootroot00000000000000gFTL-1.2.7/tests/Map/include/genericItems_decl.inc000066400000000000000000000023761372124645500217400ustar00rootroot00000000000000 __value_declare_local :: ONE __value_declare_local :: TWO __value_declare_local :: THREE __value_declare_local :: FOUR __value_declare_local :: FIVE #if defined(_value_pointer) & !defined(_value_procedure) # ifdef __value_allocatable_target # define __value_test_attrs , allocatable # else # define __value_test_attrs # endif __value_declare_target __value_test_attrs :: one_ __value_declare_target __value_test_attrs :: two_ __value_declare_target __value_test_attrs :: three_ __value_declare_target __value_test_attrs:: four_ __value_declare_target __value_test_attrs :: five_ # undef __value_test_attrs #endif __key_declare_local :: KEY1 __key_declare_local :: KEY2 __key_declare_local :: KEY3 __key_declare_local :: KEY4 __key_declare_local :: KEY5 #if defined(_key_pointer) & !defined(_key_procedure) # ifdef __key_allocatable_target # define __key_test_attrs , allocatable # else # define __key_test_attrs # endif __key_declare_target __key_test_attrs :: key1_ __key_declare_target __key_test_attrs :: key2_ __key_declare_target __key_test_attrs :: key3_ __key_declare_target __key_test_attrs:: key4_ __key_declare_target __key_test_attrs :: key5_ # undef __key_test_attrs #endif gFTL-1.2.7/tests/Map/include/genericSetUpTearDown.inc000066400000000000000000000021411372124645500223620ustar00rootroot00000000000000 subroutine genericSetUp() __VALUE_INIT(ONE, _value_ONE, one_) __VALUE_INIT(TWO, _value_TWO, two_) __VALUE_INIT(THREE, _value_THREE, three_) __VALUE_INIT(FOUR, _value_FOUR, four_) __VALUE_INIT(FIVE, _value_FIVE, five_) __KEY_INIT(KEY1, _key_ONE, key1_) __KEY_INIT(KEY2, _key_TWO, key2_) __KEY_INIT(KEY3, _key_THREE, key3_) __KEY_INIT(KEY4, _key_FOUR, key4_) __KEY_INIT(KEY5, _key_FIVE, key5_) end subroutine genericSetUp subroutine genericTearDown() __VALUE_FREE(ONE) __VALUE_FREE(TWO) __VALUE_FREE(THREE) __VALUE_FREE(FOUR) __VALUE_FREE(FIVE) __KEY_FREE(KEY1) __KEY_FREE(KEY2) __KEY_FREE(KEY3) __KEY_FREE(KEY4) __KEY_FREE(KEY5) #ifdef __value_allocatable_target deallocate(one_) deallocate(two_) deallocate(three_) deallocate(four_) deallocate(five_) #endif #ifdef __key_allocatable_target deallocate(key1_) deallocate(key2_) deallocate(key3_) deallocate(key4_) deallocate(key5_) #endif end subroutine genericTearDown gFTL-1.2.7/tests/Map/include/genericTestMap.inc000066400000000000000000000034371372124645500212440ustar00rootroot00000000000000 #define CHECK if(anyExceptions()) return #define _FILE 'genericTestMap.inc' #define ASSERT_EQUAL(a,b)call assertEqual(a,b,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_TRUE(a)call assertTrue(a,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_FALSE(a)call assertFalse(a,location=SourceLocation(_FILE,__LINE__)); CHECK #include #include #include contains #include "genericSetUpTearDown.inc" subroutine setUp() call genericSetUp() end subroutine setUp subroutine tearDown() call genericTearDown() end subroutine tearDown subroutine testIsSet() type (Map) :: m logical :: f integer, pointer :: val call m%set(KEY1,ONE) f = m%get(KEY1, val) ASSERT_TRUE(f) end subroutine testIsSet subroutine testNotSet() type (Map) :: m logical :: f integer, pointer :: val call m%set(KEY1,ONE) f = m%get(KEY2, val) ASSERT_FALSE(f) end subroutine testNotSet subroutine testGet() type (Map) :: m logical :: f integer, pointer :: val call m%set(KEY1,ONE) call m%set(KEY2,TWO) f = m%get(KEY1, val) ASSERT_TRUE(f) ASSERT_EQUAL(ONE, val) f = m%get(KEY2, val) ASSERT_TRUE(f) ASSERT_EQUAL(TWO, val) end subroutine testGet function _suite() result(s) type (TestSuite) :: s s = newTestSuite(_suite_name) call s%addTest(newTestMethod('testIsSet', testIsSet, & & setUp, tearDown)) call s%addTest(newTestMethod('testNotSet', testNotSet, & & setUp, tearDown)) call s%addTest(newTestMethod('testGet', testGet, & & setUp, tearDown)) end function _suite gFTL-1.2.7/tests/Map/mapTestSuites.inc000066400000000000000000000024601372124645500175140ustar00rootroot00000000000000! Vary value type ADD_TEST_SUITE(Test_integerintegerMap_mod_suite) ADD_TEST_SUITE(Test_integerrealMap_mod_suite) ADD_TEST_SUITE(Test_integerlogicalMap_mod_suite) ADD_TEST_SUITE(Test_integercomplexMap_mod_suite) ADD_TEST_SUITE(Test_integerFooMap_mod_suite) ADD_TEST_SUITE(Test_integerFooPolyMap_mod_suite) ADD_TEST_SUITE(Test_integerintegerPtrMap_mod_suite) ADD_TEST_SUITE(Test_integerintegerAllocMap_mod_suite) ADD_TEST_SUITE(Test_integerinteger1dMap_mod_suite) ADD_TEST_SUITE(Test_integerinteger2d_fixedExtentsMap_mod_suite) ADD_TEST_SUITE(Test_integerinteger2dPtrMap_mod_suite) ! Vary key type ADD_TEST_SUITE(Test_real32IntegerMap_mod_suite) ADD_TEST_SUITE(Test_complexIntegerMap_mod_suite) ADD_TEST_SUITE(Test_deferredLengthStringintegerMap_mod_suite) ADD_TEST_SUITE(Test_integerPtrIntegerMap_mod_suite) ADD_TEST_SUITE(Test_integerAllocIntegerMap_mod_suite) ADD_TEST_SUITE(Test_integer1dIntegerMap_mod_suite) ADD_TEST_SUITE(Test_integer2dPtrIntegerMap_mod_suite) ! duplicates ADD_TEST_SUITE(Test_integerPtrintegerPtrMap_mod_suite) ADD_TEST_SUITE(Test_integer1dinteger1dMap_mod_suite) #ifdef SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS ADD_TEST_SUITE(Test_integerdeferredLengthStringMap_mod_suite) ADD_TEST_SUITE(Test_deferredLengthStringdeferredLengthStringMap_mod_suite) #endif ADD_TEST_SUITE(AuxTest_mod_suite) gFTL-1.2.7/tests/Map/testSuites.inc000066400000000000000000000000751372124645500170560ustar00rootroot00000000000000#include #include gFTL-1.2.7/tests/Set/000077500000000000000000000000001372124645500142235ustar00rootroot00000000000000gFTL-1.2.7/tests/Set/CMakeLists.txt000066400000000000000000000023371372124645500167700ustar00rootroot00000000000000add_subdirectory(SUT) set (src ${CMAKE_CURRENT_SOURCE_DIR}) set (bin ${CMAKE_CURRENT_BINARY_DIR}) set (types integer real real64 complex deferredLengthString integer1d integer2d integer2d_fixedExtents integerAlloc integerPtr integer2dPtr Foo FooPtr FooPoly FooPolyPtr unlimitedPolyPtr # Unsupportable combinations: # unlimitedPoly ) if (SUPPORTS_POINTERS_TO_FIXED_LENGTH_STRINGS) LIST (APPEND types character17) endif () set(SRCS) foreach (type ${types} ) set (infile ${src}/Test_Set.m4) set (pfunitfile Test_${type}Set.pf) # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${pfunitfile} COMMAND ${M4} -s -Dparam=${type} -I${GFTL_SOURCE_DIR}/include/templates < ${infile} > ${pfunitfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${CMAKE_CURRENT_BINARY_DIR}/${pfunitfile} ) endforeach () add_pfunit_ctest (set_tests TEST_SOURCES ${SRCS} LINK_LIBRARIES setSUT ) target_include_directories (set_tests PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/include) target_include_directories (set_tests PRIVATE ${GFTL_SOURCE_DIR}/include) add_dependencies (tests set_tests) gFTL-1.2.7/tests/Set/SUT/000077500000000000000000000000001372124645500146765ustar00rootroot00000000000000gFTL-1.2.7/tests/Set/SUT/CMakeLists.txt000066400000000000000000000030671372124645500174440ustar00rootroot00000000000000set (instantiations "integer\;free" "real\;free" "real32\;free" "real64\;free" "complex\;free" "complex64\;free" "complex128\;free" "deferredLengthString\;free" # "unlimitedPoly\;free" "unlimitedPolyPtr\;free" "integer1d\;free" "integer2d\;free" "integer2d_fixedExtents\;free" "integerAlloc\;free" "integerPtr\;free" "integer2dPtr\;free" "integer\;fixed" "Foo\;free" "FooPtr\;free" "FooPoly\;free" "FooPolyPtr\;free" "integer1d\;free" "integer2d\;free" "integer2d_fixedExtents\;free" ) if (SUPPORTS_POINTERS_TO_FIXED_LENGTH_STRINGS) list (APPEND instantiations "character17\;free") endif () set (SRCS) foreach (instantiation ${instantiations}) list (GET instantiation 0 type) list (GET instantiation 1 format) set (infile ${CMAKE_CURRENT_SOURCE_DIR}/Set.m4) if (format STREQUAL "free") set (outfile ${type}Set.F90) else () set (outfile ${type}Set.F) endif () # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${outfile} DEPENDS ${infile} COMMAND ${M4} -Dtype=${type} -Dformat=${format} ${infile} > ${outfile} WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} ) list (APPEND SRCS ${outfile}) endforeach () list (APPEND SRCS MultiModule.F90) add_library(setSUT STATIC EXCLUDE_FROM_ALL ${SRCS}) target_include_directories (setSUT PUBLIC ${CMAKE_CURRENT_BINARY_DIR}) target_include_directories (setSUT PRIVATE ${PFUNIT_TOP_DIR}/include) target_link_libraries(setSUT type_test_values shared gftl) gFTL-1.2.7/tests/Set/SUT/IntegerFixedFormatSet.F000066400000000000000000000005001372124645500212020ustar00rootroot00000000000000 module IntegerFixedFormatSet_mod #include "types/integer.inc" #include "templates/set.inc" end module IntegerFixedFormatSet_mod ! A second module checks that all macros are cleared from the 1st case module Other_mod #include #include end module Other_mod gFTL-1.2.7/tests/Set/SUT/MultiModule.F90000066400000000000000000000002671372124645500174230ustar00rootroot00000000000000module set_one #include #include end module set_one module set_two #include #include end module set_two gFTL-1.2.7/tests/Set/SUT/Set.m4000066400000000000000000000003141372124645500156710ustar00rootroot00000000000000changecom() define(`suffix',ifelse(format(),free,,_fixedFormat)) module type()Set`'suffix()_mod #include "types/type().inc" #include "templates/set.inc" end module type()Set`'suffix()_mod gFTL-1.2.7/tests/Set/Test_Set.m4000066400000000000000000000206151372124645500162230ustar00rootroot00000000000000include(header.m4) module Test_`'param()Set #include "types/param().inc" #include "type_test_values/param().inc" use funit, only: assertTrue, assertFalse use funit, only: TestSuite use funit, only: TestMethod use funit, only: SourceLocation use funit, only: anyExceptions #ifdef _unlimited use pFUnitSupplement_mod, only: assertEqual #else use funit, only: assertEqual #endif use param()Set_mod #include "templates/type_set_use_tokens.inc" #include "templates/type_template_macros.inc" #include "templates/tmplbase.inc" #include "templates/type_testing_macros.inc" #include "genericItems_decl.inc" ! GFortran 8.2 namespace is "leaky" private :: assertEqual contains #include "genericSetUpTearDown.inc" @before subroutine setUp() call genericSetUp() end subroutine setUp @after subroutine tearDown() call genericTearDown() end subroutine tearDown @test subroutine testIsEmpty() type (Set) :: s @assertTrue(s%empty()) end subroutine testIsEmpty @test subroutine testIsEmpty_notEmpty() type (Set) :: s call s%insert(ONE) @assertFalse(s%empty()) end subroutine testIsEmpty_notEmpty @test subroutine testSize_empty() type (Set) :: s @assertEqual(0, s%size()) end subroutine testSize_empty @test subroutine testSize_simple() type (Set) :: s call s%insert(ONE) @assertEqual(1, s%size()) call s%insert(TWO) @assertEqual(2, s%size()) end subroutine testSize_simple @test subroutine testSize_duplicate() type (Set) :: s call s%insert(ONE) @assertEqual(1, s%size()) call s%insert(TWO) @assertEqual(2, s%size()) ! Insert a duplicate entry - should not modify call s%insert(ONE) @assertEqual(2, s%size()) end subroutine testSize_duplicate @test subroutine testInsert_isNew() type (Set) :: s logical :: isNew call s%insert(ONE,isNew=isNew) @assertTrue(isNew) call s%insert(TWO, isNew=isNew) @assertTrue(isNew) call s%insert(ONE, isNew=isNew) @assertFalse(isNew) call s%insert(TWO, isNew=isNew) @assertFalse(isNew) end subroutine testInsert_isNew @test subroutine testCount() type (Set) :: s @assertEqual(0, s%count(ONE)) @assertEqual(0, s%count(TWO)) call s%insert(ONE) @assertEqual(1, s%count(ONE)) @assertEqual(0, s%count(TWO)) call s%insert(TWO) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(TWO)) ! duplicate call s%insert(TWO) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(TWO)) call s%insert(THREE) call s%insert(FOUR) call s%insert(THREE) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(TWO)) @assertEqual(1, s%count(THREE)) @assertEqual(1, s%count(FOUR)) end subroutine testCount #ifdef _pointer ! This test verifies that if two pointers are put in a Set ! they are treated as separate entries even if their targets ! have the same value. (But the targets are not the same object.) ! This test is only relevant for types with _pointer. @test(ifdef=_pointer) subroutine test_findSameTarget() type (Set) :: s # ifdef __type_allocatable_target # define __type_test_attrs , allocatable # else # define __type_test_attrs # endif #define _ONE_ _ONE __type_declare_local :: pA __type_declare_local :: pB __type_declare_local :: pC __type_declare_target __type_test_attrs :: targA __type_declare_target __type_test_attrs :: targB __type_declare_target __type_test_attrs :: targC __type_declare_result, pointer :: qA, qB, qC type (SetIterator) :: iterA, iterB, iterC logical :: isNew #ifdef _DEBUG type LocalWrapper integer, pointer :: item end type LocalWrapper type (LocalWrapper):: w #endif __TYPE_INIT(pA, _ONE, targA) __TYPE_INIT(pB, _ONE, targB) __TYPE_INIT(pC, _ONE, targC) @assertFalse(associated(pA, pB)) #ifdef _DEBUG w%item => pA w%item => targB w%item => targC #endif call s%insert(pA) @assertEqual(1, s%size()) call s%insert(pB, isNew=isNew) @assertTrue(isNew) @assertEqual(2, s%size()) call s%insert(pC, isNew=isNew) @assertTrue(isNew) @assertEqual(3, s%size()) iterA = s%find(pA) iterB = s%find(pB) iterC = s%find(pC) qA => iterA%value() qB => iterB%value() qC => iterC%value() @assertFalse(associated(qA, qB)) @assertFalse(associated(qA, qC)) @assertFalse(associated(qB, qC)) end subroutine test_findSameTarget #endif @test subroutine test_iterator_empty() type (Set), target :: s type (SetIterator) :: iter iter = s%begin() @assertFalse(associated(iter%value())) end subroutine test_iterator_empty @test subroutine test_eraseOne() type (Set), target :: s type (SetIterator) :: iter call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) iter = s%find(THREE) call s%erase(iter) @assertEqual(2, s%size()) @assertEqual(0, s%count(THREE)) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(FIVE)) end subroutine test_eraseOne ! In the case of containers of pointers, it is very difficult to know what ! is included in a range. Thus we copy the set and use it as a reference. @test subroutine test_eraseRange() type (Set), target :: s type (Set), target :: sCopy type (SetIterator) :: first type (SetIterator) :: last type (SetIterator) :: iter __type_declare_result, pointer :: q call s%insert(ONE) call s%insert(THREE) call s%insert(FOUR) call s%insert(FIVE) call sCopy%insert(ONE) call sCopy%insert(THREE) call sCopy%insert(FOUR) call sCopy%insert(FIVE) first = s%begin() call first%next() last = s%end() call last%prev() ! should delete THREE and FOUR (2 items) call s%erase(first, last) @assertTrue(first == last) @assertEqual(2, s%size()) iter = sCopy%begin() call iter%next() last = sCopy%end() call last%prev() do while (iter /= last) q => iter%value() @assertEqual(0, s%count(q)) call iter%next() end do end subroutine test_eraseRange @test subroutine test_eraseAll() type (Set), target :: s type (SetIterator) :: first type (SetIterator) :: last call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) first = s%begin() last = s%end() call s%erase(first, last) @assertEqual(0, s%size()) ! Iterator should now point to end of updated set. @assertTrue(first == s%end()) end subroutine test_eraseAll @test subroutine test_equalEmpty() type (Set) :: a, b @assertTrue(a == b) @assertFalse(a /= b) end subroutine test_equalEmpty @test subroutine test_equal() type (Set), target :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(ONE) call b%insert(TWO) @assertTrue(a == b) @assertFalse(a /= b) end subroutine test_equal @test subroutine test_notEqual() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call a%insert(FOUR) call b%insert(ONE) call b%insert(TWO) call b%insert(FIVE) @assertFalse(a == b) @assertTrue(a /= b) end subroutine test_notEqual subroutine test_deepCopy() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) b = a @assertTrue(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) @assertTrue(a /= b) end subroutine test_deepCopy ! Ensure that deep copy obliterates any state the variable on the ! LHS had prior to the assignment. @test subroutine test_deepCopy2() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(THREE) b = a @assertTrue(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) @assertTrue(a /= b) end subroutine test_deepCopy2 #include "templates/type_use_tokens_undef.inc" end module Test_`'param()Set #include "templates/tmpltail.inc" gFTL-1.2.7/tests/Set/include/000077500000000000000000000000001372124645500156465ustar00rootroot00000000000000gFTL-1.2.7/tests/Set/include/genericItems_decl.inc000066400000000000000000000013101372124645500217410ustar00rootroot00000000000000 __type_declare_local :: ONE __type_declare_local :: ONE_B __type_declare_local :: TWO __type_declare_local :: THREE __type_declare_local :: FOUR __type_declare_local :: FIVE #if defined(_pointer) & !defined(_procedure) # ifdef __type_allocatable_target # define __type_test_attrs , allocatable # else # define __type_test_attrs # endif __type_declare_target __type_test_attrs :: one_ __type_declare_target __type_test_attrs :: one_b_ __type_declare_target __type_test_attrs :: two_ __type_declare_target __type_test_attrs :: three_ __type_declare_target __type_test_attrs:: four_ __type_declare_target __type_test_attrs :: five_ # undef __type_test_attrs #endif gFTL-1.2.7/tests/Set/include/genericSetUpTearDown.inc000066400000000000000000000012641372124645500224050ustar00rootroot00000000000000 subroutine genericSetUp() __TYPE_INIT(ONE, _ONE, one_) ! __TYPE_INIT(ONE_B, _ONE_B, one_b_) __TYPE_INIT(TWO, _TWO, two_) __TYPE_INIT(THREE, _THREE, three_) __TYPE_INIT(FOUR, _FOUR, four_) __TYPE_INIT(FIVE, _FIVE, five_) end subroutine genericSetUp subroutine genericTearDown() __TYPE_FREE(ONE) ! __TYPE_FREE(ONE_B) __TYPE_FREE(TWO) __TYPE_FREE(THREE) __TYPE_FREE(FOUR) __TYPE_FREE(FIVE) #ifdef __type_allocatable_target deallocate(one_) ! deallocate(one_b_) deallocate(two_) deallocate(three_) deallocate(four_) deallocate(five_) #endif end subroutine genericTearDown gFTL-1.2.7/tests/Set/include/genericTestSet.inc000066400000000000000000000206351372124645500212770ustar00rootroot00000000000000 #define CHECK if(anyExceptions()) return #define _FILE 'genericTestSet.inc' #define ASSERT_EQUAL(a,b)call assertEqual(a,b,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_TRUE(a)call assertTrue(a,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_FALSE(a)call assertFalse(a,location=SourceLocation(_FILE,__LINE__)); CHECK #include #include #include contains #include "genericSetUpTearDown.inc" subroutine setUp() call genericSetUp() end subroutine setUp subroutine tearDown() call genericTearDown() end subroutine tearDown subroutine testIsEmpty() type (Set) :: s ASSERT_TRUE(s%empty()) end subroutine testIsEmpty subroutine testIsEmpty_notEmpty() type (Set) :: s call s%insert(ONE) ASSERT_FALSE(s%empty()) end subroutine testIsEmpty_notEmpty subroutine testSize_empty() type (Set) :: s ASSERT_EQUAL(0, s%size()) end subroutine testSize_empty subroutine testSize_simple() type (Set) :: s call s%insert(ONE) ASSERT_EQUAL(1, s%size()) call s%insert(TWO) ASSERT_EQUAL(2, s%size()) end subroutine testSize_simple subroutine testSize_duplicate() type (Set) :: s call s%insert(ONE) ASSERT_EQUAL(1, s%size()) call s%insert(TWO) ASSERT_EQUAL(2, s%size()) ! Insert a duplicate entry - should not modify call s%insert(ONE) ASSERT_EQUAL(2, s%size()) end subroutine testSize_duplicate subroutine testInsert_isNew() type (Set) :: s logical :: isNew call s%insert(ONE,isNew=isNew) ASSERT_TRUE(isNew) call s%insert(TWO, isNew=isNew) ASSERT_TRUE(isNew) call s%insert(ONE, isNew=isNew) ASSERT_FALSE(isNew) call s%insert(TWO, isNew=isNew) ASSERT_FALSE(isNew) end subroutine testInsert_isNew subroutine testCount() type (Set) :: s ASSERT_EQUAL(0, s%count(ONE)) ASSERT_EQUAL(0, s%count(TWO)) call s%insert(ONE) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(0, s%count(TWO)) call s%insert(TWO) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(1, s%count(TWO)) ! duplicate call s%insert(TWO) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(1, s%count(TWO)) end subroutine testCount #ifdef _pointer ! This test verifies that if two pointers are put in a Set ! they are treated as separate entries even if their targets ! have the same value. (But the targets are not the same object.) ! This test is only relevant for types with _pointer. subroutine test_findSameTarget() type (Set) :: s # ifdef __allocatable_target # define __test_attrs , allocatable # else # define __test_attrs # endif #define _ONE_ _ONE __declare_local :: pA __declare_local :: pB __declare_local :: pC __type_declare_target __test_attrs :: targA __type_declare_target __test_attrs :: targB __type_declare_target __test_attrs :: targC __type_declare_result, pointer :: qA, qB, qC type (Iterator) :: iterA, iterB, iterC logical :: isNew __INIT(pA, _ONE, targA) __INIT(pB, _ONE, targB) __INIT(pC, _ONE, targC) ASSERT_FALSE(associated(pA, pB)) call s%insert(pA) ASSERT_EQUAL(1, s%size()) call s%insert(pB, isNew=isNew) ASSERT_TRUE(isNew) ASSERT_EQUAL(2, s%size()) call s%insert(pC, isNew=isNew) ASSERT_TRUE(isNew) ASSERT_EQUAL(3, s%size()) iterA = s%find(pA) iterB = s%find(pB) iterC = s%find(pC) qA => iterA%value() qB => iterB%value() qC => iterC%value() ASSERT_FALSE(associated(qA, qB)) ASSERT_FALSE(associated(qA, qC)) ASSERT_FALSE(associated(qB, qC)) end subroutine test_findSameTarget #endif subroutine test_eraseOne() type (Set), target :: s type (Iterator) :: iter call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) iter = s%find(THREE) call s%erase(iter) ASSERT_EQUAL(2, s%size()) ASSERT_EQUAL(0, s%count(THREE)) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(1, s%count(FIVE)) end subroutine test_eraseOne ! In the case of containers of pointers, it is very difficult to know what ! is included in a range. Thus we copy the set and use it as a reference. subroutine test_eraseRange() type (Set) :: s type (Set) :: sCopy type (Iterator) :: first type (Iterator) :: last type (Iterator) :: iter __type_declare_result, pointer :: q call s%insert(ONE) call s%insert(THREE) call s%insert(FOUR) call s%insert(FIVE) call sCopy%insert(ONE) call sCopy%insert(THREE) call sCopy%insert(FOUR) call sCopy%insert(FIVE) first = s%begin() call first%next() last = s%end() call last%prev() call s%erase(first, last) ASSERT_TRUE(first == last) ASSERT_EQUAL(2, s%size()) iter = sCopy%begin() call iter%next() last = sCopy%end() call last%prev() do while (iter /= last) q => iter%value() ASSERT_EQUAL(0, s%count(q)) call iter%next() end do end subroutine test_eraseRange subroutine test_eraseAll() type (Set) :: s type (Iterator) :: first type (Iterator) :: last __type_declare_result, pointer :: q call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) first = s%begin() last = s%end() call s%erase(first, last) ASSERT_EQUAL(0, s%size()) ! Iterator should now point to end of updated set. ASSERT_TRUE(first == s%end()) end subroutine test_eraseAll subroutine test_equalEmpty() type (Set) :: a, b ASSERT_TRUE(a == b) ASSERT_FALSE(a /= b) end subroutine test_equalEmpty subroutine test_equal() type (Set), target :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(ONE) call b%insert(TWO) ASSERT_TRUE(a == b) ASSERT_FALSE(a /= b) end subroutine test_equal subroutine test_notEqual() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call a%insert(FOUR) call b%insert(ONE) call b%insert(TWO) call b%insert(FIVE) ASSERT_FALSE(a == b) ASSERT_TRUE(a /= b) end subroutine test_notEqual subroutine test_deepCopy() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) b = a ASSERT_TRUE(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) ASSERT_TRUE(a /= b) end subroutine test_deepCopy ! Ensure that deep copy obliterates any state the variable on the ! LHS had prior to the assignment. subroutine test_deepCopy2() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(THREE) b = a ASSERT_TRUE(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) ASSERT_TRUE(a /= b) end subroutine test_deepCopy2 function _suite() result(s) type (TestSuite) :: s s = newTestSuite(_suite_name) call add('testIsEmpty', testIsEmpty) call add('testIsEmpty_notEmpty', testIsEmpty_notEmpty) call add('testSize_empty', testSize_empty) call add('testSize_simple', testSize_simple) call add('testSize_duplicate', testSize_duplicate) call add('testInsert_isNew', testInsert_isNew) call add('testCount', testCount) #ifdef _pointer call add('test_findSameTarget', test_findSameTarget) #endif call add('test_eraseOne', test_eraseOne) call add('test_eraseRange', test_eraseRange) call add('test_eraseAll', test_eraseAll) call add('test_equalEmpty', test_equalEmpty) call add('test_equal', test_equal) call add('test_notEqual', test_notEqual) call add('test_deepCopy', test_deepCopy) call add('test_deepCopy2', test_deepCopy2) contains subroutine add(name, proc) character(len=*), intent(in) :: name interface subroutine proc() end subroutine proc end interface call s%addTest(newTestMethod(name, proc, setUp, tearDown)) end subroutine add end function _suite gFTL-1.2.7/tests/Set/setTestSuites.inc000066400000000000000000000020511372124645500175440ustar00rootroot00000000000000! Vary _type ADD_TEST_SUITE(Test_IntegerSet_mod_suite) ADD_TEST_SUITE(Test_RealSet_mod_suite) ADD_TEST_SUITE(Test_ComplexSet_mod_suite) ADD_TEST_SUITE(Test_Real64Set_mod_suite) ! Strings #ifdef SUPPORTS_POINTERS_TO_FIXED_LENGTH_STRINGS ADD_TEST_SUITE(Test_Character17Set_mod_suite) Test_Character17Set) #endif ! workaround for gfortran 4.9.1 #ifdef SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS !ADD_TEST_SUITE(Test_DeferredLengthStringSet_mod_suite) #endif ! pointers ... ADD_TEST_SUITE(Test_IntegerAllocSet_mod_suite) ADD_TEST_SUITE(Test_IntegerPtrSet_mod_suite) ! arrays ... ADD_TEST_SUITE(Test_Integer1dSet_mod_suite) ADD_TEST_SUITE(Test_Integer2dSet_mod_suite) ADD_TEST_SUITE(Test_Integer2dPtrSet_mod_suite) ADD_TEST_SUITE(Test_Integer2d_fixedExtentsSet_mod_suite) ! derived type ADD_TEST_SUITE(Test_FooSet_mod_suite) ADD_TEST_SUITE(Test_FooPtrSet_mod_suite) ADD_TEST_SUITE(Test_FooPolySet_mod_suite) ADD_TEST_SUITE(Test_FooPolyPtrSet_mod_suite) ! Unlimited polymorphic #ifndef __GFORTRAN__ ADD_TEST_SUITE(Test_unlimitedPolyPtrSet_mod_suite) #endif gFTL-1.2.7/tests/Set/testSuites.inc000066400000000000000000000001031372124645500170640ustar00rootroot00000000000000#include !#include gFTL-1.2.7/tests/Vector/000077500000000000000000000000001372124645500147325ustar00rootroot00000000000000gFTL-1.2.7/tests/Vector/.gitignore000066400000000000000000000000031372124645500167130ustar00rootroot00000000000000*~ gFTL-1.2.7/tests/Vector/CMakeLists.txt000066400000000000000000000041671372124645500175020ustar00rootroot00000000000000add_subdirectory (SUT) include_directories (${PFUNIT_TOP_DIR}/include) link_directories (${PFUNIT_TOP_DIR}/lib) set (src ${CMAKE_CURRENT_SOURCE_DIR}) set (bin ${CMAKE_CURRENT_BINARY_DIR}) set (types integer real real64 complex logical unlimitedPoly unlimitedPolyPtr integer1d integer2d integer2d_fixedExtents integerAlloc integerPtr integer2dPtr Foo FooPtr FooPoly FooPolyPtr ) set (SRCS Test_nested.pf) list(APPEND SRCS Test_vector_Allocatable.pf) if (SUPPORT_FOR_POINTERS_TO_FIXED_LENGTH_STRINGS) LIST (APPEND types character17) endif () if (SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS) LIST (APPEND types deferredLengthString) endif () foreach (type ${types} ) set (infile ${src}/Test_Vector.m4) set (pfunitfile Test_${type}Vector.pf) # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${pfunitfile} COMMAND ${M4} -s -Dparam=${type} -Dcompiler=${CMAKE_Fortran_COMPILER_ID} -I${GFTL_SOURCE_DIR}/include/templates < ${infile} > ${pfunitfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${bin}/${pfunitfile} ) set (infile ${src}/Test_VectorIterator.m4) set (pfunitfile Test_${type}VectorIterator.pf) add_custom_command ( OUTPUT ${pfunitfile} COMMAND ${M4} -s -Dparam=${type} -Dcompiler=${CMAKE_Fortran_COMPILER_ID} -I${GFTL_SOURCE_DIR}/include/templates < ${infile} > ${pfunitfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${bin}/${pfunitfile} ) endforeach () if(CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") if(CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 19) if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER 17) set_property(SOURCE Test_nested.F90 PROPERTY COMPILE_DEFINITIONS "__ifort_18") endif() endif() endif() add_pfunit_ctest (vector_tests TEST_SOURCES ${SRCS} LINK_LIBRARIES vectorSUT ) target_include_directories (vector_tests PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/include) target_include_directories (vector_tests PRIVATE ${GFTL_SOURCE_DIR}/include) add_dependencies (tests vector_tests) gFTL-1.2.7/tests/Vector/SUT/000077500000000000000000000000001372124645500154055ustar00rootroot00000000000000gFTL-1.2.7/tests/Vector/SUT/CMakeLists.txt000066400000000000000000000031451372124645500201500ustar00rootroot00000000000000set(src ${CMAKE_CURRENT_SOURCE_DIR}) set(bin ${CMAKE_CURRENT_BINARY_DIR}) set (instantiations "integer\;free" "real\;free" "real32\;free" "real64\;free" "complex\;free" "complex64\;free" "complex128\;free" "logical\;free" "deferredLengthString\;free" "unlimitedPoly\;free" "unlimitedPolyPtr\;free" "integer1d\;free" "integer2d\;free" "integer2d_fixedExtents\;free" "integerAlloc\;free" "integerPtr\;free" "integer2dPtr\;free" "integer\;fixed" "Foo\;free" "FooPtr\;free" "FooPoly\;free" "FooPolyPtr\;free" ) if (SUPPORT_FOR_POINTERS_TO_FIXED_LENGTH_STRINGS) LIST (APPEND instantiations "character17\;free") endif () set (SRCS) set (infile ${src}/Vector.m4) # Empty list - will append in loop below foreach (instantiation ${instantiations}) list (GET instantiation 0 type) list (GET instantiation 1 format) if (format STREQUAL "free") set (outfile ${type}Vector.F90) else () set (outfile ${type}Vector.F) endif () # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${outfile} COMMAND ${M4} -s -Dtype=${type} -Dformat=${format} < ${infile} > ${outfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${outfile} ) endforeach () list (APPEND SRCS MultiModule.F90) add_library(vectorSUT EXCLUDE_FROM_ALL STATIC ${SRCS}) target_include_directories (vectorSUT PUBLIC ${CMAKE_CURRENT_BINARY_DIR}) target_include_directories (vectorSUT PRIVATE ${PFUNIT_TOP_DIR}/include) target_link_libraries(vectorSUT type_test_values shared gftl) gFTL-1.2.7/tests/Vector/SUT/ImplicitProcedurePtrVector.F90000066400000000000000000000002261372124645500231610ustar00rootroot00000000000000#define _procedure #define _pointer module ImplicitProcedurePtrVector_mod #include end module ImplicitProcedurePtrVector_mod gFTL-1.2.7/tests/Vector/SUT/MultiModule.F90000066400000000000000000000003111372124645500201200ustar00rootroot00000000000000module vector_one #include #include end module vector_one module vector_two #include #include end module vector_two gFTL-1.2.7/tests/Vector/SUT/Vector.m4000066400000000000000000000003231372124645500171070ustar00rootroot00000000000000changecom() define(`suffix',ifelse(format(),free,,_fixedFormat)) module type()Vector`'suffix()_mod #include #include end module type()Vector`'suffix()_mod gFTL-1.2.7/tests/Vector/Test_Character17Vector.F90000066400000000000000000000005421372124645500214410ustar00rootroot00000000000000#include #define SUITE Test_Character17Vector #define SUITE_NAME 'Test_Character17Vector' module Test_Character17Vector_mod use pfunit_mod use Character17Vector_mod implicit none private #ifndef __INTEL_COMPILER public :: SUITE #include #endif end module Test_Character17Vector_mod gFTL-1.2.7/tests/Vector/Test_DeferredLengthStringVector.F90000066400000000000000000000006251372124645500234500ustar00rootroot00000000000000#include #define SUITE Test_DeferredLengthStringVector #define SUITE_NAME 'Test_DeferredLengthStringVector' module Test_DeferredLengthStringVector_mod use pfunit_mod use DeferredLengthStringVector_mod implicit none private #ifndef __GFORTRAN__ public :: SUITE #include #endif end module Test_DeferredLengthStringVector_mod gFTL-1.2.7/tests/Vector/Test_FooVector.F90000066400000000000000000000006341372124645500201220ustar00rootroot00000000000000#define _entry type(Foo) #define EQUAL_DEFINED #define SUITE Test_FooVector #define SUITE_NAME 'Test_FooVector' #define _ONE Foo(1) #define _TWO Foo(2) #define _THREE Foo(3) #define _FOUR Foo(4) #define _FIVE Foo(5) module Test_FooVector_mod use pFUnit_mod use Foo_mod use FooVector_mod implicit none private public :: SUITE #include end module Test_FooVector_mod gFTL-1.2.7/tests/Vector/Test_Integer1dVector.F90000066400000000000000000000004661372124645500212240ustar00rootroot00000000000000#include #define SUITE Test_Integer1dVector #define SUITE_NAME 'Test_Integer1dVector' module Test_Integer1dVector_mod use pfunit_mod use Integer1dVector_mod implicit none private public :: SUITE #include end module Test_Integer1dVector_mod gFTL-1.2.7/tests/Vector/Test_IntegerPtrVector.F90000066400000000000000000000004741372124645500214640ustar00rootroot00000000000000#include #define SUITE Test_IntegerPtrVector #define SUITE_NAME 'Test_IntegerPtrVector' module Test_IntegerPtrVector_mod use pfunit_mod use IntegerPtrVector_mod implicit none private public :: SUITE #include end module Test_IntegerPtrVector_mod gFTL-1.2.7/tests/Vector/Test_LogicalVector.F90000066400000000000000000000004531372124645500207500ustar00rootroot00000000000000#include #define SUITE Test_LogicalVector #define SUITE_NAME 'Test_LogicalVector' module Test_LogicalVector_mod use pfunit_mod use LogicalVector_mod implicit none private public :: SUITE #include end module Test_LogicalVector_mod gFTL-1.2.7/tests/Vector/Test_Real64Vector.F90000066400000000000000000000004451372124645500204340ustar00rootroot00000000000000module Test_Real64Vector_mod #include #define SUITE Test_Real64Vector #define SUITE_NAME 'Test_Real64Vector' use pfunit_mod use Real64Vector_mod implicit none private public :: SUITE #include end module Test_Real64Vector_mod gFTL-1.2.7/tests/Vector/Test_Vector.m4000066400000000000000000000515201372124645500174400ustar00rootroot00000000000000include(header.m4) module Test_`'param()Vector #include "types/param().inc" #include "type_test_values/param().inc" use, intrinsic :: iso_fortran_env, only: INT64 use funit, only: assertTrue, assertFalse use funit, only: TestSuite use funit, only: SourceLocation use funit, only: anyExceptions #ifdef _unlimited use pFUnitSupplement_mod, only: assertEqual #else use funit, only: assertEqual #endif use param()Vector_mod use fhamcrest #include "templates/type_set_use_tokens.inc" #include "templates/type_template_macros.inc" #include "templates/tmplbase.inc" #include "templates/type_testing_macros.inc" #include "genericItems_decl.inc" ! GFortran 8.2 namespace is "leaky" private :: assertEqual contains #include "genericSetUpTearDown.inc" @before subroutine setUp() call genericSetUp() end subroutine setUp @after subroutine tearDown() call genericTearDown() end subroutine tearDown subroutine testSizeEmpty() type (Vector), target :: v v = Vector() @assert_that(v%size(), is(0)) end subroutine testSizeEmpty subroutine testEmpty() type (Vector), target :: v v = Vector() @assertTrue(v%empty()) end subroutine testEmpty #ifndef __type_wrapped @test(ifndef=__type_wrapped) subroutine testCopyFromArray_notEmpty() type (Vector), target :: v v = [ONE] @assertFalse(v%empty()) end subroutine testCopyFromArray_notEmpty @test(ifndef=__type_wrapped) subroutine testCopyFromArray_size() type (Vector), target :: v v = [ONE,TWO] @assert_that(v%size(), is(2_INT64)) end subroutine testCopyFromArray_size #endif @test subroutine test_push_back_size() type (Vector), target :: v v = Vector() call v%push_back(ONE) @assert_that(v%size(), is(1_INT64)) call v%push_back(TWO) @assert_that(v%size(), is(2_INT64)) call v%push_back(THREE) @assert_that(v%size(), is(3_INT64)) call v%push_back(FOUR) @assert_that(v%size(), is(4_INT64)) call v%push_back(FIVE) @assert_that(v%size(), is(5_INT64)) end subroutine test_push_back_size ! front() should always return the 1st element, no matter how many ! pushes. @test subroutine test_push_back_front() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) q => v%front() @assertEqual(ONE, q) call v%push_back(TWO) @assertEqual(2, v%size()) q => v%front() @assertEqual(ONE, q) call v%push_back(THREE) @assertEqual(3, v%size()) q => v%front() @assertEqual(ONE, q) end subroutine test_push_back_front subroutine test_push_back_back() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) q => v%back() @assertEqual(ONE, q) call v%push_back(TWO) q => v%back() @assertEqual(TWO, q) call v%push_back(THREE) q => v%back() @assertEqual(THREE, q) call v%push_back(FOUR) q => v%back() @assertEqual(FOUR, q) call v%push_back(FIVE) q => v%back() @assertEqual(FIVE, q) end subroutine test_push_back_back ! If the vector shrinks, there might be issues with ! elements that already have values. @test subroutine test_push_back_shrink() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) q => v%back() @assertEqual(ONE, q) call v%push_back(TWO) q => v%back() @assertEqual(TWO, q) call v%push_back(THREE) q => v%back() @assertEqual(THREE, q) call v%resize(2) call v%push_back(FOUR) q => v%back() @assertEqual(FOUR, q) call v%resize(1) call v%push_back(FIVE) q => v%back() @assertEqual(FIVE, q) end subroutine test_push_back_shrink @test subroutine test_at() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%push_back(FIVE) q => v%at(1) @assertEqual(ONE, q) q => v%at(2) @assertEqual(TWO, q) q => v%at(3) @assertEqual(THREE, q) q => v%at(4) @assertEqual(FOUR, q) q => v%at(5) @assertEqual(FIVE, q) end subroutine test_at @test subroutine test_of() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%push_back(FIVE) q => v%of(1) @assertEqual(ONE, q) q => v%of(2) @assertEqual(TWO, q) q => v%of(3) @assertEqual(THREE, q) q => v%of(4) @assertEqual(FOUR, q) q => v%of(5) @assertEqual(FIVE, q) end subroutine test_of @test ! Disable if unlimitedPoly and using GFortran ifelse(param,unlimitedPoly,`ifelse(compiler,GNU,@disable)') subroutine test_get() type (Vector), target :: v __type_declare_component :: q v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%push_back(FIVE) __TYPE_ASSIGN(q, v%get(1)) @assertEqual(ONE, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(2)) @assertEqual(TWO, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(3)) @assertEqual(THREE, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(4)) @assertEqual(FOUR, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(5)) @assertEqual(FIVE, q) __TYPE_FREE(q) end subroutine test_get @test ! Disable if unlimitedPoly and using GFortran ifelse(param,unlimitedPoly,`ifelse(compiler,GNU,@disable)') subroutine test_get_negativeIndex() type (Vector), target :: v __type_declare_component :: q v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%push_back(FIVE) __TYPE_ASSIGN(q, v%get(0)) @assertEqual(FIVE, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(-1)) @assertEqual(FOUR, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(-2)) @assertEqual(THREE, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(-3)) @assertEqual(TWO, q) __TYPE_FREE(q) __TYPE_ASSIGN(q, v%get(-4)) @assertEqual(ONE, q) __TYPE_FREE(q) end subroutine test_get_negativeIndex ! Verify that non-poiter assignment of the return from at() does ! not modify the internal structure of the vector. ! This is really a test of the compiler not the implementation. ! The use case does not make sense for polymorphic targets, as assignment ! must reallocate the target and thus invalidate the pointer @test subroutine test_atModify() type (Vector), target :: v __type_declare_result, pointer :: q1, q2, qt v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(FOUR) q1 => v%at(1) qt => v%at(1) ! workaround for ifort 15 with Unlimited Polymorphic Entity #ifdef _allocatable ! Cannot do direct assignment of polymorphic targets. ! Allocation is always implied, even with F2008 allocate on ! assignment for polymorphic entities. This use case is a bit ! silly, but it does not hurt to include it. allocate(qt, source=ONE_B) #else qt = ONE_B #endif q2 => v%at(1) @assertTrue(associated(q1,q2)) end subroutine test_atModify ! Ensure that resizing uses the default value if ! provided. @test subroutine test_resizeGrow() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(FOUR) call v%resize(10, FIVE) @assertEqual(10, v%size()) q => v%at(4) @assertEqual(FIVE, q) q => v%at(5) @assertEqual(FIVE, q) q => v%at(10) @assertEqual(FIVE, q) end subroutine test_resizeGrow @test subroutine test_resizeShrink() type (Vector), target :: v __type_declare_result, pointer :: q v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%resize(2) @assertEqual(2, v%size()) q => v%at(1) @assertEqual(ONE, q) q => v%at(2) @assertEqual(TWO, q) end subroutine test_resizeShrink @test subroutine test_reserve_capacity() type (Vector), target :: v v = Vector() @assertTrue(0 <= v%capacity()) call v%push_back(ONE) @assertTrue(1 <= v%capacity()) call v%reserve(8) @assertTrue(8 <= v%capacity()) end subroutine test_reserve_capacity subroutine test_shrink_to_fit() type (Vector), target :: v v = Vector() call v%shrink_to_fit() @assertTrue(0 <= v%capacity()) call v%reserve(7) call v%push_back(ONE) call v%shrink_to_fit() @assertTrue(1 <= v%capacity()) call v%push_back(TWO) call v%shrink_to_fit() @assertTrue(2 <= v%capacity()) ! check to make certain vector still has correct elements @assertEqual(TWO, v%at(2)) end subroutine test_shrink_to_fit @test subroutine test_pop_back() type (Vector), target :: v v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%pop_back() @assertEqual(2, v%size()) @assertEqual(ONE, v%at(1)) @assertEqual(TWO, v%at(2)) end subroutine test_pop_back ! This test checks that an insertion to an empty container ! acts like push_back. @test subroutine test_insertEmpty() type (Vector) :: v v = Vector() call v%insert(1,value=FIVE) @assertEqual(1, v%size()) @assertEqual(FIVE, v%at(1)) end subroutine test_insertEmpty ! This test checks that an insertion at the beginning of the vector ! correctly adjusts the location of subsequest elements. @test ! Disable if unlimitedPoly and using GFortran ifelse(param,unlimitedPoly,`ifelse(compiler,GNU,@disable)') subroutine test_insertBeginning() type (Vector), target :: v v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%insert(1,value=FIVE) @assertEqual(4, v%size()) @assertEqual(FIVE, v%at(1)) @assertEqual(ONE, v%at(2)) @assertEqual(TWO, v%at(3)) @assertEqual(THREE, v%at(4)) end subroutine test_insertBeginning ! This test checks that an insertion into the middle of the vector ! correctly adjusts the location of subsequest elements. @test ! Disable if unlimitedPoly and using GFortran ifelse(param,unlimitedPoly,`ifelse(compiler,GNU,@disable)') subroutine test_insertMiddle() type (Vector) :: v v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%insert(2,value=FIVE) @assertEqual(4, v%size()) @assertEqual(FIVE, v%at(2)) @assertEqual(ONE, v%at(1)) @assertEqual(TWO, v%at(3)) @assertEqual(THREE, v%at(4)) end subroutine test_insertMiddle ! This test checks that an insertion at the end of the vector ! leaves other elements in place. @test subroutine test_insertEnd() type (Vector) :: v v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%insert(4,value=FIVE) @assertEqual(4, v%size()) @assertEqual(FIVE, v%at(4)) @assertEqual(ONE, v%at(1)) @assertEqual(TWO, v%at(2)) @assertEqual(THREE, v%at(3)) end subroutine test_insertEnd @test subroutine test_swap() type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(ONE) call v1%push_back(TWO) call v1%push_back(THREE) v2 = Vector() call v2%push_back(FOUR) call v2%push_back(FIVE) call swap(v1, v2) @assertEqual(2, v1%size()) @assertEqual(3, v2%size()) @assertEqual(FOUR, v1%at(1)) @assertEqual(FIVE, v1%at(2)) @assertEqual(ONE, v2%at(1)) @assertEqual(TWO, v2%at(2)) @assertEqual(THREE, v2%at(3)) end subroutine test_swap @test subroutine test_swap_method() type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(ONE) call v1%push_back(TWO) call v1%push_back(THREE) v2 = Vector() call v2%push_back(FOUR) call v2%push_back(FIVE) call v1%swap(v2) @assertEqual(2, v1%size()) @assertEqual(3, v2%size()) @assertEqual(FOUR, v1%at(1)) @assertEqual(FIVE, v1%at(2)) @assertEqual(ONE, v2%at(1)) @assertEqual(TWO, v2%at(2)) @assertEqual(THREE, v2%at(3)) end subroutine test_swap_method @test subroutine test_copy() type (Vector) :: v1, v2 __type_declare_result, pointer :: q v1 = Vector() call v1%push_back(ONE) call v1%push_back(THREE) call v1%push_back(FIVE) v2 = Vector() call v2%push_back(ONE) v1 = v2 @assertEqual(1, v1%size()) q => v1%at(1) @assertEqual(ONE, q) end subroutine test_copy @test subroutine test_clear() type (Vector) :: v v = Vector() call v%push_back(ONE) call v%push_back(THREE) call v%push_back(FIVE) call v%clear() @assertEqual(0, v%size()) end subroutine test_clear @test subroutine test_eraseOne() type (Vector) :: v type (VectorIterator) :: iter v = Vector() call v%push_back(ONE) call v%push_back(THREE) call v%push_back(FIVE) iter = v%begin() call iter%next() call v%erase(iter) @assertEqual(2, v%size()) @assertEqual(ONE, v%at(1)) @assertEqual(FIVE, v%at(2)) end subroutine test_eraseOne @test subroutine test_eraseRange() type (Vector) :: v type (VectorIterator) :: first type (VectorIterator) :: last v = Vector() call v%push_back(ONE) call v%push_back(THREE) call v%push_back(FIVE) first = v%begin() last = v%begin() call last%next() call last%next() call v%erase(first, last) @assertEqual(1, v%size()) @assertEqual(FIVE, v%at(1)) end subroutine test_eraseRange @test subroutine test_eraseToEnd() type (Vector) :: v type (VectorIterator) :: iter type (VectorIterator) :: last v = Vector() call v%push_back(ONE) call v%push_back(THREE) call v%push_back(FIVE) iter = v%begin() call iter%next() last = v%end() call v%erase(iter, last) @assertEqual(1, v%size()) @assertEqual(ONE, v%at(1)) ! Iterator should now point to end of updated vector. @assertTrue(iter == v%end()) end subroutine test_eraseToEnd @test subroutine test_eraseOneCheckIter() type (Vector), target :: v type (VectorIterator) :: iter v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) iter = v%begin() call iter%next() call v%erase(iter) @assertEqual(THREE, iter%get()) end subroutine test_eraseOneCheckIter @test subroutine test_erase_lastElement() type (Vector) :: v type (VectorIterator) :: iter v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) iter = v%begin() call iter%next() call iter%next() call v%erase(iter) @assertEqual(2, v%size()) @assertEqual(ONE, v%at(1)) @assertEqual(TWO, v%at(2)) end subroutine test_erase_lastElement ! This test is motivated by a runtime error experinced in gfortran ! with allocatable items. Deallocation was not happening for things ! off the tail of the vector. @test subroutine test_reuse_after_erase() type (Vector) :: v type (VectorIterator) :: first v = Vector() call v%push_back(ONE) first = v%begin() call v%erase(first) call v%push_back(ONE) @assertEqual(1, v%size()) @assertEqual(ONE, v%at(1)) end subroutine test_reuse_after_erase #ifdef _equal_defined @test(ifdef=_equal_defined) subroutine test_get_index() type (Vector) :: v v = Vector() call v%push_back(ONE) @assertEqual(1, v%get_index(ONE)) @assertEqual(0, v%get_index(TWO)) call v%push_back(TWO) @assertEqual(1, v%get_index(ONE)) @assertEqual(2, v%get_index(TWO)) end subroutine test_get_index #endif #ifdef _equal_defined @test(ifdef=_equal_defined) subroutine test_equal_empty() type (Vector) :: v v = Vector() @assertTrue(v == v) @assertFalse(v /= v) end subroutine test_equal_empty #endif #ifdef _equal_defined @test(ifdef=_equal_defined) subroutine test_equal_equal() type (Vector) :: v v = Vector() call v%push_back(ONE) call v%push_back(TWO) @assertTrue(v == v) @assertFalse(v /= v) end subroutine test_equal_equal #endif #ifdef _equal_defined @test(ifdef=_equal_defined) subroutine test_equal_unequal_size() type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(ONE) call v1%push_back(TWO) v2 = v1 call v2%push_back(THREE) @assertFalse(v1 == v2) @assertTrue(v1 /= v2) end subroutine test_equal_unequal_size #endif #ifdef _equal_defined @test(ifdef=_equal_defined) subroutine test_equal_unequal_element() type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(ONE) v2 = v1 call v1%push_back(TWO) call v2%push_back(THREE) @assertFalse(v1 == v2) @assertTrue(v1 /= v2) end subroutine test_equal_unequal_element #endif #ifdef __type_compare_well_defined @test(ifdef=__type_compare_well_defined) subroutine test_less_than_empty() type (Vector) :: v v = Vector() @assertFalse(v < v) @assertTrue(v >= v) end subroutine test_less_than_empty @test(ifdef=__type_compare_well_defined) subroutine test_less_than_same() type (Vector) :: v v = Vector() call v%push_back(ONE) @assertFalse(v < v) @assertTrue(v >= v) end subroutine test_less_than_same @test(ifdef=__type_compare_well_defined) subroutine test_less_than_different() type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(ONE) v2 = v1 call v2%push_back(TWO) ! TWO > ONE @assertTrue(v1 < v2) @assertFalse(v1 >= v2) call v1%push_back(TWO) call v1%push_back(THREE) ! THREE >= ONE @assertFalse(v1 < v2) @assertTrue(v1 >= v2) end subroutine test_less_than_different @test(ifdef=__type_compare_well_defined) subroutine test_greater_than_empty() type (Vector) :: v v = Vector() @assertFalse(v > v) @assertTrue(v <= v) end subroutine test_greater_than_empty @test(ifdef=__type_compare_well_defined) subroutine test_greater_than_same() type (Vector) :: v v = Vector() call v%push_back(ONE) @assertFalse(v > v) @assertTrue(v <= v) end subroutine test_greater_than_same @test(ifdef=__type_compare_well_defined) subroutine test_greater_than_different() type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(ONE) v2 = v1 call v2%push_back(TWO) ! TWO > ONE @assertFalse(v1 > v2) @assertTrue(v1 <= v2) call v1%push_back(TWO) call v1%push_back(THREE) ! THREE >= ONE @assertTrue(v1 > v2) @assertFalse(v1 <= v2) end subroutine test_greater_than_different #endif @test ! Disable if unlimitedPoly and using GFortran ifelse(param,unlimitedPoly,`ifelse(compiler,GNU,@disable)') subroutine test_set() type (Vector) :: v call v%push_back(ONE) call v%push_back(TWO) call v%set(1, THREE) @assertEqual(2, v%size()) @assertEqual(THREE, v%get(1)) @assertEqual(TWO, v%get(2)) #ifdef _pointer block __type_declare_result, pointer :: q ! Check that pointer is changed, not just target. q => v%at(1) @assertFalse(associated(ONE, q)) @assertTrue(associated(THREE, q)) end block #endif end subroutine test_set @test ! Disable if unlimitedPoly and using GFortran ifelse(param,unlimitedPoly,`ifelse(compiler,GNU,@disable)') subroutine test_set_back() type (Vector) :: v call v%push_back(ONE) call v%push_back(TWO) call v%set(0, THREE) @assertEqual(2, v%size()) @assertEqual(ONE, v%get(1)) @assertEqual(THREE, v%get(2)) end subroutine test_set_back #include "templates/type_use_tokens_undef.inc" end module Test_`'param()Vector #include "templates/tmpltail.inc" gFTL-1.2.7/tests/Vector/Test_VectorIterator.m4000066400000000000000000000245631372124645500211610ustar00rootroot00000000000000include(header.m4) #include "templates/unused.inc" module Test_`'param()VectorIterator #include "types/param().inc" #include "type_test_values/param().inc" use funit, only: assertTrue, assertFalse use funit, only: TestSuite use funit, only: SourceLocation use funit, only: anyExceptions #ifdef _unlimited use pFUnitSupplement_mod, only: assertEqual #else use funit, only: assertEqual #endif use param()Vector_mod #include "templates/type_set_use_tokens.inc" #include "templates/type_template_macros.inc" #include "templates/tmplbase.inc" #include "templates/type_testing_macros.inc" #include "genericItems_decl.inc" type (Vector), target :: v ! GFortran 8.2 namespace is "leaky" private :: assertEqual contains #include @before subroutine setUp() call genericSetUp() v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%push_back(FIVE) end subroutine setUp @after subroutine tearDown() call v%clear() call genericTearDown() end subroutine tearDown @test subroutine test_Begin() type (VectorIterator) :: iter iter = v%begin() @assertEqual(ONE, iter%get()) end subroutine test_Begin ! Cannot test functionality of end() directly, so for now ! just ensure that the interface exists. ! The end() iterator cannot be dereferenced. @test subroutine test_End() type (VectorIterator) :: iter iter = v%end() _UNUSED_DUMMY(iter) end subroutine test_End @test subroutine test_Next() type (VectorIterator) :: iter iter = v%begin() call iter%next() @assertEqual(TWO, iter%get()) call iter%next() @assertEqual(THREE, iter%get()) end subroutine test_Next @test subroutine test_Previous() type (VectorIterator) :: iter iter = v%begin() ! ONE call iter%next() ! TWO call iter%next() ! THREE call iter%previous() ! back to TWO @assertEqual(TWO, iter%get()) call iter%previous() ! back to ONE @assertEqual(ONE, iter%get()) end subroutine test_Previous ! Check to make certain that get() can return a ptr that can be ! subsequently used. Exposes error with ifort 15 for const length ! strings. @test subroutine test_get_ptr() type (VectorIterator) :: iter __type_declare_result, pointer :: q iter = v%begin() q => iter%get() @assertTrue(associated(q)) @assertEqual(ONE, q) end subroutine test_get_ptr @test subroutine test_LessThan() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() @assertFalse(iter1 < iter2) call iter2%next() @assertTrue(iter1 < iter2) call iter1%next() call iter1%next() @assertFalse(iter1 < iter2) end subroutine test_LessThan @test subroutine test_LessThanOrEqual() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() @assertTrue(iter1 <= iter2) call iter2%next() @assertTrue(iter1 <= iter2) call iter1%next() call iter1%next() @assertFalse(iter1 <= iter2) end subroutine test_LessThanOrEqual @test subroutine test_GreaterThan() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() @assertFalse(iter1 > iter2) call iter2%next() @assertFalse(iter1 > iter2) call iter1%next() call iter1%next() @assertTrue(iter1 > iter2) end subroutine test_GreaterThan @test subroutine test_GreaterThanOrEqual() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() @assertTrue(iter1 >= iter2) call iter2%next() @assertFalse(iter1 >= iter2) call iter1%next() call iter1%next() @assertTrue(iter1 >= iter2) end subroutine test_GreaterThanOrEqual @test subroutine test_Equal() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() @assertTrue(iter1 == iter2) @assertFalse(iter1 /= iter2) call iter1%next() @assertFalse(iter1 == iter2) @assertTrue(iter1 /= iter2) call iter2%next() @assertTrue(iter1 == iter2) @assertFalse(iter1 /= iter2) call iter2%next() @assertFalse(iter1 == iter2) @assertTrue(iter1 /= iter2) call iter1%next() @assertTrue(iter1 == iter2) @assertFalse(iter1 /= iter2) end subroutine test_Equal ! This test is to show a more realistic use case ! for iterators. @test subroutine test_IterationCount() type (VectorIterator) :: iter integer :: count count = 0 iter = v%begin() do while (iter /= v%end()) count = count + 1 call iter%next() end do @assertEqual(count, v%size()) end subroutine test_IterationCount @test subroutine test_ValidIteratorAfterVectorSwap() type (VectorIterator) :: i1, i2 type (Vector), target :: v1, v2 v1 = Vector() call v1%push_back(TWO) call v1%push_back(THREE) call v1%push_back(FIVE) v2 = Vector() call v2%push_back(ONE) call v2%push_back(FOUR) call v2%push_back(ONE) i1 = v1%begin() i2 = v2%begin() call swap(v1, v2) @assertEqual(TWO, i1%get()) call i1%next() @assertEqual(THREE, i1%get()) ! Now check the other side of the swap @assertEqual(ONE, i2%get()) call i2%next() @assertEqual(FOUR, i2%get()) end subroutine test_ValidIteratorAfterVectorSwap @test subroutine test_Rbegin() type (VectorRiterator) :: iter iter = v%rbegin() @assertEqual(FIVE, iter%get()) end subroutine test_Rbegin ! Cannot test functionality of rEnd() directly, so for now ! just ensure that the interface exists. ! The rEnd() iterator cannot be dereferenced. @test subroutine test_Rend() type (VectorRiterator) :: iter iter = v%rend() _UNUSED_DUMMY(iter) end subroutine test_Rend @test subroutine test_Rnext() type (VectorRiterator) :: iter iter = v%rbegin() call iter%next() @assertEqual(FOUR, iter%get()) call iter%next() @assertEqual(THREE, iter%get()) end subroutine test_Rnext @test subroutine test_Rprevious() type (VectorRiterator) :: iter iter = v%rbegin() ! FIVE call iter%next() ! FOUR call iter%next() ! THREE call iter%previous() ! FOUR @assertEqual(FOUR, iter%get()) end subroutine test_Rprevious @test subroutine test_REqual() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() @assertTrue(iter1 == iter2) @assertFalse(iter1 /= iter2) end subroutine test_REqual @test subroutine test_RLessThan() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() @assertFalse(iter1 < iter2) call iter2%next() @assertTrue(iter1 < iter2) call iter1%next() call iter1%next() @assertFalse(iter1 < iter2) end subroutine test_RLessThan @test subroutine test_RLessThanOrEqual() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() @assertTrue(iter1 <= iter2) call iter2%next() @assertTrue(iter1 <= iter2) call iter1%next() call iter1%next() @assertFalse(iter1 <= iter2) end subroutine test_RLessThanOrEqual @test subroutine test_RGreaterThan() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() @assertFalse(iter1 > iter2) call iter2%next() @assertFalse(iter1 > iter2) call iter1%next() call iter1%next() @assertTrue(iter1 > iter2) end subroutine test_RGreaterThan @test subroutine test_RGreaterThanOrEqual() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() @assertTrue(iter1 >= iter2) call iter2%next() @assertFalse(iter1 >= iter2) call iter1%next() call iter1%next() @assertTrue(iter1 >= iter2) end subroutine test_RGreaterThanOrEqual @test subroutine test_ValidRIteratorAfterVectorSwap() type (VectorRiterator) :: i1, i2 type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(TWO) call v1%push_back(THREE) call v1%push_back(FIVE) v2 = Vector() call v2%push_back(ONE) call v2%push_back(FOUR) call v2%push_back(ONE) i1 = v1%rBegin() i2 = v2%rBegin() call swap(v1, v2) @assertEqual(FIVE, i1%get()) call i1%next() @assertEqual(THREE, i1%get()) ! Now check the other side of the swap call swap(v1, v2) @assertEqual(ONE, i2%get()) call i2%next() @assertEqual(FOUR, i2%get()) end subroutine test_ValidRIteratorAfterVectorSwap ! This test is to show a more realistic use case ! for iterators. @test subroutine test_rIterationCount() type (VectorRiterator) :: iter integer :: count count = 0 iter = v%rbegin() do while (iter /= v%rend()) count = count + 1 call iter%next end do @assertEqual(count, v%size()) end subroutine test_rIterationCount @test subroutine test_At() type (VectorIterator) :: iter iter = v%begin() call iter%next() @assertEqual(TWO, iter%at( )) @assertEqual(TWO, iter%at( 0)) @assertEqual(ONE, iter%at(-1)) @assertEqual(THREE, iter%at(+1)) end subroutine test_At @test subroutine test_Rat() type (VectorRiterator) :: iter iter = v%rbegin() call iter%next() @assertEqual(FOUR, iter%at( )) @assertEqual(FOUR, iter%at( 0)) @assertEqual(FIVE, iter%at(-1)) end subroutine test_Rat @test subroutine test_Add() type (VectorIterator) :: iter iter = v%begin() + 2 @assertEqual(THREE, iter%at()) end subroutine test_Add @test subroutine test_rAdd() type (VectorRiterator) :: iter iter = v%rbegin() + 2 @assertEqual(THREE, iter%at()) end subroutine test_rAdd #include "templates/type_use_tokens_undef.inc" end module Test_`'param()VectorIterator #include "templates/tmpltail.inc" gFTL-1.2.7/tests/Vector/Test_nested.pf000066400000000000000000000020161372124645500175410ustar00rootroot00000000000000module A_mod #include #define _vector IntegerVector #include #undef _equal_defined #undef _less_than_defined end module A_mod module B_mod use A_mod, only: IntegerVector #define _value class(IntegerVector) #define _value_allocatable #include #define _alt #include end module B_mod ! 7/6/2018 Under Intel 18, some nested compilers were triggering a compiler bug ! which is reladet to having a type-bound ASSIGNMENT(=) procedure. A simplified ! reproducer has been submitted to Intel, and 19 beta no longer has the issue. module Test_Nested use funit use A_mod use B_mod @suite(name='test_nested_suite') contains subroutine test_nested_vector() implicit none type (IntegerVector) :: v type (Map), target :: m call v%push_back(1) call m%insert('foo', v) @assertTrue(associated(m%at('foo'))) end subroutine test_nested_vector end module Test_Nested gFTL-1.2.7/tests/Vector/Test_vector_Allocatable.pf000066400000000000000000000016011372124645500220430ustar00rootroot00000000000000! If a container is for allocatable entities, then gFTL should enable ! external pointers into the structure to persist even when the ! container is modified. This relies on Fortran's move_alloc() ! behavior, and thus cannot be supported for non allocatable container ! elements. module Test_vector_Allocatable use funit use FooPolyVector_mod use Foo_mod contains @test subroutine test_insert() type (Vector), target :: v class (Foo), pointer :: p1, p2 call v%push_back(Foo(1)) p1 => v%at(1) call v%insert(1, Foo(2)) ! Verify that 1st element has changed p2 => v%at(1) @assertEqual(2, p2%i) ! Verify that p1 still points at correct target @assertEqual(1, p1%i) p2 => v%at(2) @assertEqual(1, p2%i) @assertTrue(associated(p1, p2)) end subroutine test_insert end module Test_vector_Allocatable gFTL-1.2.7/tests/Vector/include/000077500000000000000000000000001372124645500163555ustar00rootroot00000000000000gFTL-1.2.7/tests/Vector/include/genericItems_decl.inc000066400000000000000000000013101372124645500224500ustar00rootroot00000000000000 __type_declare_local :: ONE __type_declare_local :: ONE_B __type_declare_local :: TWO __type_declare_local :: THREE __type_declare_local :: FOUR __type_declare_local :: FIVE #if defined(_pointer) & !defined(_procedure) # ifdef __type_allocatable_target # define __type_test_attrs , allocatable # else # define __type_test_attrs # endif __type_declare_target __type_test_attrs :: one_ __type_declare_target __type_test_attrs :: one_b_ __type_declare_target __type_test_attrs :: two_ __type_declare_target __type_test_attrs :: three_ __type_declare_target __type_test_attrs:: four_ __type_declare_target __type_test_attrs :: five_ # undef __type_test_attrs #endif gFTL-1.2.7/tests/Vector/include/genericSetUpTearDown.inc000066400000000000000000000012611372124645500231110ustar00rootroot00000000000000 subroutine genericSetUp() __TYPE_INIT(ONE, _ONE, one_) __TYPE_INIT(ONE_B, _ONE_B, one_b_) __TYPE_INIT(TWO, _TWO, two_) __TYPE_INIT(THREE, _THREE, three_) __TYPE_INIT(FOUR, _FOUR, four_) __TYPE_INIT(FIVE, _FIVE, five_) end subroutine genericSetUp subroutine genericTearDown() __TYPE_FREE(ONE) __TYPE_FREE(ONE_B) __TYPE_FREE(TWO) __TYPE_FREE(THREE) __TYPE_FREE(FOUR) __TYPE_FREE(FIVE) #ifdef __type_allocatable_target deallocate(one_) deallocate(one_b_) deallocate(two_) deallocate(three_) deallocate(four_) deallocate(five_) #endif end subroutine genericTearDown gFTL-1.2.7/tests/Vector/include/genericTestVector.inc000066400000000000000000000065531372124645500225200ustar00rootroot00000000000000 #define CHECK if(anyExceptions()) return #define _FILE 'genericTestVector.inc' #define ASSERT_EQUAL(a,b)call assertEqual(a,b,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_TRUE(a)call assertTrue(a,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_FALSE(a)call assertFalse(a,location=SourceLocation(_FILE,__LINE__)); CHECK #include #ifdef _wrapentry #define _local _wrapentry #else #define _local _entry, pointer #endif #ifdef _wrapentry _wrapentry :: ONE _wrapentry :: TWO _wrapentry :: THREE _wrapentry :: FOUR _wrapentry :: FIVE #else _entry :: ONE _entry :: TWO _entry :: THREE _entry :: FOUR _entry :: FIVE #endif #ifdef _logical interface assertEqual module procedure assertEqual_logical end interface assertEqual #endif contains #ifdef _logical subroutine assertEqual_logical(a, b, message, location) logical, intent(in) :: a logical, intent(in) :: b character(len=*), optional, intent(in) :: message type (SourceLocation), optional, intent(in) :: location call assertTrue(a .eqv. b, message=message, location=location) end subroutine assertEqual_logical #endif subroutine setUp() #ifdef _pointer allocate(ONE, source=_ONE) allocate(TWO, source=_TWO) allocate(THREE, source=_THREE) allocate(FOUR, source=_FOUR) allocate(FIVE, source=_FIVE) #else ONE = _ONE two = _TWO three = _THREE four = _FOUR five = _FIVE #endif end subroutine setUp subroutine tearDown() #ifdef _pointer deallocate(ONE) deallocate(TWO) deallocate(THREE) deallocate(FOUR) deallocate(FIVE) #endif end subroutine tearDown subroutine testSizeEmpty() type (Vector) :: v v = Vector() ASSERT_EQUAL(0, v%size()) end subroutine testSizeEmpty subroutine testEmpty() type (Vector) :: v v = Vector() ASSERT_TRUE(v%empty()) end subroutine testEmpty #ifndef _wrapentry subroutine testCopyFromArray_notEmpty() type (Vector) :: v v = [ONE] ASSERT_FALSE(v%empty()) end subroutine testCopyFromArray_notEmpty #endif #ifndef _wrapentry subroutine testCopyFromArray_size() type (Vector) :: v v = [ONE,TWO] ASSERT_EQUAL(2, v%size()) end subroutine testCopyFromArray_size #endif subroutine test_push_back() type (Vector) :: v _retentry, pointer :: q v = Vector() call v%push_back(ONE) ASSERT_EQUAL(1, v%size()) q => v%at(1) ASSERT_EQUAL(ONE, q) call v%push_back(TWO) ASSERT_EQUAL(2, v%size()) q => v%at(2) ASSERT_EQUAL(TWO, q) end subroutine test_push_back function SUITE() result(s) type (TestSuite) :: s s = newTestSuite(SUITE_NAME) call s%addTest(newTestMethod('testSizeEmpty', testSizeEmpty, & & setUp, tearDown)) call s%addTest(newTestMethod('testEmpty', testSizeEmpty, & & setUp, tearDown)) #ifndef _wrapentry call s%addTest(newTestMethod('testCopyFromArray_notEmpty', testCopyFromArray_notEmpty, & & setUp, tearDown)) call s%addTest(newTestMethod('testCopyFromArray_size', testCopyFromArray_size, & & setUp, tearDown)) #endif call s%addTest(newTestMethod('test_push_back', test_push_back, & & setUp, tearDown)) end function SUITE gFTL-1.2.7/tests/Vector/include/genericTestVectorIterator.inc000066400000000000000000000316111372124645500242230ustar00rootroot00000000000000 #define CHECK if(anyExceptions()) return #define _FILE 'genericTestVectorIterator.inc' #define ASSERT_EQUAL(a,b)call assertEqual(a,b,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_TRUE(a)call assertTrue(a,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_FALSE(a)call assertFalse(a,location=SourceLocation(_FILE,__LINE__)); CHECK #include #include #include type (Vector) :: v contains #include subroutine setUp() call genericSetUp() v = Vector() call v%push_back(ONE) call v%push_back(TWO) call v%push_back(THREE) call v%push_back(FOUR) call v%push_back(FIVE) end subroutine setUp subroutine tearDown() call v%clear() call genericTearDown() end subroutine tearDown subroutine test_Begin() type (VectorIterator) :: iter iter = v%begin() ASSERT_EQUAL(ONE, iter%get()) end subroutine test_Begin ! Cannot test functionality of end() directly, so for now ! just ensure that the interface exists. ! The end() iterator cannot be dereferenced. subroutine test_End() type (VectorIterator) :: iter iter = v%end() end subroutine test_End subroutine test_Next() type (VectorIterator) :: iter iter = v%begin() call iter%next() ASSERT_EQUAL(TWO, iter%get()) call iter%next() ASSERT_EQUAL(THREE, iter%get()) end subroutine test_Next subroutine test_Previous() type (VectorIterator) :: iter iter = v%begin() ! ONE call iter%next() ! TWO call iter%next() ! THREE call iter%previous() ! back to TWO ASSERT_EQUAL(TWO, iter%get()) call iter%previous() ! back to ONE ASSERT_EQUAL(ONE, iter%get()) end subroutine test_Previous ! Check to make certain that get() can return a ptr that can be ! subsequently used. Exposes error with ifort 15 for const length ! strings. subroutine test_get_ptr() type (VectorIterator) :: iter __type_declare_result, pointer :: q iter = v%begin() q => iter%get() ASSERT_TRUE(associated(q)) ASSERT_EQUAL(ONE, q) end subroutine test_get_ptr subroutine test_LessThan() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() ASSERT_FALSE(iter1 < iter2) call iter2%next() ASSERT_TRUE(iter1 < iter2) call iter1%next() call iter1%next() ASSERT_FALSE(iter1 < iter2) end subroutine test_LessThan subroutine test_LessThanOrEqual() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() ASSERT_TRUE(iter1 <= iter2) call iter2%next() ASSERT_TRUE(iter1 <= iter2) call iter1%next() call iter1%next() ASSERT_FALSE(iter1 <= iter2) end subroutine test_LessThanOrEqual subroutine test_GreaterThan() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() ASSERT_FALSE(iter1 > iter2) call iter2%next() ASSERT_FALSE(iter1 > iter2) call iter1%next() call iter1%next() ASSERT_TRUE(iter1 > iter2) end subroutine test_GreaterThan subroutine test_GreaterThanOrEqual() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() ASSERT_TRUE(iter1 >= iter2) call iter2%next() ASSERT_FALSE(iter1 >= iter2) call iter1%next() call iter1%next() ASSERT_TRUE(iter1 >= iter2) end subroutine test_GreaterThanOrEqual subroutine test_Equal() type (VectorIterator) :: iter1, iter2 iter1 = v%begin() iter2 = v%begin() ASSERT_TRUE(iter1 == iter2) ASSERT_FALSE(iter1 /= iter2) call iter1%next() ASSERT_FALSE(iter1 == iter2) ASSERT_TRUE(iter1 /= iter2) call iter2%next() ASSERT_TRUE(iter1 == iter2) ASSERT_FALSE(iter1 /= iter2) call iter2%next() ASSERT_FALSE(iter1 == iter2) ASSERT_TRUE(iter1 /= iter2) call iter1%next() ASSERT_TRUE(iter1 == iter2) ASSERT_FALSE(iter1 /= iter2) end subroutine test_Equal ! This test is to show a more realistic use case ! for iterators. subroutine test_IterationCount() type (VectorIterator) :: iter integer :: count count = 0 iter = v%begin() do while (iter /= v%end()) count = count + 1 call iter%next end do ASSERT_EQUAL(v%size(), count) end subroutine test_IterationCount subroutine test_ValidIteratorAfterVectorSwap() type (VectorIterator) :: i1, i2 type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(TWO) call v1%push_back(THREE) call v1%push_back(FIVE) v2 = Vector() call v2%push_back(ONE) call v2%push_back(FOUR) call v2%push_back(ONE) i1 = v1%begin() i2 = v2%begin() call swap(v1, v2) ASSERT_EQUAL(TWO, i1%get()) call i1%next() ASSERT_EQUAL(THREE, i1%get()) ! Now check the other side of the swap ASSERT_EQUAL(ONE, i2%get()) call i2%next() ASSERT_EQUAL(FOUR, i2%get()) end subroutine test_ValidIteratorAfterVectorSwap subroutine test_Rbegin() type (VectorRiterator) :: iter iter = v%rbegin() ASSERT_EQUAL(FIVE, iter%get()) end subroutine test_Rbegin ! Cannot test functionality of rEnd() directly, so for now ! just ensure that the interface exists. ! The rEnd() iterator cannot be dereferenced. subroutine test_Rend() type (VectorRiterator) :: iter iter = v%rend() end subroutine test_Rend subroutine test_Rnext() type (VectorRiterator) :: iter iter = v%rbegin() call iter%next() ASSERT_EQUAL(FOUR, iter%get()) call iter%next() ASSERT_EQUAL(THREE, iter%get()) end subroutine test_Rnext subroutine test_Rprevious() type (VectorRiterator) :: iter iter = v%rbegin() ! FIVE call iter%next() ! FOUR call iter%next() ! THREE call iter%previous() ! FOUR ASSERT_EQUAL(FOUR, iter%get()) end subroutine test_Rprevious subroutine test_REqual() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() ASSERT_TRUE(iter1 == iter2) ASSERT_FALSE(iter1 /= iter2) end subroutine test_REqual subroutine test_RLessThan() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() ASSERT_FALSE(iter1 < iter2) call iter2%next() ASSERT_TRUE(iter1 < iter2) call iter1%next() call iter1%next() ASSERT_FALSE(iter1 < iter2) end subroutine test_RLessThan subroutine test_RLessThanOrEqual() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() ASSERT_TRUE(iter1 <= iter2) call iter2%next() ASSERT_TRUE(iter1 <= iter2) call iter1%next() call iter1%next() ASSERT_FALSE(iter1 <= iter2) end subroutine test_RLessThanOrEqual subroutine test_RGreaterThan() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() ASSERT_FALSE(iter1 > iter2) call iter2%next() ASSERT_FALSE(iter1 > iter2) call iter1%next() call iter1%next() ASSERT_TRUE(iter1 > iter2) end subroutine test_RGreaterThan subroutine test_RGreaterThanOrEqual() type (VectorRiterator) :: iter1, iter2 iter1 = v%rbegin() iter2 = v%rbegin() ASSERT_TRUE(iter1 >= iter2) call iter2%next() ASSERT_FALSE(iter1 >= iter2) call iter1%next() call iter1%next() ASSERT_TRUE(iter1 >= iter2) end subroutine test_RGreaterThanOrEqual subroutine test_ValidRIteratorAfterVectorSwap() type (VectorRiterator) :: i1, i2 type (Vector) :: v1, v2 v1 = Vector() call v1%push_back(TWO) call v1%push_back(THREE) call v1%push_back(FIVE) v2 = Vector() call v2%push_back(ONE) call v2%push_back(FOUR) call v2%push_back(ONE) i1 = v1%rBegin() i2 = v2%rBegin() call swap(v1, v2) ASSERT_EQUAL(FIVE, i1%get()) call i1%next() ASSERT_EQUAL(THREE, i1%get()) ! Now check the other side of the swap call swap(v1, v2) ASSERT_EQUAL(ONE, i2%get()) call i2%next() ASSERT_EQUAL(FOUR, i2%get()) end subroutine test_ValidRIteratorAfterVectorSwap ! This test is to show a more realistic use case ! for iterators. subroutine test_rIterationCount() type (VectorRiterator) :: iter integer :: count count = 0 iter = v%rbegin() do while (iter /= v%rend()) count = count + 1 call iter%next end do ASSERT_EQUAL(v%size(), count) end subroutine test_rIterationCount subroutine test_At() type (VectorIterator) :: iter iter = v%begin() call iter%next() ASSERT_EQUAL(TWO, iter%at( )) ASSERT_EQUAL(TWO, iter%at( 0)) ASSERT_EQUAL(ONE, iter%at(-1)) ASSERT_EQUAL(THREE, iter%at(+1)) end subroutine test_At subroutine test_Rat() type (VectorRiterator) :: iter iter = v%rbegin() call iter%next() ASSERT_EQUAL(FOUR, iter%at( )) ASSERT_EQUAL(FOUR, iter%at( 0)) ASSERT_EQUAL(FIVE, iter%at(-1)) end subroutine test_Rat subroutine test_Add() type (VectorIterator) :: iter iter = v%begin() + 2 ASSERT_EQUAL(THREE, iter%at()) end subroutine test_Add subroutine test_rAdd() type (VectorRiterator) :: iter iter = v%rbegin() + 2 ASSERT_EQUAL(THREE, iter%at()) end subroutine test_rAdd function _suite() result(s) type (TestSuite) :: s s = newTestSuite(_suite_name) call addForwardIteratorTests() call addReverseIteratorTests() contains subroutine addForwardIteratorTests() call s%addTest(newTestMethod('test_Begin', test_Begin, setUp, tearDown)) call s%addTest(newTestMethod('test_End', test_End, setUp, tearDown)) call s%addTest(newTestMethod('test_Next', test_Next, setUp, tearDown)) call s%addTest(newTestMethod('test_Previous', test_Previous, setUp, tearDown)) call s%addTest(newTestMethod('test_get_ptr', test_get_ptr, setUp, tearDown)) ! Relational tests call s%addTest(newTestMethod('test_LessThan', test_LessThan, setUp, tearDown)) call s%addTest(newTestMethod('test_LessThanOrEqual', test_LessThanOrEqual, & & setUp, tearDown)) call s%addTest(newTestMethod('test_GreaterThan', test_GreaterThan, setUp, tearDown)) call s%addTest(newTestMethod('test_GreaterThanOrEqual', test_GreaterThanOrEqual, & & setUp, tearDown)) call s%addTest(newTestMethod('test_Equal', test_Equal, setUp, tearDown)) call s%addTest(newTestMethod('test_IterationCount', test_IterationCount, & & setUp, tearDown)) call s%addTest(newTestMethod('test_ValidIteratorAfterVectorSwap', & & test_ValidIteratorAfterVectorSwap, & & setUp, tearDown)) call s%addTest(newTestMethod('test_at', test_at, setUp, tearDown)) call s%addTest(newTestMethod('test_add', test_add, setUp, tearDown)) end subroutine addForwardIteratorTests subroutine addReverseIteratorTests() call s%addTest(newTestMethod('test_rBegin', test_rBegin, setUp, tearDown)) call s%addTest(newTestMethod('test_rEnd', test_rEnd, setUp, tearDown)) call s%addTest(newTestMethod('test_rNext', test_rNext, setUp, tearDown)) call s%addTest(newTestMethod('test_rPrevious', test_rPrevious, setUp, tearDown)) ! Relational tests call s%addTest(newTestMethod('test_rLessThan', test_rLessThan, setUp, tearDown)) call s%addTest(newTestMethod('test_rLessThanOrEqual', test_rLessThanOrEqual, & & setUp, tearDown)) call s%addTest(newTestMethod('test_rGreaterThan', test_rGreaterThan, setUp, tearDown)) call s%addTest(newTestMethod('test_rGreaterThanOrEqual', test_rGreaterThanOrEqual, & & setUp, tearDown)) call s%addTest(newTestMethod('test_rEqual', test_rEqual, setUp, tearDown)) call s%addTest(newTestMethod('test_rIterationCount', test_rIterationCount, & & setUp, tearDown)) call s%addTest(newTestMethod('test_ValidRIteratorAfterVectorSwap', & & test_ValidRIteratorAfterVectorSwap, & & setUp, tearDown)) call s%addTest(newTestMethod('test_rat', test_rat, setUp, tearDown)) call s%addTest(newTestMethod('test_radd', test_radd, setUp, tearDown)) end subroutine addReverseIteratorTests end function _suite gFTL-1.2.7/tests/Vector/testSuites.inc000066400000000000000000000001101372124645500175710ustar00rootroot00000000000000#include #include gFTL-1.2.7/tests/Vector/vectorIteratorTestSuites.inc000066400000000000000000000027111372124645500224770ustar00rootroot00000000000000! Vary type ADD_TEST_SUITE(Test_IntegerVectorIterator_mod_suite) ADD_TEST_SUITE(Test_RealVectorIterator_mod_suite) ADD_TEST_SUITE(Test_ComplexVectorIterator_mod_suite) ADD_TEST_SUITE(Test_LogicalVectorIterator_mod_suite) ! Vary kind/len ADD_TEST_SUITE(Test_Real64VectorIterator_mod_suite) ! Vary attributes ADD_TEST_SUITE(Test_IntegerAllocVectorIterator_mod_suite) ADD_TEST_SUITE(Test_IntegerPtrVectorIterator_mod_suite) ADD_TEST_SUITE(Test_Integer1dVectorIterator_mod_suite) ADD_TEST_SUITE(Test_Integer2dVectorIterator_mod_suite) ADD_TEST_SUITE(Test_Integer2d_fixedExtentsVectorIterator_mod_suite) ADD_TEST_SUITE(Test_Integer2dPtrVectorIterator_mod_suite) ! Derived types ADD_TEST_SUITE(Test_FooVectorIterator_mod_suite) ADD_TEST_SUITE(Test_FooPtrVectorIterator_mod_suite) ADD_TEST_SUITE(Test_FooPolyVectorIterator_mod_suite) ADD_TEST_SUITE(Test_FooPolyPtrVectorIterator_mod_suite) ! Unlimited polymorphic #ifndef __GFORTRAN__ ADD_TEST_SUITE(Test_UnlimitedPolyVectorIterator_mod_suite) #endif ADD_TEST_SUITE(Test_UnlimitedPolyPtrVectorIterator_mod_suite) ! Some compilers have bugs related to returning pointers to fixed ! length strings #ifdef SUPPORT_FOR_POINTERS_TO_FIXED_LENGTH_STRINGS ADD_TEST_SUITE(Test_Character17VectorIterator_mod_suite) #endif ! And other compilers have bugs related to returning pointers to ! deferred length strings #ifdef SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS ADD_TEST_SUITE(Test_DeferredLengthStringVectorIterator_mod_suite) #endif gFTL-1.2.7/tests/Vector/vectorSUT/000077500000000000000000000000001372124645500166305ustar00rootroot00000000000000gFTL-1.2.7/tests/Vector/vectorSUT/CMakeLists.txt000066400000000000000000000007131372124645500213710ustar00rootroot00000000000000set (SRCS IntegerVector.F90 RealVector.F90 LogicalVector.F90 Real64Vector.F90 Character17Vector.F90 DeferredLengthStringVector.F90 IntegerPtrVector.F90 Integer1dVector.F90 Foo.F90 ChildOfFoo.F90 FooVector.F90 ) set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -traceback -assume realloc_lhs") include_directories (${gFTL_SOURCE_DIR}/include) include_directories (${PFUNIT}/mod) add_library(vectorSUT STATIC ${SRCS}) gFTL-1.2.7/tests/Vector/vectorSUT/Character17Vector.F90000066400000000000000000000002041372124645500223330ustar00rootroot00000000000000module Character17Vector_mod #include #include end module Character17Vector_mod gFTL-1.2.7/tests/Vector/vectorSUT/ChildOfFoo.F90000066400000000000000000000032551372124645500210710ustar00rootroot00000000000000module ChildOfFoo_mod use pFUnit_mod use Foo_mod implicit none private public :: ChildOfFoo public :: assertEqual type, extends(Foo) :: ChildOfFoo integer :: j contains procedure :: equal procedure :: copy end type ChildOfFoo interface ChildOfFoo module procedure newChildOfFoo end interface ChildOfFoo interface assertEqual module procedure assertEqual_FooFoo end interface assertEqual contains function newChildOfFoo(i,j) result(child) type (ChildOfFoo) :: child integer, intent(in) :: i integer, intent(in) :: j end function NewChildOfFoo subroutine copy(a, b) class (ChildOfFoo), intent(out) :: a class (Foo), intent(in) :: b a%i = b%i select type (b) class is (ChildOfFoo) a%j = b%j end select end subroutine copy logical function equal(a, b) class (ChildOfFoo), intent(in) :: a class (Foo), intent(in) :: b select type (b) class is (ChildOfFoo) equal = (a%i == b%i .and. a%j == b%j) class default equal = .false. end select end function equal subroutine assertEqual_FooFoo(a, b, message, location) type (ChildOfFoo), intent(in) :: a class (Foo), intent(in) :: b character(len=*), optional, intent(in) :: message type (SourceLocation), optional, intent(in) :: location select type (b) class is (ChildOfFoo) call assertEqual([a%i,a%j], [b%i,b%j], message, location) class default call throw('Dynamic types do not match.') end select end subroutine assertEqual_FooFoo end module ChildOfFoo_mod gFTL-1.2.7/tests/Vector/vectorSUT/DeferredLengthStringVector.F90000066400000000000000000000002371372124645500243460ustar00rootroot00000000000000module DeferredLengthStringVector_mod #include #include end module DeferredLengthStringVector_mod gFTL-1.2.7/tests/Vector/vectorSUT/Foo.F90000066400000000000000000000025541372124645500176410ustar00rootroot00000000000000module Foo_mod use pFUnit_mod implicit none private public :: Foo public :: assertEqual type Foo integer :: i contains procedure :: equal generic :: operator(==) => equal procedure :: copy generic :: assignment(=) => copy end type Foo interface Foo module procedure newFoo end interface Foo interface assertEqual module procedure assertEqual_FooFoo end interface assertEqual contains function newFoo(i) result(f) type (Foo) :: f integer, intent(in) :: i f%i = i end function newFoo subroutine copy(a, b) class (Foo), intent(out) :: a class (Foo), intent(in) :: b a%i = b%i end subroutine copy logical function equal(a, b) class (Foo), intent(in) :: a class (Foo), intent(in) :: b equal = (a%i == b%i) end function equal subroutine assertEqual_FooFoo(a, b, message, location) type (Foo), intent(in) :: a class (Foo), intent(in) :: b character(len=*), optional, intent(in) :: message type (SourceLocation), optional, intent(in) :: location select type (b) type is (Foo) call assertEqual(a%i, b%i, message, location) class default call throw('Dynamic types do not match.') end select end subroutine assertEqual_FooFoo end module Foo_mod gFTL-1.2.7/tests/Vector/vectorSUT/FooVector.F90000066400000000000000000000002141372124645500210130ustar00rootroot00000000000000module FooVector_mod use Foo_mod #define _entry type(Foo) #define EQUAL_DEFINED #include end module FooVector_mod gFTL-1.2.7/tests/Vector/vectorSUT/Integer1dVector.F90000066400000000000000000000001761372124645500221210ustar00rootroot00000000000000module Integer1dVector_mod #include #include end module Integer1dVector_mod gFTL-1.2.7/tests/Vector/vectorSUT/IntegerPtrVector.F90000066400000000000000000000002011372124645500223470ustar00rootroot00000000000000module IntegerPtrVector_mod #include #include end module IntegerPtrVector_mod gFTL-1.2.7/tests/Vector/vectorSUT/IntegerVector.F90000066400000000000000000000001701372124645500216660ustar00rootroot00000000000000module IntegerVector_mod #include #include end module IntegerVector_mod gFTL-1.2.7/tests/Vector/vectorSUT/LogicalVector.F90000066400000000000000000000001701372124645500216430ustar00rootroot00000000000000module LogicalVector_mod #include #include end module LogicalVector_mod gFTL-1.2.7/tests/Vector/vectorSUT/Real64Vector.F90000066400000000000000000000001651372124645500213320ustar00rootroot00000000000000module Real64Vector_mod #include #include end module Real64Vector_mod gFTL-1.2.7/tests/Vector/vectorSUT/RealVector.F90000066400000000000000000000001571372124645500211610ustar00rootroot00000000000000module RealVector_mod #include #include end module RealVector_mod gFTL-1.2.7/tests/Vector/vectorTestSuites.inc000066400000000000000000000030271372124645500207660ustar00rootroot00000000000000! Vary type ADD_TEST_SUITE(Test_IntegerVector_mod_suite) ADD_TEST_SUITE(Test_RealVector_mod_suite) ADD_TEST_SUITE(Test_ComplexVector_mod_suite) ADD_TEST_SUITE(Test_LogicalVector_mod_suite) ! Vary kind/len ADD_TEST_SUITE(Test_Real64Vector_mod_suite) ! Vary attributes ADD_TEST_SUITE(Test_IntegerPtrVector_mod_suite) ADD_TEST_SUITE(Test_IntegerAllocVector_mod_suite) ADD_TEST_SUITE(Test_Integer1dVector_mod_suite) ADD_TEST_SUITE(Test_Integer2dVector_mod_suite) ADD_TEST_SUITE(Test_Integer2d_fixedExtentsVector_mod_suite) ADD_TEST_SUITE(Test_Integer2dPtrVector_mod_suite) ! Derived types ADD_TEST_SUITE(Test_FooVector_mod_suite) ADD_TEST_SUITE(Test_FooPtrVector_mod_suite) ADD_TEST_SUITE(Test_FooPolyVector_mod_suite) ADD_TEST_SUITE(Test_FooPolyPtrVector_mod_suite) ! Unlimited polymorphic #ifndef __GFORTRAN__ ADD_TEST_SUITE(Test_UnlimitedPolyVector_mod_suite) #endif ADD_TEST_SUITE(Test_UnlimitedPolyPtrVector_mod_suite) ! Some compilers have bugs related to returning pointers to fixed ! length strings #ifdef SUPPORT_FOR_POINTERS_TO_FIXED_LENGTH_STRINGS ADD_TEST_SUITE(Test_Character17Vector_mod_suite) #endif ! And other compilers have bugs related to returning pointers to ! deferred length strings #ifdef SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS ADD_TEST_SUITE(Test_deferredLengthStringVector_mod_suite) #endif ! Test for broken intel 18 behavior with nested containers ADD_MODULE_TEST_SUITE(Test_Nested_mod, Test_nested_suite) ! Test for robust pointers to allocatable components ADD_TEST_SUITE(Test_vector_Allocatable_mod_suite) gFTL-1.2.7/tests/altSet/000077500000000000000000000000001372124645500147245ustar00rootroot00000000000000gFTL-1.2.7/tests/altSet/CMakeLists.txt000066400000000000000000000023031372124645500174620ustar00rootroot00000000000000add_subdirectory(SUT) set (src ${CMAKE_CURRENT_SOURCE_DIR}) set (bin ${CMAKE_CURRENT_BINARY_DIR}) set (types integer real real64 complex deferredLengthString unlimitedPolyPtr integer1d integer2d integer2d_fixedExtents integerAlloc integerPtr integer2dPtr Foo FooPtr FooPoly FooPolyPtr ) if (SUPPORTS_POINTERS_TO_FIXED_LENGTH_STRINGS) LIST (APPEND types character17) endif () set(SRCS) foreach (type ${types} ) set (infile ${src}/Test_altSet.m4) set (pfunitfile Test_${type}altSet.pf) # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${pfunitfile} COMMAND ${M4} -s -Dparam=${type} -I${GFTL_SOURCE_DIR}/include/templates < ${infile} > ${pfunitfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list (APPEND SRCS ${CMAKE_CURRENT_BINARY_DIR}/${pfunitfile} ) endforeach () add_pfunit_ctest (altSet_tests TEST_SOURCES ${SRCS} LINK_LIBRARIES altsetSUT ) target_include_directories (altSet_tests PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/include) target_include_directories (altSet_tests PRIVATE ${GFTL_SOURCE_DIR}/include) add_dependencies (tests altSet_tests) gFTL-1.2.7/tests/altSet/SUT/000077500000000000000000000000001372124645500153775ustar00rootroot00000000000000gFTL-1.2.7/tests/altSet/SUT/CMakeLists.txt000066400000000000000000000031521372124645500201400ustar00rootroot00000000000000include_directories (${GFTL_BINARY_DIR}/tests/shared) set (instantiations "integer\;free" "real\;free" "real32\;free" "real64\;free" "complex\;free" "complex64\;free" "complex128\;free" "deferredLengthString\;free" "unlimitedPolyPtr\;free" "integer1d\;free" "integer2d\;free" "integer2d_fixedExtents\;free" "integerAlloc\;free" "integerPtr\;free" "integer2dPtr\;free" "integer\;fixed" "Foo\;free" "FooPtr\;free" "FooPoly\;free" "FooPolyPtr\;free" "integer1d\;free" "integer2d\;free" "integer2d_fixedExtents\;free" ) if (SUPPORTS_POINTERS_TO_FIXED_LENGTH_STRINGS) list (APPEND instantiations "character17\;free") endif () set (SRCS) foreach (instantiation ${instantiations}) list (GET instantiation 0 type) list (GET instantiation 1 format) set (infile ${CMAKE_CURRENT_SOURCE_DIR}/altSet.m4) if (format STREQUAL "free") set (outfile ${type}altSet.F90) else () set (outfile ${type}altSet.F) endif () # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command ( OUTPUT ${outfile} DEPENDS ${infile} COMMAND ${M4} -Dtype=${type} -Dformat=${format} ${infile} > ${outfile} WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} ) list (APPEND SRCS ${outfile}) endforeach () list (APPEND SRCS MultiModule.F90) add_library(altsetSUT STATIC EXCLUDE_FROM_ALL ${SRCS}) target_include_directories (altsetSUT PUBLIC ${CMAKE_CURRENT_BINARY_DIR}) target_include_directories (altsetSUT PRIVATE ${PFUNIT_TOP_DIR}/include) target_link_libraries(altsetSUT type_test_values shared gftl) gFTL-1.2.7/tests/altSet/SUT/IntegerFixedFormatSet.F000066400000000000000000000005061372124645500217110ustar00rootroot00000000000000 module IntegerFixedFormatSet_mod #include "types/integer.inc" #include "templates/altset.inc" end module IntegerFixedFormatSet_mod ! A second module checks that all macros are cleared from the 1st case module Other_mod #include #include end module Other_mod gFTL-1.2.7/tests/altSet/SUT/MultiModule.F90000066400000000000000000000003111372124645500201120ustar00rootroot00000000000000module altset_one #include #include end module altset_one module altset_two #include #include end module altset_two gFTL-1.2.7/tests/altSet/SUT/altSet.m4000066400000000000000000000003251372124645500170750ustar00rootroot00000000000000changecom() define(`suffix',ifelse(format(),free,,_fixedFormat)) module type()altSet`'suffix()_mod #include "types/type().inc" #include "templates/altSet.inc" end module type()altSet`'suffix()_mod gFTL-1.2.7/tests/altSet/Test_altSet.m4000066400000000000000000000203041372124645500174200ustar00rootroot00000000000000include(header.m4) module Test_`'param()altSet #include "types/param().inc" #include "templates/type_set_use_tokens.inc" #include "type_test_values/param().inc" use funit, only: assertTrue, assertFalse use funit, only: TestSuite use funit, only: TestMethod use funit, only: SourceLocation use funit, only: anyExceptions #ifdef _unlimited use pFUnitSupplement_mod, only: assertEqual #else use funit, only: assertEqual #endif use param()altSet_mod #include "templates/type_template_macros.inc" #include "templates/type_testing_macros.inc" #include "templates/tmplbase.inc" #include "genericItems_decl.inc" ! GFortran 8.2 namespace is "leaky" private :: assertEqual contains #include "genericSetUpTearDown.inc" @before subroutine setUp() call genericSetUp() end subroutine setUp @after subroutine tearDown() call genericTearDown() end subroutine tearDown @test subroutine testIsEmpty() type (Set) :: s @assertTrue(s%empty()) end subroutine testIsEmpty @test subroutine testIsEmpty_notEmpty() type (Set) :: s call s%insert(ONE) @assertFalse(s%empty()) end subroutine testIsEmpty_notEmpty @test subroutine testSize_empty() type (Set) :: s @assertEqual(0, s%size()) end subroutine testSize_empty @test subroutine testSize_simple() type (Set) :: s call s%insert(ONE) @assertEqual(1, s%size()) call s%insert(TWO) @assertEqual(2, s%size()) end subroutine testSize_simple @test subroutine testSize_duplicate() type (Set) :: s call s%insert(ONE) @assertEqual(1, s%size()) call s%insert(TWO) @assertEqual(2, s%size()) ! Insert a duplicate entry - should not modify call s%insert(ONE) @assertEqual(2, s%size()) end subroutine testSize_duplicate @test subroutine testInsert_isNew() type (Set) :: s logical :: isNew call s%insert(ONE,isNew=isNew) @assertTrue(isNew) call s%insert(TWO, isNew=isNew) @assertTrue(isNew) call s%insert(ONE, isNew=isNew) @assertFalse(isNew) call s%insert(TWO, isNew=isNew) @assertFalse(isNew) end subroutine testInsert_isNew @test subroutine testCount() type (Set) :: s @assertEqual(0, s%count(ONE)) @assertEqual(0, s%count(TWO)) call s%insert(ONE) @assertEqual(1, s%count(ONE)) @assertEqual(0, s%count(TWO)) call s%insert(TWO) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(TWO)) ! duplicate call s%insert(TWO) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(TWO)) end subroutine testCount #ifdef _pointer ! This test verifies that if two pointers are put in a Set ! they are treated as separate entries even if their targets ! have the same value. (But the targets are not the same object.) ! This test is only relevant for types with _pointer. @test(ifdef=_pointer) subroutine test_findSameTarget() type (Set), target :: s # ifdef __type_allocatable_target # define __type_test_attrs , allocatable # else # define __type_test_attrs # endif #define _ONE_ _ONE __type_declare_local :: pA __type_declare_local :: pB __type_declare_local :: pC __type_declare_target __type_test_attrs :: targA __type_declare_target __type_test_attrs :: targB __type_declare_target __type_test_attrs :: targC __type_declare_result, pointer :: qA, qB, qC type (SetIterator) :: iterA, iterB, iterC logical :: isNew #ifdef _DEBUG type LocalWrapper integer, pointer :: item end type LocalWrapper type (LocalWrapper):: w #endif __TYPE_INIT(pA, _ONE, targA) __TYPE_INIT(pB, _ONE, targB) __TYPE_INIT(pC, _ONE, targC) @assertFalse(associated(pA, pB)) #ifdef _DEBUG w%item => pA w%item => targB w%item => targC #endif call s%insert(pA) @assertEqual(1, s%size()) call s%insert(pB, isNew=isNew) @assertTrue(isNew) @assertEqual(2, s%size()) call s%insert(pC, isNew=isNew) @assertTrue(isNew) @assertEqual(3, s%size()) iterA = s%find(pA) iterB = s%find(pB) iterC = s%find(pC) qA => iterA%value() qB => iterB%value() qC => iterC%value() @assertFalse(associated(qA, qB)) @assertFalse(associated(qA, qC)) @assertFalse(associated(qB, qC)) end subroutine test_findSameTarget #endif @test subroutine test_eraseOne() type (Set), target :: s type (SetIterator) :: iter call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) iter = s%find(THREE) call s%erase(iter) @assertEqual(2, s%size()) @assertEqual(0, s%count(THREE)) @assertEqual(1, s%count(ONE)) @assertEqual(1, s%count(FIVE)) end subroutine test_eraseOne ! In the case of containers of pointers, it is very difficult to know what ! is included in a range. Thus we copy the set and use it as a reference. @test subroutine test_eraseRange() type (Set), target :: s type (Set), target :: sCopy type (SetIterator) :: first type (SetIterator) :: last type (SetIterator) :: iter __type_declare_result, pointer :: q call s%insert(ONE) call s%insert(THREE) call s%insert(FOUR) call s%insert(FIVE) call sCopy%insert(ONE) call sCopy%insert(THREE) call sCopy%insert(FOUR) call sCopy%insert(FIVE) first = s%begin() call first%next() last = s%end() call last%prev() ! should delete THREE and FOUR (2 items) call s%erase(first, last) @assertTrue(first == last) @assertEqual(2, s%size()) iter = sCopy%begin() call iter%next() last = sCopy%end() call last%prev() do while (iter /= last) q => iter%value() @assertEqual(0, s%count(q)) call iter%next() end do end subroutine test_eraseRange @test subroutine test_eraseAll() type (Set), target :: s type (SetIterator) :: first type (SetIterator) :: last call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) first = s%begin() last = s%end() call s%erase(first, last) @assertEqual(0, s%size()) ! Iterator should now point to end of updated set. @assertTrue(first == s%end()) end subroutine test_eraseAll @test subroutine test_equalEmpty() type (Set) :: a, b @assertTrue(a == b) @assertFalse(a /= b) end subroutine test_equalEmpty @test subroutine test_iterator_empty() type (Set), target :: s type (SetIterator) :: iter iter = s%begin() @assertFalse(associated(iter%value())) end subroutine test_iterator_empty @test subroutine test_equal() type (Set), target :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(ONE) call b%insert(TWO) @assertTrue(a == b) @assertFalse(a /= b) end subroutine test_equal @test subroutine test_notEqual() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call a%insert(FOUR) call b%insert(ONE) call b%insert(TWO) call b%insert(FIVE) @assertFalse(a == b) @assertTrue(a /= b) end subroutine test_notEqual subroutine test_deepCopy() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) b = a @assertTrue(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) @assertTrue(a /= b) end subroutine test_deepCopy ! Ensure that deep copy obliterates any state the variable on the ! LHS had prior to the assignment. @test subroutine test_deepCopy2() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(THREE) call b%deepCopy(a) @assertTrue(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) @assertTrue(a /= b) end subroutine test_deepCopy2 #include "templates/type_use_tokens_undef.inc" end module Test_`'param()altSet #include "templates/tmpltail.inc" gFTL-1.2.7/tests/altSet/Test_altSet_Allocatable.pf000066400000000000000000000022161372124645500217720ustar00rootroot00000000000000! If a container is for allocatable entities, then gFTL should enable ! external pointers into the structure to persist even when the ! container is modified. This relies on Fortran's move_alloc() ! behavior, and thus cannot be supported for non allocatable container ! elements. module Test_altSet_Allocatable use funit use FooPolyaltSet_mod use Foo_mod contains @test subroutine test_insert() type (Set), target :: s class (Foo), pointer :: pa, pb, pc type (SetIterator) :: iter call s%insert(Foo(3)) iter = s%begin() pc => iter%value() call s%insert(Foo(2)) iter = s%begin() pb => iter%value() call s%insert(Foo(1)) iter = s%begin() pa => iter%value() ! Sanity checks @assertEqual(1, pa%i) @assertEqual(2, pb%i) @assertEqual(3, pc%i) call s%insert(Foo(5)) call s%insert(Foo(6)) call s%insert(Foo(-7)) call s%insert(Foo(-8)) ! Pointers still valid? @assertEqual(1, pa%i) @assertEqual(2, pb%i) @assertEqual(3, pc%i) end subroutine test_insert end module Test_altSet_Allocatable gFTL-1.2.7/tests/altSet/altSetTestSuites.inc000066400000000000000000000023031372124645500207060ustar00rootroot00000000000000! Vary _type ADD_TEST_SUITE(Test_IntegeraltSet_mod_suite) ADD_TEST_SUITE(Test_RealaltSet_mod_suite) ADD_TEST_SUITE(Test_ComplexaltSet_mod_suite) ADD_TEST_SUITE(Test_Real64altSet_mod_suite) ! Strings #ifdef SUPPORTS_POINTERS_TO_FIXED_LENGTH_STRINGS ADD_TEST_SUITE(Test_Character17altSet_mod_suite) Test_Character17Set) #endif ! workaround for gfortran 4.9.1 #ifdef SUPPORT_FOR_POINTERS_TO_DEFERRED_LENGTH_STRINGS !ADD_TEST_SUITE(Test_DeferredLengthStringaltSet_mod_suite) #endif ! pointers ... ADD_TEST_SUITE(Test_IntegerAllocaltSet_mod_suite) ADD_TEST_SUITE(Test_IntegerPtraltSet_mod_suite) ! arrays ... ADD_TEST_SUITE(Test_Integer1daltSet_mod_suite) ADD_TEST_SUITE(Test_Integer2daltSet_mod_suite) ADD_TEST_SUITE(Test_Integer2dPtraltSet_mod_suite) ADD_TEST_SUITE(Test_Integer2d_fixedExtentsaltSet_mod_suite) ! derived type ADD_TEST_SUITE(Test_FooaltSet_mod_suite) ADD_TEST_SUITE(Test_FooPtraltSet_mod_suite) ADD_TEST_SUITE(Test_FooPolyaltSet_mod_suite) ADD_TEST_SUITE(Test_FooPolyPtraltSet_mod_suite) ! Unlimited polymorphic #ifndef __GFORTRAN__ ADD_TEST_SUITE(Test_unlimitedPolyPtraltSet_mod_suite) #endif ! Test for robust pointers to allocatable components ADD_TEST_SUITE(Test_altSet_Allocatable_mod_suite) gFTL-1.2.7/tests/altSet/include/000077500000000000000000000000001372124645500163475ustar00rootroot00000000000000gFTL-1.2.7/tests/altSet/include/genericItems_decl.inc000066400000000000000000000013101372124645500224420ustar00rootroot00000000000000 __type_declare_local :: ONE __type_declare_local :: ONE_B __type_declare_local :: TWO __type_declare_local :: THREE __type_declare_local :: FOUR __type_declare_local :: FIVE #if defined(_pointer) & !defined(_procedure) # ifdef __type_allocatable_target # define __type_test_attrs , allocatable # else # define __type_test_attrs # endif __type_declare_target __type_test_attrs :: one_ __type_declare_target __type_test_attrs :: one_b_ __type_declare_target __type_test_attrs :: two_ __type_declare_target __type_test_attrs :: three_ __type_declare_target __type_test_attrs:: four_ __type_declare_target __type_test_attrs :: five_ # undef __type_test_attrs #endif gFTL-1.2.7/tests/altSet/include/genericSetUpTearDown.inc000066400000000000000000000012641372124645500231060ustar00rootroot00000000000000 subroutine genericSetUp() __TYPE_INIT(ONE, _ONE, one_) ! __TYPE_INIT(ONE_B, _ONE_B, one_b_) __TYPE_INIT(TWO, _TWO, two_) __TYPE_INIT(THREE, _THREE, three_) __TYPE_INIT(FOUR, _FOUR, four_) __TYPE_INIT(FIVE, _FIVE, five_) end subroutine genericSetUp subroutine genericTearDown() __TYPE_FREE(ONE) ! __TYPE_FREE(ONE_B) __TYPE_FREE(TWO) __TYPE_FREE(THREE) __TYPE_FREE(FOUR) __TYPE_FREE(FIVE) #ifdef __type_allocatable_target deallocate(one_) ! deallocate(one_b_) deallocate(two_) deallocate(three_) deallocate(four_) deallocate(five_) #endif end subroutine genericTearDown gFTL-1.2.7/tests/altSet/include/genericTestSet.inc000066400000000000000000000206351372124645500220000ustar00rootroot00000000000000 #define CHECK if(anyExceptions()) return #define _FILE 'genericTestSet.inc' #define ASSERT_EQUAL(a,b)call assertEqual(a,b,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_TRUE(a)call assertTrue(a,location=SourceLocation(_FILE,__LINE__)); CHECK #define ASSERT_FALSE(a)call assertFalse(a,location=SourceLocation(_FILE,__LINE__)); CHECK #include #include #include contains #include "genericSetUpTearDown.inc" subroutine setUp() call genericSetUp() end subroutine setUp subroutine tearDown() call genericTearDown() end subroutine tearDown subroutine testIsEmpty() type (Set) :: s ASSERT_TRUE(s%empty()) end subroutine testIsEmpty subroutine testIsEmpty_notEmpty() type (Set) :: s call s%insert(ONE) ASSERT_FALSE(s%empty()) end subroutine testIsEmpty_notEmpty subroutine testSize_empty() type (Set) :: s ASSERT_EQUAL(0, s%size()) end subroutine testSize_empty subroutine testSize_simple() type (Set) :: s call s%insert(ONE) ASSERT_EQUAL(1, s%size()) call s%insert(TWO) ASSERT_EQUAL(2, s%size()) end subroutine testSize_simple subroutine testSize_duplicate() type (Set) :: s call s%insert(ONE) ASSERT_EQUAL(1, s%size()) call s%insert(TWO) ASSERT_EQUAL(2, s%size()) ! Insert a duplicate entry - should not modify call s%insert(ONE) ASSERT_EQUAL(2, s%size()) end subroutine testSize_duplicate subroutine testInsert_isNew() type (Set) :: s logical :: isNew call s%insert(ONE,isNew=isNew) ASSERT_TRUE(isNew) call s%insert(TWO, isNew=isNew) ASSERT_TRUE(isNew) call s%insert(ONE, isNew=isNew) ASSERT_FALSE(isNew) call s%insert(TWO, isNew=isNew) ASSERT_FALSE(isNew) end subroutine testInsert_isNew subroutine testCount() type (Set) :: s ASSERT_EQUAL(0, s%count(ONE)) ASSERT_EQUAL(0, s%count(TWO)) call s%insert(ONE) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(0, s%count(TWO)) call s%insert(TWO) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(1, s%count(TWO)) ! duplicate call s%insert(TWO) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(1, s%count(TWO)) end subroutine testCount #ifdef _pointer ! This test verifies that if two pointers are put in a Set ! they are treated as separate entries even if their targets ! have the same value. (But the targets are not the same object.) ! This test is only relevant for types with _pointer. subroutine test_findSameTarget() type (Set) :: s # ifdef __allocatable_target # define __test_attrs , allocatable # else # define __test_attrs # endif #define _ONE_ _ONE __declare_local :: pA __declare_local :: pB __declare_local :: pC __type_declare_target __test_attrs :: targA __type_declare_target __test_attrs :: targB __type_declare_target __test_attrs :: targC __type_declare_result, pointer :: qA, qB, qC type (Iterator) :: iterA, iterB, iterC logical :: isNew __INIT(pA, _ONE, targA) __INIT(pB, _ONE, targB) __INIT(pC, _ONE, targC) ASSERT_FALSE(associated(pA, pB)) call s%insert(pA) ASSERT_EQUAL(1, s%size()) call s%insert(pB, isNew=isNew) ASSERT_TRUE(isNew) ASSERT_EQUAL(2, s%size()) call s%insert(pC, isNew=isNew) ASSERT_TRUE(isNew) ASSERT_EQUAL(3, s%size()) iterA = s%find(pA) iterB = s%find(pB) iterC = s%find(pC) qA => iterA%value() qB => iterB%value() qC => iterC%value() ASSERT_FALSE(associated(qA, qB)) ASSERT_FALSE(associated(qA, qC)) ASSERT_FALSE(associated(qB, qC)) end subroutine test_findSameTarget #endif subroutine test_eraseOne() type (Set), target :: s type (Iterator) :: iter call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) iter = s%find(THREE) call s%erase(iter) ASSERT_EQUAL(2, s%size()) ASSERT_EQUAL(0, s%count(THREE)) ASSERT_EQUAL(1, s%count(ONE)) ASSERT_EQUAL(1, s%count(FIVE)) end subroutine test_eraseOne ! In the case of containers of pointers, it is very difficult to know what ! is included in a range. Thus we copy the set and use it as a reference. subroutine test_eraseRange() type (Set) :: s type (Set) :: sCopy type (Iterator) :: first type (Iterator) :: last type (Iterator) :: iter __type_declare_result, pointer :: q call s%insert(ONE) call s%insert(THREE) call s%insert(FOUR) call s%insert(FIVE) call sCopy%insert(ONE) call sCopy%insert(THREE) call sCopy%insert(FOUR) call sCopy%insert(FIVE) first = s%begin() call first%next() last = s%end() call last%prev() call s%erase(first, last) ASSERT_TRUE(first == last) ASSERT_EQUAL(2, s%size()) iter = sCopy%begin() call iter%next() last = sCopy%end() call last%prev() do while (iter /= last) q => iter%value() ASSERT_EQUAL(0, s%count(q)) call iter%next() end do end subroutine test_eraseRange subroutine test_eraseAll() type (Set) :: s type (Iterator) :: first type (Iterator) :: last __type_declare_result, pointer :: q call s%insert(ONE) call s%insert(THREE) call s%insert(FIVE) first = s%begin() last = s%end() call s%erase(first, last) ASSERT_EQUAL(0, s%size()) ! Iterator should now point to end of updated set. ASSERT_TRUE(first == s%end()) end subroutine test_eraseAll subroutine test_equalEmpty() type (Set) :: a, b ASSERT_TRUE(a == b) ASSERT_FALSE(a /= b) end subroutine test_equalEmpty subroutine test_equal() type (Set), target :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(ONE) call b%insert(TWO) ASSERT_TRUE(a == b) ASSERT_FALSE(a /= b) end subroutine test_equal subroutine test_notEqual() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call a%insert(FOUR) call b%insert(ONE) call b%insert(TWO) call b%insert(FIVE) ASSERT_FALSE(a == b) ASSERT_TRUE(a /= b) end subroutine test_notEqual subroutine test_deepCopy() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) b = a ASSERT_TRUE(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) ASSERT_TRUE(a /= b) end subroutine test_deepCopy ! Ensure that deep copy obliterates any state the variable on the ! LHS had prior to the assignment. subroutine test_deepCopy2() type (Set) :: a, b call a%insert(ONE) call a%insert(TWO) call b%insert(THREE) b = a ASSERT_TRUE(a == b) ! Shallow copy will show problems if we now insert an element ! and compare again. call b%insert(THREE) ASSERT_TRUE(a /= b) end subroutine test_deepCopy2 function _suite() result(s) type (TestSuite) :: s s = newTestSuite(_suite_name) call add('testIsEmpty', testIsEmpty) call add('testIsEmpty_notEmpty', testIsEmpty_notEmpty) call add('testSize_empty', testSize_empty) call add('testSize_simple', testSize_simple) call add('testSize_duplicate', testSize_duplicate) call add('testInsert_isNew', testInsert_isNew) call add('testCount', testCount) #ifdef _pointer call add('test_findSameTarget', test_findSameTarget) #endif call add('test_eraseOne', test_eraseOne) call add('test_eraseRange', test_eraseRange) call add('test_eraseAll', test_eraseAll) call add('test_equalEmpty', test_equalEmpty) call add('test_equal', test_equal) call add('test_notEqual', test_notEqual) call add('test_deepCopy', test_deepCopy) call add('test_deepCopy2', test_deepCopy2) contains subroutine add(name, proc) character(len=*), intent(in) :: name interface subroutine proc() end subroutine proc end interface call s%addTest(newTestMethod(name, proc, setUp, tearDown)) end subroutine add end function _suite gFTL-1.2.7/tests/altSet/testSuites.inc000066400000000000000000000001061372124645500175700ustar00rootroot00000000000000#include !#include gFTL-1.2.7/tests/include/000077500000000000000000000000001372124645500151135ustar00rootroot00000000000000gFTL-1.2.7/tests/include/CMakeLists.txt000066400000000000000000000002431372124645500176520ustar00rootroot00000000000000add_library (type_test_values INTERFACE) target_include_directories (type_test_values INTERFACE ${CMAKE_CURRENT_BINARY_DIR}) add_subdirectory (type_test_values) gFTL-1.2.7/tests/include/type_test_values/000077500000000000000000000000001372124645500205125ustar00rootroot00000000000000gFTL-1.2.7/tests/include/type_test_values/CMakeLists.txt000066400000000000000000000023111372124645500232470ustar00rootroot00000000000000set (src ${CMAKE_CURRENT_SOURCE_DIR}) set (bin ${CMAKE_CURRENT_BINARY_DIR}) set (template_params type key value) set (macro_files integer real real32 real64 complex complex64 complex128 logical character17 deferredLengthString unlimitedPoly unlimitedPolyPtr integer1d integer2d integer2d_fixedExtents integerPtr integer2dPtr integerAlloc Foo FooPtr FooPoly FooPolyPtr ) # Empty list - will append in loop below set (depends) foreach( macro_file ${macro_files} ) foreach( param ${template_params} ) set( infile ${src}/${macro_file}.m4 ) if (${param} STREQUAL type) set( outfile ${macro_file}.inc ) else() set( outfile ${param}_${macro_file}.inc ) endif () # Use relative path for outfile so that CMake correctly # detects the need to generate include files. add_custom_command( OUTPUT ${outfile} COMMAND ${M4} -s -Dparam=${param} -I${GFTL_SOURCE_DIR}/include/templates < ${infile} > ${outfile} WORKING_DIRECTORY ${bin} DEPENDS ${infile} ) list( APPEND depends ${outfile} ) endforeach() endforeach() add_custom_target (make_type_test_values DEPENDS ${depends} ) add_dependencies (type_test_values make_type_test_values) gFTL-1.2.7/tests/include/type_test_values/Foo.m4000066400000000000000000000004321372124645500214760ustar00rootroot00000000000000include(header.m4) use Foo_mod, only: assertEqual #define __PARAM()_CAST_FROM_INTEGER(var,val) var = Foo(val) #define _base()_ONE Foo(1) #define _base()_ONE_B Foo(-1) #define _base()_TWO Foo(2) #define _base()_THREE Foo(3) #define _base()_FOUR Foo(4) #define _base()_FIVE Foo(5) gFTL-1.2.7/tests/include/type_test_values/FooPoly.m4000066400000000000000000000004451372124645500223460ustar00rootroot00000000000000include(header.m4) use ChildOfFoo_mod #define __PARAM()_CAST_FROM_INTEGER(var,val) var = Foo(val) #define _base()_ONE Foo(1) #define _base()_ONE_B Foo(-1) #define _base()_TWO ChildOfFoo(2,3) #define _base()_THREE Foo(3) #define _base()_FOUR ChildOfFoo(4,5) #define _base()_FIVE Foo(6) gFTL-1.2.7/tests/include/type_test_values/FooPolyPtr.m4000066400000000000000000000004441372124645500230330ustar00rootroot00000000000000include(header.m4) use ChildOfFoo_mod #define __PARAM()_CAST_FROM_INTEGER(var,val) var = Foo(val) #define _base()_ONE Foo(1) #define _base()_ONE_B Foo(-1) #define _base()_TWO ChildOfFoo(2,3) #define _base()_THREE Foo(3) #define _base()_FOUR ChildOfFoo(4,5) #define _base()_FIVE Foo(6) gFTL-1.2.7/tests/include/type_test_values/FooPtr.m4000066400000000000000000000004321372124645500221640ustar00rootroot00000000000000include(header.m4) use Foo_mod, only: assertEqual #define __PARAM()_CAST_FROM_INTEGER(var,val) var = Foo(val) #define _base()_ONE Foo(1) #define _base()_ONE_B Foo(-1) #define _base()_TWO Foo(2) #define _base()_THREE Foo(3) #define _base()_FOUR Foo(4) #define _base()_FIVE Foo(5) gFTL-1.2.7/tests/include/type_test_values/character17.m4000066400000000000000000000005141372124645500230600ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) write(var,'(i)') val ! 12345678901234567 #define _ONE 'aone ' #define _ONE_B 'a--- ' #define _TWO 'btwo ' #define _THREE 'cthree ' #define _FOUR 'dfour ' #define _FIVE 'efive ' gFTL-1.2.7/tests/include/type_test_values/complex.m4000066400000000000000000000004121372124645500224200ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = complx(val,val-1) #define _base()_ONE (1.,0.) #define _base()_ONE_B (-1.,0.) #define _base()_TWO (2.,1.) #define _base()_THREE (3.,2.) #define _base()_FOUR (4.,5.) #define _base()_FIVE (5.,4.) gFTL-1.2.7/tests/include/type_test_values/complex128.m4000066400000000000000000000004121372124645500226530ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = complx(val,val-1) ! The following are only used for testing #define _ONE (1.,0.) #define _ONE_B (-1.,0.) #define _TWO (2.,1.) #define _THREE (3.,2.) #define _FOUR (4.,5.) #define _FIVE (5.,4.) gFTL-1.2.7/tests/include/type_test_values/complex64.m4000066400000000000000000000004121372124645500225720ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = complx(val,val-1) ! The following are only used for testing #define _ONE (1.,0.) #define _ONE_B (-1.,0.) #define _TWO (2.,1.) #define _THREE (3.,2.) #define _FOUR (4.,5.) #define _FIVE (5.,4.) gFTL-1.2.7/tests/include/type_test_values/deferredLengthString.m4000066400000000000000000000005021372124645500250620ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = castToString(val)) ! Note - Need to be in alphabetical order for testing Set #define _base()_ONE 'aOne' #define _base()_ONE_B 'a---' #define _base()_TWO 'bTwo ' #define _base()_THREE 'cThree' #define _base()_FOUR 'dFour' #define _base()_FIVE 'eFive' gFTL-1.2.7/tests/include/type_test_values/integer.m4000066400000000000000000000003271372124645500224130ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = val #define _base()_ONE 1 #define _base()_ONE_B -1 #define _base()_TWO 2 #define _base()_THREE 3 #define _base()_FOUR 4 #define _base()_FIVE 5 gFTL-1.2.7/tests/include/type_test_values/integer1d.m4000066400000000000000000000005061372124645500226370ustar00rootroot00000000000000include(header.m4) ! This creates arrays of length 1 to 10 #define __BASE()_CAST_FROM_INTEGER(var,val) var = spread(val,1,mod(max(i,1),10)+1) #define _base()_ONE ([1]) #define _base()_ONE_B ([-1]) #define _base()_TWO ([2,2]) #define _base()_THREE ([3,3,3]) #define _base()_FOUR ([4,4,4,4]) #define _base()_FIVE ([5,5,5,5,5]) gFTL-1.2.7/tests/include/type_test_values/integer2d.m4000066400000000000000000000006341372124645500226420ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = spread(spread(val,1,mod(i,3)+1),mod(i,2)+1) ! the following are only used for testing #define _base()_ONE reshape([1,1],[1,2]) #define _base()_ONE_B reshape([-1,-1],[1,2]) #define _base()_TWO reshape([2,2],[1,2]) #define _base()_THREE reshape([3,3],[1,2]) #define _base()_FOUR reshape([4,4],[1,2]) #define _base()_FIVE reshape([5,5],[1,2]) gFTL-1.2.7/tests/include/type_test_values/integer2dPtr.m4000066400000000000000000000006341372124645500233300ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = spread(spread(val,1,mod(i,3)+1),mod(i,2)+1) ! the following are only used for testing #define _base()_ONE reshape([1,1],[1,2]) #define _base()_ONE_B reshape([-1,-1],[1,2]) #define _base()_TWO reshape([2,2],[1,2]) #define _base()_THREE reshape([3,3],[1,2]) #define _base()_FOUR reshape([4,4],[1,2]) #define _base()_FIVE reshape([5,5],[1,2]) gFTL-1.2.7/tests/include/type_test_values/integer2d_fixedExtents.m4000066400000000000000000000005701372124645500253730ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = reshape(spread(val,1,product(_extents)),_extents) #define _base()_ONE reshape([1,1],[1,2]) #define _base()_ONE_B reshape([-1,-1],[1,2]) #define _base()_TWO reshape([2,2],[1,2]) #define _base()_THREE reshape([3,3],[1,2]) #define _base()_FOUR reshape([4,4],[1,2]) #define _base()_FIVE reshape([5,5],[1,2]) gFTL-1.2.7/tests/include/type_test_values/integerAlloc.m4000066400000000000000000000003271372124645500233660ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = val #define _base()_ONE 1 #define _base()_ONE_B -1 #define _base()_TWO 2 #define _base()_THREE 3 #define _base()_FOUR 4 #define _base()_FIVE 5 gFTL-1.2.7/tests/include/type_test_values/integerPtr.m4000066400000000000000000000003271372124645500231010ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = val #define _base()_ONE 1 #define _base()_ONE_B -1 #define _base()_TWO 2 #define _base()_THREE 3 #define _base()_FOUR 4 #define _base()_FIVE 5 gFTL-1.2.7/tests/include/type_test_values/logical.m4000066400000000000000000000004051372124645500223650ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = (mod(val,2) == 1) #define _base()_ONE .true. #define _base()_ONE_B .false. #define _base()_TWO .false. #define _base()_THREE .true. #define _base()_FOUR .true. #define _base()_FIVE .false. gFTL-1.2.7/tests/include/type_test_values/real.m4000066400000000000000000000003351372124645500217000ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = val #define _base()_ONE 1. #define _base()_ONE_B -1. #define _base()_TWO 2. #define _base()_THREE 3. #define _base()_FOUR 4. #define _base()_FIVE 5. gFTL-1.2.7/tests/include/type_test_values/real32.m4000066400000000000000000000004071372124645500220450ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) var = val #define _base()_ONE 1._REAL32 #define _base()_ONE_B -1._REAL32 #define _base()_TWO 2._REAL32 #define _base()_THREE 3._REAL32 #define _base()_FOUR 4._REAL32 #define _base()_FIVE 5._REAL32 gFTL-1.2.7/tests/include/type_test_values/real64.m4000066400000000000000000000004111372124645500220450ustar00rootroot00000000000000changecom() ifelse(param,type,`define(`_base',)',`define(`_base',_param())') #define _base()_ONE 1._REAL64 #define _base()_ONE_B -1._REAL64 #define _base()_TWO 2._REAL64 #define _base()_THREE 3._REAL64 #define _base()_FOUR 4._REAL64 #define _base()_FIVE 5._REAL64 gFTL-1.2.7/tests/include/type_test_values/unlimitedPoly.m4000066400000000000000000000004141372124645500236110ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) call castToUnlimited(val, var) #define _unlimited #define _base()_ONE 1. #define _base()_ONE_B -1. #define _base()_TWO 2. #define _base()_THREE 3.d0 #define _base()_FOUR (4.,5.) #define _base()_FIVE 5 gFTL-1.2.7/tests/include/type_test_values/unlimitedPolyPtr.m4000066400000000000000000000004141372124645500242770ustar00rootroot00000000000000include(header.m4) #define __PARAM()_CAST_FROM_INTEGER(var,val) call castToUnlimited(val, var) #define _unlimited #define _base()_ONE 1. #define _base()_ONE_B -1. #define _base()_TWO 2. #define _base()_THREE 3.d0 #define _base()_FOUR (4.,5.) #define _base()_FIVE 5 gFTL-1.2.7/tests/shared/000077500000000000000000000000001372124645500147365ustar00rootroot00000000000000gFTL-1.2.7/tests/shared/CMakeLists.txt000066400000000000000000000004221372124645500174740ustar00rootroot00000000000000set (SRCS Foo.F90 ChildOfFoo.F90 pFUnitSupplement.F90 ) add_library(shared ${SRCS}) target_include_directories (shared PRIVATE ${PFUNIT_TOP_DIR}/include) target_include_directories (shared PUBLIC ${CMAKE_CURRENT_BINARY_DIR}) target_link_libraries(shared gftl funit) gFTL-1.2.7/tests/shared/ChildOfFoo.F90000066400000000000000000000040241372124645500171720ustar00rootroot00000000000000module ChildOfFoo_mod use funit use Foo_mod, only: Foo implicit none private public :: ChildOfFoo public :: assertEqual type, extends(Foo) :: ChildOfFoo integer :: j contains procedure :: equal procedure :: copy end type ChildOfFoo interface ChildOfFoo module procedure newChildOfFoo end interface ChildOfFoo interface assertEqual module procedure assertEqual_FooFoo end interface assertEqual contains function newChildOfFoo(i,j) result(child) type (ChildOfFoo) :: child integer, intent(in) :: i integer, intent(in) :: j child%i = i child%j = j end function NewChildOfFoo subroutine copy(a, b) class (ChildOfFoo), intent(out) :: a class (Foo), intent(in) :: b a%i = b%i select type (b) class is (ChildOfFoo) a%j = b%j end select end subroutine copy logical function equal(a, b) class (ChildOfFoo), intent(in) :: a class (Foo), intent(in) :: b select type (b) class is (ChildOfFoo) equal = (a%i == b%i .and. a%j == b%j) class default equal = .false. end select end function equal subroutine assertEqual_FooFoo(a, b, message, location) class (Foo), intent(in) :: a class (Foo), intent(in) :: b character(len=*), optional, intent(in) :: message type (SourceLocation), optional, intent(in) :: location select type (a) class is (ChildOfFoo) select type (b) class is (ChildOfFoo) call assertEqual([a%i,a%j], [b%i,b%j], message, location) class default call throw('a and b are of different dynamic type') end select type is (Foo) select type (b) type is (Foo) call assertEqual(a%i, b%i, message, location) class default call throw('a and b are of different dynamic type') end select end select end subroutine assertEqual_FooFoo end module ChildOfFoo_mod gFTL-1.2.7/tests/shared/Foo.F90000066400000000000000000000021311372124645500157360ustar00rootroot00000000000000module Foo_mod use funit implicit none private public :: Foo public :: assertEqual type Foo integer :: i contains procedure :: equal generic :: operator(==) => equal !!$ procedure :: copy !!$ generic :: assignment(=) => copy end type Foo interface Foo module procedure newFoo end interface Foo interface assertEqual module procedure assertEqual_FooFoo end interface assertEqual contains function newFoo(i) result(f) type (Foo) :: f integer, intent(in) :: i f%i = i end function newFoo logical function equal(a, b) class (Foo), intent(in) :: a class (Foo), intent(in) :: b equal = (a%i == b%i) end function equal subroutine assertEqual_FooFoo(a, b, message, location) class (Foo), intent(in) :: a class (Foo), intent(in) :: b character(len=*), optional, intent(in) :: message type (SourceLocation), optional, intent(in) :: location call assertEqual(a%i, b%i, message, location) end subroutine assertEqual_FooFoo end module Foo_mod gFTL-1.2.7/tests/shared/pFUnitSupplement.F90000066400000000000000000000066111372124645500205040ustar00rootroot00000000000000!--------------------------------------------------------------------------- ! AssertEqual cannot be overloaded for unlimited polymorphic, as it would ! lead to ambiguous interface. A future pFUnit could provide only ! unlimited poly and then do selection under the hood. ! ! For the special purpose of testing Unlimited Polymorphic containers, ! this module should be used. !--------------------------------------------------------------------------- module pFUnitSupplement_mod use funit, only: shadowAssert => assertEqual use funit, only: SourceLocation use funit, only: throw use iso_fortran_env, only: INT64 use iso_fortran_env, only: REAL64 implicit none private public :: assertEqual interface assertEqual module procedure assertEqual_unlimited !!$ module procedure assertEqual_unlimitedArray end interface assertEqual contains subroutine assertEqual_unlimited(a, b, location) class (*), intent(in) :: a class (*), intent(in) :: b type (SourceLocation), intent(in) :: location select type (pa => a) type is (integer) select type (pb => b) type is (integer) call shadowAssert(pa, pb, location=location) type is (integer(kind=INT64)) call shadowAssert(pa, pb, location=location) class default call throw('inconsistent type', location=location) end select type is (integer(kind=INT64)) select type (pb => b) !!$ type is (integer) !!$ call shadowAssert(pa, pb, location=location) type is (integer(kind=INT64)) call shadowAssert(pa, pb, location=location) class default call throw('inconsistent type', location=location) end select type is (real) select type (pb => b) type is (real) call shadowAssert(pa, pb, location=location) class default call throw('inconsistent type', location=location) end select type is (real(REAL64)) select type (pb => b) type is (real(REAL64)) call shadowAssert(pa, pb, location=location) class default call throw('inconsistent type', location=location) end select type is (complex) select type (pb => b) type is (complex) call shadowAssert(pa, pb, location=location) class default call throw('inconsistent type', location=location) end select class default call throw('unsupported type', location=location) end select end subroutine assertEqual_unlimited !!$ subroutine assertEqual_unlimitedArray(a, b, location) !!$ type (XWrap), intent(in) :: a(:) !!$ type (XWrap), intent(in) :: b(:) !!$ type (SourceLocation), intent(in) :: location !!$ !!$ integer :: i !!$ !!$ call assertEqual(shape(a), shape(b), message='different shape', location=location) !!$ if (anyExceptions()) return !!$ !!$ do i = 1, size(a) !!$ select type (pa => a(i)%item) !!$ type is (integer) !!$ select type (pb => b(i)%item) !!$ type is (integer) !!$ call assertEqual(pa, pb, location=location) !!$ end select !!$ end select !!$ if (anyExceptions()) return !!$ end do !!$ !!$ !!$ end subroutine assertEqual_unlimitedArray end module pFUnitSupplement_mod gFTL-1.2.7/tests/testSuites.inc000066400000000000000000000001761372124645500163430ustar00rootroot00000000000000#include #include #include #include gFTL-1.2.7/tools/000077500000000000000000000000001372124645500134665ustar00rootroot00000000000000gFTL-1.2.7/tools/README.md000066400000000000000000000002231372124645500147420ustar00rootroot00000000000000# pFlogger/tools pFlogger/tools contains resources for use during development, build, and install, but which should not themselves be installed. gFTL-1.2.7/tools/travis-install-cmake.sh000066400000000000000000000006701372124645500200570ustar00rootroot00000000000000#!/bin/sh set -e cmake_ver="$1" if [ ! -d "${HOME}/local/cmake/bin" ] ; then wget https://github.com/Kitware/CMake/releases/download/v${cmake_ver}/cmake-${cmake_ver}.tar.gz tar -xzf cmake-${cmake_ver}.tar.gz && rm cmake-${cmake_ver}.tar.gz cd cmake-${cmake_ver} mkdir build && cd build cmake .. -DCMAKE_INSTALL_PREFIX=${HOME}/local/cmake make -j$(nproc) make install/strip cd ../.. && rm -r cmake-${cmake_ver} fi gFTL-1.2.7/tools/travis-install-gfe.bash000066400000000000000000000007311372124645500200410ustar00rootroot00000000000000#!/bin/bash set -e GFE_DIR=${HOME}/gfe mkdir -p ${GFE_DIR} # First install prerequisites GFE_INSTALL_DIR=${HOME}/Software/GFE mkdir -p ${GFE_INSTALL_DIR} to_build=(pFUnit) for repo in "${to_build[@]}" do cd ${GFE_DIR} git clone https://github.com/Goddard-Fortran-Ecosystem/${repo}.git cd ${GFE_DIR}/${repo} mkdir build && cd build cmake .. -DCMAKE_INSTALL_PREFIX=${GFE_INSTALL_DIR} -DCMAKE_PREFIX_PATH=${GFE_INSTALL_DIR} make -j$(nproc) install done