From dd031e7edb33c339becc42eef7893cdca42d212d Mon Sep 17 00:00:00 2001 From: Hugh Sorby Date: Mon, 2 Dec 2024 17:09:51 +1300 Subject: [PATCH 1/3] Remove pFUnit-3.2.9. --- tests/pFUnit-3.2.9/CMakeLists.txt | 188 -- tests/pFUnit-3.2.9/COPYRIGHT | 2 - tests/pFUnit-3.2.9/ChangeLog | 128 -- tests/pFUnit-3.2.9/Copyright.txt | 57 - tests/pFUnit-3.2.9/LICENSE | 195 -- tests/pFUnit-3.2.9/README-INSTALL | 543 ------ tests/pFUnit-3.2.9/README-RELEASE-CHECKLIST | 72 - tests/pFUnit-3.2.9/VERSION | 2 - tests/pFUnit-3.2.9/bin/CMakeLists.txt | 2 - tests/pFUnit-3.2.9/bin/pFUnitParser.py | 896 --------- tests/pFUnit-3.2.9/bin/parseDirectiveArgs.py | 77 - .../pFUnit-3.2.9/cmake/pFUnitConfig.cmake.in | 150 -- .../cmake/pFUnitConfigVersion.cmake.in | 11 - tests/pFUnit-3.2.9/cmake/packaging.cmake | 12 - tests/pFUnit-3.2.9/include/.cvsignore | 1 - tests/pFUnit-3.2.9/include/.gitignore | 4 - tests/pFUnit-3.2.9/include/CMakeLists.txt | 45 - tests/pFUnit-3.2.9/include/GNU.mk | 21 - tests/pFUnit-3.2.9/include/IBM.mk | 25 - tests/pFUnit-3.2.9/include/INTEL.mk | 64 - tests/pFUnit-3.2.9/include/NAG.mk | 31 - tests/pFUnit-3.2.9/include/PGI.mk | 27 - .../include/PreprocessMacro.cmake | 43 - tests/pFUnit-3.2.9/include/TestUtil.F90 | 23 - tests/pFUnit-3.2.9/include/base-develop.mk | 38 - tests/pFUnit-3.2.9/include/base-install.mk | 69 - tests/pFUnit-3.2.9/include/base.mk | 39 - .../cmake/Modules/FindOpenMP_Fortran.cmake | 107 - tests/pFUnit-3.2.9/include/driver.F90 | 336 ---- tests/pFUnit-3.2.9/include/extensions.mk | 28 - tests/pFUnit-3.2.9/source/.cvsignore | 13 - tests/pFUnit-3.2.9/source/.gitignore | 19 - .../source/AbstractTestParameter.F90 | 29 - .../source/AbstractTestResult.F90 | 86 - tests/pFUnit-3.2.9/source/Assert.F90 | 54 - tests/pFUnit-3.2.9/source/AssertBasic.F90 | 636 ------ tests/pFUnit-3.2.9/source/BaseTestRunner.F90 | 56 - tests/pFUnit-3.2.9/source/CMakeLists.txt | 105 - tests/pFUnit-3.2.9/source/CodeUtilities.py | 409 ---- tests/pFUnit-3.2.9/source/DebugListener.F90 | 95 - tests/pFUnit-3.2.9/source/DynamicTestCase.F90 | 77 - tests/pFUnit-3.2.9/source/Exception.F90 | 506 ----- tests/pFUnit-3.2.9/source/Expectation.F90 | 86 - .../source/GenerateAssertsOnArrays.py | 1726 ----------------- tests/pFUnit-3.2.9/source/GeneratedSources.py | 40 - tests/pFUnit-3.2.9/source/MakeDependenciesInc | 27 - tests/pFUnit-3.2.9/source/MakeDependenciesTmp | 38 - tests/pFUnit-3.2.9/source/Mock.F90 | 54 - tests/pFUnit-3.2.9/source/MockCall.F90 | 60 - tests/pFUnit-3.2.9/source/MockRepository.F90 | 288 --- tests/pFUnit-3.2.9/source/MpiContext.F90 | 339 ---- tests/pFUnit-3.2.9/source/MpiStubs.F90 | 114 -- tests/pFUnit-3.2.9/source/MpiTestCase.F90 | 143 -- tests/pFUnit-3.2.9/source/MpiTestMethod.F90 | 107 - .../pFUnit-3.2.9/source/MpiTestParameter.F90 | 79 - tests/pFUnit-3.2.9/source/ParallelContext.F90 | 116 -- .../pFUnit-3.2.9/source/ParallelException.F90 | 103 - .../source/ParameterizedTestCase.F90 | 58 - tests/pFUnit-3.2.9/source/Params.F90 | 47 - .../source/RemoteProxyTestCase.F90 | 216 --- tests/pFUnit-3.2.9/source/ResultPrinter.F90 | 203 -- tests/pFUnit-3.2.9/source/RobustRunner.F90 | 322 --- tests/pFUnit-3.2.9/source/SerialContext.F90 | 108 -- tests/pFUnit-3.2.9/source/SourceLocation.F90 | 74 - .../source/StringConversionUtilities.F90 | 328 ---- tests/pFUnit-3.2.9/source/SubsetRunner.F90 | 182 -- .../pFUnit-3.2.9/source/SurrogateTestCase.F90 | 73 - tests/pFUnit-3.2.9/source/Test.F90 | 67 - tests/pFUnit-3.2.9/source/TestCase.F90 | 200 -- tests/pFUnit-3.2.9/source/TestFailure.F90 | 46 - tests/pFUnit-3.2.9/source/TestListener.F90 | 108 -- tests/pFUnit-3.2.9/source/TestMethod.F90 | 101 - tests/pFUnit-3.2.9/source/TestResult.F90 | 342 ---- tests/pFUnit-3.2.9/source/TestRunner.F90 | 144 -- tests/pFUnit-3.2.9/source/TestSuite.F90 | 296 --- .../source/ThrowFundamentalTypes.F90 | 228 --- .../source/UnixPipeInterfaces.F90 | 97 - tests/pFUnit-3.2.9/source/UnixProcess.F90 | 248 --- tests/pFUnit-3.2.9/source/Utilities.py | 60 - tests/pFUnit-3.2.9/source/XmlPrinter.F90 | 306 --- tests/pFUnit-3.2.9/source/pFUnit.F90 | 185 -- tests/pFUnit-3.2.9/source/pFUnitPackage.F90 | 116 -- 82 files changed, 12796 deletions(-) delete mode 100644 tests/pFUnit-3.2.9/CMakeLists.txt delete mode 100644 tests/pFUnit-3.2.9/COPYRIGHT delete mode 100644 tests/pFUnit-3.2.9/ChangeLog delete mode 100644 tests/pFUnit-3.2.9/Copyright.txt delete mode 100644 tests/pFUnit-3.2.9/LICENSE delete mode 100644 tests/pFUnit-3.2.9/README-INSTALL delete mode 100644 tests/pFUnit-3.2.9/README-RELEASE-CHECKLIST delete mode 100644 tests/pFUnit-3.2.9/VERSION delete mode 100644 tests/pFUnit-3.2.9/bin/CMakeLists.txt delete mode 100755 tests/pFUnit-3.2.9/bin/pFUnitParser.py delete mode 100755 tests/pFUnit-3.2.9/bin/parseDirectiveArgs.py delete mode 100644 tests/pFUnit-3.2.9/cmake/pFUnitConfig.cmake.in delete mode 100644 tests/pFUnit-3.2.9/cmake/pFUnitConfigVersion.cmake.in delete mode 100644 tests/pFUnit-3.2.9/cmake/packaging.cmake delete mode 100644 tests/pFUnit-3.2.9/include/.cvsignore delete mode 100644 tests/pFUnit-3.2.9/include/.gitignore delete mode 100644 tests/pFUnit-3.2.9/include/CMakeLists.txt delete mode 100644 tests/pFUnit-3.2.9/include/GNU.mk delete mode 100644 tests/pFUnit-3.2.9/include/IBM.mk delete mode 100644 tests/pFUnit-3.2.9/include/INTEL.mk delete mode 100644 tests/pFUnit-3.2.9/include/NAG.mk delete mode 100644 tests/pFUnit-3.2.9/include/PGI.mk delete mode 100644 tests/pFUnit-3.2.9/include/PreprocessMacro.cmake delete mode 100644 tests/pFUnit-3.2.9/include/TestUtil.F90 delete mode 100644 tests/pFUnit-3.2.9/include/base-develop.mk delete mode 100644 tests/pFUnit-3.2.9/include/base-install.mk delete mode 100644 tests/pFUnit-3.2.9/include/base.mk delete mode 100644 tests/pFUnit-3.2.9/include/cmake/Modules/FindOpenMP_Fortran.cmake delete mode 100644 tests/pFUnit-3.2.9/include/driver.F90 delete mode 100644 tests/pFUnit-3.2.9/include/extensions.mk delete mode 100644 tests/pFUnit-3.2.9/source/.cvsignore delete mode 100644 tests/pFUnit-3.2.9/source/.gitignore delete mode 100644 tests/pFUnit-3.2.9/source/AbstractTestParameter.F90 delete mode 100644 tests/pFUnit-3.2.9/source/AbstractTestResult.F90 delete mode 100644 tests/pFUnit-3.2.9/source/Assert.F90 delete mode 100644 tests/pFUnit-3.2.9/source/AssertBasic.F90 delete mode 100644 tests/pFUnit-3.2.9/source/BaseTestRunner.F90 delete mode 100644 tests/pFUnit-3.2.9/source/CMakeLists.txt delete mode 100755 tests/pFUnit-3.2.9/source/CodeUtilities.py delete mode 100644 tests/pFUnit-3.2.9/source/DebugListener.F90 delete mode 100644 tests/pFUnit-3.2.9/source/DynamicTestCase.F90 delete mode 100644 tests/pFUnit-3.2.9/source/Exception.F90 delete mode 100644 tests/pFUnit-3.2.9/source/Expectation.F90 delete mode 100755 tests/pFUnit-3.2.9/source/GenerateAssertsOnArrays.py delete mode 100755 tests/pFUnit-3.2.9/source/GeneratedSources.py delete mode 100755 tests/pFUnit-3.2.9/source/MakeDependenciesInc delete mode 100755 tests/pFUnit-3.2.9/source/MakeDependenciesTmp delete mode 100644 tests/pFUnit-3.2.9/source/Mock.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MockCall.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MockRepository.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MpiContext.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MpiStubs.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MpiTestCase.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MpiTestMethod.F90 delete mode 100644 tests/pFUnit-3.2.9/source/MpiTestParameter.F90 delete mode 100644 tests/pFUnit-3.2.9/source/ParallelContext.F90 delete mode 100644 tests/pFUnit-3.2.9/source/ParallelException.F90 delete mode 100644 tests/pFUnit-3.2.9/source/ParameterizedTestCase.F90 delete mode 100644 tests/pFUnit-3.2.9/source/Params.F90 delete mode 100644 tests/pFUnit-3.2.9/source/RemoteProxyTestCase.F90 delete mode 100644 tests/pFUnit-3.2.9/source/ResultPrinter.F90 delete mode 100644 tests/pFUnit-3.2.9/source/RobustRunner.F90 delete mode 100644 tests/pFUnit-3.2.9/source/SerialContext.F90 delete mode 100644 tests/pFUnit-3.2.9/source/SourceLocation.F90 delete mode 100644 tests/pFUnit-3.2.9/source/StringConversionUtilities.F90 delete mode 100644 tests/pFUnit-3.2.9/source/SubsetRunner.F90 delete mode 100644 tests/pFUnit-3.2.9/source/SurrogateTestCase.F90 delete mode 100644 tests/pFUnit-3.2.9/source/Test.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestCase.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestFailure.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestListener.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestMethod.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestResult.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestRunner.F90 delete mode 100644 tests/pFUnit-3.2.9/source/TestSuite.F90 delete mode 100644 tests/pFUnit-3.2.9/source/ThrowFundamentalTypes.F90 delete mode 100644 tests/pFUnit-3.2.9/source/UnixPipeInterfaces.F90 delete mode 100644 tests/pFUnit-3.2.9/source/UnixProcess.F90 delete mode 100755 tests/pFUnit-3.2.9/source/Utilities.py delete mode 100644 tests/pFUnit-3.2.9/source/XmlPrinter.F90 delete mode 100644 tests/pFUnit-3.2.9/source/pFUnit.F90 delete mode 100644 tests/pFUnit-3.2.9/source/pFUnitPackage.F90 diff --git a/tests/pFUnit-3.2.9/CMakeLists.txt b/tests/pFUnit-3.2.9/CMakeLists.txt deleted file mode 100644 index 8dafe4ea..00000000 --- a/tests/pFUnit-3.2.9/CMakeLists.txt +++ /dev/null @@ -1,188 +0,0 @@ -# ------------------------------------------------------------------------ # -# DOCUMENTATION: -# ------------------------------------------------------------------------ # -# -# Command line options: -# MPI=YES ! defaults to NO -# MAX_RANK= -# ! defaults to 5 or -# ! ${PFUNIT_MAX_ARRAY_RANK} -# -# Usage: -# cmake -DMPI=YES -# -# ------------------------------------------------------------------------ # -cmake_minimum_required(VERSION 3.3) -cmake_policy(SET CMP0048 NEW) -project (pFUnit - VERSION 3.1.1 - LANGUAGES Fortran) - -if (DEFINED MAX_RANK) - set(PFUNIT_MAX_RANK ${MAX_RANK} CACHE STRING "Maximum array rank for generated code." FORCE) -endif () -set(PFUNIT_MAX_RANK 5 CACHE STRING "Maximum array rank for generated code.") -if (NOT PFUNIT_MAX_RANK) - # Remove PFUNIT_MAX_RANK in version 4. - if (DEFINED ENV{PFUNIT_MAX_RANK}) - set(PFUNIT_MAX_RANK "$ENV{PFUNIT_MAX_RANK}") - # Promote following to primary in version 4. - elseif (DEFINED ENV{PFUNIT_MAX_ARRAY_RANK}) - set(PFUNIT_MAX_RANK "$ENV{PFUNIT_MAX_ARRAY_RANK}") - else () - set(PFUNIT_MAX_RANK 5) - endif () -endif () - -if (DEFINED MPI) - set(PFUNIT_MPI ${MPI} CACHE BOOL "Use MPI for parallel runs" FORCE) -endif () -option(PFUNIT_MPI "Use MPI for parallel runs" NO) -option(PFUNIT_FIND_MPI "Attempt to automatically find MPI information" YES) -option(PFUNIT_MPI_USE_MPIEXEC "Use CMake's FindMPI to find mpiexec" NO) -option(PFUNIT_OPENMP "Use OPENMP for parallel runs" NO) - -# The following sets robust to "ON". -option(PFUNIT_ROBUST "Build robust test runner" YES) - -# If the user specifies this on the command line (or equivalently, in the -# CMake cache), we take them at their word and do not attempt any kind of -# autodetection. -set(PFUNIT_OPENMP_FLAGS "OPENMP_FLAGS-NOTFOUND" - CACHE STRING "OpenMP flags for the Fortran compiler.") - - -if (PFUNIT_MPI) - add_definitions(-DUSE_MPI) - if (PFUNIT_FIND_MPI) - set(MPI_USE_MPIEXEC ${PFUNIT_MPI_USE_MPIEXEC}) - find_package(MPI REQUIRED) - add_definitions(${MPI_Fortran_COMPILE_FLAGS}) - include_directories(${MPI_Fortran_INCLUDE_PATH}) - endif() - message( STATUS "MPI enabled") -endif() - -# 2014-0807 MLR MAX_RANK needed for code generation, not here. -#if (MAX_RANK) -# add_definitions(-DMAX_RANK=${MAX_RANK}) -#endif() - -if (PFUNIT_ROBUST) - add_definitions(-DBUILD_ROBUST) -endif() - -if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - - if (UNIX) - execute_process(COMMAND ifort --version - OUTPUT_VARIABLE INTEL_COMPILER_VERSION) - string (REGEX MATCH "([0-9]+)" - NUM_VERSION ${INTEL_COMPILER_VERSION}) - if ("${NUM_VERSION}" STREQUAL "13") - add_definitions(-DINTEL_13) - endif () - if ("${NUM_VERSION}" STREQUAL "16") - add_definitions(-DINTEL_16) - endif () - endif () - - #Use ifort - #There seems to be no easy way to determine the compiler version on Windows - #since it isn't necessary defined in the PATH. As a workaround, assume version - #different to 13 if exectuing ifort doesn't give any results - if (NOT "${INTEL_COMPILER_VERSION}" STREQUAL "") - string (REGEX MATCH "([0-9]+)" - NUM_VERSION ${INTEL_COMPILER_VERSION}) - if ("${NUM_VERSION}" STREQUAL "13") - add_definitions(-DINTEL_13) - endif () - if ("${NUM_VERSION}" STREQUAL "16") - add_definitions(-DINTEL_16) - endif () - endif () - - add_definitions(-DIntel) - if (WIN32) - set(CMAKE_Fortran_FLAGS - "-check:uninit -check:bounds -traceback -assume:realloc_lhs ${CMAKE_Fortran_FLAGS}" - ) - else (WIN32) - set(CMAKE_Fortran_FLAGS - "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -check uninit -check bounds -check pointers -check stack -traceback -assume realloc_lhs ${CMAKE_Fortran_FLAGS}" - ) - endif (WIN32) - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL GNU) - - # Use Gfortran - add_definitions(-DGNU) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -fbounds-check") - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL NAG) - - # use nagfor - add_definitions(-DNAG) -# Strong checking (-C=all breaks 6.0, but later releases will include it. -# set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -f2003 -w=uda -gline -fpp -C=all -fpp") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -f2003 -w=uda -gline -fpp -C=present -fpp") - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL XL) - - # Use XLF. - add_definitions(-DIBM) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -WF,-qfpp -C") - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL PGI) - - # Use PGI. - add_definitions(-DPGI) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS_DEBUG} -O0 -g -traceback -Mallocatable=03 -Mbounds -Mchkfpstk -Mchkstk") - -else() - - message( FATAL_ERROR "Unrecognized compiler. Please use ifort, gfortran, gfortran-mp-4.8, PGI, or nagfor" ) - -endif() - -# Fortran OpenMP support is not yet integrated into the CMake distribution. -set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} "${CMAKE_SOURCE_DIR}/include/cmake/Modules/") -if (PFUNIT_OPENMP) -# find_package(OpenMP_Fortran REQUIRED) -# if(OPENMP_FORTRAN_FOUND) -# set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") -# set(CMAKE_Fortran_LINKER_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") -# message( STATUS "OpenMP enabled") -# endif() - if (PFUNIT_OPENMP_FLAGS) - set(OpenMP_Fortran_FLAGS "${PFUNIT_OPENMP_FLAGS}") - else() - find_package(OpenMP_Fortran REQUIRED) - endif() - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") - set(CMAKE_Fortran_LINKER_FLAGS "${CMAKE_Fortran_FLAGS} ${OpenMP_Fortran_FLAGS}") - message( STATUS "OpenMP enabled") -endif() - -set(CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS "") -set(CMAKE_SKIP_RPATH ON) - -add_subdirectory (source) -# add_subdirectory (tests) -add_subdirectory (include) -add_subdirectory (bin) - -# Packaging -include (cmake/packaging.cmake) - -# Create the pFUnitConfig.cmake and pFUnitConfigVersion files -configure_file(cmake/pFUnitConfig.cmake.in - "${PROJECT_BINARY_DIR}/pFUnitConfig.cmake" @ONLY) -configure_file(cmake/pFUnitConfigVersion.cmake.in - "${PROJECT_BINARY_DIR}/pFUnitConfigVersion.cmake" @ONLY) - -# Install the pFUnitConfig.cmake and pFUnitConfigVersion.cmake -#install(FILES -# "${PROJECT_BINARY_DIR}/pFUnitConfig.cmake" -# "${PROJECT_BINARY_DIR}/pFUnitConfigVersion.cmake" -# DESTINATION . ) diff --git a/tests/pFUnit-3.2.9/COPYRIGHT b/tests/pFUnit-3.2.9/COPYRIGHT deleted file mode 100644 index a553584a..00000000 --- a/tests/pFUnit-3.2.9/COPYRIGHT +++ /dev/null @@ -1,2 +0,0 @@ -Copyright 2005 United States Government as represented by the Administrator of the National Aeronautics and Space Administration. All Rights Reserved. - diff --git a/tests/pFUnit-3.2.9/ChangeLog b/tests/pFUnit-3.2.9/ChangeLog deleted file mode 100644 index bf6ab4d2..00000000 --- a/tests/pFUnit-3.2.9/ChangeLog +++ /dev/null @@ -1,128 +0,0 @@ -3.2.9 July 21, 2017 - - minify code to suite reuse in project. - -3.2.8 September 5, 2016 - - Patch for PGI system() call (sf patch #9) - - Patch for deffered length strings (sf patch #10) - - Increased required version of cmake from 2.8 to 3.0 - It was alreaddy effectively required - just not noticed. - -3.2.7 May 24, 2016 - - Fix 3.2.7 broke the NAG 6.0 compiler (internal compiler error). - Workaround is to simply not use -C=all during the build for now. - -3.2.6 May 24, 2016 - - Bug fix for several issues identified by the latest NAG compiler - (6.1). These are mostly related to nostandard usage of TARGET - attributes that are unsafe for copyin/copyout. Many thanks to NAG - for helping to identify the problems. Note: these bugs are - innocuous under most circumstances/compilers. - -3.2.5 April 27, 2016 - - Another bug that prevented the compiler version workaround from - being handled correctly. - -3.2.4 April 27, 2016 - - Bug fix - earlier merge broke unix test for Intel compiler - version. This prevented fix in 3.2.2 from being used. - -3.2.3 April 25, 2016 - - Fixed mistake in OpenMP introduced during previous bug fix. - -3.2.2 April 24, 2016 - - Workaround for ifort 16.0.2 bug with openmp - - Various minor improvements to code: - . Fixed inconsistent names in self tests. - . Introduced "-qopenmp" in find_package for OpenMP - . RemoteProxy now ignores output starting with "DEBUG:" - useful - for debugging self tests. - - -3.2.1 April 21, 2016 - - Trivial bug fix in include/driver.F90. Missed in rush to do release 3.2.1. - -3.2.0 April 21, 2016 - - Extension: support test to run on "all available" pes. - . This is primarily aimed to enable testing coarray Fortran procedures - CAF does not yet have "teams", so tests must use all images. But - MPI users may find it useful as well. Just use "*" instead of a number - when specifying NPES. True CAF support should be expected in release 4.0.0. - - Extension: support test case with custom constructor. With this extension was - able to create external extensions to the framework that allow testing ESMF grideded - components. Contact Tom Clune if you want to have those extensions - did not want to - induce an ESMF requirement for pFUnit. - - Improved support for CMake (contributed by Pal Levold) - . packaging - . add_pfunit_test() macro - . Ctests (CMake testing package) - . NOTE: now requires a more recent CMake version. - - Increased max filename length to avoid truncation - - Disabled --verbose command line option (breaks under gcc) - - Cleanup to reduce/eliminate compiler warnings when building. - - There is a regression in NAG 6.1, so NAG users should continue to use 6.0 until a - fix or a workaround are found - -3.1.1 - - PGI 15.7 appears to be working robustly - . some previously necessary workarounds have been removed - - Additional documentation for XML printer - - Improved compliance with JUnit for XML printer - - Bug fix for RemoteProxyTestCase - - CMake workaround for OpenMPI 1.8.8 which otherwise complains about nested - MPI programs in self tests. - - Fixed KEEP_ALL option in AssertEqual for zero-length strings. - Because "" == " " in Fortran, AssertEqual(""," ",whitespace=KEEP_ALL), - which should throw an exception, failed silently for zero-length arrays. - - Fixed the make clean bug in Example code. - - Added time out command line arguments. - - Added PFUNIT_EXTRA_USAGE in include/driver.F90 for suite-wide fixture use. - - Cray workarounds on a separate branch (hope for a release in November). - -3.1 March 20, 2015 - - PGI 15.1 now supported. - - Asserts over integer arrays now supported. INT32 and INT64 support added. - - Consolidated assertAssociated directives to: - @assertAssociated - @assertNotAssociated - - Added ifndef option to preprocessor directives. - - Fixes: Name length checking, unbalanced allocate, python 3 basestring. - -3.0.2 December 12, 2014 - - Corrected lack of PRESENT check on some optional arguments. - - Brought integer array version of assertEqual up to level of other numbers. - - Directives added: - @assertEquivalent(...) - @assertEqual(a,b) - @assertAssociated(...), @assertUnAssociated(...) - @assertAssociatedWith(...), @assertUnAssociatedWith(...) - - Added code to parse brackets in directive arguments, - allowing @assertEquivalent([...],[...]). - Needed for directives that must parse arguments to construct other calls. - - Extended assertTrue and assertFalse to cover arrays of logical. - - Removed dependency on CPP stringification in the REFLECT macro simplifying build. - - Improved portability of build, fixing problem with OUTPUT_FLAG, i.e. "-o". - - Fixed build problem on NAG, cmake/gmake, and OS X. - - Replaced explicit invocations of python with $(PYTHON), set in GNUmakefile, - to aid specification. - - Removed an extraneous allocate (Patch 5). - -3.0.1 September 15, 2014 - - Fixed parser bug that was not recognizing user-provided procedures - annotated with @before/@after for MPI tests. - - Corrected end-of-run logic in include/driver.F90. - - Minor corrections & simplifications to build process. - - Improved compilation time by refactoring automatically generated code. - - Added compile-time configuration parameter to control maximum rank - supported by assertions over arrays, e.g. AssertReal. - - Added "whitespace=IGNORE_DIFFERENCES" and similar options to AssertEqual. - - -3.0.0 April 04, 2014 - - Design improvement that unfortunately breaks GFortran prior to - 4.8.3 and 4.9.0 (main reason for major release) - - Default driver now produces useful return code in serial (and some MPI) - - New assertions for floating point: <, <=, >, >= - - Various improvements to parser - - - diff --git a/tests/pFUnit-3.2.9/Copyright.txt b/tests/pFUnit-3.2.9/Copyright.txt deleted file mode 100644 index 9342249a..00000000 --- a/tests/pFUnit-3.2.9/Copyright.txt +++ /dev/null @@ -1,57 +0,0 @@ -CMake - Cross Platform Makefile Generator -Copyright 2000-2013 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. - ------------------------------------------------------------------------------- - -The above copyright and license notice applies to distributions of -CMake in source and binary form. Some source files contain additional -notices of original copyright by their contributors; see each source -for details. Third-party software packages supplied with CMake under -compatible licenses provide their own copyright notices documented in -corresponding subdirectories. - ------------------------------------------------------------------------------- - -CMake was initially developed by Kitware with the following sponsorship: - - * National Library of Medicine at the National Institutes of Health - as part of the Insight Segmentation and Registration Toolkit (ITK). - - * US National Labs (Los Alamos, Livermore, Sandia) ASC Parallel - Visualization Initiative. - - * National Alliance for Medical Image Computing (NAMIC) is funded by the - National Institutes of Health through the NIH Roadmap for Medical Research, - Grant U54 EB005149. - - * Kitware, Inc. diff --git a/tests/pFUnit-3.2.9/LICENSE b/tests/pFUnit-3.2.9/LICENSE deleted file mode 100644 index 03175835..00000000 --- a/tests/pFUnit-3.2.9/LICENSE +++ /dev/null @@ -1,195 +0,0 @@ -NASA OPEN SOURCE AGREEMENT VERSION 1.3 - -THIS OPEN SOURCE AGREEMENT ("AGREEMENT") DEFINES THE RIGHTS OF USE, -REPRODUCTION, DISTRIBUTION, MODIFICATION AND REDISTRIBUTION OF CERTAIN -COMPUTER SOFTWARE ORIGINALLY RELEASED BY THE UNITED STATES GOVERNMENT -AS REPRESENTED BY THE GOVERNMENT AGENCY LISTED BELOW ("GOVERNMENT -AGENCY"). THE UNITED STATES GOVERNMENT, AS REPRESENTED BY GOVERNMENT -AGENCY, IS AN INTENDED THIRD-PARTY BENEFICIARY OF ALL SUBSEQUENT -DISTRIBUTIONS OR REDISTRIBUTIONS OF THE SUBJECT SOFTWARE. ANYONE WHO -USES, REPRODUCES, DISTRIBUTES, MODIFIES OR REDISTRIBUTES THE SUBJECT -SOFTWARE, AS DEFINED HEREIN, OR ANY PART THEREOF, IS, BY THAT ACTION, -ACCEPTING IN FULL THE RESPONSIBILITIES AND OBLIGATIONS CONTAINED IN -THIS AGREEMENT. - -Government Agency: National Aeronautics and Space Administration -(NASA), Goddard Space Flight Center Government Agency Original -Software Designation and Software Title: GSC-15,137-1 F-UNIT - -User Registration Requested. Please Visit: Government Agency Point of -Contact for Original Software: - - - -1. DEFINITIONS - -A. "Contributor" means Government Agency, as the developer of the -Original Software, and any entity that makes a Modification. - -B. "Covered Patents" mean patent claims licensable by a Contributor -that are necessarily infringed by the use or sale of its Modification -alone or when combined with the Subject Software. - -C. "Display" means the showing of a copy of the Subject Software, -either directly or by means of an image, or any other device. - -D. "Distribution" means conveyance or transfer of the Subject -Software, regardless of means, to another. - -E. "Larger Work" means computer software that combines Subject -Software, or portions thereof, with software separate from the Subject -Software that is not governed by the terms of this Agreement. - -F. "Modification" means any alteration of, including addition to or -deletion from, the substance or structure of either the Original -Software or Subject Software, and includes derivative works, as that -term is defined in the Copyright Statute, 17 USC 101. However, the -act of including Subject Software as part of a Larger Work does not in -and of itself constitute a Modification. - -G. "Original Software" means any or all of the computer software -first released under this Agreement by Government Agency with -Government Agency designation GSC-15,137-1, with title identified -herein, including source code, object code and accompanying -documentation, if any. - -H. "Recipient" means anyone who acquires the Subject Software under -this Agreement, including all Contributors. - -I. "Redistribution" means Distribution of the Subject Software after -a Modification has been made. - -J. "Reproduction" means the making of a counterpart, image or copy of -the Subject Software. - -K. "Sale" means the exchange of the Subject Software for money or -equivalent value. - -L. "Subject Software" means the Original Software, Modifications, or -any respective parts thereof. - -M. "Use" means the application or employment of the Subject Software -for any purpose. - - -2. GRANT OF RIGHTS - -A. Under Non-Patent Rights: Subject to the terms and conditions of -this Agreement, each Contributor, with respect to its own contribution -to the Subject Software, hereby grants to each Recipient a -non-exclusive, world-wide, royalty-free license to engage in the -following activities pertaining to the Subject Software: - -1. Use 2. Distribution 3. Reproduction 4. Modification -5. Redistribution 6. Display - -B. Under Patent Rights: Subject to the terms and conditions of this -Agreement, each Contributor, with respect to its own contribution to -the Subject Software, hereby grants to each Recipient under Covered -Patents a non-exclusive, world-wide, royalty-free license to engage in -the following activities pertaining to the Subject Software: - -1. Use 2. Distribution 3. Reproduction 4. Sale 5. Offer for Sale - -C. The rights granted under Paragraph B. also apply to the -combination of a Contributor's Modification and the Subject Software -if, at the time the Modification is added by the Contributor, the -addition of such Modification causes the combination to be covered by -the Covered Patents. It does not apply to any other combinations that -include a Modification. - -D. The rights granted in Paragraphs A. and B. allow the Recipient to -sublicense those same rights. Such sublicense must be under the same -terms and conditions of this Agreement. - - -3. OBLIGATIONS OF RECIPIENT - -A. Distribution or Redistribution of the Subject Software must be -made under this Agreement except for additions covered under paragraph -3H. - -1. Whenever a Recipient distributes or redistributes the Subject -Software, a copy of this Agreement must be included with each copy of -the Subject Software; and - -2. If Recipient distributes or redistributes the Subject Software in -any form other than source code, Recipient must also make the source -code freely available, and must provide with each copy of the Subject -Software information on how to obtain the source code in a reasonable -manner on or through a medium customarily used for software exchange. - -B. Each Recipient must ensure that the following copyright notice -appears prominently in the Subject Software: - -Copyright 2005 United States Government as represented by the -Administrator of The National Aeronautics and Space -Administration. All Rights Reserved. - -C. Each Contributor must characterize its alteration of the Subject -Software as a Modification and must identify itself as the originator -of its Modification in a manner that reasonably allows subsequent -Recipients to identify the originator of the Modification. In -fulfillment of these requirements, Contributor must include a file -(e.g., a change log file) that describes the alterations made and the -date of the alterations, identifies Contributor as originator of the -alterations, and consents to characterization of the alterations as a -Modification, for example, by including a statement that the -Modification is derived, directly or indirectly, from Original -Software provided by Government Agency. Once consent is granted, it -may not thereafter be revoked. - -D. A Contributor may add its own copyright notice to the Subject -Software. Once a copyright notice has been added to the Subject -Software, a Recipient may not remove it without the express permission -of the Contributor who added the notice. - -E. A Recipient may not make any representation in the Subject -Software or in any promotional, advertising or other material that may -be construed as an endorsement by Government Agency or by any prior -Recipient of any product or service provided by Recipient, or that may -seek to obtain commercial advantage by the fact of Government Agency's -or a prior Recipient's participation in this Agreement. - -F. In an effort to track usage and maintain accurate records of the -Subject Software, each Recipient, upon receipt of the Subject -Software, is requested to register with Government Agency by visiting -the following website: . Recipient's name and personal information -shall be used for statistical purposes only. Once a Recipient makes a -Modification available, it is requested that the Recipient inform -Government Agency at the web site provided above how to access the -Modification. - -G. Each Contributor represents that its Modification is believed to -be Contributor's original creation and does not violate any existing -agreements, regulations, statutes or rules, and further that -Contributor has sufficient rights to grant the rights conveyed by this -Agreement. - -H. A Recipient may choose to offer, and to charge a fee for, -warranty, support, indemnity and/or liability obligations to one or -more other Recipients of the Subject Software. A Recipient may do so, -however, only on its own behalf and not on behalf of Government Agency -or any other Recipient. Such a Recipient must make it absolutely -clear that any such warranty, support, indemnity and/or liability -obligation is offered by that Recipient alone. Further, such -Recipient agrees to indemnify Government Agency and every other -Recipient for any liability incurred by them as a result of warranty, -support, indemnity and/or liability offered by such Recipient. - -I. A Recipient may create a Larger Work by combining Subject Software -with separate software not governed by the terms of this agreement and -distribute the Larger Work as a single product. In such case, the -Recipient must make sure Subject Software, or portions thereof, -included in the Larger Work is subject to this Agreement. - -J. Notwithstanding any provisions contained herein, Recipient is -hereby put on notice that export of any goods or technical data from -the United States may require some form of export license from the -U.S. Government. Failure to obtain necessary export licenses may -result in criminal liability under U.S. laws. Government Agency -neither represents that a license shall not be required nor that, if -required, it shall be issued. Nothing granted herein provides any -such export license. - - diff --git a/tests/pFUnit-3.2.9/README-INSTALL b/tests/pFUnit-3.2.9/README-INSTALL deleted file mode 100644 index c7318e82..00000000 --- a/tests/pFUnit-3.2.9/README-INSTALL +++ /dev/null @@ -1,543 +0,0 @@ - -PFUNIT VERSION 3.2.1 INSTALLATION AND BASIC USAGE GUIDE - -VERSION 2015-1210 M. Rilee mike@rilee.net - -TABLE OF CONTENTS - -1. PREREQUISITES -2. OBTAINING PFUNIT -3. WHAT'S IN THE DIRECTORY? -4. CONFIGURATION -5. BUILDING PFUNIT -6. INSTALLATION -7. USAGE -8. DEVELOPMENT -9. FEEDBACK & SUPPORT -10. ACKNOWLEDGMENTS -11. KNOWN INSTALLATIONS/VERSIONS -12. NOTES -13. TODO - - -1. PREREQUISITES - -The development work for pFUnit has mostly been carried out on a -mixture of systems, including high-end computers, Apple Mac OSX, and -linux-based systems. A preliminary Windows/CYGWIN port has been -contributed by a user. Full use of the system depends on the following -being available. - -Fortran 2003+ - Tested with: - Intel 14+, - NAG 6.0, - GFortran 4.8.3, 4.9.+, 5.0+ - IBM's XLF - PGI 15.7 -The Message Passing Interface (MPI) -OPENMP -GNU Make -Python 2.7+ - -A CMake build process is also available. - -Doxygen is used to generate documentation (see http://www.doxygen.org). - -The system is routinely undergoes regression testing, including with GNU, -Intel, and NAG fortran compilers and OpenMPI. - -pFUnit makes extensive use of leading edge Fortran language features, -which are generally best supported with by the latest compiler -versions. The capacity to support older compilers is limited. - -2. OBTAINING PFUNIT - -The best way to obtain pFUnit is to clone the git repository from -SourceForge as follows. - -# Read Only Access -git clone git://git.code.sf.net/p/pfunit/code pFUnit - -This will create the directory pFUnit in the current working -directory. - -You may also visit the project page at SourceForge and -download the source tarfile "pFUnit.tar.gz" there. - -http://sourceforge.net/projects/pfunit/ - -or - -http://sourceforge.net/projects/pfunit/files/latest/download - -Extracting this tarfile via a command like - -$ tar zxf ./pFUnit.tar.gz - -will place the pFUnit files into the current working directory. - -For other ways to acquire the code visit - -https://sourceforge.net/p/pfunit/code/ci/master/tree/ - -or contact the pFUnit team. - -3. WHAT'S IN THE DIRECTORY? - -In the top level of the pFUnit distribution you will see the following -files. - -CMakeLists.txt - Initial support for cmake-based builds. - -COPYRIGHT - Contains information pertaining to the use and -distribution of pFUnit. - -Examples - Contains examples of how to use pFUnit once it is -installed. - -GNUmakefile - The top level makefile for building and installing -pFUnit. - -bin - Executables used to construct and perform unit tests. - -documentation - Provides information about the pFUnit. - -include - Files to be included into makefiles or source, including use -code. - -LICENSE - The NASA Open Source Agreement for GSC-15,137-1 F-UNIT, also known as pFUnit. - -README-INSTALL - This file. - -source - Source code and scripts of the pFUnit library and framework. - -tests - Source code for unit testing pFUnit itself. - -tools - Tools used to help develop, build, and install pFUnit. - -VERSION - Contains a string describing the current version of the framework. - -4. CONFIGURATION - -Little needs to be done to configure pFUnit for the build, however -there are several environment variables on which the package depends. - -F90_VENDOR - is set to include the correct makefile in -$(TOP_DIR)/include, i.e. GNU, Intel, NAG, or PGI. Case insensitive -file systems may cause some confusion from time-to-time. - -F90 - is set to the Fortran compiler being used: e.g. ifort for Intel, gfortran for GNU. - -COMPILER - is set according to F90_VENDOR and is automatically set in -the top level makefile. - -For MPI-based unit testing, your setup may require the following as well. - -MPIF90 -$ # e.g. -$ export MPIF90=mpif90 - -As a convenience for working with multiple MPI configurations, you may -also set the following. - -MPIRUN -$ # e.g. -$ export MPIRUN=/some.path/mpirun - -PFUNIT_MAX_ARRAY_RANK - controls the maximum number of (Fortran) dimensions -of the arrays asserts are defined over. If PFUNIT_MAX_ARRAY_RANK is not -set, the default is 5 and pFUnit's assertions will be able to handle -arrays up to rank 5, i.e. A(:,:,:,:,:). PFUNIT_MAX_ARRAY_RANK and MAX_RANK -do not refer to MPI ranks (process id within a group). Example: - -$ export PFUNIT_MAX_ARRAY_RANK=8 - -PFUNIT_MAX_RANK is a deprecated way to set maximum rank and is to be removed -in version 4. - -DOXYGEN - To generate documentation, set DOXYGEN to the desired -executable. NOTE: Doxygen Version 1.8.5 does not respect CamelCase -names from Fortran source code by currently converting all to -lowercase. It does this to get HTML links correct for references in -the source code that also do not respect the CamelCase convention. -The Fortran standard specifies case insensitivity. Doxygen 1.7.x -seems to better respect CamelCase. -$ #.e.g. -$ export DOXYGEN=/opt/local/share/doxygen/doxygen-1.7.6/bin/doxygen - -5.1 BUILDING PFUNIT FOR TESTING SERIAL CODES (Non-MPI) - -1. Change to the directory into which pFUnit has been placed. -2. Set these environment variables (bash example): -$ export F90=gfortran-mp-4.8 -$ export F90_VENDOR=GNU -3. To build pFUnit for unit testing of serial codes, execute make. -The unit tests for pFUnit itself will run automatically. -$ make tests -3.1 Occasionally on the first run through, one will get a spurious -(runtime) error, for example in the unix process component. -Re-execute "make tests" to check again. -4. At this point the pFUnit object library is in the source directory, -along with a large number of Fortran module files. - -5.2 BUILDING PFUNIT FOR TESTING PARALLEL CODES (MPI) - -To build pFUnit for unit testing MPI-based codes, be sure that the -environment is properly set up for the MPI implementation you are -using. Depending on your local environment, you may need execute the -build within a batch or other job queing system, e.g. an interactive -batch job under PBS. The steps for building pFUnit start out the same -as for the serial case above, but add MPI=YES to the environment to -switch on MPI support. The MPI-based unit tests for pFUnit itself -will run automatically. Again, occasionally a spurious (runtime) -error may appear on the first execution. - -3. Execute make as follows. -$ make tests MPI=YES - -4. At this point an MPI-enabled pFUnit object library is in the source -directory, along with a large number of Fortran module files. - -Also, one may get some harmless "no symbols" warnings when the pFUnit library is constructed. - -5.3 BUILDING PFUNIT FOR TESTING PARALLEL CODES (OPENMP) - -Initial (limited) support for OPENMP has been implemented. At this -writing, a basic functionality is available. - -The process for building pFUnit for testing OPENMP-based codes is -similar to that for other paradigms. - -3. To compile for OPENMP support execute make as follows. -$ make tests OPENMP=YES - -4. At this point the OPENMP-enabled pFUnit is ready to be installed. - -5.4 CLEANING - -To clean the pFUnit build directory for the space or to rebuild there -are two options. - -1. Make clean to remove object files and other intermediate products. -$ make clean - -2. Make distclean to remove libraries and other more final products. -$ make distclean - -3. Some directories support a "make src_clean" to remove intermediate -products in subdirectories. - -5.5 BUILDING THE DOCUMENTATION - -A start at documentation for pFUnit is in the documentation directory. -Doxygen is our primary documentation tool. To make the documentation, -which will be generated in the documentation directory, please invoke -the following from the top level of the PFUNIT distribution. - -$ make documentation - -Or to make a reference manual: - -$ make documentation/pFUnit2-ReferenceManual.pdf - -To select a specific version of Doxygen, please set the DOXYGEN -environment variable as in the Configuration section above. You -may wish to do this if your code uses CamelCase names as current -versions of Doxygen (1.8.5) do not respect this convention for -Fortran. - -5.6 BUILDING PFUNIT USING CMAKE - -Initial support for CMAKE has been implemented. At this -writing, a basic functionality is available. - -3. The process for building pFUnit using cmake is as follows. In the -top directory of the distribution make a new directory to support the -build, then change to that directory and run cmake (pointing back to -the source) to generate the required makefiles. - -$ mkdir build -$ cd build -$ # e.g. cmake -DMPI=YES -DOPENMP=NO -$ cmake -DMPI=NO .. -$ make tests - -Don't forget you can use the standard -DCMAKE_INSTALL_PREFIX to define where -the resulting tool will be installed. - -If your MPI installation does not provide mpirun, you may try to set --DMPI_USE_MPIEXEC=YES to tell CMake to use its FindMPI function to -find out how to execute the tests. - -4. If the build is successful, then at this point make install should work. - -6. INSTALLATION - -Installations 6.1-6.5 are based on GNU make and the project makefiles. If you -use CMake then "make install" will install to the expected place. That is, to -/usr/local if you specify nothing, otherwise to wherever CMAKE_INSTALL_PREFIX -points. - -6.1 INSTALLATION - SERIAL - -To install pFUnit for regular use, set INSTALL_DIR to the location in -which to place pFUnit. This can be done on the make command line. -For example, after compiling pFUnit for serial use (MPI absent or -MPI=NO), please try. - -$ # In the top of the pFUnit build directory. -$ make install INSTALL_DIR=/opt/pfunit/pfunit-serial - -Note: you may need special priveleges to install in some locations, -e.g. via sudo. - -To test the installation set PFUNIT to INSTALL_DIR, then change the -working directory to Examples in pFUnit distribution and execute -"make," which will run a number of examples. These include some -expected (intentional) failures. - -$ # In the top pFUnit build directory... -$ export PFUNIT=/opt/pfunit/pfunit-serial -$ cd Examples -$ make - -6.2 INSTALLATION - MPI - -For installing an MPI-enabled pFUnit library, change to the top of the -distribution and execute make with MPI=YES. You may need to "make -distclean" first. After compilation and pFUnit passes its self-tests, -then installation proceeds as for the serial case above. - -$ make install INSTALL_DIR=/opt/pfunit/pfunit-parallel - -To test, set PFUNIT and go into Examples/MPI_Halo directory. - -$ # In the top pFUnit build directory... -$ export PFUNIT=/opt/pfunit/pfunit-parallel -$ # The variable MPIF90 must be set to the appropriate build script. -$ export MPIF90=mpif90 -$ cd Examples/MPI_Halo/ -$ make - -This will compile and run a set of parallel examples that includes -intentional failures. To run all of the examples try executing -"make MPI=YES" in the Examples directory. - -6.3 INSTALLATION - OPENMP - -At this time the OPENMP version of pFUnit can be installed in the same -way as for the serial or MPI-parallel codes. OPENMP support, tests, -and examples are limited as of this writing. - -6.4 INSTALLATION - DEFAULT DIRECTORY - -If INSTALL_DIR is not set, "make install" will attempt to install -pFUnit into the top build directory. This will create directories -such as lib and mod in the top level of the build directory and will -overwrite the include/base.mk with include/base-install.mk. If this -is not desired, then "make develop" will put back the original -base.mk, which is the file to be used for development and building -pFUnit. In general, we recommend installing to a directory that is -not also the build directory. - -7.1 USAGE - CONFIGURATION - -For regular use, after installation, the same compiler/MPI development -configuration that was used to build pFUnit should be used. Once the -environment variables and paths associated with the environment are -set, to configure pFUnit, please set the following. - -PFUNIT - set to the directory into which pFUnit was installed. -F90_VENDOR - set to Intel, GNU, NAG, or PGI accordingly. - -7.2 USAGE - PREPROCESSOR - HELLO WORLD - -An example of how to use the preprocessor can be found in -Examples/Simple. The GNU makefile shows how to construct an F90 file -from a preprocessor input file. For example, the GNU make rule can be: - -# GNU makefile rule -%.F90: %.pf - $(PFUNIT)/bin/pFUnitParser.py $< $@ - -The file testSuites.inc is included in the include/driver.F90 file -during the build process. To include tests, one must add the test -suite module to testSuites.inc, as follows. - -! Add a test suite to the build. -ADD_TESTS_SUITE(helloWorld_suite) - -A preprocessor input file contains tests and is a -Fortran free-format file with directives, for example: - -! helloWorld.pf - with a successful test... -@test -subroutine testHelloWorld() - use pfunit_mod - implicit none - @assertEqual("Hello World!","Hello World!") -end subroutine testHelloWorld - -7.3 USAGE - Compiling and Executing the Tests (SERIAL) - -An example of a GNU make rule for for the final step of compiling a test follows. - -# This step presumes "include $(PFUNIT)/include/base.mk" earlier in the makefile. -tests.x: testSuites.inc myTests.pf - $(F90) -o $@ -I$(PFUNIT)/mod -I$(PFUNIT)/include \ - $(PFUNIT)/include/driver.F90 \ - ./*$(OBJ_EXT) $(LIBS) $(FFLAGS) - -To execute the tests, one invokes "./tests.x" with the appropriate command line options (see below). - -In some cases, since include/driver.F90 is "implicit none," it may be -necessary to insert a "use" clause to identify external suite-wide -fixture code to the compiler. As a convenience, the CPP macro -PFUNIT_EXTRA_USAGE can be set to a module of fixture code via a -compiler command line argument turning on a "use PFUNIT_EXTRA_USAGE" -line at the beginning of include/driver.F90. - -7.3.1 USAGE - Compiling and Executing the Tests (MPI PARALLEL) - -One invokes MPI-based parallel tests according to the MPI framework being used. For example: - -$ mpirun -np 4 tests.x - - -7.4 USAGE - Command Line Options - -The executable test program provides several command line options, -when "include/driver.F90" is used, as it is automatically when using -the PFUNIT preprocessor. - --v or -verbose Verbose execution. --d or -debug Provide debugging information. --h Print help message. --o Direct pFUnit messages to a file. --robust Use the robust runner. Runs tests as processes so failures do not halt testing. --max-timeout-duration Limit detection time for robust runner. --max-launch-duration Limit detection time for robust runner. --skip Use the subset runner, which runs a subset of the tests in a suite. - -An example from Examples/Robust: - -$ ./tests.x -robust - -8. DEVELOPMENT - -Generally pFUnit development is performed in the build directory -structure. Care should be taken to make clean or distclean in between -configuration changes. As stated above, it is best to set INSTALL_DIR -and "make install" pFUnit to another directory that can be placed in a -user's paths. - -9.1 FEEDBACK AND BUGS - -9.2 SUPPORT - -9.3 TIPS - -1. Environment Modules - Though not strictly required, the Environment -Modules package can be a convenient way to package, maintain, and -switch between environments. This can be particularly important for -pFUnit, which must be built using the same tool suite being used for -development, e.g. compilers, linkers, etc. [To do: A sample pFUnit -modulefile is provided in the OTHER directory.] Environment Modules - -2. Compile time errors like '"include [...]include/.mk" not found' -likely signify that you not executing make in the top level -directory during a build. Alternatively, during regular usage after -installation, PFUNIT has not been set. - -During building, if you wish to compile in a subdirectory of within the -pFUnit heriarchy, please try setting the COMPILER environment variable -on the make command line. For example: - -$ make all COMPILER=Intel - -3. If you wish to see the intermediate files, use the target .PRECIOUS -in the makefile to keep them from being deleted. For example: - -# In GNUmakefile -.PRECIOUS: %_cpp.F90 - -9.4 PLATFORM SPECIFIC NOTES - -9.4.1 Mac OSX - -The MacPorts package management system is a convenient way to install -and maintain many packages, including gcc which includes gfortran. - -9.4.2 Windows/CYGWIN - -User contributed code for Windows/CYGWIN has been added, but is -currently not tested and supported by the pFUnit team. At this -writing, 2013-1031, serial Examples and MPI are not known to be -supported. Please contact us if you wish to either contribute or -otherwise discuss this port. - -9.4.3 Intel Fortran Version 13: -DINTEL_13 - -Using version 13 is deprecated. We have encountered problems using -version 13, which we believe may be due to subtle compiler bugs. We -strongly recommend upgrading to the latest version possible. - -To make pFUnit work with Intel Fortran Version 13, please ensure that -"-DINTEL_13" is passed to the compiler when building or using -pFUnit. In the build process for pFUnit, this is added to the make -variables CPPFLAGS and FPPFLAGS. - -10. ACKNOWLEDGMENTS - -Thanks to the follwing for their review and comments: B. Van Aartsen, T. Clune. - -Windows/CYGWIN contributions from E. Lezar. - -PGI port contributions from M. Leair (PG Group). - -Other acknowledgments: S.P. Santos (NCAR), M. Hambley (UK Met Office), - J. Krishna (ANL), J. Ebo David. - -11. KNOWN INSTALLATIONS/VERSIONS (git cognizant from "sourceforge.net/projects/pfunit") - -master - The current release. - -development - The cutting edge of pFUnit development. - -mock_services - Experimental support for mocking. - -pfunit_2.1.0 - A feature freeze prior to a major upgrade of the preprocessor. - -cray - An intermediate port to Cray CCE. - -12. NOTES - -* For modifications and feature requests please see "sourceforge.net/projects/pfunit". - -TBD - -13. --TODO-- - -- Make other directory. -- Make Environment Modules example in other directory. -- Other build systems, e.g. CMake. - - -14. REVISIONS TO THIS DOCUMENT - -f2015-1210 Minor changes to documentation. MLR -2015-0608 Added note about PFUNIT_EXTRA_USAGE (from MH). MLR -2015-0508 Some PGI workarounds removed for PGI 15.4. MLR -2015-0420 Clarified PFUNIT_MAX_ARRAY_RANK note. MLR -2015-0320 PGI port workarounds, including examples. 3.1. MLR -2014-1211 Minor updates for 3.0.2. MLR -2014-1110, 2014-1031 Minor edits. MLR -2014-0915 Minor updates for 3.0.1. MLR -2014-0404 Updated for release of 3.0. TLC -2014-0131, 2014-0205. Updated. MLR -2013-1107. Minor edits. MLR -2013-1031. Added user contributed code for Windows/CYGWIN & IBM's XLF. MLR -2013-0830-1359. Minor corrections and added MPIF90 to 6.2. MLR -2013-0806-1345. Corrected git reference. Was using old URL. MLR -2013-0805. Initial draft. MLR diff --git a/tests/pFUnit-3.2.9/README-RELEASE-CHECKLIST b/tests/pFUnit-3.2.9/README-RELEASE-CHECKLIST deleted file mode 100644 index 060fa409..00000000 --- a/tests/pFUnit-3.2.9/README-RELEASE-CHECKLIST +++ /dev/null @@ -1,72 +0,0 @@ - -README-RELEASE-CHECKLIST MLR 2015-1210 - -******************************************************** -**** THIS CHECKLIST NEEDS TO BE REVIEWED BEFORE USE **** -******************************************************** - -This file contains the sequence of steps to be followed to publish a -new release of pFUnit. - -0. Coordinate with development team members to minimize changes to the -repository during the release process. - -1. Complete work on the development branch, synchronize with the -SourceForge repository. This requires pulling develop from -SourceForge, merging, testing, and then pushing back to SourceForge. -Then review the regression testing produced on Discover. If the -regression tests are acceptable, then continue to update documentation -and version information as follows. - -2. Update the version and documentation. Edit README-INSTALL and -VERSION to match the release's tag number. Update ChangeLog to reflect -changes to pFUnit, ordered by release number, but listing the most -important changes first within releases. Update the doxygen files in -the documentation directory. Review the top level GNUmakefile and set -the location of the appropriate version of doxygen. Make the pdf -version of the documentation, the html version will be produced as a -side effect. Publish the html files to SourceForge using ftp. Also -upload README-INSTALL as README and update the PDF file on -SourceForge. We generally name the PDF file to reflect the current -version of the code. - -bash-3.2$ sftp @frs.sourceforge.net -Password: -Connected to frs.sourceforge.net. -sftp> cd /home/project-web/pfunit/htdocs -sftp> !pwd -/documentation/html -sftp> mput * -sftp> lcd /documentation -sftp> cd /home/frs/project/pfunit -sftp> put README-INSTALL -sftp> cd Documentation -sftp> put README-INSTALL -sftp> put pFUnit3-ReferenceManual.pdf -sftp> put pFUnit3-ReferenceManual.pdf pFUnit3-ReferenceManual---1.pdf - -Similarly, one can put a tar'd version of the pFUnit release into -"/home/pfs/project/pfunit/Source" at frs.sourceforge.net. -$ git archive master --prefix pFUnit-/ --output pFUnit-.tar --format tgz - -3. Clean pFUnit, especially the documentation directory, but retain -the PDF file. At this point the documentation files (README-INSTALL, -VERSION, ChangeLog, documentation/pFUnit3-ReferenceManual.pdf, etc) -will need to be committed and pushed to the repository. Commit these -and synchronize the development branch with SourceForge. - -4. Ensure the local code is tagged with the appropriate version -number. E.g. using "git tag 3.1.2". To check the tag of the current -branch use "git describe --tag". Then share the tags via "git push - --tags" where is the SourceForge location. - -5. At this point, it is time to merge in master. On development, "git -merge master" and resolve any conflicts. Push development to -SourceForge be sure to review the regression tests. Then "git checkout -master; git merge development" and then push to SourceForge. This -constitutes the release. - -6. Notify the development team that the release is complete, then -prepare and announce the release via the pFUnit mailing list hosted at -SourceForge. - diff --git a/tests/pFUnit-3.2.9/VERSION b/tests/pFUnit-3.2.9/VERSION deleted file mode 100644 index 729da908..00000000 --- a/tests/pFUnit-3.2.9/VERSION +++ /dev/null @@ -1,2 +0,0 @@ -pFUnit 3.2.9 - diff --git a/tests/pFUnit-3.2.9/bin/CMakeLists.txt b/tests/pFUnit-3.2.9/bin/CMakeLists.txt deleted file mode 100644 index fe0be142..00000000 --- a/tests/pFUnit-3.2.9/bin/CMakeLists.txt +++ /dev/null @@ -1,2 +0,0 @@ -#install(PROGRAMS pFUnitParser.py parseDirectiveArgs.py DESTINATION bin) - diff --git a/tests/pFUnit-3.2.9/bin/pFUnitParser.py b/tests/pFUnit-3.2.9/bin/pFUnitParser.py deleted file mode 100755 index 65e858ad..00000000 --- a/tests/pFUnit-3.2.9/bin/pFUnitParser.py +++ /dev/null @@ -1,896 +0,0 @@ -#!/usr/bin/env python -# For python 2.6-2.7 -from __future__ import print_function - -from os.path import * -import re -# from parseBrackets import parseBrackets -from parseDirectiveArgs import parseDirectiveArguments - - -class MyError(Exception): - - def __init__(self, value): - self.value = value - - def __str__(self): - return repr(self.value) - - -assertVariants = 'Fail|Equal|True|False|LessThan|LessThanOrEqual|GreaterThan|GreaterThanOrEqual' -assertVariants += '|IsMemberOf|Contains|Any|All|NotAll|None|IsPermutationOf' -assertVariants += '|ExceptionRaised|SameShape|IsNaN|IsFinite' - - -def cppSetLineAndFile(line, file): - return "#line " + str(line) + ' "' + file + '"\n' - - -def getSubroutineName(line): - try: - m = re.match('\s*subroutine\s+(\w*)\s*(\\([\w\s,]*\\))?\s*(!.*)*$', line, re.IGNORECASE) - return m.groups()[0] - except: - raise MyError('Improper format in declaration of test procedure.') - - -def parseArgsFirstRest(directiveName,line): - """If the @-directive has more than one argument, parse into first and rest strings. - Added for assertAssociated. - """ - - if directiveName != '': - m = re.match('\s*'+directiveName+'\s*\\((.*\w.*)\\)\s*$',line,re.IGNORECASE) - if m: - argStr = m.groups()[0] - else: - return None - else: - argStr = line - - args = parseDirectiveArguments(argStr) - - if args == []: - returnArgs = None - elif len(args) == 1: - returnArgs = [args[0]] - else: - returnArgs = [args[0],','.join(args[1:])] - - return returnArgs - - -def parseArgsFirstSecondRest(directiveName,line): - """If the @-directive must have at least two arguments, parse into first, second, - and rest strings. Added for assertAssociated. - """ - args1 = parseArgsFirstRest(directiveName,line) - - returnArgs = None - - if args1 != None: - if len(args1) == 1: - returnArgs = args1 - elif len(args1) == 2: - args2 = parseArgsFirstRest('',args1[1]) - returnArgs = [args1[0]] + args2 - elif len(args1) == 3: - print(-999,'parseArgsFirstSecondRest::error!') - returnArgs = None - - return returnArgs - - -def getSelfObjectName(line): - m = re.match('\s*subroutine\s+\w*\s*\\(\s*(\w+)\s*(,\s*\w+\s*)*\\)\s*$', line, re.IGNORECASE) - if m: - return m.groups()[0] - else: - return m - - -def getTypeName(line): - m = re.match('\s*type(.*::\s*|\s+)(\w*)\s*$', line, re.IGNORECASE) - return m.groups()[1] - - -class Action(): - def apply(self, line): - m = self.match(line) - if m: self.action(m, line) - return m - - -class AtTest(Action): - def __init__(self, parser): - self.parser = parser - self.keyword = '@test' - - def match(self, line): - m = re.match('\s*'+self.keyword+'(\s*(\\(.*\\))?\s*$)', line, re.IGNORECASE) - return m - - def action(self, m, line): - options = re.match('\s*'+self.keyword+'\s*\\((.*)\\)\s*$', line, re.IGNORECASE) - method = {} - - if options: - - npesOption = re.search('npes\s*=\s*\\[([0-9,\s]+)\\]', options.groups()[0], re.IGNORECASE) - if npesOption: - npesString = npesOption.groups()[0] - npes = map(int, npesString.split(',')) - method['npRequests'] = npes - - #ifdef is optional - matchIfdef = re.match('.*ifdef\s*=\s*(\w+)', options.groups()[0], re.IGNORECASE) - if matchIfdef: - ifdef = matchIfdef.groups()[0] - method['ifdef'] = ifdef - - matchIfndef = re.match('.*ifndef\s*=\s*(\w+)', options.groups()[0], re.IGNORECASE) - if matchIfndef: - ifndef = matchIfndef.groups()[0] - method['ifndef'] = ifndef - - matchType = re.match('.*type\s*=\s*(\w+)', options.groups()[0], re.IGNORECASE) - if matchType: - print ('Type', matchType.groups()[0]) - method['type'] = matchType.groups()[0] - - paramOption = re.search('testParameters\s*=\s*[{](.*)[}]', options.groups()[0], re.IGNORECASE) - if paramOption: - paramExpr = paramOption.groups()[0] - method['testParameters'] = paramExpr - - casesOption = re.search('cases\s*=\s*(\\[[0-9,\s]+\\])', options.groups()[0], re.IGNORECASE) - if casesOption: - method['cases'] = casesOption.groups()[0] - - - nextLine = self.parser.nextLine() - method['name'] = getSubroutineName(nextLine) - # save "self" name for use with @mpiAssert - self.parser.currentSelfObjectName = getSelfObjectName(nextLine) - - # save "self" name for use with @mpiAssert - dummyArgument = getSelfObjectName(nextLine) - if dummyArgument: - method['selfObjectName'] = dummyArgument - - self.parser.userTestMethods.append(method) - self.parser.commentLine(line) - self.parser.outputFile.write(nextLine) - - -# deprecated - should now just use @test -class AtMpiTest(AtTest): - def __init__(self, parser): - self.parser = parser - self.keyword = '@mpitest' - - -class AtTestCase(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@testcase\s*(|\\(.*\\))\s*$', line, re.IGNORECASE) - return m - - def action(self, m, line): - options = re.match('\s*@testcase\s*\\((.*)\\)\s*$', line, re.IGNORECASE) - if options: - value = re.search('constructor\s*=\s*(\w*)', options.groups()[0], re.IGNORECASE) - if value: - self.parser.userTestCase['constructor'] = value.groups()[0] - - value = re.search('npes\s*=\s*\\[([0-9,\s]+)\\]', options.groups()[0], re.IGNORECASE) - if value: - npesString = value.groups()[0] - npes = map(int,npesString.split(',')) - self.parser.userTestCase['npRequests'] = npes - - value = re.search('cases\s*=\s*(\\[[0-9,\s]+\\])', options.groups()[0], re.IGNORECASE) - if value: - cases = value.groups()[0] - self.parser.userTestCase['cases'] = cases - - value = re.search('testParameters\s*=\s*[{](.*)[}]', options.groups()[0], re.IGNORECASE) - if value: - paramExpr = value.groups()[0] - self.parser.userTestCase['testParameters'] = paramExpr - - nextLine = self.parser.nextLine() - self.parser.userTestCase['type']=getTypeName(nextLine) - self.parser.commentLine(line) - self.parser.outputFile.write(nextLine) - - -class AtSuite(Action): - def __init__(self, parser): - self.parser = parser - def match(self, line): - nameRe = "'\w+'|" + """\w+""" - m = re.match("\s*@suite\s*\\(\s*name\s*=\s*("+nameRe+")\s*\\)\s*$", line, re.IGNORECASE) - return m - - def action(self, m, line): - self.parser.suiteName=m.groups()[0][1:-1] - self.parser.wrapModuleName = 'Wrap' + self.parser.suiteName - - -class AtBegin(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*module\s+(\w*)\s*$', line, re.IGNORECASE) - return m - - def action(self, m, line): - self.parser.userModuleName = m.groups()[0] - self.parser.wrapModuleName = 'Wrap' + self.parser.userModuleName - if not self.parser.suiteName: - self.parser.suiteName = self.parser.userModuleName + "_suite" - self.parser.outputFile.write(line) - - -class AtAssert(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@assert('+assertVariants+')\s*\\((.*\w.*)\\)\s*$', line, re.IGNORECASE) - return m - - def appendSourceLocation(self, fileHandle, fileName, lineNumber): - fileHandle.write(" & location=SourceLocation( &\n") - fileHandle.write(" & '" + str(basename(fileName)) + "', &\n") - fileHandle.write(" & " + str(lineNumber) + ")") - - def action(self, m, line): - p = self.parser - - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber, p.fileName)) - p.outputFile.write(" call assert"+m.groups()[0]+"(" + m.groups()[1] + ", &\n") - self.appendSourceLocation(p.outputFile, p.fileName, p.currentLineNumber) - p.outputFile.write(" )\n") - p.outputFile.write(" if (anyExceptions()) return\n") - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber+1, p.fileName)) - - -class AtAssertAssociated(Action): - def __init__(self,parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@assertassociated\s*\\((.*\w.*)\\)\s*$', line, re.IGNORECASE) - - if not m: - m = re.match( \ - '\s*@assertassociated\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*),(.*\w*.*))\\)\s*$', \ - line, re.IGNORECASE) - - # How to get both (a,b) and (a,b,c) to match? - if not m: - m = re.match( \ - '\s*@assertassociated\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*))\\)\s*$', \ - line, re.IGNORECASE) - return m - - def appendSourceLocation(self, fileHandle, fileName, lineNumber): - fileHandle.write(" & location=SourceLocation( &\n") - fileHandle.write(" & '" + str(basename(fileName)) + "', &\n") - fileHandle.write(" & " + str(lineNumber) + ")") - - def action(self, m, line): - p = self.parser - - # args = parseArgsFirstRest('@assertassociated',line) - args = parseArgsFirstSecondRest('@assertassociated',line) - - # print(9000,line) - # print(9001,args) - - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber, p.fileName)) - if len(args) > 1: - if re.match('.*message=.*',args[1],re.IGNORECASE): - p.outputFile.write(" call assertTrue(associated(" + args[0] + "), " + args[1] + ", &\n") - elif len(args) > 2: - p.outputFile.write(" call assertTrue(associated(" + args[0] + "," + args[1] + "), " + args[2] + ", &\n") - else: - p.outputFile.write(" call assertTrue(associated(" + args[0] + "," + args[1] + "), &\n") - else: - p.outputFile.write(" call assertTrue(associated(" + args[0] + "), &\n") - self.appendSourceLocation(p.outputFile, p.fileName, p.currentLineNumber) - p.outputFile.write(" )\n") - p.outputFile.write(" if (anyExceptions()) return\n") - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber+1, p.fileName)) - - -class AtAssertNotAssociated(Action): - def __init__(self,parser): - self.parser = parser - self.name='@assertnotassociated' - - def match(self, line): - m = re.match('\s*@assert(not|un)associated\s*\\((.*\w.*)\\)\s*$', line, re.IGNORECASE) - if m: - self.name='@assert'+m.groups()[0]+'associated' - else: - self.name='@assertnotassociated' - - if not m: - m = re.match( \ - '\s*@assert(not|un)associated\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*),(.*\w*.*))\\)\s*$', \ - line, re.IGNORECASE) - - # How to get both (a,b) and (a,b,c) to match? - if not m: - m = re.match( \ - '\s*@assert(not|un)associated\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*))\\)\s*$', \ - line, re.IGNORECASE) - - if m: - self.name='@assert'+m.groups()[0]+'associated' - else: - self.name='@assertnotassociated' - - - return m - - def appendSourceLocation(self, fileHandle, fileName, lineNumber): - fileHandle.write(" & location=SourceLocation( &\n") - fileHandle.write(" & '" + str(basename(fileName)) + "', &\n") - fileHandle.write(" & " + str(lineNumber) + ")") - - def action(self, m, line): - p = self.parser - - #-- args = parseArgsFirstRest('@assertassociated',line) - #ok args = parseArgsFirstSecondRest('@assertassociated',line) - args = parseArgsFirstSecondRest(self.name,line) - - # print(9000,line) - # print(9001,args) - - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber, p.fileName)) - if len(args) > 1: - if re.match('.*message=.*',args[1],re.IGNORECASE): - p.outputFile.write(" call assertFalse(associated(" + args[0] + "), " + args[1] + ", &\n") - elif len(args) > 2: - p.outputFile.write(" call assertFalse(associated(" + args[0] + "," + args[1] + "), " + args[2] + ", &\n") - else: - p.outputFile.write(" call assertFalse(associated(" + args[0] + "," + args[1] + "), &\n") - else: - p.outputFile.write(" call assertFalse(associated(" + args[0] + "), &\n") - self.appendSourceLocation(p.outputFile, p.fileName, p.currentLineNumber) - p.outputFile.write(" )\n") - p.outputFile.write(" if (anyExceptions()) return\n") - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber+1, p.fileName)) - - -class AtAssertEqualUserDefined(Action): - """Convenience directive replacing (a,b) with a call to assertTrue(a==b) - and an error message, if none is provided when invoked. - """ - def __init__(self,parser): - self.parser = parser - - def match(self, line): - m = re.match( \ - '\s*@assertequaluserdefined\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*),(.*\w*.*))\\)\s*$', \ - line, re.IGNORECASE) - - # How to get both (a,b) and (a,b,c) to match? - if not m: - m = re.match( \ - '\s*@assertequaluserdefined\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*))\\)\s*$', \ - line, re.IGNORECASE) - - return m - - def appendSourceLocation(self, fileHandle, fileName, lineNumber): - fileHandle.write(" & location=SourceLocation( &\n") - fileHandle.write(" & '" + str(basename(fileName)) + "', &\n") - fileHandle.write(" & " + str(lineNumber) + ")") - - def action(self, m, line): - p = self.parser - - args = parseArgsFirstSecondRest('@assertequaluserdefined',line) - - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber, p.fileName)) - if len(args) > 2: - p.outputFile.write(" call assertTrue(" \ - + args[0] + "==" + args[1] + ", " + args[2] + ", &\n") - else: - p.outputFile.write(" call assertTrue(" \ - + args[0] + "==" + args[1] + ", &\n") - if not re.match('.*message=.*',line,re.IGNORECASE): - p.outputFile.write(" & message='<" + args[0] + "> not equal to <" + args[1] + ">', &\n") - self.appendSourceLocation(p.outputFile, p.fileName, p.currentLineNumber) - p.outputFile.write(" )\n") - p.outputFile.write(" if (anyExceptions()) return\n") - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber+1, p.fileName)) - - -class AtAssertEquivalent(Action): - """Convenience directive replacing (a,b) with a call to assertTrue(a.eqv.b) - and an error message, if none is provided when invoked. - """ - def __init__(self,parser): - self.parser = parser - - def match(self, line): - m = re.match( \ - '\s*@assertequivalent\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*),(.*\w*.*))\\)\s*$', \ - line, re.IGNORECASE) - - # How to get both (a,b) and (a,b,c) to match? - if not m: - m = re.match( \ - '\s*@assertequivalent\s*\\((\s*([^,]*\w.*),\s*([^,]*\w.*))\\)\s*$', \ - line, re.IGNORECASE) - - return m - - def appendSourceLocation(self, fileHandle, fileName, lineNumber): - fileHandle.write(" & location=SourceLocation( &\n") - fileHandle.write(" & '" + str(basename(fileName)) + "', &\n") - fileHandle.write(" & " + str(lineNumber) + ")") - - def action(self, m, line): - p = self.parser - - args = parseArgsFirstSecondRest('@assertequivalent',line) - - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber, p.fileName)) - if len(args) > 2: - p.outputFile.write(" call assertTrue(" \ - + args[0] + ".eqv." + args[1] + ", " + args[2] + ", &\n") - else: - p.outputFile.write(" call assertTrue(" \ - + args[0] + ".eqv." + args[1] + ", &\n") - if not re.match('.*message=.*',line,re.IGNORECASE): - p.outputFile.write(" & message='<" + args[0] + "> not equal to <" + args[1] + ">', &\n") - self.appendSourceLocation(p.outputFile, p.fileName, p.currentLineNumber) - p.outputFile.write(" )\n") - p.outputFile.write(" if (anyExceptions()) return\n") - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber+1, p.fileName)) - - -class AtMpiAssert(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@mpiassert('+assertVariants+')\s*\\((.*\w.*)\\)\s*$', line, re.IGNORECASE) - return m - - def appendSourceLocation(self, fileHandle, fileName, lineNumber): - fileHandle.write(" & location=SourceLocation( &\n") - fileHandle.write(" & '" + str(basename(fileName)) + "', &\n") - fileHandle.write(" & " + str(lineNumber) + ")") - - def action(self, m, line): - p = self.parser - - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber, p.fileName)) - p.outputFile.write(" call assert"+m.groups()[0]+"(" + m.groups()[1] + ", &\n") - self.appendSourceLocation(p.outputFile, p.fileName, p.currentLineNumber) - p.outputFile.write(" )\n") - - # 'this' object may not exist if test is commented out. - if hasattr(p,'currentSelfObjectName'): - p.outputFile.write(" if (anyExceptions("+p.currentSelfObjectName+"%context)) return\n") - p.outputFile.write(cppSetLineAndFile(p.currentLineNumber+1, p.fileName)) - - -class AtBefore(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@before\s*$', line, re.IGNORECASE) - return m - - def action(self, m, line): - nextLine = self.parser.nextLine() - self.parser.userTestCase['setUp'] = getSubroutineName(nextLine) - self.parser.commentLine(line) - self.parser.outputFile.write(nextLine) - - -class AtAfter(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@after\s*$', line, re.IGNORECASE) - return m - - def action(self, m, line): - nextLine = self.parser.nextLine() - self.parser.userTestCase['tearDown'] = getSubroutineName(nextLine) - self.parser.commentLine(line) - self.parser.outputFile.write(nextLine) - - -class AtTestParameter(Action): - def __init__(self, parser): - self.parser = parser - - def match(self, line): - m = re.match('\s*@testParameter\s*(|.*)$', line, re.IGNORECASE) - return m - - def action(self, m, line): - options = re.match('\s*@testParameter\s*\\((.*)\\)\s*$', line, re.IGNORECASE) - - self.parser.commentLine(line) - nextLine = self.parser.nextLine() - if not 'testParameterType' in self.parser.userTestCase: - self.parser.userTestCase['testParameterType'] = getTypeName(nextLine) - self.parser.outputFile.write(nextLine) - - if options: - value = re.search('constructor\s*=\s*(\w*)', options.groups()[0], re.IGNORECASE) - if value: - self.parser.userTestCase['testParameterConstructor'] = value.groups()[0] - else: - self.parser.userTestCase['testParameterConstructor'] = self.parser.userTestCase['testParameterType'] - - -class Parser(): - def __init__(self, inputFileName, outputFileName): - def getBaseName(fileName): - from os.path import basename, splitext - base = basename(fileName) - return splitext(base)[0] - - self.fileName = inputFileName - self.inputFile = open(inputFileName, 'r') - self.outputFile = open(outputFileName, 'w') - self.defaultSuiteName = getBaseName(inputFileName) + "_suite" - self.suiteName = '' - - self.currentLineNumber = 0 - self.userModuleName = '' # if any - - self.userTestCase = {} - self.userTestCase['setUpMethod'] = '' - self.userTestCase['tearDownMethod'] = '' - self.userTestCase['defaultTestParameterNpes'] = [] # is MPI if not empty - self.userTestCase['defaultTestParametersExpr'] = '' - self.userTestCase['defaultTestParameterCases'] = [] - - self.userTestMethods = [] # each entry is a dictionary - - self.wrapModuleName = "Wrap" + getBaseName(inputFileName) - self.currentLineNumber = 0 - - self.actions=[] - self.actions.append(AtTest(self)) - self.actions.append(AtMpiTest(self)) - self.actions.append(AtTestCase(self)) - self.actions.append(AtSuite(self)) - self.actions.append(AtBegin(self)) - - self.actions.append(AtAssert(self)) - self.actions.append(AtAssertAssociated(self)) -# self.actions.append(AtAssertAssociatedWith(self)) - self.actions.append(AtAssertNotAssociated(self)) -# self.actions.append(AtAssertNotAssociatedWith(self)) - - self.actions.append(AtAssertEqualUserDefined(self)) - self.actions.append(AtAssertEquivalent(self)) - - self.actions.append(AtMpiAssert(self)) - self.actions.append(AtBefore(self)) - self.actions.append(AtAfter(self)) - self.actions.append(AtTestParameter(self)) - - - def commentLine(self, line): - self.outputFile.write(re.sub('@','!@',line)) - - def run(self): - def parse(line): - for action in self.actions: - if (action.apply(line)): return - self.outputFile.write(line) - - while True: - line = self.nextLine() - if not line: break - parse(line) - - if (not self.suiteName): self.suiteName = self.defaultSuiteName - if ('testParameterType' in self.userTestCase and (not 'constructor' in self.userTestCase)): - self.userTestCase['constructor'] = self.userTestCase['testParameterType'] - self.makeWrapperModule() - - def isComment(self, line): - return re.match('\s*(!.*|)$', line) - - def nextLine(self): - while True: - self.currentLineNumber += 1 - line = self.inputFile.readline() - if not line: break - if (self.isComment(line)): - self.outputFile.write(line) - pass - else: - break - return line - - - def printHeader(self): - self.outputFile.write('\n') - self.outputFile.write('module ' + self.wrapModuleName + '\n') - self.outputFile.write(' use pFUnit_mod\n') - if (self.userModuleName): self.outputFile.write(' use ' + self.userModuleName + '\n') - self.outputFile.write(' implicit none\n') - self.outputFile.write(' private\n\n') - - - - def printTail(self): - self.outputFile.write('\n') - self.outputFile.write('end module ' + self.wrapModuleName + '\n\n') - - def printWrapUserTestCase(self): - self.outputFile.write(' public :: WrapUserTestCase\n') - self.outputFile.write(' public :: makeCustomTest\n') - self.outputFile.write(' type, extends(' + self.userTestCase['type'] + ') :: WrapUserTestCase\n') - self.outputFile.write(' procedure(userTestMethod), nopass, pointer :: testMethodPtr\n') - self.outputFile.write(' contains\n') - self.outputFile.write(' procedure :: runMethod\n') - self.outputFile.write(' end type WrapUserTestCase\n\n') - - self.outputFile.write(' abstract interface\n') - self.outputFile.write(' subroutine userTestMethod(this)\n') - if self.userModuleName: - self.outputFile.write(' use ' + self.userModuleName + '\n') - if 'type' in self.userTestCase: - self.outputFile.write(' class (' + self.userTestCase['type'] + '), intent(inout) :: this\n') - self.outputFile.write(' end subroutine userTestMethod\n') - self.outputFile.write(' end interface\n\n') - - def printRunMethod(self): - self.outputFile.write(' subroutine runMethod(this)\n') - self.outputFile.write(' class (WrapUserTestCase), intent(inout) :: this\n\n') - self.outputFile.write(' call this%testMethodPtr(this)\n') - self.outputFile.write(' end subroutine runMethod\n\n') - - - def printParameterHeader(self, type): - self.outputFile.write(' type (' + type + '), allocatable :: testParameters(:)\n') - self.outputFile.write(' type (' + type + ') :: testParameter\n') - self.outputFile.write(' integer :: iParam \n') - self.outputFile.write(' integer, allocatable :: cases(:) \n') - self.outputFile.write(' \n') - - - def printMakeSuite(self): - self.outputFile.write('function ' + self.suiteName + '() result(suite)\n') - self.outputFile.write(' use pFUnit_mod\n') - if (self.userModuleName): self.outputFile.write(' use ' + self.userModuleName + '\n') - self.outputFile.write(' use '+ self.wrapModuleName + '\n') - self.outputFile.write(' type (TestSuite) :: suite\n\n') - - if not self.userModuleName: - for testMethod in self.userTestMethods: - if ('ifdef' in testMethod): - self.outputFile.write('#ifdef ' + testMethod['ifdef'] + '\n') - elif ('ifndef' in testMethod): - self.outputFile.write('#ifndef ' + testMethod['ifndef'] + '\n') - self.outputFile.write(' external ' + testMethod['name'] + '\n') - if ('ifdef' in testMethod or 'ifndef' in testMethod): - self.outputFile.write('#endif\n') - self.outputFile.write('\n') - if 'setUp' in self.userTestCase: - self.outputFile.write(' external ' + self.userTestCase['setUp'] + '\n') - if 'tearDown' in self.userTestCase: - self.outputFile.write(' external ' + self.userTestCase['tearDown'] + '\n') - self.outputFile.write('\n') - - if 'testParameterType' in self.userTestCase: - type = self.userTestCase['testParameterType'] - self.printParameterHeader(type) - - self.outputFile.write(" suite = newTestSuite('" + self.suiteName + "')\n\n") - - for testMethod in self.userTestMethods: - if ('ifdef' in testMethod): - self.outputFile.write('#ifdef ' + testMethod['ifdef'] + '\n') - elif ('ifndef' in testMethod): - self.outputFile.write('#ifndef ' + testMethod['ifndef'] + '\n') - if 'type' in self.userTestCase: - self.addUserTestMethod(testMethod) - else: - if 'npRequests' in testMethod: - self.addMpiTestMethod(testMethod) - else: # vanilla - self.addSimpleTestMethod(testMethod) - self.outputFile.write('\n') - if ('ifdef' in testMethod or 'ifndef' in testMethod): - self.outputFile.write('#endif\n') - - self.outputFile.write('\nend function ' + self.suiteName + '\n\n') - - def addSimpleTestMethod(self, testMethod): - args = "'" + testMethod['name'] + "', " + testMethod['name'] - if 'setUp' in testMethod: - args += ', ' + testMethod['setUp'] - elif 'setUp' in self.userTestCase: - args += ', ' + self.userTestCase['setUp'] - - if 'tearDown' in testMethod: - args += ', ' + testMethod['tearDown'] - elif 'tearDown' in self.userTestCase: - args += ', ' + self.userTestCase['tearDown'] - - if 'type' in testMethod: - type = testMethod['type'] - else: - type = 'newTestMethod' - - self.outputFile.write(' call suite%addTest(' + type + '(' + args + '))\n') - - def addMpiTestMethod(self, testMethod): - for npes in testMethod['npRequests']: - args = "'" + testMethod['name'] + "', " + testMethod['name'] + ", " + str(npes) - if 'setUp' in testMethod: - args += ', ' + testMethod['setUp'] - elif 'setUp' in self.userTestCase: - args += ', ' + self.userTestCase['setUp'] - - if 'tearDown' in testMethod: - args += ', ' + testMethod['tearDown'] - elif 'tearDown' in self.userTestCase: - args += ', ' + self.userTestCase['tearDown'] - - if 'type' in testMethod: - type = testMethod['type'] - else: - type = 'newMpiTestMethod' - - self.outputFile.write(' call suite%addTest(' + type + '(' + args + '))\n') - - - def addUserTestMethod(self, testMethod): - - args = "'" + testMethod['name'] + "', " + testMethod['name'] - if 'npRequests' in testMethod: - npRequests = testMethod['npRequests'] - else: - if 'npRequests' in self.userTestCase: - npRequests = self.userTestCase['npRequests'] - else: - npRequests = [1] - - if 'cases' in testMethod: - cases = testMethod['cases'] - elif 'cases' in self.userTestCase: - cases = self.userTestCase['cases'] - - testParameterArg = '' # unless - - if 'cases' in locals(): - testParameterArg = ', testParameter' - self.outputFile.write(' cases = ' + testMethod['cases'] + '\n') - self.outputFile.write(' testParameters = [(' + - self.userTestCase['testParameterConstructor'] + - '(cases(iCase)), iCase = 1, size(cases))]\n\n') - - if 'testParameterType' in self.userTestCase: - if 'testParameters' in testMethod: - testParameters = testMethod['testParameters'] - elif 'testParameters' in self.userTestCase: - testParameters = self.userTestCase['testParameters'] - - isMpiTestCase = 'npRequests' in self.userTestCase - isMpiTestCase = isMpiTestCase or any('npRequests' in testMethod for testMethod in self.userTestMethods) - - if 'testParameters' in locals(): - testParameterArg = ', testParameter' - self.outputFile.write(' testParameters = ' + testParameters + '\n\n') - elif isMpiTestCase: - testParameterArg = ', testParameter' - - - for npes in npRequests: - - if 'testParameters' in locals() or 'cases' in locals(): - self.outputFile.write(' do iParam = 1, size(testParameters)\n') - self.outputFile.write(' testParameter = testParameters(iParam)\n') - - if isMpiTestCase: - self.outputFile.write(' call testParameter%setNumProcessesRequested(' + str(npes) + ')\n') - - self.outputFile.write(' call suite%addTest(makeCustomTest(' + - args + testParameterArg + '))\n') - if 'cases' in locals() or 'testParameters' in locals(): - self.outputFile.write(' end do\n') - - def printMakeCustomTest(self, isMpiTestCase): - args = 'methodName, testMethod' - declareArgs = '#ifdef INTEL_13\n' - declareArgs += ' use pfunit_mod, only: testCase\n' - declareArgs += '#endif\n' - declareArgs += ' type (WrapUserTestCase) :: aTest\n' - declareArgs += '#ifdef INTEL_13\n' - declareArgs += ' target :: aTest\n' - declareArgs += ' class (WrapUserTestCase), pointer :: p\n' - declareArgs += '#endif\n' - declareArgs += ' character(len=*), intent(in) :: methodName\n' - declareArgs += ' procedure(userTestMethod) :: testMethod\n' - - if 'testParameterType' in self.userTestCase: - args += ', testParameter' - declareArgs += ' type (' + self.userTestCase['testParameterType'] + '), intent(in) :: testParameter\n' - - self.outputFile.write(' function makeCustomTest(' + args + ') result(aTest)\n') - self.outputFile.write(declareArgs) - - if 'constructor' in self.userTestCase: - if 'testParameterType' in self.userTestCase: - constructor = self.userTestCase['constructor'] + '(testParameter)' - else: - constructor = self.userTestCase['constructor'] + '()' - self.outputFile.write(' aTest%' + self.userTestCase['type'] + ' = ' + constructor + '\n\n') - - self.outputFile.write(' aTest%testMethodPtr => testMethod\n') - - self.outputFile.write('#ifdef INTEL_13\n') - self.outputFile.write(' p => aTest\n') - self.outputFile.write(' call p%setName(methodName)\n') - self.outputFile.write('#else\n') - self.outputFile.write(' call aTest%setName(methodName)\n') - self.outputFile.write('#endif\n') - - if 'testParameterType' in self.userTestCase: - self.outputFile.write(' call aTest%setTestParameter(testParameter)\n') - - self.outputFile.write(' end function makeCustomTest\n') - - def makeWrapperModule(self): - # ! Start here - self.printHeader() - - if 'type' in self.userTestCase: - self.printWrapUserTestCase() - - self.outputFile.write('contains\n\n') - - if 'type' in self.userTestCase: - self.printRunMethod() - - if 'type' in self.userTestCase: - isMpiTestCase = 'npRequests' in self.userTestCase - isMpiTestCase = isMpiTestCase or any('npRequests' in testMethod for testMethod in self.userTestMethods) - if isMpiTestCase and not 'testParameterType' in self.userTestCase: - self.userTestCase['testParameterType'] = 'MpiTestParameter' - - self.printMakeCustomTest(isMpiTestCase) - - self.printTail() - self.printMakeSuite() - - def final(self): - self.inputFile.close() - self.outputFile.close() - -if __name__ == "__main__": - import sys - print("Processing file", sys.argv[1]) - p = Parser(sys.argv[1], sys.argv[2]) - p.run() - p.final() - print(" ... Done. Results in", sys.argv[2]) - - diff --git a/tests/pFUnit-3.2.9/bin/parseDirectiveArgs.py b/tests/pFUnit-3.2.9/bin/parseDirectiveArgs.py deleted file mode 100755 index e631a9d2..00000000 --- a/tests/pFUnit-3.2.9/bin/parseDirectiveArgs.py +++ /dev/null @@ -1,77 +0,0 @@ -#!/usr/bin/env python - -import re -import unittest -import collections - -def flatten(l): - "http://stackoverflow.com/questions/2158395/flatten-an-irregular-list-of-lists-in-python" - if l: - for el in l: - if isinstance(el, collections.Iterable) and not isinstance(el, (str,bytes)): -# The following is incompatible with python 3. -# if isinstance(el, collections.Iterable) and not isinstance(el, basestring): - for sub in flatten(el): - yield sub - else: - yield el - -def parseDirectiveArguments(data): - - """Makes a list whose elements are delimited by commas in an input - - string. Commas inside a scope started with brackets, parens, single- - or double-quotes, are skipped. Scopes delimited by brackets or - parentheses are assumed to be well formed. I.e. we simply count - opening and closing brackets and parens without regards to any other - syntax or ordering rules. It would be nice to throw an exception or - emit warnings when we detect suspicious syntax. - """ - - pos = 0; npos = len(data); str=''; maskCommas=False - scopeCounts = {'[':0,'(':0,'"':0,"'":0} # Assume well formed scopes. - scopeTerminators = {'[':']','(':')','"':'"',"'":"'"} - scopeNames = {'(':'parens','[':'brackets','"':'double quotes',"'":'single quotes'} - while (pos < npos): - if data[pos] == ',' and not maskCommas: - return [i for i in flatten([str,parseDirectiveArguments(data[pos+1:])])] - else: - for key in scopeCounts.keys(): - if data[pos] == key: - scopeCounts[key] = scopeCounts[key] + 1 - maskCommas = True - elif data[pos] == scopeTerminators[key]: - scopeCounts[key] = scopeCounts[key] - 1 - if scopeCounts[key] < 0: - # Maybe try exceptions... - print('parseDirectiveArguments::error: mismatched '+scopeNames[key]+' parenCount < 0 "',str,'" from "',data,'"') - return None - else: - maskCommas = sum(map(abs,scopeCounts.values())) > 0 - str = str + data[pos] - pos = pos + 1 - return [str] - - -class TestParseDirectiveArgs(unittest.TestCase): - - def test_args1(self): - self.assertEqual(['a','b','c'],parseDirectiveArguments('a,b,c')) - - def test_args2(self): - self.assertEqual(['a','b(1,2)','c((1,3,z(x,y(4))))'],parseDirectiveArguments('a,b(1,2),c((1,3,z(x,y(4))))')) - - def test_args3(self): - self.assertEqual(['a','b','c[d,e,f(x,y)]'],parseDirectiveArguments('a,b,c[d,e,f(x,y)]')) - - def test_args4(self): - self.assertEqual(['a','b','c[d,e,f(x,y]'],parseDirectiveArguments('a,b,c[d,e,f(x,y]')) - - def test_args5(self): - self.assertEqual(['a','b="This, is, a, test."'],parseDirectiveArguments('a,b="This, is, a, test."')) - self.assertEqual(["a","b='This, is, a, test.'"],parseDirectiveArguments("a,b='This, is, a, test.'")) - -if __name__ == '__main__': - print('starting') - unittest.main() - print('done') diff --git a/tests/pFUnit-3.2.9/cmake/pFUnitConfig.cmake.in b/tests/pFUnit-3.2.9/cmake/pFUnitConfig.cmake.in deleted file mode 100644 index 81c9d53a..00000000 --- a/tests/pFUnit-3.2.9/cmake/pFUnitConfig.cmake.in +++ /dev/null @@ -1,150 +0,0 @@ -# Config file for the pFUnit package -# It defines the following variables -# PFUNIT_INCLUDE_DIRS - Include directories for pFUnit -# PFUNIT_LIBRARIES - libraries to link against -# PFUNIT_PARSER - Command for executing the pFUnit parsers for parsing .pf-files -# PFUNIT_DRIVER - The pFUnit driver needed for running tests -# add_pfunit_test - Helper function for defining test suites with .pf-files - -find_package (Python COMPONENTS Interpreter REQUIRED) - -set (PFUNIT_FOUND TRUE) -set (PFUNIT_VERSION "@PROJECT_VERSION@") -set (PFUNIT_INCLUDE_DIRS ${CMAKE_CURRENT_LIST_DIR}/mod) -set (PFUNIT_LINK_DIRS ${CMAKE_CURRENT_LIST_DIR}/lib) -find_library (PFUNIT_LIBRARIES pfunit - PATHS ${CMAKE_CURRENT_LIST_DIR}/lib - NO_DEFAULT_PATH) -set(PFUNIT_PARSER "${Python_EXECUTABLE}" "@CMAKE_CURRENT_LIST_DIR@/bin/pFUnitParser.py") -set(PFUNIT_DRIVER "@CMAKE_CURRENT_LIST_DIR@/include/driver.F90") -set(PFUNIT_TESTUTILS "@CMAKE_CURRENT_LIST_DIR@/include/TestUtil.F90") - -# Function : add_pfunit_test -# -# Description : Helper function for compiling and adding pFUnit tests to the CTest testing framework. Any libraries needed -# in testing should be linked to manually. -# IMPORTANT! This function will only work if the test source filename is the same as the module inside it! -# For example, the file testSomething.pf should contain the module testSomething. -# -# Arguments : - test_package_name: Name of the test package -# - test_sources : List of pf-files to be compiled -# - extra_sources : List of extra Fortran source code used for testing (if none, input empty string "") -# - extra_sources_c : List of extra C/C++ source code used for testing (if none, input empty string "") -# -# Example usage: enable_testing() -# set (TEST_SOURCES -# testMyLib.pf -# ) -# add_pfunit_test (myTests "${TEST_SOURCES} "" "") -# target_link_libraries (myTests myLibrary) #Assuming "myLibrary" is already defined -# -# Compile the tests: make myTests -# Run the tests with CTest: ctest -R myTests --verbose -function (add_pfunit_test test_package_name test_sources extra_sources extra_sources_c) - - if (NOT test_sources) - message (WARNING "No test sources defined for '${test_package_name}', ignoring...") - return () - endif (NOT test_sources) - - ################################################# - # Preprocessing # - ################################################# - set (SRC_GEN_DIR ${CMAKE_CURRENT_BINARY_DIR}/src_gen/${test_package_name}) - execute_process(COMMAND ${CMAKE_COMMAND} -E make_directory ${SRC_GEN_DIR}/) - - set (TEST_SUITES_INC "") - foreach (file ${test_sources}) - get_filename_component (basename ${file} NAME_WE) - set (fsrc "${SRC_GEN_DIR}/${basename}.F90") - list (APPEND test_sources_f90 ${fsrc}) - set (TEST_SUITES_INC "${TEST_SUITES_INC}ADD_TEST_SUITE(${basename}_suite)\n") - endforeach() - - set (TEST_SUITE_INC_FILE ${SRC_GEN_DIR}/testSuites.inc) - set (SHOULD_WRITE_INC_FILE True) - - # Check if .inc file already has been generated. If so, only write new - # file if contents has changed. This avoid tests recompiling after reconfiguring cmake. - if (EXISTS ${TEST_SUITE_INC_FILE}) - file (READ ${TEST_SUITE_INC_FILE} existing_file) - if (${existing_file} STREQUAL ${TEST_SUITES_INC}) - set (SHOULD_WRITE_INC_FILE False) - endif (${existing_file} STREQUAL ${TEST_SUITES_INC}) - endif (EXISTS ${TEST_SUITE_INC_FILE}) - - if (${SHOULD_WRITE_INC_FILE}) - file (WRITE ${TEST_SUITE_INC_FILE} ${TEST_SUITES_INC}) - endif (${SHOULD_WRITE_INC_FILE}) - - list (LENGTH test_sources len) - math(EXPR n "${len} - 1") - foreach (i RANGE ${n}) - list (GET test_sources ${i} pf_file) - list (GET test_sources_f90 ${i} f90_file) - add_custom_command( - OUTPUT ${f90_file} - COMMAND ${PFUNIT_PARSER} ${CMAKE_CURRENT_SOURCE_DIR}/${pf_file} ${f90_file} - MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${pf_file} - #COMMENT "Generating '${f90_file}' from '${CMAKE_CURRENT_SOURCE_DIR}/${pf_file}'" - ) - endforeach() - - ################################################# - # Define executable and any auxiliary library # - ################################################# - - # Main executable - add_executable (${test_package_name} - ${test_sources_f90} - ${extra_sources} - ${PFUNIT_DRIVER} - ${PFUNIT_TESTUTILS} - ) - - # Define directory of Fortran mod-files for main executable - execute_process(COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/include/${test_package_name}) - set_property (TARGET ${test_package_name} - PROPERTY Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/include/${test_package_name}) - - # C files library, if relevant - if (NOT extra_sources_c STREQUAL "") - add_library (${test_package_name}_c STATIC ${extra_sources_c}) - target_link_libraries (${test_package_name} ${test_package_name}_c) - endif () - - # Define dependencies - target_link_libraries (${test_package_name} pfunit) - #target_include_directories (${test_package_name} PRIVATE ${PFUNIT_INCLUDE_DIRS}) - target_include_directories (${test_package_name} PRIVATE ${SRC_GEN_DIR}) - target_include_directories (${test_package_name} PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/include/${test_package_name}) - - - # Test utility preprocessing - set_property ( SOURCE ${PFUNIT_TESTUTILS} - APPEND - PROPERTY COMPILE_DEFINITIONS "__PROJECT_DIR__='${CMAKE_CURRENT_SOURCE_DIR}'" - ) - - if(MSVC) - set_property (TARGET ${test_package_name} - PROPERTY LINK_FLAGS " /INCREMENTAL:NO ") - endif(MSVC) - - if (UNIX) - set_property (TARGET ${test_package_name} - PROPERTY LINKER_LANGUAGE Fortran) - endif (UNIX) - - ################################################# - # Define test in CTest system # - ################################################# - add_test (NAME ${test_package_name} - WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} - COMMAND ${test_package_name} - ) - set_property (TEST ${test_package_name} - PROPERTY FAIL_REGULAR_EXPRESSION "Encountered 1 or more failures/errors during testing" - ) - -endfunction (add_pfunit_test test_package_name test_sources extra_sources extra_sources_c) diff --git a/tests/pFUnit-3.2.9/cmake/pFUnitConfigVersion.cmake.in b/tests/pFUnit-3.2.9/cmake/pFUnitConfigVersion.cmake.in deleted file mode 100644 index 8610ebf0..00000000 --- a/tests/pFUnit-3.2.9/cmake/pFUnitConfigVersion.cmake.in +++ /dev/null @@ -1,11 +0,0 @@ -set(PACKAGE_VERSION "@PROJECT_VERSION@") - -# Check whether the requested PACKAGE_FIND_VERSION is compatible -if("${PACKAGE_VERSION}" VERSION_LESS "${PACKAGE_FIND_VERSION}") - set(PACKAGE_VERSION_COMPATIBLE FALSE) -else() - set(PACKAGE_VERSION_COMPATIBLE TRUE) - if ("${PACKAGE_VERSION}" VERSION_EQUAL "${PACKAGE_FIND_VERSION}") - set(PACKAGE_VERSION_EXACT TRUE) - endif() -endif() diff --git a/tests/pFUnit-3.2.9/cmake/packaging.cmake b/tests/pFUnit-3.2.9/cmake/packaging.cmake deleted file mode 100644 index 171be217..00000000 --- a/tests/pFUnit-3.2.9/cmake/packaging.cmake +++ /dev/null @@ -1,12 +0,0 @@ -set (CPACK_GENERATOR ZIP) - -set (CPACK_PACKAGE_DESCRIPTION_SUMMARY "pFUnit") -set (CPACK_PACKAGE_CONTACT "pFUnit developers ") -set (CPACK_PACKAGE_VERSION_MAJOR "${PROJECT_VERSION_MAJOR}") -set (CPACK_PACKAGE_VERSION_MINOR "${PROJECT_VERSION_MINOR}") -set (CPACK_PACKAGE_VERSION_PATCH "${PROJECT_VERSION_PATCH}") -set (CPACK_INCLUDE_TOPLEVEL_DIRECTORY FALSE) - - -include (CPack) - diff --git a/tests/pFUnit-3.2.9/include/.cvsignore b/tests/pFUnit-3.2.9/include/.cvsignore deleted file mode 100644 index 6cf78161..00000000 --- a/tests/pFUnit-3.2.9/include/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -semantic.cache diff --git a/tests/pFUnit-3.2.9/include/.gitignore b/tests/pFUnit-3.2.9/include/.gitignore deleted file mode 100644 index e9cf6a71..00000000 --- a/tests/pFUnit-3.2.9/include/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -*~ -/.DS_Store - - diff --git a/tests/pFUnit-3.2.9/include/CMakeLists.txt b/tests/pFUnit-3.2.9/include/CMakeLists.txt deleted file mode 100644 index cddf9a35..00000000 --- a/tests/pFUnit-3.2.9/include/CMakeLists.txt +++ /dev/null @@ -1,45 +0,0 @@ - -# Install the files needed to support installation via GNUmakefile. - -# We need to generate the following -# include/configuration.mk: -# @echo "# include/configuration.mk generated automatically during build" \ -# > include/configuration.mk -# @echo COMPILER ?= $(COMPILER) >> include/configuration.mk -# @echo USEOPENMP ?= $(USEOPENMP) >> include/configuration.mk -# @echo USEMPI ?= $(USEMPI) >> include/configuration.mk -# @echo BUILDROBUST ?= $(BUILDROBUST) >> include/configuration.mk -# @echo VERSION ?= `cat VERSION` >> include/configuration.mk - -function(file_compile_configuration) - file(STRINGS "${CMAKE_CURRENT_SOURCE_DIR}/../VERSION" BUILD_VERSION) - file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "# include/configuration.mk generated automatically during build\n") - file(APPEND ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "COMPILER ?= ${CMAKE_Fortran_COMPILER_ID}\n") - file(APPEND ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "USEOPENMP ?= ${OPENMP}\n") - file(APPEND ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "USEMPI ?= ${MPI}\n") - if (PFUNIT_ROBUST) - file(APPEND ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "BUILDROBUST ?= YES\n") - else() - file(APPEND ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "BUILDROBUST ?= \n") - endif() - file(APPEND ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk "VERSION = \"${BUILD_VERSION}\"\n") -endfunction() - -# message("***--- COMPILER: ${COMPILER}") -# message("***--- BUILDROBUST:${PFUNIT_ROBUST}") - -file_compile_configuration() - -# add_custom_command( -# OUTPUT configuration.mk -# COMMAND file_compile_configuration -# ) -# add_custom_target(configuration.mk ALL) - -# Perform the install. -# -#install(FILES GNU.mk IBM.mk INTEL.mk NAG.mk PGI.mk extensions.mk driver.F90 DESTINATION include) -#install(FILES base-install.mk DESTINATION include RENAME base.mk) -#install(FILES ${CMAKE_CURRENT_BINARY_DIR}/include/configuration.mk DESTINATION include) -#install(FILES ${CMAKE_CURRENT_SOURCE_DIR}/TestUtil.F90 DESTINATION include) - diff --git a/tests/pFUnit-3.2.9/include/GNU.mk b/tests/pFUnit-3.2.9/include/GNU.mk deleted file mode 100644 index 84925ca0..00000000 --- a/tests/pFUnit-3.2.9/include/GNU.mk +++ /dev/null @@ -1,21 +0,0 @@ -F90 ?= gfortran - -I=-I -M=-I -L=-L - -FFLAGS += -g -O0 -fbacktrace -FFLAGS += -fbounds-check -fcheck=mem -FPPFLAGS += -DGNU - -# The ramifications across all GNUish configurations of eliding CPPFLAGS here are not known. MLR 2013-1104 -CPPFLAGS += -DGNU - -F90_PP_ONLY = -E -F90_PP_OUTPUT = > - -ifeq ($(USEOPENMP),YES) -FFLAGS += -fopenmp -LIBS += -lgomp -endif - diff --git a/tests/pFUnit-3.2.9/include/IBM.mk b/tests/pFUnit-3.2.9/include/IBM.mk deleted file mode 100644 index 486ae316..00000000 --- a/tests/pFUnit-3.2.9/include/IBM.mk +++ /dev/null @@ -1,25 +0,0 @@ -ifeq ($(USEOPENMP),YES) -F90 ?= xlf2003 -else -F90 ?= xlf2003_r -endif - -D=-WF,-D -I=-I -M=-I -L=-L - -FFLAGS += -g -O0 -WF,-qfpp -C - -ifeq ($(USEOPENMP),YES) -FFLAGS += -qsmp=omp -endif - -FPPFLAGS := $(FPPFLAGS:-D%=$D%) -CPPFLAGS := $(CPPFLAGS:-D%=$D%) -FPPFLAGS += $DIBM -CPPFLAGS += -WF,-DIBM - -F90_PP_ONLY = -E -F90_PP_OUTPUT = > - diff --git a/tests/pFUnit-3.2.9/include/INTEL.mk b/tests/pFUnit-3.2.9/include/INTEL.mk deleted file mode 100644 index 19430662..00000000 --- a/tests/pFUnit-3.2.9/include/INTEL.mk +++ /dev/null @@ -1,64 +0,0 @@ -F90 ?=ifort - -I=-I -M=-I -L=-L - -ifneq ($(UNAME),Windows) -# Non-Windows (Linux) command line options for the intel compiler -version13 = $(shell $(F90) --version | grep -E '\(IFORT\) 13') -version16 = $(shell $(F90) --version | grep -E '\(IFORT\) 16') - -FFLAGS += -assume realloc_lhs -FFLAGS += -g -O0 -traceback -check uninit -check bounds -check stack -check uninit - -ifeq ($(USEOPENMP),YES) -FFLAGS += -openmp -endif - - -else -# Windows command line options for the intel compiler -version13 = $(shell $(F90) --version 2>&1 | head -1 | grep 'Version 13') -version16 = $(shell $(F90) --version 2>&1 | head -1 | grep 'Version 16') - -# Suppress version information with each compile. -FFLAGS += /nologo -FFLAGS += /assume:realloc_lhs -FFLAGS += /Z7 /Od /traceback /check:uninit /check:bounds /check:stack /check:uninit -# Enable the Fortran preprocessor -FFLAGS += /fpp - -# Remove the DEBUG_FLAGS -g option. -DEBUG_FLAGS = /Z7 -endif - - -# Common command line options. - -F90_PP_ONLY = -E -F90_PP_OUTPUT = > - -CPPFLAGS +=-DIntel -FPPFLAGS +=-DIntel - -# Check if the version of the compiler is 13 - -ifneq ($(version13),) - CPPFLAGS+=-DINTEL_13 - FPPFLAGS+=-DINTEL_13 -endif - -ifneq ($(version16),) - CPPFLAGS+=-DINTEL_16 - FPPFLAGS+=-DINTEL_16 -endif - -ifeq ($(USEOPENMP),YES) - ifeq ($(version16),) - FFLAGS += -openmp - else - FFLAGS += -qopenmp - endif -LIBS += -openmp -endif diff --git a/tests/pFUnit-3.2.9/include/NAG.mk b/tests/pFUnit-3.2.9/include/NAG.mk deleted file mode 100644 index b8a27c0c..00000000 --- a/tests/pFUnit-3.2.9/include/NAG.mk +++ /dev/null @@ -1,31 +0,0 @@ - -# GNU makefile include for NAG compilers. Ver. 2014-0428-1 MLR - -F90 ?= nagfor - -I=-I -M=-I -L=-L - -FFLAGS += -g -O0 -f2008 -w=uda -mismatch_all -fpp -C=present - -ifeq ($(USEOPENMP),YES) -FFLAGS += -openmp -else -FFLAGS += -gline -endif - -CPPFLAGS += -DNAG - -F90_PP_ONLY = -F -F90_PP_OUTPUT = -o - -# For OS X Mavericks (i.e. Apple LLVM version 6.0...), bring your own CPP. -# CPP = /opt/local/bin/cpp-mp-4.9 -traditional -C -# CPP =cpp -traditional -C - -ifeq ($(DSO),YES) - FFLAGS +=-PIC -endif - -LDFLAGS+= -ldl diff --git a/tests/pFUnit-3.2.9/include/PGI.mk b/tests/pFUnit-3.2.9/include/PGI.mk deleted file mode 100644 index 8bd6e59b..00000000 --- a/tests/pFUnit-3.2.9/include/PGI.mk +++ /dev/null @@ -1,27 +0,0 @@ -F90 ?= pgfortran - -I=-I -M=-I -L=-L - -FFLAGS += -O0 -g -traceback -Mallocatable=03 -Mbounds -Mchkfpstk -Mchkstk -DPGI - -ifeq ($(USEOPENMP),YES) -FFLAGS += -mp -endif - -FPPFLAGS += -DPGI -CPPFLAGS += -DPGI -Mpreprocess - -F90_PP_ONLY = -E -F90_PP_OUTPUT = > - -ifeq ($(DSO),YES) - FFLAGS +=-PIC -endif - -LDFLAGS+= -ldl - - - - diff --git a/tests/pFUnit-3.2.9/include/PreprocessMacro.cmake b/tests/pFUnit-3.2.9/include/PreprocessMacro.cmake deleted file mode 100644 index cf128d14..00000000 --- a/tests/pFUnit-3.2.9/include/PreprocessMacro.cmake +++ /dev/null @@ -1,43 +0,0 @@ -set (PFUNIT_PREPROCESSOR python $ENV{PFUNIT}/bin/pFUnitParser.py) -set (PFUNIT_SUFFIX "\\.pfunit") -# - Pass a list of files through the pFUnit macro processor -# -# ADD_PFUNIT_SOURCES( OUTVAR source1 ... sourceN ) -# -# OUTVAR A list containing all the output file names, suitable -# to be passed to add_executable or add_library. -# -# If the source files have a .m4 suffix it is stripped from the output -# file name. The output files are placed in the same relative location -# to CMAKE_CURRENT_BINARY_DIR as they are to CMAKE_CURRENT_SOURCE_DIR. -# -# Example: -# add_pfunit_sources( SRCS src/test1.cxx.pfunit src/test2.cxx.pfunit ) -# add_executable( test ${SRCS} ) -function( ADD_PFUNIT_SOURCES OUTVAR ) - set( outfiles ) - foreach( f ${ARGN} ) - # first we might need to make the input file absolute - get_filename_component( f "${f}" ABSOLUTE ) - # get the relative path of the file to the current source dir - file( RELATIVE_PATH baseFile "${CMAKE_CURRENT_SOURCE_DIR}" "${f}" ) - # strip the .pfunit off the end if present - string( REGEX REPLACE "${PFUNIT_SUFFIX}" ".F90" outFile "${CMAKE_CURRENT_BINARY_DIR}/${baseFile}" ) - # append the output file to the list of outputs - list( APPEND outfiles "${outFile}" ) - # create the output directory if it doesn't exist - get_filename_component( dir "${outFile}" PATH ) - if( NOT IS_DIRECTORY "${dir}" ) - file( MAKE_DIRECTORY "${dir}" ) - endif( NOT IS_DIRECTORY "${dir}" ) - # now add the custom command to generate the output file - add_custom_command( OUTPUT "${outFile}" - COMMAND ${PFUNIT_PREPROCESSOR} "${f}" "${outFile}" - DEPENDS "${f}" - ) - endforeach( f ) - # set the output list in the calling scope - set( ${OUTVAR} ${outfiles} PARENT_SCOPE ) -endfunction( ADD_PFUNIT_SOURCES ) - - diff --git a/tests/pFUnit-3.2.9/include/TestUtil.F90 b/tests/pFUnit-3.2.9/include/TestUtil.F90 deleted file mode 100644 index ec9bbc32..00000000 --- a/tests/pFUnit-3.2.9/include/TestUtil.F90 +++ /dev/null @@ -1,23 +0,0 @@ -module TestUtil - implicit none - - private - public getResource - -contains - - function getResource(path) result(absolutePath) - character(len=*), intent(in) :: path - character(len=:), allocatable :: absolutePath - - integer :: status, n - - n = len(__PROJECT_DIR__ // "/" // trim(adjustl(path))) - allocate(character(len=n) :: absolutePath, stat=status) - if (status == 0) then - absolutePath = __PROJECT_DIR__ // "/" // trim(adjustl(path)) - end if - - end function getResource - -end module TestUtil diff --git a/tests/pFUnit-3.2.9/include/base-develop.mk b/tests/pFUnit-3.2.9/include/base-develop.mk deleted file mode 100644 index 9e6b7441..00000000 --- a/tests/pFUnit-3.2.9/include/base-develop.mk +++ /dev/null @@ -1,38 +0,0 @@ -BASEMK_INCLUDED=YES - -SRC_DIR =$(TOP)/source -TESTS_DIR =$(TOP)/tests -INCLUDE_DIR =$(TOP)/include -LIB_DIR =$(TOP)/source -MOD_DIR =$(TOP)/source - -# Set the required file extensions. -include $(INCLUDE_DIR)/extensions.mk - -COMPILER_ = $(shell echo $(COMPILER) | tr a-z A-Z ) - -# Include the compiler-specific options. -include $(INCLUDE_DIR)/$(COMPILER_).mk - -FFLAGS += $I$(INCLUDE_DIR) - -ifeq ($(USEMPI),) - FC=$(F90) -else - override FC=$(MPIF90) -endif - -%$(OBJ_EXT): %.F90 - $(FC) -c $(FFLAGS) $(CPPFLAGS) -o $@ $< - -.PHONY: clean distclean - -clean: - -$(RM) *$(OBJ_EXT) *.mod *.i90 *~ *.tmp *.dbg - -$(RM) -r *.dSYM - -distclean: clean - -$(RM) *$(LIB_EXT) *$(EXE_EXT) dependencies.inc - -export FC -export BASEMK_INCLUDED diff --git a/tests/pFUnit-3.2.9/include/base-install.mk b/tests/pFUnit-3.2.9/include/base-install.mk deleted file mode 100644 index 34a11ddf..00000000 --- a/tests/pFUnit-3.2.9/include/base-install.mk +++ /dev/null @@ -1,69 +0,0 @@ - -BASEMK_INCLUDED=YES - -INCLUDE_DIR =$(PFUNIT)/include -LIB_DIR =$(PFUNIT)/lib -MOD_DIR =$(PFUNIT)/mod - -# These two are not part of an installation. -# SRC_DIR =$(PFUNIT)/source -# TESTS_DIR =$(PFUNIT)/tests - -# Read in compile configuration to help set flags like -gomp for GNU. -include $(INCLUDE_DIR)/configuration.mk - -# Set the required file extensions. -include $(INCLUDE_DIR)/extensions.mk - -# F90 Vendor common elements (override below) -# FFLAGS ?= -D=-D -I=-I -MOD=-I -DEBUG_FLAGS =-g - -# Include the compiler-specific options. -COMPILER ?= COMPILER_NOT_SET -COMPILER_ = $(shell echo $(COMPILER) | tr a-z A-Z ) -include $(INCLUDE_DIR)/$(COMPILER_).mk - -FFLAGS += $I$(INCLUDE_DIR) - -ifeq ($(BUILDROBUST),YES) - FPPFLAGS += $DBUILD_ROBUST - CPPFLAGS += -DBUILD_ROBUST -endif - -# include/driver.F90 needs both BUILD_ROBUST -ifneq ($(USEMPI),YES) - FC=$(F90) -else - FC=$(MPIF90) -endif - -%$(OBJ_EXT): %.F90 - $(FC) -c $(FFLAGS) $(CPPFLAGS) -o $@ $< - -.PHONY: clean distclean echo - -clean: local-base0-clean - -local-base0-clean: - $(RM) *$(OBJ_EXT) *.mod *.i90 *~ *.tmp *.s *.dbg - $(RM) -r *.dSYM - -distclean: local-base0-distclean - -local-base0-distclean: clean - $(RM) *$(LIB_EXT) *$(EXE_EXT) - -echo: - @echo COMPILER: $(COMPILER) - @echo FC: $(FC) - @echo USEMPI: $(USEMPI) - @echo FFLAGS: $(FFLAGS) - @echo FPPFLAGS: $(FPPFLAGS) - @echo CPPFLAGS: $(CPPFLAGS) - -export FC -export BASEMK_INCLUDED diff --git a/tests/pFUnit-3.2.9/include/base.mk b/tests/pFUnit-3.2.9/include/base.mk deleted file mode 100644 index d304196f..00000000 --- a/tests/pFUnit-3.2.9/include/base.mk +++ /dev/null @@ -1,39 +0,0 @@ - -BASEMK_INCLUDED=YES - -SRC_DIR =$(TOP)/source -TESTS_DIR =$(TOP)/tests -INCLUDE_DIR =$(TOP)/include -LIB_DIR =$(TOP)/source -MOD_DIR =$(TOP)/source - -# Set the required file extensions. -include $(INCLUDE_DIR)/extensions.mk - -COMPILER_ = $(shell echo $(COMPILER) | tr a-z A-Z ) - -# Include the compiler-specific options. -include $(INCLUDE_DIR)/$(COMPILER_).mk - -FFLAGS += $I$(INCLUDE_DIR) - -ifeq ($(USEMPI),) - FC=$(F90) -else - override FC=$(MPIF90) -endif - -%$(OBJ_EXT): %.F90 - $(FC) -c $(FFLAGS) $(CPPFLAGS) -o $@ $< - -.PHONY: clean distclean - -clean: - -$(RM) *$(OBJ_EXT) *.mod *.i90 *~ *.tmp *.s *.dbg - -$(RM) -r *.dSYM - -distclean: clean - -$(RM) *$(LIB_EXT) *$(EXE_EXT) dependencies.inc - -export FC -export BASEMK_INCLUDED diff --git a/tests/pFUnit-3.2.9/include/cmake/Modules/FindOpenMP_Fortran.cmake b/tests/pFUnit-3.2.9/include/cmake/Modules/FindOpenMP_Fortran.cmake deleted file mode 100644 index 29998549..00000000 --- a/tests/pFUnit-3.2.9/include/cmake/Modules/FindOpenMP_Fortran.cmake +++ /dev/null @@ -1,107 +0,0 @@ -# - Finds OpenMP support -# This module can be used to detect OpenMP support in a compiler. -# If the compiler supports OpenMP, the flags required to compile with -# openmp support are set. -# -# This module was modified from the standard FindOpenMP module to find Fortran -# flags. -# -# The following variables are set: -# OpenMP_Fortran_FLAGS - flags to add to the Fortran compiler for OpenMP -# support. In general, you must use these at both -# compile- and link-time. -# OMP_NUM_PROCS - the max number of processors available to OpenMP - -#============================================================================= -# Copyright 2009 Kitware, Inc. -# Copyright 2008-2009 André Rigland Brodtkorb -# -# Distributed under the OSI-approved BSD License (the "License"); -# see accompanying file Copyright.txt for details. -# -# This software is distributed WITHOUT ANY WARRANTY; without even the -# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -# See the License for more information. -#============================================================================= -# (To distribute this file outside of CMake, substitute the full -# License text for the above reference.) - -INCLUDE (${CMAKE_ROOT}/Modules/FindPackageHandleStandardArgs.cmake) - -SET (OpenMP_Fortran_FLAG_CANDIDATES - #Portland Group - "-mp" - #Intel - "-qopenmp" - "-openmp" - #Gnu - "-fopenmp" - #Microsoft Visual Studio - "/openmp" - #Intel windows - "/Qopenmp" - #Empty, if compiler automatically accepts openmp - " " - #Sun - "-xopenmp" - #HP - "+Oopenmp" - #IBM XL C/c++ - "-qsmp=omp" -) - -IF (DEFINED OpenMP_Fortran_FLAGS) - SET (OpenMP_Fortran_FLAG_CANDIDATES) -ENDIF (DEFINED OpenMP_Fortran_FLAGS) - -# check fortran compiler. also determine number of processors -FOREACH (FLAG ${OpenMP_Fortran_FLAG_CANDIDATES}) - SET (SAFE_CMAKE_REQUIRED_FLAGS "${CMAKE_REQUIRED_FLAGS}") - SET (CMAKE_REQUIRED_FLAGS "${FLAG}") - UNSET (OpenMP_FLAG_DETECTED CACHE) - MESSAGE (STATUS "Try OpenMP Fortran flag = [${FLAG}]") - FILE (WRITE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortranOpenMP.f90" -" -program TestOpenMP - use omp_lib - write(*,'(I2)',ADVANCE='NO') omp_get_num_procs() -end program TestOpenMP -") - - SET (MACRO_CHECK_FUNCTION_DEFINITIONS - "${CMAKE_REQUIRED_FLAGS}") - TRY_RUN (OpenMP_RUN_FAILED OpenMP_FLAG_DETECTED ${CMAKE_BINARY_DIR} - ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortranOpenMP.f90 - COMPILE_DEFINITIONS ${CMAKE_REQUIRED_DEFINITIONS} -DOpenMP_FLAG_DETECTED - CMAKE_FLAGS -DCOMPILE_DEFINITIONS:STRING=${MACRO_CHECK_FUNCTION_DEFINITIONS} - COMPILE_OUTPUT_VARIABLEOUTPUT - RUN_OUTPUT_VARIABLE OMP_NUM_PROCS_INTERNAL) - - IF (OpenMP_FLAG_DETECTED) - FILE (APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log - "Determining if the Fortran compiler supports OpenMP passed with " - "the following output:\n${OUTPUT}\n\n") - SET (OpenMP_FLAG_DETECTED 1) - IF (OpenMP_RUN_FAILED) - MESSAGE (FATAL_ERROR "OpenMP found, but test code did not run") - ENDIF (OpenMP_RUN_FAILED) - SET (OMP_NUM_PROCS ${OMP_NUM_PROCS_INTERNAL} CACHE - STRING "Number of processors OpenMP may use" FORCE) - SET (OpenMP_Fortran_FLAGS_INTERNAL "${FLAG}") - BREAK () - ELSE () - FILE (APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log - "Determining if the Fortran compiler supports OpenMP failed with " - "the following output:\n${OUTPUT}\n\n") - SET (OpenMP_FLAG_DETECTED 0) - ENDIF (OpenMP_FLAG_DETECTED) -ENDFOREACH (FLAG ${OpenMP_Fortran_FLAG_CANDIDATES}) - -SET (OpenMP_Fortran_FLAGS "${OpenMP_Fortran_FLAGS_INTERNAL}" - CACHE STRING "Fortran compiler flags for OpenMP parallization") - -# handle the standard arguments for FIND_PACKAGE -FIND_PACKAGE_HANDLE_STANDARD_ARGS (OpenMP_Fortran DEFAULT_MSG - OpenMP_Fortran_FLAGS) - -MARK_AS_ADVANCED(OpenMP_Fortran_FLAGS) diff --git a/tests/pFUnit-3.2.9/include/driver.F90 b/tests/pFUnit-3.2.9/include/driver.F90 deleted file mode 100644 index 3d3e0977..00000000 --- a/tests/pFUnit-3.2.9/include/driver.F90 +++ /dev/null @@ -1,336 +0,0 @@ -program main - use iso_fortran_env, only: OUTPUT_UNIT - use pfunit_mod -#ifdef PFUNIT_EXTRA_USAGE - ! Use external code for whatever suite-wide fixture is in use. - use PFUNIT_EXTRA_USAGE -#endif - implicit none -#ifdef USE_MPI - include 'mpif.h' -#endif - type (TestSuite) :: all - class(BaseTestRunner), allocatable :: runner - - integer :: i - character(len=:), allocatable :: executable - character(len=:), allocatable :: argument - - real :: maxTimeoutDuration - real :: maxLaunchDuration - - logical :: useRobustRunner - logical :: useSubsetRunner - logical :: printXmlFile - integer :: numSkip - logical :: useMpi -! Regular Output - integer :: numArguments - logical :: debug = .false. ! override with -d - integer :: outputUnit ! override with -o - character(len=:), allocatable :: outputFile -! XML Additions - character(len=:), allocatable :: xmlFileName - integer :: iostat - integer :: xmlFileUnit - logical :: xmlFileOpened - integer :: numListeners, iListener - class (ListenerPointer), allocatable :: listeners(:) - type (DebugListener) :: debugger - character(len=128) :: suiteName - character(len=128) :: maxTimeoutDuration_ - character(len=128) :: maxLaunchDuration_ - character(len=128) :: fullExecutable - -! Support for the runs - class (ParallelContext), allocatable :: context - type (TestResult) :: result - - ! Initialize variables... - - maxTimeoutDuration = 5.00 ! seconds - maxLaunchDuration = 5.00 ! seconds - - useRobustRunner = .false. - useSubsetRunner = .false. - printXmlFile = .false. - numSkip = 0 - numListeners = 1; iListener = 0 - - executable = getCommandLineArgument(0) - - outputUnit = OUTPUT_UNIT ! stdout unless modified below - - ! Loop over optional arguments in the command line - numArguments = command_argument_count() - - suiteName = 'default_suite_name' - - i = 0 - do - i = i + 1 - if (i > numArguments) exit - - argument = getCommandLineArgument(i) - - select case(argument) - case ('-h','--help') - call printHelpMessage() - call finalize(successful=.true.) - case ('-v','--verbose','-d','--debug') - debug = .true. - numListeners = numListeners + 1 - case ('-o') - i = i + 1 - if (i > numArguments) call commandLineArgumentError() - - outputFile = getCommandLineArgument(i) - - open(file=outputfile, newUnit=outputUnit, form='formatted', & - & status='unknown', access='sequential') - - case ('-robust') -#ifdef BUILD_ROBUST - useRobustRunner = .true. -#else - ! TODO: This should be a failing test. - write (*,*) 'Robust runner not built.' - useRobustRunner = .false. -#endif - - case ('-max-timeout-duration') -#ifdef BUILD_ROBUST - i = i+1; if (i>numArguments) call commandLineArgumentError() - maxTimeoutDuration_ = getCommandLineArgument(i) - read(maxTimeoutDuration_,*) maxTimeoutDuration -#else - ! TODO: This should be a failing test. - write (*,*) 'Robust runner not built.' -#endif - - case ('-max-launch-duration') -#ifdef BUILD_ROBUST - i = i+1; if (i>numArguments) call commandLineArgumentError() - maxLaunchDuration_ = getCommandLineArgument(i) - read(maxLaunchDuration_,*)maxLaunchDuration -#else - ! TODO: This should be a failing test. - write (*,*) 'Robust runner not built.' -#endif - - case ('-skip') - useSubsetRunner = .true. - i = i + 1 - if (i > numArguments) call commandLineArgumentError() - - argument = getCommandLineArgument(i) - read(argument,*) numSkip - - case default - call commandLineArgumentError() - - case ('-xml') - i = i + 1 - if (i > numArguments) call commandLineArgumentError() - xmlFileName = getCommandLineArgument(i) - open(newUnit=xmlFileUnit, file=xmlFileName, form='formatted', & - & status='unknown', access='sequential', iostat=iostat) - if(iostat /= 0) then - write(*,*) 'Could not open XML file ', xmlFileName, & - ', error: ', iostat - else - printXmlFile = .true. - numListeners = numListeners + 1 - end if - case ('-name') - i = i + 1 - call get_command_argument(i, value=suiteName) - end select - - end do - - -! Allocate and fill listeners array. - allocate(listeners(numListeners)) -! Default listener - iListener = iListener + 1 - allocate(listeners(iListener)%pListener, source=newResultPrinter(outputUnit)) -! XML listener - if(printXmlFile) then - iListener = iListener + 1 - allocate(listeners(iListener)%pListener, source=newXmlPrinter(xmlFileUnit)) - end if -! Debugger - if(debug) then - iListener = iListener + 1 - debugger=DebugListener(outputUnit) - allocate(listeners(iListener)%pListener, source=debugger) - end if - - ! Initialize should be called on the second timethrough. - - ! useMPI optional argument has no effect if not USE_MPI. - if (useRobustRunner) then - call initialize(useMPI=.false.) - else - call initialize(useMPI=.true.) - end if - -!------------------------------------------------------------------------- -! Some users may have 1-time only non-reentrant libraries that must -! be initialized prior to executing their tests. The motivating example -! here is the Earth System Modeling Framework. Rather than customize -! this driver to each case as it arises, we are leaving it to users -! to write a single init routine that is invoked here. -!------------------------------------------------------------------------- -#ifdef PFUNIT_EXTRA_INITIALIZE - call PFUNIT_EXTRA_INITIALIZE() -#endif - -#ifdef USE_MPI - useMpi = .true. -#else - useMpi = .false. -#endif - - if (useRobustRunner) then - useMpi = .false. ! override build -#ifdef BUILD_ROBUST -#ifdef USE_MPI - fullExecutable = 'mpirun -np 4 ' // executable -#else - fullExecutable = executable -#endif -! allocate(runner, source=RobustRunner(fullExecutable, listeners)) - allocate(runner, & - & source=RobustRunner( & - & fullExecutable, & - & listeners, & - & maxLaunchDuration=maxLaunchDuration, & - & maxTimeoutDuration=maxTimeoutDuration )) -#else - ! TODO: This should be a failing test. - write (*,*) 'Robust runner not built.' -#endif - else if (useSubsetRunner) then - allocate(runner, source=SubsetRunner(numSkip=numSkip)) - else - allocate(runner, source=newTestRunner(listeners)) - end if - - all = getTestSuites() - call all%setName(suiteName) - - call getContext(context, useMpi) - - result = runner%run(all, context) - - if (outputUnit /= OUTPUT_UNIT) then - close(outputUnit) - end if - - if(printXmlFile) then - inquire(unit=xmlFileUnit, opened=xmlFileOpened) - if(xmlFileOpened) then - close(xmlFileUnit) - end if - end if - -#ifdef PFUNIT_EXTRA_FINALIZE - call PFUNIT_EXTRA_FINALIZE() -#endif - - call finalize(result%wasSuccessful()) - -contains - - subroutine getContext(context, useMpi) - class (ParallelContext), allocatable :: context - logical, intent(in) :: useMpi - -#ifdef USE_MPI - if (useMpi) then - allocate(context, source=newMpiContext()) - return - end if -#endif - - allocate(context, source=newSerialContext()) - - end subroutine getContext - - function getTestSuites() result(suite) -#define ADD_MODULE_TEST_SUITE(m,s) use m, only: s -#define ADD_TEST_SUITE(s) ! do nothing -#include "testSuites.inc" -#undef ADD_MODULE_TEST_SUITE -#undef ADD_TEST_SUITE - - type (TestSuite) :: suite - -#define ADD_MODULE_TEST_SUITE(m,s) ! do nothing -#define ADD_TEST_SUITE(s) type (TestSuite), external :: s -#include "testSuites.inc" -#undef ADD_TEST_SUITE -#undef ADD_MODULE_TEST_SUITE - - suite = newTestSuite() - - ! accumulate tests in top suite -#define ADD_TEST_SUITE(s) call suite%addTest(s()) -#define ADD_MODULE_TEST_SUITE(m,s) call suite%addTest(s()) -#include "testSuites.inc" -#undef ADD_TEST_SUITE -#undef ADD_MODULE_TEST_SUITE - - end function getTestSuites - - function getCommandLineArgument(i) result(argument) - integer, intent(in) :: i - character(:), allocatable :: argument - - integer :: length - - call get_command_argument(i, length=length) - allocate(character(len=length) :: argument) - call get_command_argument(i, value=argument) - - end function getCommandLineArgument - - subroutine commandLineArgumentError() - use iso_fortran_env, only: OUTPUT_UNIT - - write(OUTPUT_UNIT,*)'Unsupported/mismatched command line arguments.' - write(OUTPUT_UNIT,*)' ' - call printHelpMessage() - call finalize(successful=.false.) - - end subroutine commandLineArgumentError - - subroutine printHelpMessage() - use iso_fortran_env, only: OUTPUT_UNIT - - write(OUTPUT_UNIT,*)'Command line arguments:' - write(OUTPUT_UNIT,*)' ' - write(OUTPUT_UNIT,*)' Options: ' - write(OUTPUT_UNIT,*)" '-h', '--help' : Prints this message" - write(OUTPUT_UNIT,*)" '-v', '--verbose' : Logs start/stop of each test" - write(OUTPUT_UNIT,*)" '-d', '--debug' : Logs start/stop of each test (same as -v)" - write(OUTPUT_UNIT,*)" '-o ' : Diverts output to specified file" - write(OUTPUT_UNIT,*)" '-robust' : (experimental) runs tests in a separate shell" - write(OUTPUT_UNIT,*)" Attempts to detect/handle hangs and crashes" - write(OUTPUT_UNIT,*)" '-max-timeout-duration ' : Limit detection time for robust" - write(OUTPUT_UNIT,*)" '-max-launch-duration ' : Limit detection time for robust" - write(OUTPUT_UNIT,*)" '-skip n' : used by remote start with 'robust' internally" - write(OUTPUT_UNIT,*)" This flag should NOT be used directly by users." - write(OUTPUT_UNIT,*)" '-xml ' : output JUnit XML to specified file" - write(OUTPUT_UNIT,*)" XML can be used with e.g. Jenkins." - write(OUTPUT_UNIT,*)" '-name ' : give tests an identifying name in XML output" - write(OUTPUT_UNIT,*)" " - - end subroutine printHelpMessage - -end program main - - - diff --git a/tests/pFUnit-3.2.9/include/extensions.mk b/tests/pFUnit-3.2.9/include/extensions.mk deleted file mode 100644 index 65cf7b3e..00000000 --- a/tests/pFUnit-3.2.9/include/extensions.mk +++ /dev/null @@ -1,28 +0,0 @@ -# Decide the file extensions depending on the platform. - -ifeq ($(UNAME),) -LOCAL_UNAME ?=$(shell uname) -ifeq ($(LOCAL_UNAME),) - LOCAL_UNAME =UNKNOWN -else -# Check for Windows/CYGWIN compilation. -ifneq (,$(findstring CYGWIN,$(UNAME))) - LOCAL_UNAME =Windows -endif -endif -else -LOCAL_UNAME := $(UNAME) -endif - -# Set the file extensions based on the LOCAL_UNAME. -ifneq ($(LOCAL_UNAME),Windows) -# File extensions for non-Windows. -OBJ_EXT ?= .o -LIB_EXT ?= .a -EXE_EXT ?= .x -else -# File extensions for Windows. -OBJ_EXT ?= .obj -LIB_EXT ?= .lib -EXE_EXT ?= .exe -endif diff --git a/tests/pFUnit-3.2.9/source/.cvsignore b/tests/pFUnit-3.2.9/source/.cvsignore deleted file mode 100644 index e2d2518d..00000000 --- a/tests/pFUnit-3.2.9/source/.cvsignore +++ /dev/null @@ -1,13 +0,0 @@ -*.dylib -*.mod -*.x -.libs -AssertComplex_mod.F90 -AssertReal_mod.F90 -dispatch.c -dlCloseWrapper.c -dlOpenWrapper.c -dlsymWrapper.c -getAddress.c -m_AssertReal.F90 -semantic.cache diff --git a/tests/pFUnit-3.2.9/source/.gitignore b/tests/pFUnit-3.2.9/source/.gitignore deleted file mode 100644 index 7cfa88fd..00000000 --- a/tests/pFUnit-3.2.9/source/.gitignore +++ /dev/null @@ -1,19 +0,0 @@ -*.a -*.i90 -*.lib -*.mod -*.o -*.obj -*.pyc -*.tmp -*~ -/.#* -/AssertComplex.F90 -/AssertComplex_mod.F90 -/AssertComplex_mod_cpp.F90 -/AssertInteger1.F90 -/AssertReal.F90 -/AssertReal_mod.F90 -/dependencies.inc -/pre.m4 -/testCM.* diff --git a/tests/pFUnit-3.2.9/source/AbstractTestParameter.F90 b/tests/pFUnit-3.2.9/source/AbstractTestParameter.F90 deleted file mode 100644 index e236429d..00000000 --- a/tests/pFUnit-3.2.9/source/AbstractTestParameter.F90 +++ /dev/null @@ -1,29 +0,0 @@ -module AbstractTestParameter_mod - implicit none - private - - public :: AbstractTestParameter - - type, abstract :: AbstractTestParameter - contains - procedure(toString), deferred :: toString - procedure :: toStringActual - end type AbstractTestParameter - - abstract interface - function toString(this) result(string) - import AbstractTestParameter - class (AbstractTestParameter), intent(in) :: this - character(:), allocatable :: string - end function toString - end interface - -contains - - function toStringActual(this) result(string) - class (AbstractTestParameter), intent(in) :: this - character(:), allocatable :: string - string = this%toString() - end function toStringActual - -end module AbstractTestParameter_mod diff --git a/tests/pFUnit-3.2.9/source/AbstractTestResult.F90 b/tests/pFUnit-3.2.9/source/AbstractTestResult.F90 deleted file mode 100644 index cbcb115f..00000000 --- a/tests/pFUnit-3.2.9/source/AbstractTestResult.F90 +++ /dev/null @@ -1,86 +0,0 @@ - -module AbstractTestResult_mod - - implicit none - private - - public :: AbstractTestResult - - type, abstract :: AbstractTestResult -! private - contains - procedure(getRuntime), deferred :: getRuntime - procedure(getFailures), deferred :: getFailures - procedure(getErrors), deferred :: getErrors - procedure(getSuccesses), deferred :: getSuccesses - procedure(wasSuccessful), deferred :: wasSuccessful - procedure(runCount), deferred :: runCount - procedure(failureCount), deferred :: failureCount - procedure(errorCount), deferred :: errorCount - procedure(getName), deferred :: getName - procedure(setName), deferred :: setName - - end type AbstractTestResult - - abstract interface - function getRunTime(this) result(time) -! TestFailure_mod, only : TestFailure - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - real :: time - end function getRunTime - function getFailures(this) result(failures) - use TestFailure_mod, only : TestFailure - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - type (TestFailure), allocatable :: failures(:) - end function getFailures - function getErrors(this) result(errors) - use TestFailure_mod, only : TestFailure - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - type (TestFailure), allocatable :: errors(:) - end function getErrors - function getSuccesses(this) result(successes) - use TestFailure_mod, only : TestFailure - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - type (TestFailure), allocatable :: successes(:) - end function getSuccesses - - logical function wasSuccessful(this) - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - end function wasSuccessful - - integer function runCount(this) - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - end function runCount - - integer function errorCount(this) - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - end function errorCount - - integer function failureCount(this) - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - end function failureCount - - function getName(this) result(name) - import AbstractTestResult - class (AbstractTestResult), intent(in) :: this - character(:), allocatable :: name - end function getName - - subroutine setName(this, name) - import AbstractTestResult - class (AbstractTestResult), intent(inout) :: this - character(len=*),intent(in) :: name - end subroutine setName - - - end interface - -end module AbstractTestResult_mod diff --git a/tests/pFUnit-3.2.9/source/Assert.F90 b/tests/pFUnit-3.2.9/source/Assert.F90 deleted file mode 100644 index 0188e7c3..00000000 --- a/tests/pFUnit-3.2.9/source/Assert.F90 +++ /dev/null @@ -1,54 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: Assert -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module Assert_mod - use AssertBasic_mod -#include "AssertArrays.fh" - implicit none - private - - public :: assertFail - public :: assertTrue - public :: assertFalse - public :: assertEqual - public :: assertExceptionRaised - public :: assertSameShape - - public :: assertAny - public :: assertAll - public :: assertNone - public :: assertNotAll - - public :: assertNotEqual - public :: assertLessThan, assertLessThanOrEqual - public :: assertGreaterThan, assertGreaterThanOrEqual - public :: assertRelativelyEqual - - public :: assertIsNan, assertIsFinite - - ! Optional arguments for assertEqual. - public :: WhitespaceOptions - public :: IGNORE_ALL, TRIM_ALL, KEEP_ALL, IGNORE_DIFFERENCES - -contains - -end module Assert_mod diff --git a/tests/pFUnit-3.2.9/source/AssertBasic.F90 b/tests/pFUnit-3.2.9/source/AssertBasic.F90 deleted file mode 100644 index f8da2f81..00000000 --- a/tests/pFUnit-3.2.9/source/AssertBasic.F90 +++ /dev/null @@ -1,636 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: AssertBasic -! -!> @brief -!! Provides fundamental assertions over the most basic types, a -!! foundation for providing test services to end users. -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note For assertions on strings whitespace may or may not be -!! significant to a test. We now have several options for dealing -!! with whitespace via the optional argument -!! Whitespace. These options are -!! IGNORE_ALL, TRIM_ALL, and KEEP_ALL. Usage is as follows. -!! -!! -!! call assertEqual(expectedString, foundString, & -!! & Whitespace=IGNORE_ALL ) -!! -!! -!! WhitespaceOptions: -!!
    -!!
  • TRIM_ALL ignores leading and trailing whitespace.
    • -!!
  • KEEP_ALL keeps all whitespace as significant, even discriminating -!! between tabs and spaces.
    • -!!
  • IGNORE_ALL ignores all whitespace (spaces & tabs).
    • -!!
-!! -!! Example usages can be seen in tests/Test_AssertBasic.F90 or -!! Examples/Simple/tests/helloWorld.pf. -! -! REVISION HISTORY: -! -! 05 Sep 2014 - Added polite whitespace options trim, ignore, and -! keep. MLR -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module AssertBasic_mod - use Exception_mod - use SourceLocation_mod - use StringConversionUtilities_mod - implicit none - private - - public :: fail - public :: assertFail - - public :: assertTrue - public :: assertFalse - public :: assertEqual - public :: assertExceptionRaised - public :: assertSameShape - - public :: assertAny - public :: assertAll - public :: assertNone - public :: assertNotAll - - public :: assertIsNaN - public :: assertIsFinite - - - ! Utility procedures - public :: conformable - public :: nonConformable - - public :: UnusableArgument - - ! from StringConversionUtilities - public :: WhitespaceOptions - public :: IGNORE_ALL, TRIM_ALL, KEEP_ALL, IGNORE_DIFFERENCES - - interface fail - module procedure fail_ - end interface fail - - interface assertFail - module procedure fail_ - end interface assertFail - - interface assertTrue - module procedure assertTrue_ - module procedure assertTrue_1d_ - end interface - - interface assertFalse - module procedure assertFalse_ - module procedure assertFalse_1d_ - end interface - - interface assertEqual - module procedure assertEqualString_ - module procedure assertEqualLogical_ - end interface - - interface assertExceptionRaised - module procedure assertExceptionRaisedBasic - module procedure assertExceptionRaisedMessage - end interface assertExceptionRaised - - interface assertIsNaN - module procedure assertIsNan_single - module procedure assertIsNan_double - end interface assertIsNaN - - interface assertIsFinite - module procedure assertIsFinite_single - module procedure assertIsFinite_double - end interface assertIsFinite - - ! Arguments of the type below are used to force keyword arguments - ! for optional arguments. - type UnusableArgument - end type UnusableArgument - - -contains - - subroutine fail_(message, location) - character(len=*), intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call throw(message, location) - - end subroutine fail_ - - - subroutine assertTrue_(condition, message, location) - logical, intent(in) :: condition - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - character(len=:), allocatable :: message_ - - message_ = NULL_MESSAGE - if (present(message)) message_ = message - - if (.not. condition) call throw(trim(message_), location) - end subroutine assertTrue_ - - subroutine assertTrue_1d_(condition, message, location) - logical, intent(in) :: condition(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - character(len=:), allocatable :: message_ - - message_ = NULL_MESSAGE - if (present(message)) message_ = message - - if (.not. all(condition)) call throw(trim(message_), location) - end subroutine assertTrue_1d_ - - - subroutine assertExceptionRaisedBasic(location) - use Exception_mod, only: throw, catch - type (SourceLocation), optional, intent(in) :: location - - if (.not. catch()) then - call throw('Failed to throw exception.', location) - end if - - end subroutine assertExceptionRaisedBasic - - subroutine assertExceptionRaisedMessage(message, location) - use Exception_mod, only: throw, catch - character(len=*), intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - if (.not. catch(message)) then - call throw('Failed to throw exception: <' // trim(message) // '>', & - & location) - end if - - end subroutine assertExceptionRaisedMessage - - subroutine assertSameShape(shapeA, shapeB, message, location) - integer, intent(in) :: shapeA(:) - integer, intent(in) :: shapeB(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - character(len=MAXLEN_MESSAGE) :: throwMessage - character(len=MAXLEN_MESSAGE) :: message_ - - message_ = NULL_MESSAGE - if (present(message)) message_ = message - - if (nonConformable(shapeA, shapeB)) then - throwMessage = 'nonconforming arrays - expected shape: ' // & - & trim(toString(shapeA)) // ' but found shape: ' // & - & trim(toString(shapeB)) - - call throw(appendWithSpace(message_, throwMessage), & - & location) - end if - - - end subroutine assertSameShape - - logical function conformable(shapeA, shapeB) - integer, intent(in) :: shapeA(:) - integer, intent(in) :: shapeB(:) - - if (size(shapeA) == 0 .or. size(shapeB) == 0) then - conformable = .true. - return - end if - - conformable = size(shapeA) == size(shapeB) - if (conformable) then - conformable = all(shapeA == shapeB) - end if - end function conformable - - logical function nonConformable(shapeA, shapeB) - integer, intent(in) :: shapeA(:) - integer, intent(in) :: shapeB(:) - - nonConformable = .not. conformable(shapeA, shapeB) - - end function nonConformable - - subroutine assertFalse_(condition, message, location) - logical, intent(in) :: condition - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call assertTrue(.not. condition, message, location) - end subroutine assertFalse_ - - subroutine assertFalse_1d_(condition, message, location) - logical, intent(in) :: condition(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call assertTrue(.not. condition, message, location) - end subroutine assertFalse_1d_ - - subroutine assertEqualLogical_(expected, found, message, location) - use Exception_mod, only: throw, MAXLEN_MESSAGE - logical, intent(in) :: expected - logical, intent(in) :: found - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - character(len=MAXLEN_MESSAGE) :: throwMessage - character(len=:), allocatable :: message_ - - if (expected .neqv. found) then - write(throwMessage,'((a,a),2(a,a,a,a))') & - & 'Logical assertion failed:', new_line('A'), & - & ' expected: <"', expected, '">', new_line('A'), & - & ' but found: <"', found, '">', new_line('A') - - message_ = NULL_MESSAGE - if (present(message)) message_ = message - - call throw(appendWithSpace(message_,throwMessage), location) - end if - - end subroutine assertEqualLogical_ - - subroutine assertEqualString_(expected, found, message, location, & - & whitespace) - use Exception_mod, only: throw, MAXLEN_MESSAGE - character(len=*), intent(in) :: expected - character(len=*), intent(in) :: found - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - type (WhitespaceOptions), optional, intent(in) :: & - & whitespace - - character(len=:), allocatable :: message_ - type (WhitespaceOptions) :: whitespace_ - - character(len=MAXLEN_MESSAGE) :: throwMessage - integer :: i, j - integer :: numI, numJ - integer :: numSameCharacters - - integer, parameter :: iachar_spc = 32, iachar_tab = 9 - - logical :: checkCharacterByCharacter - logical :: throwException - logical :: whitespaceYes - character(len=:), allocatable :: expected_, found_ - - throwException = .false. - - message_ = NULL_MESSAGE - if (present(message)) message_ = message - - if(present(whitespace))then - whitespace_ = whitespace - else - ! This is the default whitespace option. TRIM_ALL is the legacy behavior. - ! TODO: Change default behavior to IGNORE_DIFFERENCES. - whitespace_ = TRIM_ALL - end if - - select case (whitespace_%value) - case (TRIM_ALL%value) - expected_ = trimAll(expected) - found_ = trimAll(found) - case (IGNORE_ALL%value) - expected_ = trimAll(expected) - found_ = trimAll(found) - case (IGNORE_DIFFERENCES%value) - expected_ = trimAll(expected) - found_ = trimAll(found) - case (KEEP_ALL%value) - expected_ = expected - found_ = found - end select - - ! Determine if we need to iterate through the characters in the strings. - ! Trim: ignore leading & trailing white space. - ! Ignore: ignore all white space. - ! Keep: white space is significant. - ! Worry: Original code written to !print out trimmed strings. Not sure what effect - ! Keep will have. - !print *,1000 - checkCharacterByCharacter = .true. - select case (whitespace_%value) - case (TRIM_ALL%value) - ! Check to see if we have to do more work. - checkCharacterByCharacter = expected_ /= found_ - numI = len(expected_); numJ = len(found_) - - case (IGNORE_ALL%value) - checkCharacterByCharacter = expected_ /= found_ - numI = len(expected_); numJ = len(found_) - - case (IGNORE_DIFFERENCES%value) - checkCharacterByCharacter = expected_ /= found_ - numI = len(expected_); numJ = len(found_) - !print *,1001,whitespace_%value - !print *,1002,'e="',expected_,'"' - !print *,1003,'f="',found_,'"' - - case (KEEP_ALL%value) - checkCharacterByCharacter = expected_ /= found_ - numI = len(expected_); numJ = len(found_) - - case default - write(throwMessage,'(a)')& - & 'assertEqualString_InternalError: ' & - & // 'Unknown case for handling Whitespace' - call throw(appendWithSpace(message_,throwMessage), location) - end select - - ! Flag a check if zero-length arrays are involved. - if ((numI .eq. 0) .or. (numJ .eq. 0)) then - checkCharacterByCharacter = .true. - end if - - ! Fortran implicitly pads strings of different lengths with spaces - ! when comparing using /= or ==. Detect them and compare carefully. - if (numI .ne. numJ) then - checkCharacterByCharacter = .true. - end if - - !if (numI .eq. 0) then - ! print *,'e: "'//expected_//'"' - ! print *,'f: "'//found_//'"' - ! print *,'?: ',checkCharacterByCharacter - ! print *,'!: ',expected_ /= found_ - ! print *,'z: ',expected_ == found_ - !end if - - !print *,2000,whitespace_%value - -! if (trim(expected) /= trim(found)) then - if (checkCharacterByCharacter) then - numSameCharacters = 0 - - ! Cycle over both strings, compare each element, skipping if needed. - i = 1; j = 1 - countNumSameCharacters: do - - ! Is a string traversal complete? - if ( i .gt. numI .or. j .gt. numJ ) then - ! If both made it to end, exit ok, else continue other traverse. - if ( i .gt. numI .and. j .gt. numJ ) exit - end if - - ! Handle whitespace options. - whitespaceYes = .false. - if ( i .le. numI ) whitespaceYes = whitespacep(expected_(i:i)) - if ( j .le. numJ ) whitespaceYes = whitespaceYes .or. & - & whitespacep(found_(j:j)) - - if ( whitespaceYes ) then - - select case (whitespace_%value) - - ! IGNORE_ALL? Then skip that element. Skip on i first, then j. - case (IGNORE_ALL%value) - if( i .le. numI ) then - if(whitespacep(expected_(i:i)))then - i=i+1; cycle - end if - end if - if( j .le. numJ ) then - if(whitespacep(found_(j:j)))then - j=j+1; cycle - end if - end if - - ! IGNORE_DIFFERENCES? - ! If either i & j start sequences that are white, skip past. - case (IGNORE_DIFFERENCES%value) - - !print *,2001 - - ! Because we expect to be dealing with trimmed strings - ! at this point, we need both sequences to be - ! whitespace, else fail. - - if( & - & .not.( & - & whitespacep(expected_(i:i)) & - & .and.whitespacep(found_(j:j))) ) then - throwException = .true.; exit - end if - - !print *,2100 - - ! Skip past i's whitespace. - iWhitespace: if( i .le. numI ) then - iLoop: do - ! Found white char, skip. - if(whitespacep(expected_(i:i)))then - i=i+1; if (i .gt. numI) exit iLoop - else - exit iLoop - end if - end do iLoop - ! i now either indexes non-whitespace or is past its bound. - end if iWhitespace - - ! Skip past j's whitespace. - jWhitespace: if( j .le. numJ ) then - jLoop: do - if(whitespacep(found_(j:j)))then - ! Found white char, skip. - j=j+1; if (j .gt. numJ) exit jLoop - else - exit jLoop - end if - end do jLoop - ! j now either indexes non-whitespace or is past its bound. - end if jWhitespace - - ! If both finish at the same time, i,j .gt. numI, numJ. - ! should be an error condition. Remember, we're - ! dealing with trimmed sequences. - ! - !if ( i .gt. numI .and. j .gt. numJ ) then - ! ...cycle loop... - !end if - - end select - - end if - - ! Fail if a traverse is complete. - !print *,2500,i,numI - !print *,2501,j,numJ - if ( i .gt. numI .or. j .gt. numJ ) then - !print *,2502 - throwException = .true. ; exit - end if - - ! A character is not white space! - - ! Both characters are not whitespace: fail if unequal. - !print *,3001,i,j,whitespace_%value,expected_,found_ - !print *,3002,expected_(i:i),found_(j:j) - !print *,3003,expected_(i:i) /= found_(j:j) - if (expected_(i:i) /= found_(j:j)) then - !print *,3004,'x' - throwException = .true. ; exit - end if - !print *,3005 - - ! Consume both of the equal characters. - i=i+1; j=j+1; numSameCharacters = numSameCharacters + 1 - - end do countNumSameCharacters - - !print *,4000 - if (throwException) then - select case (whitespace_%value) - case (TRIM_ALL%value) - expected_ = trimTrailingWhitespace(expected) - found_ = trimTrailingWhitespace(found) - case (IGNORE_ALL%value) - expected_ = trimTrailingWhitespace(expected) - found_ = trimTrailingWhitespace(found) - case (IGNORE_DIFFERENCES%value) - expected_ = trimTrailingWhitespace(expected) - found_ = trimTrailingWhitespace(found) - case (KEEP_ALL%value) - expected_ = expected - found_ = found - end select - - write(throwMessage,'((a,a),2(a,a,a,a),(a,a,a))') & - & 'String assertion failed:', new_line('A'), & - & ' expected: <"', expected_, '">', new_line('A'), & - & ' but found: <"', found_, '">', new_line('A'), & - & ' first diff: ', repeat('-', numSameCharacters), '^' - call throw(appendWithSpace(message_, throwMessage), location) - - end if - - ! else ! if checkCharacterByCharacter == .false. and we don't have to compare character-by-character - - end if - - end subroutine assertEqualString_ - - subroutine assertAny(conditions, message, location) - logical, intent(in) :: conditions(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call assertTrue(any(conditions), message, location) - - end subroutine assertAny - - subroutine assertAll(conditions, message, location) - logical, intent(in) :: conditions(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call assertTrue(all(conditions), message, location) - - end subroutine assertAll - - subroutine assertNone(conditions, message, location) - logical, intent(in) :: conditions(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call assertTrue(.not. any(conditions), message, location) - - end subroutine assertNone - - subroutine assertNotAll(conditions, message, location) - logical, intent(in) :: conditions(:) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call assertTrue(.not. all(conditions), message, location) - - end subroutine assertNotAll - - - subroutine assertIsNaN_single(x, message, location) - use Params_mod, only: r32 -#ifndef __GFORTRAN__ - use, intrinsic :: ieee_arithmetic, only: ieee_is_nan -#endif - real(kind=r32), intent(in) :: x - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - -#ifdef __GFORTRAN__ - call assertTrue(isNaN(x), message, location) -#else - call assertTrue(ieee_is_nan(x), message, location) -#endif - end subroutine assertIsNaN_single - - subroutine assertIsNaN_double(x, message, location) - use Params_mod, only: r64 -#ifndef __GFORTRAN__ - use, intrinsic :: ieee_arithmetic, only: ieee_is_nan -#endif - real(kind=r64), intent(in) :: x - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - -#ifdef __GFORTRAN__ - call assertTrue(isNaN(x), message, location) -#else - call assertTrue(ieee_is_nan(x), message, location) -#endif - end subroutine assertIsNaN_double - - - subroutine assertIsFinite_single(x, message, location) - use Params_mod, only: r32 -#ifndef __GFORTRAN__ - use, intrinsic :: ieee_arithmetic, only: ieee_is_finite -#endif - real(kind=r32), intent(in) :: x - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - -#ifdef __GFORTRAN__ - call assertTrue(abs(x) <= huge(x), message, location) -#else - call assertTrue(ieee_is_finite(x), message, location) -#endif - end subroutine assertIsFinite_single - - subroutine assertIsFinite_double(x, message, location) - use Params_mod, only: r64 -#ifndef __GFORTRAN__ - use, intrinsic :: ieee_arithmetic, only: ieee_is_finite -#endif - real(kind=r64), intent(in) :: x - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - -#ifdef __GFORTRAN__ - call assertTrue(abs(x) <= huge(x), message, location) -#else - call assertTrue(ieee_is_finite(x), message, location) -#endif - end subroutine assertIsFinite_double - - -end module AssertBasic_mod diff --git a/tests/pFUnit-3.2.9/source/BaseTestRunner.F90 b/tests/pFUnit-3.2.9/source/BaseTestRunner.F90 deleted file mode 100644 index 5f8977a7..00000000 --- a/tests/pFUnit-3.2.9/source/BaseTestRunner.F90 +++ /dev/null @@ -1,56 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: BaseTestRunner -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module BaseTestRunner_mod - use TestListener_mod - implicit none - private - - public :: BaseTestRunner - - type, abstract, extends(TestListener) :: BaseTestRunner - private - - contains - procedure(run2), deferred :: run - end type BaseTestRunner - - abstract interface - - ! TODO - report bug to NAG. If this is named "run" then - ! RubustRunner fails to compile with message about conflicting types - - function run2(this, aTest, context) result(result) - use Test_mod - use ParallelContext_mod - use TestResult_mod - import BaseTestRunner - - type (TestResult) :: result - class (BaseTestRunner), target, intent(inout) :: this - class (Test), intent(inout) :: aTest - class (ParallelContext), intent(in) :: context - end function run2 - - end interface - -end module BaseTestRunner_mod diff --git a/tests/pFUnit-3.2.9/source/CMakeLists.txt b/tests/pFUnit-3.2.9/source/CMakeLists.txt deleted file mode 100644 index dbe43466..00000000 --- a/tests/pFUnit-3.2.9/source/CMakeLists.txt +++ /dev/null @@ -1,105 +0,0 @@ - -find_package(Python COMPONENTS Interpreter REQUIRED) #Sets ${Python_EXECUTABLE} - -set(srcs Assert.F90) - -set(GENERATED_ASSERT_FILES_DIR "${CMAKE_CURRENT_BINARY_DIR}/tmp_assert_files_dir") -if (NOT EXISTS "${GENERATED_ASSERT_FILES_DIR}") - make_directory("${GENERATED_ASSERT_FILES_DIR}") -endif () -list(APPEND _ADDTIONAL_SRCS_TO_CLEAN ${GENERATED_ASSERT_FILES_DIR}) - -# Get list of source files -execute_process( - COMMAND ${Python_EXECUTABLE} ${CMAKE_CURRENT_SOURCE_DIR}/GenerateAssertsOnArrays.py --maxRank ${PFUNIT_MAX_RANK} - WORKING_DIRECTORY "${GENERATED_ASSERT_FILES_DIR}" - OUTPUT_VARIABLE generate_asserts_on_array_output -) -string(REPLACE "\n" ";" GENERATED_ASSERT_FILES ${generate_asserts_on_array_output}) - -# Generate AssertArray files: AssertArrays.fh, generated.inc, and AssertXYZ?.F90 -add_custom_command(OUTPUT ${GENERATED_ASSERT_FILES} AssertArrays.fh generated.inc - COMMAND ${Python_EXECUTABLE} ${CMAKE_CURRENT_SOURCE_DIR}/GenerateAssertsOnArrays.py --maxRank ${PFUNIT_MAX_RANK} --quiet True - WORKING_DIRECTORY "${CMAKE_CURRENT_BINARY_DIR}" - COMMENT "Generating assert files." -) -add_custom_target(generate_assert_files - DEPENDS ${GENERATED_ASSERT_FILES} -) - -list(APPEND srcs "${GENERATED_ASSERT_FILES}") -#list(APPEND _ADDTIONAL_SRCS_TO_CLEAN ${GENERATED_ASSERTS}) - -list(APPEND srcs AssertBasic.F90) - -list(APPEND srcs AbstractTestResult.F90) -list(APPEND srcs BaseTestRunner.F90) -list(APPEND srcs DebugListener.F90) - -list(APPEND srcs DynamicTestCase.F90) -list(APPEND srcs Exception.F90) -list(APPEND srcs Expectation.F90) -list(APPEND srcs MockCall.F90) -list(APPEND srcs MockRepository.F90) - -list(APPEND srcs ParallelContext.F90) -list(APPEND srcs ParallelException.F90) -list(APPEND srcs AbstractTestParameter.F90) -list(APPEND srcs ParameterizedTestCase.F90) -list(APPEND srcs Params.F90) - -list(APPEND srcs XmlPrinter.F90) -list(APPEND srcs ResultPrinter.F90) - -if ( PFUNIT_ROBUST ) - list(APPEND srcs UnixPipeInterfaces.F90) - list(APPEND srcs UnixProcess.F90) - list(APPEND srcs RobustRunner.F90) - list(APPEND srcs RemoteProxyTestCase.F90) -endif() - -list(APPEND srcs SerialContext.F90) -list(APPEND srcs SourceLocation.F90) -list(APPEND srcs StringConversionUtilities.F90) -list(APPEND srcs SubsetRunner.F90) -list(APPEND srcs SurrogateTestCase.F90) -list(APPEND srcs Test.F90) -list(APPEND srcs TestCase.F90) -list(APPEND srcs TestFailure.F90) -list(APPEND srcs TestListener.F90) -list(APPEND srcs TestMethod.F90) -list(APPEND srcs TestResult.F90) -list(APPEND srcs TestRunner.F90) -list(APPEND srcs TestSuite.F90) -list(APPEND srcs ThrowFundamentalTypes.F90) -list(APPEND srcs pFUnit.F90) -list(APPEND srcs pFUnitPackage.F90) - -if (MPI) - list(APPEND srcs MpiContext.F90) - list(APPEND srcs MpiStubs.F90) - list(APPEND srcs MpiTestParameter.F90) - list(APPEND srcs MpiTestCase.F90) - list(APPEND srcs MpiTestMethod.F90) -endif() - -list(APPEND pysrcs CodeUtilities.py) -list(APPEND pysrcs GenerateAssertsOnArrays.py) -list(APPEND pysrcs Utilities.py) - -set(SOURCES ${srcs}) - -add_library(pfunit STATIC ${SOURCES}) -add_dependencies(pfunit generate_assert_files) - -set(MODULES_DIR "${CMAKE_CURRENT_BINARY_DIR}/Modules") -set_target_properties(pfunit PROPERTIES - Fortran_MODULE_DIRECTORY "${MODULES_DIR}") -target_include_directories(pfunit PUBLIC - "${CMAKE_CURRENT_BINARY_DIR}" - "${MODULES_DIR}") - -#install(TARGETS pfunit DESTINATION lib) -#install(DIRECTORY "${MODULES_DIR}" DESTINATION .) - -set_directory_properties(PROPERTIES ADDITIONAL_MAKE_CLEAN_FILES "${_ADDTIONAL_SRCS_TO_CLEAN}") diff --git a/tests/pFUnit-3.2.9/source/CodeUtilities.py b/tests/pFUnit-3.2.9/source/CodeUtilities.py deleted file mode 100755 index 4512c963..00000000 --- a/tests/pFUnit-3.2.9/source/CodeUtilities.py +++ /dev/null @@ -1,409 +0,0 @@ -#!/usr/bin/env python -# For python 2.6-2.7 -from __future__ import print_function -# For python2.5 -# from __future__ import with_statement - -from Utilities import * -import textwrap - -class module: - def __init__(self, name): - # what do we need? - self.name = '' - self.declarations = [] - self.implementations = [] - self.generation = [] - # - self.name = name - self.fileName = name+'.F90' - return - def generate(self): - generation = [ 'module '+self.name] - generation.extend( [ i.generate() for i in self.declarations ] ) - generation.extend([ 'contains' ]) - generation.extend( [ i.generate() for i in self.implementations ] ) - generation.extend([ 'end module '+self.name]) - return generation - def addDeclaration(self,declaration): - # print('adding declaration: ',declaration) - if type(declaration) is list : - self.declarations.extend(declaration) - else: - self.declarations.append(declaration) - return self - def addImplementation(self,implementation): - self.implementations.append(implementation) - return self - def addRoutineUnit(self, rUnit,expose=False): - # Might need to add more than one decl. - self.addDeclaration(rUnit.getDeclarations(expose=expose)) - self.addImplementation(rUnit.getImplementation()) - return self - def addInterfaceBlock(self, interface,expose=False): - self.addDeclaration(interface.getDeclaration(expose=expose)) - self.addImplementation(interface.getImplementation()) - return self - def getName(self): - return self.name - def setFileName(self,fName): - self.fileName = fName - return self - def getFileName(self): - return self.fileName - -class declaration: - def __init__(self,name,simpleDeclaration): - self.simpleDeclaration = simpleDeclaration - self.fullDeclaration = '' - self.name = name - return - def generate(self): - return self.simpleDeclaration - -class implementation: - def __init__(self,name,source): - self.name = name - self.source = source - def generate(self): - return self.source - -class routineUnit: - def __init__(self,name,implementSource): - self.name = name - self.declaration = declaration(self.name, self.name) # get better later - self.declarations = [] - self.declarations.append(self.declaration) - self.implementation = implementation(self.name,implementSource) - return - def setName(self,name): - self.name = name - return - def getName(self): - return self.name - def setDeclaration(self,declaration): - self.declaration = declaration - self.declarations = [self.declaration] - return - def addDeclaration(self,declaration): - self.declarations.append(declaration) - return - def setImplementation(self,implementationSource): - self.implementation = implementation(self.name, implementationSource) - return - def getDeclaration(self,expose=False): - return self.declaration - def getDeclarations(self,expose=False): - return self.declarations - def getImplementation(self): - return self.implementation - def clearDeclarations(self): - self.declarations = [] - self.declaration = '' - return self - -class interfaceBlock: -# name = '' -# moduleProcedureAlternatives = [] -# moduleProcedureImplementations = [] - def __init__(self,name): - self.name = name - self.moduleProcedureAlternatives = [] - self.moduleProcedureImplementations = [] - def generateDeclaration(self): - retStr = '\ninterface ' + self.name + '\n' - if self.moduleProcedureAlternatives != [] : - # Note that we need to treat the first line as a special case. - retStr += \ - '\n module procedure ' + \ - '\n module procedure '.join(self.moduleProcedureAlternatives) - retStr += '\n\nend interface ' + self.name + '\n' - return declaration(self.name,retStr) - - def generateItemizedDeclarations(self): - retStr = '\n!interface ' + self.name + '\n' - if self.moduleProcedureAlternatives != [] : - # Note that we need to treat the first line as a special case. - retStr += \ - '\n public :: ' + \ - '\n public :: '.join(self.moduleProcedureAlternatives) - retStr += '\n\n!end interface ' + self.name + '\n' - return declaration(self.name,retStr) - - def generateImplementation(self): - retStr = '! interface ' + self.name + ' implementations\n' - if self.moduleProcedureImplementations != [] : - retStr += \ - '\n '.join(self.moduleProcedureImplementations) - retStr += '\n! end interface ' + self.name + ' implementations' - return implementation(self.name,retStr) - def addModuleProcedureAlternative(self,newName): - self.moduleProcedureAlternatives.append(newName) - return self - def addRoutineUnit(self,routineUnit,expose=False): - for d in routineUnit.getDeclarations(expose=expose): - self.addModuleProcedureAlternative(d.generate()) - # self.addModuleProcedureAlternative(routineUnit.getDeclaration().generate()) - self.moduleProcedureImplementations.append(routineUnit.getImplementation().generate()) - return self - def getDeclaration(self,expose=False): - if expose : - return self.generateItemizedDeclarations() - else : - return self.generateDeclaration() - def getImplementation(self): - return self.generateImplementation() - -class fortranSubroutineSignature: - def __init__(self,name): - self.name = name - self.ArgumentToFType = {} - self.ReturnFType = '' - self.SubroutineType = 'subroutine' - def setReturnFType(self,ReturnFType): - self.ReturnFType = ReturnFType - if not ReturnFType : - self.SubroutineType = 'function' - return self - def addArg(self,arg,fType): - self.ArgumentToFType[arg] = fType - return self - def generateInterfaceEntry(self): - print('generateInterfaceEntryNotImplemented_'+this.name) - return - def generateImplementationSignature(self): - print('generateImplementationSignatureNotImplemented_'+this.name) - return - def generateImplementationClose(self): - print('generateImplementationCloseNotImplemented_'+this.name) - return - -def indentKluge(indentString,txt): - wrapper = textwrap.TextWrapper(initial_indent=indentString, subsequent_indent=indentString); - txtList=map(wrapper.fill,str.splitlines(txt)) - return "\n".join(txtList) - -def iterateOverMultiRank(nr,variableName,shapeName,centralText): - indent= str(' '*(3*(nr+1))); - txt = indentKluge(indent,centralText) - r = range(nr); rrev = range(nr); rrev.reverse(); - codeSnippet = ''.join([' '*(3*(nr-i))+'do '+variableName+str(i+1)+'= 1,'+shapeName+'('+str(i+1)+')\n' for i in rrev])+txt+'\n'+''.join([' '*(3*(nr-i))+'end do\n' for i in r]) - # print(codeSnippet) - return codeSnippet - -# Text formatting functions for Fortran from the m4-based code generator. - -def DIMS(rank): - if rank > 0: - return '('+','.join([':' for i in range(rank) ])+')' - else: - return '' - -def DIMS_SET(dims): - "Return a comma separated list of dimensions, delineated by parentheses." - retStr = '' - if len(dims) > 0: - retStr = '('+','.join([str(i) for i in dims])+')' - return retStr - -def DIMS_RANDOM_INTS(rank,maxDim): - return [random.randint(1,maxDim) for i in range(rank)] - -def RANDOM_INDEX(dims): - return [random.randint(1,dims[i]) for i in range(len(dims))] - -def DIMS_RANDOM(rank,maxDim): - return DIMS_SET(DIMS_RANDOM_INTS(rank,maxDim)) - -def DIMS_IncrementRandomElement(dims): - newDims = copy.copy(dims) - i = random.randint(0,len(dims)-1) - newDims[i] = newDims[i] + 1 - return DIMS_SET(newDims) - -def FULLTYPE(fType): - fTypes = { 'int' : 'integer', - 'char' : 'character' } - if fType in fTypes: - ret = fTypes[fType] - else: - ret = fType - return ret - -typeTower = { - 'integer' : 0, - 'real' : 1, - 'complex' : 2 } - -def maxType(type1,type2) : - retType = type1 - if typeTower[type1] < typeTower[type2] : - retType = type2 - return retType - -def maxPrecision(prec1,prec2) : - retPrec = prec1 - if 'default' in [prec1,prec2] : - if prec2 != 'default' : - retPrec = prec2 - elif prec1 < prec2 : - retPrec = prec2 - return retPrec - -def KINDATTRIBUTE0(fType,precision): - ret = '' - if fType.lower() == 'real' : - ret = 'kind=r'+str(precision)+'' - elif fType.lower() == 'complex' : - ret = 'kind=r'+str(precision)+'' - elif fType.lower() == 'integer' : - ret = 'kind=i'+str(precision)+'' - #ret = '' - return ret - -def KINDATTRIBUTE(fType,precision): - ret = '' - if fType.lower() == 'real' : - ret = '(kind=r'+str(precision)+')' - elif fType.lower() == 'complex' : - ret = '(kind=r'+str(precision)+')' - elif fType.lower() == 'integer' : - ret = '(kind=i'+str(precision)+')' - #ret = '' - return ret - -def testKINDATTRIBUTE(): - print('COMPLEX,32 -> ' + KINDATTRIBUTE('COMPLEX',32)) - print('REAL,32 -> ' + KINDATTRIBUTE('REAL',32)) - print('real,32 -> ' + KINDATTRIBUTE('real',32)) - print('integer,32 -> ' + KINDATTRIBUTE('integer',32)) - -def DECLARE(variableName,fType,precision,rank,opts=', intent(in)'): - return FULLTYPE(fType)+KINDATTRIBUTE(fType,precision)+opts+' :: '+variableName+DIMS(rank) - -def DECLARESCALAR(variableName,fType,precision,rank): - return FULLTYPE(fType)+KINDATTRIBUTE(fType,precision)+' :: '+variableName - -def testDECLARE(): - print('xVar,real,32,3 -> ' + DECLARE('xVar','real',32,3)) - print('iVar,int,32,3 -> ' + DECLARE('iVar','int',32,3)) - print('iVar,int,32,0 -> ' + DECLARE('iVar','int',32,0)) - print('iVar,int,default,1 -> ' + DECLARE('iVar','int','default',1)) - -def OVERLOAD(routineName,fType,precision,rank): - routineNameModifier=str(fType)+'_'+str(precision)+'_'+str(rank) - return routineName+'_'+routineNameModifier.lower()+'D' - -def testOVERLOAD(): - print('testRoutine,real,32,2 -> '+OVERLOAD('testRoutine','real',32,2)) - print('testRoutine,integer,64,0 -> '+OVERLOAD('testRoutine','integer',64,0)) - print('testRoutine,int,32,4 -> '+OVERLOAD('testRoutine','int',32,4)) - -def DECLAREPOINTER(pointerName,fType,precision,rank): - return FULLTYPE(fType)+KINDATTRIBUTE(fType,precision)+', pointer :: '+ \ - OVERLOAD(pointerName,fType,precision,rank)+DIMS(rank)+' = null()' - -def testDECLAREPOINTER(): - print('d-pointer: p,real,32,0 -> '+DECLAREPOINTER('p','real',32,0)) - print('d-pointer: p,integer, 64, 1 -> '+DECLAREPOINTER('p','integer',64,1)) - print('d-pointer: p,integer, 64, 3 -> '+DECLAREPOINTER('p','integer',64,3)) - -def NAME(fType,kind,rank): - if fType == 'real' : - fTypeToken = 'r' - elif fType == 'complex' : - fTypeToken = 'c' - else: - fTypeToken = 'int' - if kind == 'default': - kindToken = '' - else: - kindToken = str(kind) - return fTypeToken+kindToken+'_'+str(rank)+'D' - -def testNAME(): - print('real,32,2 -> '+NAME('real',32,2)) - print('integer,64,0 -> '+NAME('integer',64,0)) - -def EXPANDSHAPE(rank, variableName): - if rank == 0: - return '' - elif rank == 1: - return '(size('+variableName+'))' - else: - return '('+','.join(['size('+variableName+','+str(i)+')' for i in range(1,rank+1)])+')' - -def testEXPANDSHAPE(): - print('0,test -> ' + str(EXPANDSHAPE(0,'test'))) - print('1,test -> ' + str(EXPANDSHAPE(1,'test'))) - print('3,test -> ' + str(EXPANDSHAPE(3,'test'))) - print('5,test -> ' + str(EXPANDSHAPE(5,'test'))) - -class ArrayDescription: - def __init__(self,fType,kind,rank): - self.fType = fType - self.kind = kind - self.rank = rank - # if rank == 0: - # print('ArrayDescription:Warning: rank == 0!!!') - def NAME(self): - return NAME(self.fType, self.kind, self.rank) - def DECLARE(self,variableName): - return DECLARE(variableName,self.fType, self.kind, self.rank) - def DECLARESCALAR(self,variableName): - return DECLARESCALAR(variableName,self.fType, self.kind, 0) - def KIND(self): - return self.kind - def RANK(self): - return self.rank - def FTYPE(self): - return self.fType - def EXPANDSHAPE(self,variableName): - return EXPANDSHAPE(self.rank,variableName) - def FailureMessageFork(self,messageForRank1,messageOtherwise): - if self.rank == 1 : - return messageForRank1 - else: - return messageOtherwise - -def AddBlockSymbols(predicate, blockSymbols, inStr): - # Note a big change in how this works -- this will actually remove str... - retStr = '' - if predicate : - if blockSymbols : - retStr = blockSymbols[0] + inStr + blockSymbols[1] - return retStr - -def MakeNamesWithRank(variableName, rank): - retStr = '' - if rank != 0: - retStr = ','.join([variableName+str(i+1) for i in range(rank)]) - else: - retStr = ''.join([variableName+str(rank+1)]) - return retStr - -# def compareELEMENTS(varName1,varName2,itername,shape,rank): -# if rank == 0: -# retStr = '' - -def reportKind(t,p): - k = '' - if t == 'real' : - k = '(kind=r'+str(p)+')' - elif t == 'complex' : - k = '(kind=c'+str(p)+')' - elif t == 'integer' : - k = '(kind=i'+str(p)+')' - # default integer - # k = '' - else : - k = '' - return k - -def CONJG(x,fType='complex'): - # If x complex return conjg, else return as is. - retStr = str(x) - if fType == 'complex': - retStr = 'conjg('+str(x)+')' - return retStr - diff --git a/tests/pFUnit-3.2.9/source/DebugListener.F90 b/tests/pFUnit-3.2.9/source/DebugListener.F90 deleted file mode 100644 index c01fef8f..00000000 --- a/tests/pFUnit-3.2.9/source/DebugListener.F90 +++ /dev/null @@ -1,95 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: DebugListener -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module DebugListener_mod - use TestListener_mod - implicit none - private - - public :: DebugListener - - type, extends(TestListener) :: DebugListener - integer :: unit - contains - procedure :: addFailure - procedure :: startTest - procedure :: endTest - procedure :: endRun - end type DebugListener - - interface DebugListener - module procedure newDebugListener_unit - module procedure newDebugListener_default - end interface DebugListener - -contains - - function newDebugListener_unit(unit) result(listener) - type (DebugListener) :: listener - integer, intent(in) :: unit - call listener%setDebug() - listener%unit = unit - end function newDebugListener_unit - - function newDebugListener_default() result(listener) - use iso_fortran_env, only: OUTPUT_UNIT - type (DebugListener) :: listener - call listener%setDebug() - listener = DebugListener(OUTPUT_UNIT) - end function newDebugListener_default - - subroutine addFailure(this, testName, exceptions) - use Exception_mod - class (DebugListener), intent(inOut) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - write(this%unit,*)'Failure in <',trim(testName),'>' - flush(this%unit) - - end subroutine addFailure - - subroutine startTest(this, testName) - class (DebugListener), intent(inOut) :: this - character(len=*), intent(in) :: testName - - write(this%unit,*)new_line('A') - write(this%unit,*)'Start: <',trim(testName),'>' - flush(this%unit) - end subroutine startTest - - subroutine endTest(this, testName) - class (DebugListener), intent(inOut) :: this - character(len=*), intent(in) :: testName - - write(this%unit,*)' end: <',trim(testName),'>' - flush(this%unit) - - end subroutine endTest - - subroutine endRun(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (DebugListener), intent(inout) :: this - class (AbstractTestResult), intent(in) :: result - end subroutine endRun - -end module DebugListener_mod diff --git a/tests/pFUnit-3.2.9/source/DynamicTestCase.F90 b/tests/pFUnit-3.2.9/source/DynamicTestCase.F90 deleted file mode 100644 index 64f4504f..00000000 --- a/tests/pFUnit-3.2.9/source/DynamicTestCase.F90 +++ /dev/null @@ -1,77 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: DynamicTestCase -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module DynamicTestCase_mod - use TestCase_mod - implicit none - private - - public :: DynamicTestCase - public :: newDynamicTestCase - public :: delete - - type, extends(TestCase) :: DynamicTestCase - procedure(testMethod), pointer :: testMethod => null() - contains - procedure :: runMethod - end type DynamicTestCase - - abstract interface - subroutine testmethod(this) - import DynamicTestCase - class (DynamicTestCase), intent(inOut) :: this - end subroutine testMethod - end interface - - interface delete - module procedure delete_ - end interface - -contains - - function newDynamicTestCase(testMethod, name) result(this) - type (DynamicTestCase), pointer :: this - character(len=*), intent(in) :: name - interface - subroutine testMethod(this) - import DynamicTestCase - class (DynamicTestCase), intent(inout) :: this - end subroutine testMethod - end interface - - allocate(this) - call this%setName(trim(name)) - this%testMethod => testMethod - - end function newDynamicTestCase - - subroutine delete_(this) - type (DynamicTestCase), intent(inOut) :: this - nullify(this%testMethod) - end subroutine delete_ - - subroutine runMethod(this) - class (DynamicTestCase), intent(inout) :: this - call this%testMethod - end subroutine runMethod - -end module DynamicTestCase_mod diff --git a/tests/pFUnit-3.2.9/source/Exception.F90 b/tests/pFUnit-3.2.9/source/Exception.F90 deleted file mode 100644 index 5e1a7bb2..00000000 --- a/tests/pFUnit-3.2.9/source/Exception.F90 +++ /dev/null @@ -1,506 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC, Software Integration & Visualization Office, Code 610.3 -!------------------------------------------------------------------------------- -! MODULE: PrivateException -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module PrivateException_mod - use SourceLocation_mod - implicit none - private - - public :: Exception - public :: newException - public :: ExceptionList - public :: newExceptionList - - public :: MAXLEN_MESSAGE - public :: MAXLEN_FILE_NAME - public :: NULL_MESSAGE - public :: UNKNOWN_LINE_NUMBER - public :: UNKNOWN_FILE_NAME - - integer, parameter :: MAXLEN_MESSAGE = 80*15 - integer, parameter :: MAXLEN_FILE_NAME = 255 - character(len=*), parameter :: NULL_MESSAGE = '' - - type Exception - character(len=MAXLEN_MESSAGE) :: message = NULL_MESSAGE - type (SourceLocation) :: location = UNKNOWN_SOURCE_LOCATION - logical :: nullFlag = .true. - contains - procedure :: getMessage - procedure :: getLineNumber - procedure :: getFileName - procedure :: isNull - end type Exception - - type (Exception), parameter :: NULL_EXCEPTION = Exception('NULL EXCEPTION', UNKNOWN_SOURCE_LOCATION, .true.) - - type ExceptionList - type (Exception), allocatable :: exceptions(:) - contains - - procedure :: getNumExceptions - - procedure :: catch_any - procedure :: catchNext - procedure :: gather - procedure :: catch_message - generic :: catch => catch_any - generic :: catch => catch_message - procedure :: getExceptions - procedure :: noExceptions - procedure :: anyExceptions - procedure :: clearAll - procedure, private :: deleteIthException - - generic :: throw => throwMessage - generic :: throw => throwException - - procedure :: throwMessage - procedure :: throwException -!TODO - NAG does not yet support FINAL keyword -!!$$ final :: delete - end type ExceptionList - - interface newException - module procedure Exception_ - end interface - -contains - - type(Exception) function Exception_(message, location) - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - if (present(message)) then - Exception_%message = trim(message) - else - Exception_%message = NULL_MESSAGE - end if - - if (present(location)) then - Exception_%location = location - else - Exception_%location = UNKNOWN_SOURCE_LOCATION - end if - - Exception_%nullFlag = .false. - - end function Exception_ - - function getMessage(this) result(message) - class (Exception), intent(in) :: this - character(len=len_trim(this%message)) :: message - message = trim(this%message) - end function getMessage - - integer function getLineNumber(this) - class (Exception), intent(in) :: this - getLineNumber = this%location%lineNumber - end function getLineNumber - - character(len=MAXLEN_FILE_NAME) function getFileName(this) - class (Exception), intent(in) :: this - getFileName = trim(this%location%fileName) - end function getFileName - - logical function isNull(this) - class (Exception), intent(in) :: this - isNull = this%nullFlag - end function isNull - - function newExceptionList() result(list) - type (ExceptionList) :: list - if (allocated(list%exceptions)) then - deallocate(list%exceptions) - end if - allocate(list%exceptions(0)) - end function newExceptionList - - integer function getNumExceptions(this) - class (ExceptionList), intent(in) :: this - getNumExceptions = size(this%exceptions) - end function getNumExceptions - - subroutine throwMessage(this, message, location) - class (ExceptionList), intent(inOut) :: this - character(len=*), intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call this%throw(newException(message, location)) - - end subroutine throwMessage - - subroutine throwException(this, anException) - class (ExceptionList), intent(inOut) :: this - type (Exception), intent(in) :: anException - - type (Exception), allocatable :: tmp(:) - integer :: n - - n = size(this%exceptions) - allocate(tmp(n+1)) - tmp(1:n) = this%exceptions - tmp(n+1) = anException - deallocate(this%exceptions) - allocate(this%exceptions(n+1)) - this%exceptions = tmp - deallocate(tmp) - - end subroutine throwException - - function catchNext(this, preserve) result(anException) - class (ExceptionList), intent(inOut) :: this - logical, optional, intent(in) :: preserve - type (Exception) :: anException - if (size(this%exceptions) > 0) then - anException = this%exceptions(1) - call this%deleteIthException(1, preserve) - else - anException = NULL_EXCEPTION - end if - - end function catchNext - - subroutine gather(this, context) - use ParallelContext_mod - class (ExceptionList), intent(inOut) :: this - class (ParallelContext), intent(in) :: context - - type (ExceptionList) :: list - integer :: globalExceptionCount -! character(len=MAXLEN_MESSAGE) :: msg - integer :: i - - - globalExceptionCount = context%sum(size(this%exceptions)) - - if (globalExceptionCount > 0) then - - allocate(list%exceptions(globalExceptionCount)) - - do i = 1, this%getNumExceptions() - call context%labelProcess(this%exceptions(i)%message) - end do - - call context%gather(this%exceptions(:)%nullFlag, list%exceptions(:)%nullFlag) - call context%gather(this%exceptions(:)%location%fileName, list%exceptions(:)%location%fileName) - call context%gather(this%exceptions(:)%location%lineNumber, list%exceptions(:)%location%lineNumber) - call context%gather(this%exceptions(:)%message, list%exceptions(:)%message) - - call clearAll(this) - - if (context%isRootProcess()) then - deallocate(this%exceptions) - allocate(this%exceptions(globalExceptionCount)) - this%exceptions(:) = list%exceptions - end if - - call clearAll(list) - - end if - - end subroutine gather - - logical function noExceptions(this) - class (ExceptionList), intent(inOut) :: this - - noExceptions = .not. this%anyExceptions() - - end function noExceptions - - logical function anyExceptions(this) - class (ExceptionList), intent(inOut) :: this - - anyExceptions = (this%getNumExceptions() > 0) - - end function anyExceptions - - ! Fortran does not require "short-circuit" so be careful with - ! evaluation of optional arguments. - logical function preserveMessage(preserve) - logical, optional, intent(in) :: preserve - - preserveMessage = .false. ! default - if (present(preserve)) preserveMessage = preserve - - end function preserveMessage - - subroutine deleteIthException(this, i, preserve) - class (ExceptionList), intent(inOut) :: this - integer, intent(in) :: i - logical, optional, intent(in) :: preserve - - type (Exception), allocatable :: tmp(:) - integer :: n - - if (preserveMessage(preserve)) return - - n = this%getNumExceptions() - if (n == 0) return ! cannot throw exceptions here, alas - allocate(tmp(n-1)) - tmp(1:i-1) = this%exceptions(1:i-1) - tmp(i:n-1) = this%exceptions(i+1:n) - deallocate(this%exceptions) - allocate(this%exceptions(n-1)) - this%exceptions = tmp - deallocate(tmp) - - end subroutine deleteIthException - - logical function catch_any(this, preserve) - class (ExceptionList), intent(inOut) :: this - logical, optional, intent(in) :: preserve - - integer :: n - logical :: preserve_ ! for default value - - n = this%getNumExceptions() - - if (n >= 1) then - catch_any =.true. - preserve_ = .false. - if (present(preserve)) preserve_ = preserve - if (.not. preserve_) call this%deleteIthException(n, preserve) - return - end if - - catch_any =.false. - - end function catch_any - - logical function catch_message(this, message, preserve) - class (ExceptionList), intent(inOut) :: this - character(len=*), intent(in) :: message - logical, optional, intent(in) :: preserve - - integer :: i, n - logical :: preserve_ ! for default value - - n = this%getNumExceptions() - - do i = 1, n - if (trim(message) == this%exceptions(i)%getMessage()) then - catch_message =.true. - preserve_ = .false. - if (present(preserve)) preserve_ = preserve - if (.not. preserve_) call this%deleteIthException(i, preserve) - return - end if - end do - catch_message =.false. - - end function catch_message - - function getExceptions(this) result(exceptions) - type (Exception), allocatable :: exceptions(:) - class (ExceptionList), intent(inOut) :: this - - call move_alloc(from=this%exceptions, to=exceptions) - allocate(this%exceptions(0)) - - end function getExceptions - - subroutine clearAll(this) - class (ExceptionList), intent(inOut) :: this - deallocate(this%exceptions) - allocate(this%exceptions(0)) - end subroutine clearAll - - subroutine delete(this) - type (ExceptionList), intent(inOut) :: this - if (allocated(this%exceptions)) deallocate(this%exceptions) - end subroutine delete - -end module PrivateException_mod - -module Exception_mod - use SourceLocation_mod - use PrivateException_mod - implicit none - private - - public :: Exception - public :: newException - public :: ExceptionList - public :: newExceptionList - - public :: MAXLEN_MESSAGE - public :: NULL_MESSAGE - public :: UNKNOWN_LINE_NUMBER - public :: UNKNOWN_FILE_NAME - - public :: getNumExceptions - public :: throw - public :: gatherExceptions - public :: catchNext - public :: catch - public :: getExceptions - public :: noExceptions - public :: anyExceptions - public :: anyErrors - public :: clearAll - - public :: initializeGlobalExceptionList - - type (ExceptionList), save :: globalExceptionList ! private - logical, save :: init = .false. ! private - - - interface throw - module procedure throw_message - end interface - - interface catch - module procedure catch_any - module procedure catch_message - end interface catch - - interface anyExceptions - module procedure anyExceptions_local - end interface anyExceptions - - interface getNumExceptions - module procedure getNumExceptions_local - end interface getNumExceptions - -contains - - subroutine initializeGlobalExceptionList() - globalExceptionList = newExceptionList() - end subroutine initializeGlobalExceptionList - - - integer function getNumExceptions_local() result(numExceptions) - - if (.not. init) then - call initializeGlobalExceptionList() - init = .true. - end if - - numExceptions = globalExceptionList%getNumExceptions() - end function getNumExceptions_local - - subroutine throw_message(message, location) - character(len=*), intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - !$omp critical - if (.not. init) then - init = .true. - call initializeGlobalExceptionList() - !$omp flush(init) - end if - - call globalExceptionList%throw(message, location) - !$omp end critical - - end subroutine throw_message - - function catchNext(preserve) result(anException) - logical, optional, intent(in) :: preserve - type (Exception) :: anException - - if (.not. allocated(globalExceptionList%exceptions)) then - call initializeGlobalExceptionList() - end if - - anException = globalExceptionList%catchNext(preserve) - end function catchNext - - logical function catch_any(preserve) - logical, optional, intent(in) :: preserve - - if (.not. allocated(globalExceptionList%exceptions)) then - call initializeGlobalExceptionList() - end if - - catch_any = globalExceptionList%catch(preserve) - end function catch_any - - logical function catch_message(message, preserve) - character(len=*), intent(in) :: message - logical, optional, intent(in) :: preserve - - if (.not. allocated(globalExceptionList%exceptions)) then - call initializeGlobalExceptionList() - end if - - catch_message = globalExceptionList%catch(message, preserve) - end function catch_message - - function getExceptions() result(exceptions) - type (Exception), allocatable :: exceptions(:) - - if (.not. allocated(globalExceptionList%exceptions)) then - call initializeGlobalExceptionList() - end if -#ifdef INTEL_16 - call move_alloc(from=globalExceptionList%exceptions, to=exceptions) -#else - exceptions = globalExceptionList%getExceptions() -#endif - - end function getExceptions - - logical function noExceptions() - - if (.not. allocated(globalExceptionList%exceptions)) then - call initializeGlobalExceptionList() - end if - - noExceptions = globalExceptionList%noExceptions() - end function noExceptions - - logical function anyExceptions_local() result(anyExceptions) - - if (.not. allocated(globalExceptionList%exceptions)) then - call initializeGlobalExceptionList() - end if - - anyExceptions = globalExceptionList%anyExceptions() - end function anyExceptions_local - - logical function anyErrors() - integer :: i - integer :: n - - do i = 1, globalExceptionList%getNumExceptions() - n = min(14,len(globalExceptionList%exceptions(i)%message)) - if (globalExceptionList%exceptions(i)%message(1:n) == 'RUNTIME-ERROR:') then - anyErrors = .true. - return - end if - end do - anyErrors = .false. - end function anyErrors - - subroutine gatherExceptions(context) - use ParallelContext_mod - class (ParallelContext), intent(in) :: context - call globalExceptionList%gather(context) - end subroutine gatherExceptions - - subroutine clearAll() - call globalExceptionList%clearAll() - end subroutine clearAll - -end module Exception_mod diff --git a/tests/pFUnit-3.2.9/source/Expectation.F90 b/tests/pFUnit-3.2.9/source/Expectation.F90 deleted file mode 100644 index fbf6c2cc..00000000 --- a/tests/pFUnit-3.2.9/source/Expectation.F90 +++ /dev/null @@ -1,86 +0,0 @@ - - -! Note: maybe have multiple expectation types for subroutines, classes, etc. -! - -module Expectation_mod - use StringConversionUtilities_mod, only : MAXLEN_STRING - implicit none - private - - public :: Expectation, newExpectation - public :: Predicate, newPredicate - public :: Subject, newSubject, newSubjectNameOnly - public :: wasCalled, wasNotCalled, wasCalledOnce - - type :: Subject - ! mlr todo allocatable strings - character(len=MAXLEN_STRING) :: name - procedure(subVoid), pointer, nopass :: ptr - end type Subject - - interface - subroutine subVoid - end subroutine subVoid - end interface - - - type :: Predicate - character(len=MAXLEN_STRING) :: name - end type Predicate - -! TDD - type(Predicate), parameter :: wasCalled = Predicate('wasCalled') - type(Predicate), parameter :: wasNotCalled = Predicate('wasNotCalled') - type(Predicate), parameter :: wasCalledOnce = Predicate('wasCalledOnce') -! todo: -! checking expectation sub called with right value (important for sci.) -! syntax for distinguishing arguments -- (position/keys) -! combined expectations -- one on method, one on argument -! -- or combined in the text... -! todo expectation augment -! - vary numbers & kinds of arguments -! todo: automatic generation -- for proposal -! todo: a trivial example of interleaved method calls -! -! todo question: ! how to require mock functions to return certain values - - type :: Expectation - type(Subject) :: subj - type(Predicate) :: pred - end type Expectation - -contains - - type(Predicate) function newPredicate(name) result(pred_) - character(*) :: name - pred_%name = name - end function newPredicate - - type(Subject) function newSubject(name,sub) result(subj_) - character(*) :: name - procedure(subVoid), pointer :: sub - subj_%name = name - subj_%ptr => sub - ! maybe include a reference too - end function newSubject - - type(Subject) function newSubjectNameOnly(name) result(subj_) - character(*) :: name - procedure(subVoid), pointer :: sub - subj_%name = name - ! subj_%ptr => sub ! Maybe nullify... - nullify(subj_%ptr) - ! maybe include a reference too - end function newSubjectNameOnly - -! type(Subject) function newSubject(name) result(subj_) - - type(Expectation) function newExpectation(subj, pred) result(exp_) - type(Subject), intent(in) :: subj - type(Predicate), intent(in) :: pred - exp_%subj = subj - exp_%pred = pred - end function newExpectation - -end module Expectation_mod diff --git a/tests/pFUnit-3.2.9/source/GenerateAssertsOnArrays.py b/tests/pFUnit-3.2.9/source/GenerateAssertsOnArrays.py deleted file mode 100755 index 0427ec83..00000000 --- a/tests/pFUnit-3.2.9/source/GenerateAssertsOnArrays.py +++ /dev/null @@ -1,1726 +0,0 @@ -#!/usr/bin/env python -# For python 2.6-2.7 -from __future__ import print_function -# For python2.5 -from __future__ import with_statement -# -# Generate Assert.F90, which provides assertEqual and others for arrays. -# -# Usage: ./GenerateAssertsOnArrays.py -# -# Outputs: -# A large number of library files implementing assertRELATION routines. -# generated.inc -# AssertArrays.fh -# -# M. Rilee -# -# 2014-1215: Minor revisions. Updated integer arrays to handle same number of ranks as others. -# -# 2014-0418: Moved effective assert routines to own file. Segregated other routines into files by rank. -# -# 2014-0324: Fully implemented relational operators beyond "=". -# -# 2013-0814: Added default r64 to call from assertEqual_w/o_tol to internal proc. -# Added logical to makeExpectedFTypes - but not for prime time. -# -# Initial: 2013-0304 -# - -## Abbreviations -# WOTol => WithoutTolerance -# def => default - -##### system code ##### - -import sys -# python2 - Deprecated in python 2.7+ -import imp -try: - imp.find_module('argparse') - found = True -except ImportError: - found = False - -# Preferred for python 2.7+, python 3 -# import importlib -# argparse_loader = importlib.find_loader('argparse') -# found = argparse_loader is not None - -if found: - import argparse -else: - print('GenerateAssertOnArrays.py::Error. pFUnit requires argparse module provided by python version >= 2.7.') - print('Quitting!'); quit() - -##### utility code ##### - -from Utilities import * -from CodeUtilities import * -import textwrap -import random -import copy - -##### preliminaries ##### - -parser = argparse.ArgumentParser( \ - description='Generate assertions with relational operators on arrays.', \ - usage='%(prog) --maxRank MaximumRankOfArrays' \ - ) -parser.add_argument('--maxRank', help='The maximum rank of the arrays for which to generate code.') -parser.add_argument('--quiet', help='Suppress printing to stdout.') -args = parser.parse_args() - - -##### begin generation code ##### - - -### Restrictions on types and type combinations. - -def dr_TolAllowedPrecisions(t,pFound='64') : - "returns a list of strings corresponding to the precisions 'tolerance' may take on. \ - dr_ refers to 'Difference Report.' Please see the DifferenceReport routines." - allowed = [] - if t == 'logical' : - allowed = [] - elif t == 'integer' : - allowed = ['32','64'] - elif t == 'real' or 'complex' : - if pFound == '32' : - allowed = ['32'] - elif pFound == '64' : - allowed = ['32','64'] - else : - raise ValueError("dr_TolAllowedPrecisions: Bad value of pFound.") - return allowed - -def dr_TolAllowedPrecisions_orig(t,pFound='64') : - "returns a list of strings corresponding to the precisions 'tolerance' may take on. \ - dr_ refers to 'Difference Report.' Please see the DifferenceReport routines." - allowed = [] - if t == 'logical' : - allowed = [] - elif t == 'integer' : - allowed = ['64'] - else: - allowed = ['32','64'] - return allowed -# Sorry the following is confusing. -# It's partially a risky mess because default might be overloaded with 32 and 64. -def allowedPrecisions(t,tFound='',pFound='64') : - "returns a list of strings corresponding to the precisions 'expected' may take on." - allowed = [] - if tFound == 'integer' : - # The new case - if t == 'logical' : - allowed = [] - else: - # If found is integer allow t=tExpected to be either 32 or 64 - # without regard to pFound. - allowed = ['32','64'] - else : - # The old case, with 'def' below, which ladders the precisions appropriately. - if t == 'logical' : - allowed = [] - elif t == 'integer' : - allowed =['32','64'] - # allowed = ['def'] - elif t == 'real' or 'complex' : - if pFound == '32' : - allowed = ['32'] - elif pFound == '64' : - allowed = ['32','64'] - return allowed - -# 2014-1208-1646-25-UTC MLR -def allowedExpected(tFound) : - # allowed = [] - if tFound in 'integer' : - allowed = ['integer','real'] - # mlr: old and good allowed = ['integer'] - # allowed = [] - #elif tFound in 'integer' : - # allowed = ['integer'] - elif tFound == 'real' : - allowed = ['integer','real'] - elif tFound == 'complex' : - allowed = ['integer','real','complex'] - else : - allowed = [] - return allowed - -#### Type coercions - -def coerceReal(x,kind='r32') : - if kind == 'ckDefault' : - kind = 'r32' - return 'real('+x+',kind='+kind+')' - -def coerceComplex(x,kind='c32') : - if kind == 'ckDefault' : - kind = 'c32' - return 'cmplx('+x+',kind='+kind+')' - -def coerceKind(x,kind='ckDefault',t='real'): - coerceStr = x - if t == 'real' : - coerceStr = coerceReal(x,kind=kind) - elif t == 'complex' : - coerceStr = coerceComplex(x,kind=kind) - elif t == 'integer': - coerceStr = coerceReal(x,kind=kind) - else: - coerceStr = 'coerceKind: ERROR - t = '+t+', kind = '+kind+', x = '+x - return coerceStr - -#### - -def tolDECLARE(tolerance,descr,opts=', optional, intent(in)',name='tolerance'): - retStr = '' - if tolerance == 0 : - retStr = DECLARE(name,descr.FTYPE(),descr.KIND(),0,opts=opts) - else: - retStr = """real(kind=r"""+str(tolerance)+""")"""+opts+""" :: """+name - return retStr - -def makeSubroutineName(assertionName,expectedName,foundName,tolerance): - return \ - """assert"""+assertionName+"""_""" + \ - expectedName + """_""" + foundName + """_tol""" + tolerance - - # - # What does it mean to compare a 0D with a 1D array? MLR *** - # - -comparisonCase = { - "NotEqual":"NEQP", - "Equal":"EQP", - "GreaterThan":"GTP", - "GreaterThanOrEqual":"GEP", - "LessThan":"LTP", - "LessThanOrEqual":"LEP", - "RelativelyEqual":"RELEQP" - } - -def generateASSERT(assertionName,expectedDescr, foundDescr, tolerance): - subroutineName = makeSubroutineName(assertionName, \ - expectedDescr.NAME(), \ - foundDescr.NAME(), \ - str(tolerance)) - - # Maybe set up an object where comments have some extra meaning. - commentPreambleString = \ -""" - !--------------------------------------------------------------------------- - !> Asserts that two real numbers are equal. If they are not, an - !! Exception is thrown with the given message. - !! - !! @param expected - expected real numbers - !! @param found - found real numbers - !! @param message - the identifying message for the Exception - !! - !! @throw Exception - when two real numbers are not equal. - !--------------------------------------------------------------------------- -""" - - declareExpected = \ -" " + expectedDescr.DECLARE('expected') + "\n" - declareFound = \ -" " + foundDescr.DECLARE('found') + "\n" - declareTolerance = \ -" " + tolDECLARE(tolerance,foundDescr,opts=', intent(in)') - declareTolerance_orig = \ -" " + tolDECLARE(tolerance,foundDescr,opts=', optional, intent(in)') - -# foundDescr.FTYPE() == integer breaks the tolerance cast near line 337. -# toleranceKind = KINDATTRIBUTE0(foundDescr.FTYPE(),foundDescr.KIND()) -# If found is an integer, then recast the kind parameter i32 -> r64. -# Note: tolerances are set at r64 by default. - -# Okay -- we need to recall the logic in tolDECLARE, which accounts for when -# tolerance=0, in which case we default to found->kind(). - if tolerance != 0: - toleranceKind = KINDATTRIBUTE0('real',tolerance) - else: - fft0 = foundDescr.FTYPE() - if fft0.lower() == 'integer': - toleranceKind = KINDATTRIBUTE0('real',foundDescr.KIND()) - else: - toleranceKind = KINDATTRIBUTE0(foundDescr.FTYPE(),foundDescr.KIND()) - - declareExpectedScalar_expected = \ -" " + expectedDescr.DECLARESCALAR('expected') + "\n" - declareFoundScalar_found = \ -" " + foundDescr.DECLARESCALAR('found') + "\n" - - declareExpectedScalar_expected0 = \ -" " + expectedDescr.DECLARESCALAR('expected0') + "\n" - declareFoundScalar_found0 = \ -" " + foundDescr.DECLARESCALAR('found0') + "\n" - - # eType = expectedDescr.FTYPE(); fType=foundDescr.FTYPE() - # ePrec = expectedDescr.KIND(); fPrec=foundDescr.KIND() - internalSubroutineName = makeAssertInternalName(assertionName, - expectedDescr,foundDescr,tolerance) - - # 2014-0415 Need to go to an older style of reference since we're fooling - # the TKR system of the compilers. - # foundArray = 'found'+DIMS_SET([1]*foundDescr.RANK()) - foundArray = 'found' - -# Subroutine name - callInternalSubroutineName = internalSubroutineName -# Interface name -# callInternalSubroutineName = 'Assert'+assertionName+'_internal' - - - if 'complex' in [foundDescr.FTYPE(),expectedDescr.FTYPE()] : - declareDelta = \ -" " + "complex(kind=kind(found)) :: delta"+foundDescr.EXPANDSHAPE('found') +"\n"+ \ -" " + "complex(kind=kind(found)) :: delta1" +"\n" - else: - declareDelta = \ -" " + "real(kind=kind(found)) :: delta"+foundDescr.EXPANDSHAPE('found') +"\n"+ \ -" " + "real(kind=kind(found)) :: delta1" +"\n" - -# Need to handle scalar case... - foundFirstElt = DIMS_SET([1]*foundDescr.RANK()) - expectedFirstElt = DIMS_SET([1]*expectedDescr.RANK()) - - retString = \ - commentPreambleString + \ -""" - subroutine """+subroutineName+"""( & - & expected, found, tolerance, message, location ) -! was tolerance, message -- need to propagate changes... e.g. to test files - implicit none\n""" + \ - declareExpected + \ - declareFound + \ - declareTolerance + """ - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - real(kind=kind(tolerance)) :: tolerance_ - character(len=:), allocatable :: message_ - type (SourceLocation) :: location_ - -! Tolerance is now not optional. -! if(present(tolerance)) then - tolerance_ = tolerance -! else -! tolerance_ = real(0."""+ifElseString(toleranceKind,', '+toleranceKind,'')+""") -! end if - - if(present(location)) then - location_ = location - else - location_ = UNKNOWN_SOURCE_LOCATION - end if - - if(present(message)) then - message_ = message - else - message_ = NULL_MESSAGE - end if - - call assertSameShape(shape(expected),shape(found), message=message_, location=location_) - if (anyExceptions()) return - -! Next allow call to here... -!mlr-NextStep-Begin -! 2014-0414 Call interface here instead of internal subroutine name, if possible. mlr -! """ + internalSubroutineName + """ - call """+callInternalSubroutineName+"""(& - & expected, shape(expected), """+foundArray+""", shape(found), & - & tolerance_, message_, location_, """+ comparisonCase[assertionName] +""" ) -!mlr-NextStep-End - - end subroutine -""" - - declareTolerance_ = \ -" " + tolDECLARE(tolerance,foundDescr,opts='',name='tolerance_') - - retString += \ - commentPreambleString + \ -""" - subroutine """+subroutineName+'_WOTol'+"""( & - & expected, found, message, location ) - implicit none\n""" + \ - declareExpected + \ - declareFound + """ - character(len=*), optional, intent(in) :: message - type (SourceLocation), optional, intent(in) :: location - - call """+subroutineName+"""(& - & expected, found, & - & tolerance=real(0."""+ifElseString(toleranceKind,', '+toleranceKind,', '+KINDATTRIBUTE0('real',64))+"""), & - & message=message, location=location ) - - end subroutine -""" - - return retString - -def makeAssertInternalName(assertionName,eDescr,fDescr,tolerance): - eType=eDescr.FTYPE(); fType=fDescr.FTYPE() - ePrec=eDescr.KIND(); fPrec=fDescr.KIND() - eRank=min(eDescr.RANK(),1) - fRank=min(fDescr.RANK(),1) - subroutineName = \ - 'assert' + assertionName + \ - '_e'+ str(eRank) +'_'+eType+str(ePrec)+ \ - '_f'+ str(fRank) +'_'+fType+str(fPrec)+ \ - '_tol'+str(tolerance)+'_' - return subroutineName - -def makeAssertInternal_type(assertionName,eDescr,fDescr,tolerance): - eType=eDescr.FTYPE(); fType=fDescr.FTYPE() - ePrec=eDescr.KIND(); fPrec=fDescr.KIND() - eRank=min(eDescr.RANK(),1) - fRank=min(fDescr.RANK(),1) - - subroutineName = makeAssertInternalName(assertionName,eDescr,fDescr,tolerance) - - if(eRank != 0): - expected_i = 'expected(i)' - eOpts = ", dimension(product(eShape))" - else: - expected_i = 'expected' - eOpts = "" - - if(fRank != 0): - found_i = 'found(i)' - fOpts = ", dimension(product(fShape))" - else: - found_i = 'found' - fOpts = "" - - if(eRank != 0 or fRank != 0): - all_i = "all" - else: - all_i = "" - - expectedDeclaration = \ -" " + DECLARE('expected',eType,ePrec,0,\ - opts=eOpts+', intent(in)') + "\n" + \ -" " + DECLARE('expected_',eType,ePrec,0,\ - opts='') + "\n" - - foundDeclaration = \ -" " + DECLARE('found',fType,fPrec,0,\ - opts=fOpts+', intent(in)') + "\n" + \ -" " + DECLARE('found_',fType,fPrec,0,\ - opts= '' ) + "\n" + \ -" " + DECLARE('delta1',fType,fPrec,0,\ - opts= '' ) + "\n" - - toleranceDeclaration = \ -ifElseString(tolerance == 0,\ -""" - real(kind=kind(found)) :: tolerance -""", \ -""" - real(kind=r"""+str(tolerance)+"""), intent(in) :: tolerance -""" ) - -# Start to define routine... - retStr = """ - subroutine """+subroutineName+"""( & - & expected,eShape,found,fShape,tolerance,message,location, & - & comparison )""" + \ -""" - use Params_mod - use Exception_mod - use StringConversionUtilities_mod - use ThrowFundamentalTypes_mod, only : locationFormat - implicit none - integer, intent(in), dimension(:) :: eShape, fShape - character(len=*), intent(in) :: message - type (SourceLocation), intent(in) :: location - integer, intent(in) :: comparison -""" + \ - expectedDeclaration + \ - foundDeclaration + \ - toleranceDeclaration + """ - -! mlr 2013-0908 Note: Perhaps have tolerance_ with a type depending on found... incl. logical or int. - real(kind=kind(tolerance)) :: tolerance_ -!--- real(kind=kind(expected)) :: expected_ -!--- real(kind=kind(found)) :: found_ - integer :: i,m,ir - logical OK - integer, dimension(size(fShape)) :: iLocation - character(len=MAXLEN_SHAPE) :: locationInArray - real :: denominator - - ! Return immediately if the two are precisely equal. - ! This is necessary to deal with identical infinities, which cannot be - ! subtracted. - if (comparison .eq. EQP) then - if (""" + all_i + """(expected == found)) return - end if - ! Note: The above begs the question about how to handle Inf for non-.eq. cases... - -! MLR: The following just might work... - tolerance_ = tolerance - -! fType != 'complex' = """ + str(fType != 'complex') + """ - -! Note: Could assert size(expected) = size(found) and fShape = eShape... - -! print *,'0800 ',product(fShape),fShape - m = product(fShape) - i = 0 -! - OK = .true. - -! Note: Comparison occurs here. Could use isWithinTolerance or other comparison function. -! mlr 2013-0908 Other comparisons: tolerance-less integer comparison... logical... - if( m > 0 )then - do while ( i < m .and. OK ) - i = i + 1 - - delta1 = """ + expected_i + """-""" + found_i + """ - - select case (comparison) - case (EQP) - OK = & - & isWithinTolerance( & - & delta1, & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) - case (NEQP) - OK = & - & .not. & - & isWithinTolerance( & - & delta1, & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) """ + \ -ifElseString(fType != 'complex', \ -""" - case (GTP) - OK = delta1 .gt. 0 - case (GEP) - OK = delta1 .ge. 0 - case (LTP) - OK = delta1 .lt. 0 - case (LEP) - OK = delta1 .le. 0 """,'') + \ -""" - case (RELEQP) - if ( abs("""+expected_i+""") > 0 ) then - OK = & - & isWithinTolerance( & - & delta1 / """+expected_i+""", & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) - else - OK = & - & isWithinTolerance( & - & delta1, & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) - end if - case default - ! This case should not occur for this type-kind-rank. - print *,'internal: """+subroutineName +""" select-error-1' - OK = .false. - end select - -! OK = .not. ( expected(i) /= found(i) ) -! OK = .not. ( """+expected_i+""" /= """+found_i+""" ) - end do - else -! i = 1 - delta1 = """ + expected_i + """-""" + found_i + """ - - select case (comparison) - case (EQP) - OK = & - & isWithinTolerance( & - & delta1, & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) - case (NEQP) - OK = & - & .not. & - & isWithinTolerance( & - & delta1, & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) """ + \ -ifElseString(fType != 'complex', \ -""" - case (GTP) - OK = delta1 .gt. 0 - case (GEP) - OK = delta1 .ge. 0 - case (LTP) - OK = delta1 .lt. 0 - case (LEP) - OK = delta1 .le. 0 """,'') + \ -""" - case (RELEQP) - if ( abs("""+expected_i+""") > 0 ) then - OK = & - & isWithinTolerance( & - & delta1 / """+expected_i+""", & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) - else - OK = & - & isWithinTolerance( & - & delta1, & - & real(tolerance_,kind=r64), & - & L_INFINITY_NORM ) - end if - case default - ! This case should not occur for this type-kind-rank. - print *,'internal: """+subroutineName +""" select-error-2' - OK = .false. - end select - -! OK = & -! & isWithinTolerance( & -! & delta1, & -! & real(tolerance_,kind=r64), & -! & L_INFINITY_NORM ) - -! OK = .not. ( """+expected_i+""" /= """+found_i+""" ) - end if - - if( .not. OK )then - - ! Save the FirstBad... - expected_ = """+expected_i+""" - found_ = """+found_i+""" - -! if( m > 0 )then - if( size(fshape) > 0 ) then - - i = i - 1 - do ir = 1,size(fShape) - iLocation(ir) = mod(i,fShape(ir)) + 1 - i = i / fShape(ir) - end do - -! print *,'0998 ',m -! print *,'0999 ',size(fShape) -! print *,'1000 ',iLocation - write(locationInArray,locationFormat(iLocation)) iLocation - - else - - write(locationInArray,*) '[1]' - - end if - -! Scalar -! Note use of abs - - select case (comparison) - case (EQP) - call throw( & - & appendWithSpace(message, & - & trim(valuesReport(expected_,found_)) // & - & '; '//trim(differenceReport(abs(found_ - expected_), tolerance_)) // & - & unlessScalar(fShape,'; first difference at element '//trim(locationInArray))//'.'), & - & location = location & - ) - case (NEQP) - call throw( & - & appendWithSpace(message, & - & 'NOT: '//trim(valuesReport(expected_,found_)) // & - & '; '//trim(differenceReport(abs(found_ - expected_), tolerance_)) // & - & unlessScalar(fShape,'; first equality at element '//trim(locationInArray))//'.'), & - & location = location & - ) """ + \ -ifElseString(fType != 'complex', \ -""" - case (GTP) - call throw( & - & appendWithSpace(message, & - & trim(valuesReport(expected_,found_, & - & ePrefix='expected', & - & fPrefix='to be greater than:')) // & - & unlessScalar(fShape,'; first difference at element '//trim(locationInArray))//'.'), & - & location = location & - ) - case (GEP) - call throw( & - & appendWithSpace(message, & - & trim(valuesReport(expected_,found_, & - & ePrefix='expected', & - & fPrefix='to be greater than or equal to:')) // & - & unlessScalar(fShape,'; first difference at element '//trim(locationInArray))//'.'), & - & location = location & - ) - case (LTP) - call throw( & - & appendWithSpace(message, & - & trim(valuesReport(expected_,found_, & - & ePrefix='expected', & - & fPrefix='to be less than:')) // & - & unlessScalar(fShape,'; first difference at element '//trim(locationInArray))//'.'), & - & location = location & - ) - case (LEP) - call throw( & - & appendWithSpace(message, & - & trim(valuesReport(expected_,found_, & - & ePrefix='expected', & - & fPrefix='to be less than or equal to:')) // & - & unlessScalar(fShape,'; first difference at element '//trim(locationInArray))//'.'), & - & location = location & - ) """,'') + \ -""" - case (RELEQP) - if (expected_ .eq. 0) then - denominator = expected_ - else - denominator = 1.0 - end if - call throw( & - & appendWithSpace(message, & - & trim(valuesReport(expected_,found_, & - & ePrefix='RELEQ: expected', & - & fPrefix='to be near:')) // & - & '; '//trim(differenceReport( & - & abs(found_ - expected_)/denominator, tolerance_)) // & - & unlessScalar(fShape,'; first difference at element '//trim(locationInArray))//'.'), & - & location = location & - ) - case default - ! This case should not occur for this type-kind-rank. - print *,'internal: """+subroutineName +""" select-error-3' - call throw( & - & appendWithSpace(message, & - & 'pFUnit internal error: unexpected comparison given type-kind-rank'), & - & location = location & - & ) - end select - - end if - - end subroutine """+subroutineName+""" - - - -""" - - runit = routineUnit(subroutineName,retStr) - - - return runit - - -class constraintASSERT(routineUnit): - "Defines the comparison code as a routineUnit so that it can be \ - used by the module generation code. These declarations are used \ - to construct interface blocks as well as the routines themeselves." - def __init__(self, assertionName, expectedDescr, foundDescr, tolerance): - self.expectedDescr = expectedDescr - self.foundDescr = foundDescr - self.name = makeSubroutineName( assertionName, \ - expectedDescr.NAME(), \ - foundDescr.NAME(), \ - str(tolerance) ) - #! bad... too simple... - ## Add in the extra module procedures... If needed... - self.setDeclaration(declaration(self.name,self.name)) - ## Kluge. Need to make makeSubroutineNames and load the extra interface entries there. - self.name1 = self.name+'_WOTol' - self.addDeclaration(declaration(self.name1,self.name1)) - - ## If you need another kind of code generator, perhaps - ## conditioned on eDesc., fDesc., or tol, then that logic - ## would go here... E.g. to implement assertEqual(Logical(...)) - ## - ## Dependency injection. Will generate "assert"+assertionName - ## assertionName="Equal" - ## This next line actually generates the text of the code. - self.setImplementation(generateASSERT(assertionName, \ - expectedDescr, \ - foundDescr, \ - tolerance )) - self.tolerance = tolerance - return - -def constructAssertInterfaceBlock(assertionName,foundFTypes=['real'],foundRanks=[],patchIntXX=False): - AssertInterfaceBlockName='assert'+assertionName - AssertInterfaceBlock = interfaceBlock(AssertInterfaceBlockName) - # Construct asserts generates the combinations based on what is passed in here. - [AssertInterfaceBlock.addRoutineUnit(r) for r in constructASSERTS(assertionName,foundFTypes=foundFTypes,foundRanks=foundRanks,patchIntXX=patchIntXX)] - return AssertInterfaceBlock - -def VECTOR_NORM_NAME(rank,fType='real',precision=64): - return """vectorNorm_"""+str(rank)+"D"+"_"+fType+str(precision) - -def vnSQRT(x,fType,precision): - retStr = '' - if fType == 'integer' : - retStr = 'sqrt(real('+x+',kind=r64))' - else : - retStr = 'sqrt('+x+')' - return retStr - -def generateVECTOR_NORM(rank,fType='real',precision=64): - subroutineName = VECTOR_NORM_NAME(rank,fType=fType,precision=precision) - dimStr = DIMS(rank) - retstr = \ -""" - !--------------------------------------------------------------------------- - !> Returns the independent of norm in vector by the given diminsional - !! double-precission real numbers and given integer norm - !! - !! The following is for rank = """+str(rank)+""". - !! - !! @param x - given dimensional double-precision real numbers - !! @param norm - given norm - !! - !! @return independent of norm - !--------------------------------------------------------------------------- - function """+subroutineName+"""(x, norm) result(y) - """+DECLARE('x',fType,precision,rank,opts=', intent(in)')+""" - integer :: norm -! mlr 2013-0908 Maybe we change the range of VECTOR_NORM to include integer & logical. - real (kind=r64) :: y -""" + ifElseString(rank == 0, \ -""" - y = abs(x) ! independent of norm for rank=0 (scalar) case. -""", \ -""" -! Note that abs(complex) is like the L2_NORM unless care is taken *here*. Fix later... - select case (norm) ! code to support rank /= 0 cases. - case (L_INFINITY_NORM) - y = maxval(abs(x)) - case (L1_NORM) - y = sum(abs(x)) - case (L2_NORM) -! y = sqrt(sum(x**2)) -! y = sqrt(sum(x*conjg(x))) -! y = sqrt(sum(x*"""+CONJG('x',fType)+""")) - y = """ + vnSQRT("""sum(x*"""+CONJG('x',fType)+""")""",fType,precision) + """ - end select -""") + \ -""" - end function """ + subroutineName + """ -""" - return retstr - -class VECTOR_NORM(routineUnit): - def __init__(self,rank,fType='real',precision=32): - self.rank = rank - self.fType = fType - self.precision = precision - self.name = VECTOR_NORM_NAME(rank,fType=self.fType,precision=self.precision) - self.declaration = declaration(self.name,self.name) - self.declarations = [self.declaration] - self.implementation \ - = implementation( \ - self.name, \ - generateVECTOR_NORM(rank,fType=self.fType,precision=self.precision)) - return - -def constructVectorNormInterfaceBlock(foundRanks=range(6)): - VectorNormInterface = interfaceBlock('vectorNorm') - list(map(VectorNormInterface.addRoutineUnit, - flattened( [[VECTOR_NORM(i,fType=t,precision=p) for i in foundRanks \ - for p in allowedPrecisions(t) ] \ - for t in ['real','complex','integer'] - ]))) - return VectorNormInterface - -def constructDifferenceReportInterfaceBlock(): - DifferenceReportInterface = interfaceBlock('differenceReport') - list(map(DifferenceReportInterface.addRoutineUnit, - flattened( [[[makeDifferenceReport_type(t=t,p=p,tol=tol) \ - for tol in dr_TolAllowedPrecisions(t) ] - for p in allowedPrecisions(t) ] - for t in ['integer','real','complex'] \ - ]))) - return DifferenceReportInterface - -def constructValuesReportInterfaceBlock(): - ValuesReportInterface = interfaceBlock('valuesReport') - list(map(ValuesReportInterface.addRoutineUnit, - flattened( [[[[makeValuesReport_type(te=te,tf=tf,pe=pe,pf=pf) \ - for pe in allowedPrecisions(te,tFound=tf,pFound=pf) ] \ - #sigh for pe in allowedPrecisions(te,pFound=pf) ] \ - for pf in allowedPrecisions(tf) ] \ - for te in allowedExpected(tf) ] \ - for tf in ['integer','real','complex'] \ - ]))) - return ValuesReportInterface - -# Scalar args? -# Need assertionName... -# def constructAssertInternalInterfaceBlock(assertionName="Equal"): -def constructAssertInternalInterfaceBlock(assertionName,expose=False): - # foundRanks... mlr... how would foundRanks work here? - AssertInternalInterfaceBlockName='assert'+assertionName+'_internal' - AssertInternalInterface = interfaceBlock(AssertInternalInterfaceBlockName) - # 2014-0415 expose may not be necessary here! MLR - list(map((lambda x: AssertInternalInterface.addRoutineUnit(x,expose=expose)), - [makeAssertInternal_type(assertionName, - a.getExpectedDescription(), - a.getFoundDescription(), - a.getTolerance() - ) - for a in - flattened( - [[[[[[[[AssertRealArrayArgument(assertionName,te,pe,re,tf,pf,rf,tol) - for re in [0,1] ] - for rf in [0,1] ] - for tol in makeTolerances(pe,pf) ] - for pe in allowedPrecisions(te,tFound=tf,pFound=pf) ] - #sigh for pe in allowedPrecisions(te,pFound=pf) ] - for pf in allowedPrecisions(tf) ] - for te in allowedExpected(tf) ] - for tf in ['integer','real','complex'] - ]])])) - return AssertInternalInterface - -def isWithinToleranceName(rank,fType='real',precision=64): - return """isWithinTolerance_"""+str(rank)+"""D"""+"_"+fType+str(precision) - -def generateIsWithinTolerance(rank,fType='real',precision=64): - "Generate the code for the comparison function. Calls \ - vectorNorm..." - subroutineName = isWithinToleranceName(rank,fType=fType,precision=precision) - dimStr = DIMS(rank) - - declareKind = '' - if fType == 'integer' : - declareKind = '(kind=i'+str(precision)+')' - #declareKind = '' - elif fType == 'real' : - declareKind = '(kind=r'+str(precision)+')' - elif fType == 'complex' : - declareKind = '(kind=c'+str(precision)+')' - else: - print('isWithinToleranceTypeError') - - retstr = \ -""" - logical function """+subroutineName+"""(x, tolerance, norm) -! """+fType+""" (kind=r"""+str(precision)+"""), intent(in) :: x"""+dimStr+""" - """+fType+declareKind+""", intent(in) :: x"""+dimStr+""" - real (kind=r64), intent(in) :: tolerance - integer, intent(in) :: norm - - """+subroutineName+""" = ( vectorNorm(x, norm) <= tolerance ) - - end function """+subroutineName+""" -""" - return retstr - -class IsWithinTolerance(routineUnit): - "A routineUnit specialized to the isWithinTolerance comparison function." - def __init__(self,rank,fType='real',precision=64): - self.rank = rank - self.precision = precision - self.name = isWithinToleranceName(rank,fType=fType,precision=precision) - self.fType = fType - self.declaration = declaration(self.name, self.name) - self.declarations = [self.declaration] - self.implementation \ - = implementation(self.name, \ - generateIsWithinTolerance(self.rank, \ - fType=self.fType, \ - precision=self.precision)) - return - -def constructIsWithinToleranceInterfaceBlock(foundRanks=range(6)): - "For the comparison function, make an interface block and \ - implementation for inclusion into a module." - iwt_InterfaceBlock = interfaceBlock('isWithinTolerance') - list(map(iwt_InterfaceBlock.addRoutineUnit, - flattened( - [[IsWithinTolerance(i,fType=t,precision=p) - for i in foundRanks - for p in allowedPrecisions(t) ] - for t in ['real','complex','integer'] - ]))) - return iwt_InterfaceBlock - - -### Currently Active ### -def makeValuesReport_type(te='real',tf='real',pe='64',pf='64'): - expectedKind = reportKind(te,pe) - foundKind = reportKind(tf,pf) - mxType = maxType(te,tf) - mxPrec = maxPrecision(pe,pf) - - if te == 'integer': - coercedExpected = 'expected' - else: - coercedExpected = coerceKind('expected',t=mxType) - if tf == 'integer': - coercedFound = 'found' - else: - coercedFound = coerceKind('found',t=mxType) - - runit = routineUnit('valuesReport_'+te+tf+pe+pf, \ -""" - character(len=MAXLEN_MESSAGE) & - & function valuesReport_"""+te+tf+pe+pf+""" & - & (expected,found,ePrefix,ePostfix,fPrefix,fPostfix) & - & result(valuesReport) - """+te+expectedKind+""", intent(in) :: expected - """+tf+foundKind+""", intent(in) :: found - character(len=*), optional, intent(in) :: & - & ePrefix, ePostfix, fPrefix, fPostfix - character(len=MAXLEN_MESSAGE) :: & - & ePrefix_, ePostfix_, fPrefix_, fPostfix_ - - if( .not.present(ePrefix) ) then - ePrefix_ = 'expected' - else - ePrefix_ = ePrefix - end if - if( .not.present(ePostfix) ) then - ePostfix_ = '' - else - ePostfix_ = ePostfix - end if - if( .not.present(fPrefix) ) then - fPrefix_ = 'but found:' - else - fPrefix_ = fPrefix - end if - if( .not.present(fPostfix) ) then - fPostfix_ = '' - else - fPostfix_ = fPostfix - end if - -! Note: removed '<.>' - valuesReport = & - & trim(ePrefix_)//' '// trim(toString("""+coercedExpected+""")) // & - & trim(ePostfix_)//' '// & - & trim(fPrefix_)//' '//trim(toString("""+coercedFound+""")) // & - & trim(fPostfix_)// & - & '' - - end function -""") - # runit.setDeclaration(declaration(runit.getName(),'public '+runit.getName())) - return runit - -### Currently Active ### -def makeDifferenceReport_type(t='real',p='64',tol='64'): - """Report on the difference found between expected and found. This should be - redesigned to support difference between real & integer, e.g. treatment of tolerances.""" - # TODO: Fix integer for non-default values, e.g. INT64... - # TODO: Fix the papering-over of integer/real/tolerance treatment. - if t == 'integer' : - # expectedDeclaration = " integer, intent(in) :: difference" - expectedDeclaration = t+"""(kind=i"""+p+"""), intent(in) :: difference""" - coercedDifference = 'difference' - else : - expectedDeclaration = t+"""(kind=r"""+p+"""), intent(in) :: difference""" - coercedDifference = coerceKind('difference',t=t) - # coercedTolerance = coerceKind('tolerance',t=t) - - # runit = routineUnit( - - differenceReportSource=\ -""" - character(len=MAXLEN_MESSAGE) & - & function differenceReport_"""+t+p+tol+"""(difference, tolerance) result(differenceReport) - """+expectedDeclaration+""" - real(kind=r"""+tol+"""), intent(in) :: tolerance -! real(kind=r"""+tol+"""), optional, intent(in) :: tolerance - character(len=2) rel - if (abs("""+coercedDifference+""") .gt. tolerance) then - rel = '> ' - else - rel = '<=' - end if""" - if t != 'integer': - differenceReportSource=differenceReportSource+\ -""" - differenceReport = ' difference: |' // trim(toString("""+coercedDifference+""")) // & - & '| '// trim(rel) //' tolerance:' // trim(toString("""+'tolerance'+""")) - end function -""" - else: - differenceReportSource=differenceReportSource+\ -""" - differenceReport = ' difference: |' // trim(toString("""+coercedDifference+""")) // & - & '| ' - end function -""" - runit = routineUnit('differenceReport_'+t+p+tol,differenceReportSource) - -# Don't need the following because we'll add to an interface block. -# runit.setDeclaration(declaration(runit.getName(),'public '+runit.getName())) - return runit - -def declareUSES(internalRoutines=[]): - retStr=\ -""" - use Params_mod - use AssertBasic_mod - use Exception_mod - use SourceLocation_mod - use StringConversionUtilities_mod - use AssertArraysSupport_mod -""" - for i in internalRoutines: - retStr=retStr+\ -""" use AssertArraysInternal"""+i+"""_mod -""" - return retStr - -def declareDISCIPLINE(): - return \ -""" - implicit none - private -""" - -# Flag AssertEqual - -def declareEXPORTS(assertionRoutines,basename='AssertReal'): - retPublic = "" - for aRoutineName in assertionRoutines: - retPublic = retPublic + \ -""" public :: """+aRoutineName+""" -""" - if basename == 'AssertReal' : - retPublic = retPublic + """ - - public :: vectorNorm - public :: isWithinTolerance - - public :: L_INFINITY_NORM - public :: L1_NORM - public :: L2_NORM - -""" - return retPublic - -def declareEXPORTS_PARAMETERS(): - return \ -""" - integer, parameter :: L_INFINITY_NORM = 0 - integer, parameter :: L1_NORM = 1 - integer, parameter :: L2_NORM = 2 - - integer, parameter :: MAXLEN_SHAPE = 80 -""" - -#### Helper functions for constructASSERTS -- a main workhorse for generating the specific routines. - -# -# In the following: expectedPrecision and foundFType are strings. -# -def makeExpectedFTypes(expectedPrecision,foundFType,foundFTypes=['real']): - """A very application-specific mapping to construct an fType list - for expected. Make sure that if we're looking at complex that we - do not replicate real-real comparisons.""" - retTypes = ['makeExpectedFType::ERROR'] - if 'logical' in foundFTypes : - if foundFType == 'logical' : - retTypes=['logical'] - elif expectedPrecision == 'def': - # - if not 'complex' in foundFTypes : - retTypes=['integer'] - else : - # If we're in AssertComplex and we're not duplicating reals... - if foundFType == 'real' : - retTypes=[] - else : - retTypes=['integer'] - elif expectedPrecision == 32 or expectedPrecision == 64: - # This logic is probably not correct. - if foundFType == 'integer' : - # Processing integer-found. - # mlr - fingers crossed. - retTypes=['integer','real'] - elif not 'complex' in foundFTypes : - # Processing case where we're not combining with complex. - # mlr 2 - ??? - retTypes=['integer','real'] - # retTypes=['real'] - else : - if foundFType == 'real' : - # Tom asserts that finding a real when expecting complex should be an error. - # retTypes=['complex'] - retTypes=[] - else : - retTypes=['integer','real','complex'] - #? retTypes=['real','complex'] - return retTypes - -# Compare with allowedExpected -def makeExpectedFTypesWithoutExpectedPrecision( \ - foundFType,foundFTypes=['ERROR']): - if 'ERROR' in foundFTypes: - print('makeExpectedFTypesWithoutExpectedPrecision::ERROR') - retTypes = [] - # if found is something, then expected is in... - if 'logical' == foundFType : - retTypes = ['logical'] - elif 'integer' == foundFType : - # Is Finding an integer when expecting complex an error too? - retTypes = ['integer','real'] - elif 'real' == foundFType : - # Finding a real when expecting complex is an error. TLC - retTypes = ['integer','real'] - elif 'complex' : - # We're finding complexes. - retTypes = ['integer','real','complex'] - return retTypes - -def makeExpectedRanks(foundRank): - ranks = [0] - if foundRank != 0: - ranks.append(foundRank) - return ranks - -def makeTolerances(expectedP, foundP) : - "unless default (int) is found, collect all of the tolerances \ - found in eP and fP and return the maximum" - tol = -1 - if type(expectedP) is list : - ep = expectedP - else : - ep = [expectedP] - if type(foundP) is list : - fp = foundP - else: - fp = [foundP] - lp = [] - if not 'def' in ep : - lp = lp + ep - if not 'def' in fp : - lp = lp + fp - if lp == [] : - # 2013-1022 MLR Fix this!!! - # print('tolerance error! setting lp to 64.') - lp = [64] - tol = max(lp) - return [tol] - -class AssertRealArrayArgument: - def __init__(self,aName,eft,ep,er,fft,fp,fr,tol): - # print(' ',eft,ep,er,fft,fp,fr,tol) - self.assertionName = aName - self.expectedFType = eft - self.expectedPrecision = ep - self.expectedRank = er - self.foundFType = fft - self.foundPrecision = fp - self.foundRank = fr - self.tolerance = tol - # ArrayDescriptions - self.expectedDescription = None - self.foundDescription = None - # Now set them... - self.updateDescriptions() - - def updateDescriptions(self): - self.expectedDescription = ArrayDescription( \ - self.expectedFType, \ - self.expectedPrecision, \ - self.expectedRank ) - self.foundDescription = ArrayDescription( \ - self.foundFType, \ - self.foundPrecision, \ - self.foundRank ) - return - - def getAssertionName(self): - return self.assertionName - def getExpectedDescription(self): - return self.expectedDescription - def getFoundDescription(self): - return self.foundDescription - def getTolerance(self): - return self.tolerance - -# See allowedPrecisions. -def makeExpectedPrecisions(foundPrecision,foundFType='real',expectedFType=''): - if expectedFType == 'integer' : - # New style, eFT known. - expectedPrecisions = [32,64] - elif expectedFType == 'real' : - expectedPrecisions = [32] - if foundPrecision > 32 : - expectedPrecisions.append(foundPrecision) - elif expectedFType == 'complex' : - expectedPrecisions = [32] - if foundPrecision > 32 : - expectedPrecisions.append(foundPrecision) - elif expectedFType == 'logical' : - expectedPrecisions = [''] - else: - # Old style, eFT not known. - if foundFType == 'logical' : - expectedPrecisions = [''] - elif foundFType == 'integer' : - expectedPrecisions = [32,64] - # expectedPrecisions = ['def'] - else : - expectedPrecisions = [32] - #expectedPrecisions = ['def',32] - #expectedPrecisions = ['defXXX',32] - if foundPrecision > 32 : - expectedPrecisions.append(foundPrecision) - return expectedPrecisions - -def ca_MakeAllowedPrecisions(foundFType) : - precs = [] - ap = allowedPrecisions(foundFType,pFound='64') - for i in ap : - if i == 'def' : - precs = precs + [i] - else : - precs = precs + [int(i)] - return precs - -def constructASSERTS(assertionName,foundFTypes=['real','complex'],foundRanks = [0,1,2,3,4,5],patchIntXX=False): - - AssertList = [] - - # Note: expectedPrecision <= foundPrecision - # Note: Need to eliminate redundancy of real asserts that can arise in AssertComplex. - # I.e. remove real-real comparisons when complex is available. - - # expectedFTypes -> 'integer' if expectedPrecision 'def' else 'real' - # was tolerances = [32,64], but replaced by the following: - # tolerances = max expectedPrecisions & foundPrecisions - # expectedPrecisions = ['def',32,64] that are < foundPrecision - # expectedRanks(foundRank) -> [0,foundRank] - # + passed in foundFTypes = ['real','complex'] - # + passed in foundFTypes = ['real'] - # foundPrecisions = [32,64] replaced with ca_MakeAllowedPrecisions - # + passed in foundRanks = [0,1,2,3,4,5] - -# -> foundFTypes --> adding 'complex' - -# THE MAIN LOOP. -# May need a special case if we don't want to construct a real-real in AssertComplex... -# Many type-kind-rank combinations are not allowed. The allowed combinations result from -# some options depending on others. These are implemented in the "make..." functions listed below. -# The argument foundFType (found Fortran Type) is a key independent variable, which drives the types -# chosen for other arguments. -# -# The variable a contains the arguments for the specialized AssertEqual being generated. -# The constraintASSERTEQUAL object is the specialized routine, which is then used to -# construct the module. -# -# To change the list of asserts constructed, one can either change the logic implemented in the -# network of "make..." functions below, or one could add other routineUnits to AssertList, as long -# as it make sense to include them in the list (and interface block). -# -# print ('1000: ',foundRanks) - -# The following provides basic functionality, originally thought through for -# the default integer type. Moving to multiple integer kinds has a gap in -# combinatorial type coverage. So we'll handle the gaps below. -# - AssertList = \ - [ \ - #test a \ - constraintASSERT(a.getAssertionName(),\ - a.getExpectedDescription(),\ - a.getFoundDescription(),\ - a.getTolerance()\ - ) \ - for a in \ - flattened( \ - [[[[[[[ \ - AssertRealArrayArgument(assertionName,eft,ep,er,fft,fp,fr,tol) \ - for tol in makeTolerances(ep,fp) ] \ - for eft in makeExpectedFTypes(ep,fft,foundFTypes=foundFTypes) ] \ - for ep in makeExpectedPrecisions(fp,foundFType=fft) ] \ - for er in makeExpectedRanks(fr) ] \ - for fp in ca_MakeAllowedPrecisions(fft) ] \ - for fft in foundFTypes ] \ - for fr in foundRanks ] \ - )] - - ## To insert by hand, one might try the following (sketch...)... - ## a = AssertRealArrayArgument('integer','def','1','integer','def','1',0) - ## AssertList += [MyConstraintAssertEqual(a.getExpectedDescription(),a.getFoundDescription())] - ## Any specialization of routineUnit should work here... - ## The code is generated when the routineUnit is instantiated, so that support code would - ## need to be available. - - # - # For real and complex r32/r64 and c32/c64 precisions are the same kind of thing, - # while i32/i64 for integers have completely different meanings. Therefore our - # default logic, which does not allow the combination [expected-x64, found-x32], - # is incorrect for integer. - # - # if len(foundFTypes) == 1 : - if patchIntXX: - if foundFTypes[0] != 'integer' : - nameList = [ assertionName ] - eftList = [ 'integer' ] - epList = [ 64 ] - fftList = foundFTypes - fpList = [ 32 ] - frList = foundRanks - # erList = [] - # tolList = [ 32 ] - - for name in nameList: - for eft in eftList: - for ep in epList: - for fft in fftList: - for fp in fpList: - for fr in frList: - for er in makeExpectedRanks(fr): - for tol in makeTolerances(ep,fp): - a = AssertRealArrayArgument( name, eft, ep, er, fft, fp, fr, tol ) - AssertList.append(\ - constraintASSERT(a.getAssertionName(),\ - a.getExpectedDescription(),\ - a.getFoundDescription(),\ - a.getTolerance()\ - )) - - return AssertList - -def constructDeclarations(assertionRoutines,basename='',foundRanks=[]): - "Construct declarations to be used at the beginning of the Module." - # foundRanks works into this... how? mlr 2014-0407 - declarations = \ - [ \ - declaration('uses',declareUSES(internalRoutines=assertionRoutines)), \ - declaration('discipline',declareDISCIPLINE()), \ - declaration('exports',declareEXPORTS(assertionRoutines,basename)), \ - declaration('exportsParameters',declareEXPORTS_PARAMETERS()) \ - ] - return declarations - - - -def declareUSES_() : - "Set up use statements for SupportModule." - return \ -""" - use Params_mod - use AssertBasic_mod - use Exception_mod - use SourceLocation_mod - use StringConversionUtilities_mod -""" - - -# Use "global" declareDISCIPLINE() -def declareEXPORTS_(exportedRoutines) : - retPublic="" - for aRoutineName in exportedRoutines : - retPublic = retPublic + \ -""" public :: """+aRoutineName+""" -""" - retPublic = retPublic + \ -""" - public :: valuesReport - public :: differenceReport - - public :: vectorNorm - public :: isWithinTolerance - -""" -# print ('3000: retPublic: ',retPublic) - return retPublic - -def declareEXPORTS_INTERNAL_(exportedRoutines) : - retPublic="" - for aRoutineName in exportedRoutines : - retPublic = retPublic + \ -""" public :: """+aRoutineName+""" -""" -#- retPublic = retPublic + \ -#-""" -#- public :: valuesReport -#- public :: differenceReport -#- -#- public :: vectorNorm -#- public :: isWithinTolerance -#- -#-""" -# print ('3000: retPublic: ',retPublic) - return retPublic - - -# Use "global" declareEXPORTS_PARAMETERS(): - -def constructSupportModuleDeclarations(exportedRoutineNames=[]): -# print ('2000: eRN: ',exportedRoutineNames) -# Start main of constructSupportModuleDeclarations - declarations = \ - [ \ - declaration('uses',declareUSES_()), \ - declaration('discipline',declareDISCIPLINE()), \ - declaration('exports',declareEXPORTS_(exportedRoutineNames)), \ - declaration('exportsParameters',declareEXPORTS_PARAMETERS()) \ - ] - return declarations - -def constructInternalModuleDeclarations(exportedRoutineNames=[]): -# print ('2000: eRN: ',exportedRoutineNames) -# Start main of constructSupportModuleDeclarations - declarations = \ - [ \ - declaration('uses',declareUSES_()), \ - declaration('discipline',declareDISCIPLINE()), \ - declaration('exports',declareEXPORTS_INTERNAL_(exportedRoutineNames)), \ - declaration('exportsParameters',declareEXPORTS_PARAMETERS()) \ - ] - return declarations - - -def constructSupportModule(baseName='AssertArraysSupport',assertionShortNames=[],foundRanks=[],maxRank=5): - # Just a rename to capture an idea. Will fix later. MLR -# exportedRoutineNames = ['assert'+i+'_internal' for i in assertionShortNames] - exportedRoutineNames = [] -# print ('1500: exportedRoutineNames: ',exportedRoutineNames) - m1 = module(baseName+'_mod') - m1.setFileName(baseName+'.F90') - # Note exportedRoutineNames may be empty but still makes a bunch of declarations. - [m1.addDeclaration(d) for d in constructSupportModuleDeclarations(exportedRoutineNames)] - m1.addInterfaceBlock(constructDifferenceReportInterfaceBlock()) - m1.addInterfaceBlock(constructValuesReportInterfaceBlock()) - # Generate internals for all ranks. - m1.addInterfaceBlock(constructVectorNormInterfaceBlock(foundRanks=range(maxRank+1))) - m1.addInterfaceBlock(constructIsWithinToleranceInterfaceBlock(foundRanks=range(maxRank+1))) - - # The following will add "assert" to the shortname. -#+ for assertionShortName in assertionShortNames: -#+ m1.addInterfaceBlock(constructAssertInternalInterfaceBlock(assertionShortName,foundRanks=foundRanks,expose=True),expose=True) -#? m1.addInterfaceBlock(constructAssertInternalInterfaceBlock(assertionShortName,expose=True),expose=True) - - return m1 - -def constructInternalModule(baseName='AssertArraysInternal',assertionShortName="",exportedRoutineNames=[],maxRank=[]): -# oops -- hardwired longname here - baseName_ = baseName+"assert"+str(assertionShortName) - m1 = module(baseName_+'_mod') - m1.setFileName(baseName_+'.F90') - - [m1.addDeclaration(d) for d in constructInternalModuleDeclarations(exportedRoutineNames)] - - m1.addInterfaceBlock(constructDifferenceReportInterfaceBlock()) - m1.addInterfaceBlock(constructValuesReportInterfaceBlock()) - # Generate internals for all ranks. - m1.addInterfaceBlock(constructVectorNormInterfaceBlock(foundRanks=range(maxRank+1))) - m1.addInterfaceBlock(constructIsWithinToleranceInterfaceBlock(foundRanks=range(maxRank+1))) - - - # The following will add "assert" to the shortname. - m1.addInterfaceBlock(constructAssertInternalInterfaceBlock(assertionShortName,expose=True),expose=True) - - return m1 - - -def constructModule(baseName='AssertReal',assertionShortNames=['NOP'],foundFTypes=['real'],foundRanks=[],patchIntXX=False): -# assertionShortNames=['Equal'] -# assertionShortNames=['GreaterThan'] - assertionNames=['assert'+Suffix for Suffix in assertionShortNames] - rankName = '' - for iRank in foundRanks : rankName = rankName + str(iRank) - "A main test of how to construct the module." - m1 = module(baseName+rankName+'_mod') - m1.setFileName(baseName+rankName+'.F90') - [m1.addDeclaration(d) for d in constructDeclarations(assertionNames,basename=baseName,foundRanks=foundRanks)] - # add interface blocks (and the implementations) - foundRanks1=foundRanks - if (not 0 in foundRanks) : foundRanks1 = [0] + foundRanks -#! Moved to support module. -#! m1.addInterfaceBlock(constructVectorNormInterfaceBlock(foundRanks=foundRanks1)) -#! m1.addInterfaceBlock(constructIsWithinToleranceInterfaceBlock(foundRanks=foundRanks1)) - for assertionName in assertionShortNames: - m1.addInterfaceBlock(constructAssertInterfaceBlock(assertionName,foundFTypes=foundFTypes,foundRanks=foundRanks,patchIntXX=patchIntXX)) - -# The following lines have been moved to the support module. -# m1.addInterfaceBlock(constructDifferenceReportInterfaceBlock()) -# m1.addInterfaceBlock(constructValuesReportInterfaceBlock()) -# - -# The following generates internal routines. Moved to support module. - # *in test* - # This is where the "list of asserts" is generated. -#??? for assertionName in assertionShortNames: -#??? m1.addInterfaceBlock(constructAssertInternalInterfaceBlock(assertionName,foundRanks=foundRanks)) - -# Old removal. 2014-0414 - # add individual routine units - # m1.addRoutineUnit(makeThrowDifferentValues()) # arg. provides a routine unit. - return m1 - -def filePreamble(filename): - return """ - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This file '"""+filename+"""' is automatically generated by -! 'GenerateAssertsOnArrays.py'. Changes made here will be -! overwritten the next time that script is run. -! -! 2013-0722 MLR Michael.L.Rilee-1@nasa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -""" - -def addFileToMakefile(fileName,includeFile="generated.inc", quiet=False): - if not quiet: - sys.stdout.write('{0}\n'.format(fileName)) - - with open(includeFile,'a') as f: - f.write('GENERATED_CODE += ' + fileName + '\n') - return - -def addModToF90Include(modName,includeFile="AssertArrays.fh",postFix=""): - with open(includeFile,'a') as f: - f.write(' use ' + modName + postFix + '\n') - return - -def makeGeneratedInclude(includeFile="generated.inc"): - with open(includeFile,'w') as f: - f.write('# This file automatically generated. Do not modify.\n') - return - -relationalOperatorShortNames=["NotEqual",\ - "Equal",\ - "GreaterThan",\ - "GreaterThanOrEqual",\ - "LessThan",\ - "LessThanOrEqual",\ - "RelativelyEqual"] -def makeModuleReal(maxRank=5, quiet=False): - assertionShortNames=relationalOperatorShortNames -# assertionShortNames=["NotEqual",\ -# "Equal",\ -# "GreaterThan",\ -# "GreaterThanOrEqual",\ -# "LessThan",\ -# "LessThanOrEqual",\ -# "RelativelyEqual"] - for iRank in range(0,maxRank+1): - foundRanks = [iRank] - mod = constructModule( \ - assertionShortNames=assertionShortNames,\ - foundRanks=foundRanks) - with open(mod.getFileName(),'w') as f: - f.write(filePreamble(mod.getFileName())) - f.write('\n'.join(mod.generate())) - addFileToMakefile(mod.getFileName(), quiet=quiet) - for iName in assertionShortNames : - addModToF90Include(mod.getName(),postFix=", only : " + 'Assert'+iName) - #print('makeModuleReal: done') - return - -def makeModuleComplex(maxRank=5, quiet=False): - assertionShortNames=['NotEqual','Equal','RelativelyEqual'] - for iRank in range(0,maxRank+1): - foundRanks = [iRank] - mod = constructModule(baseName='AssertComplex',\ - assertionShortNames=assertionShortNames,\ - foundFTypes=['real','complex'],\ - foundRanks=foundRanks,\ - patchIntXX=True) - with open(mod.getFileName(),'w') as f: - f.write(filePreamble(mod.getFileName())) - f.write('\n'.join(mod.generate())) - addFileToMakefile(mod.getFileName(), quiet=quiet) - for iName in assertionShortNames : - addModToF90Include(mod.getName(),postFix=", only : " + 'assert'+iName) - #print('makeModuleComplex: done') - return - -def makeModuleInteger(maxRank=5, quiet=False): - # assertionShortNames=['Equal'] - assertionShortNames=\ - ["NotEqual",\ - "Equal",\ - "GreaterThan",\ - "GreaterThanOrEqual",\ - "LessThan",\ - "LessThanOrEqual"] - - for iRank in range(0,maxRank+1): - foundRanks=[iRank] - mod = constructModule(baseName='AssertInteger',\ - assertionShortNames=assertionShortNames,\ - foundFTypes=['integer'],\ - foundRanks=foundRanks) - with open(mod.getFileName(),'w') as f: - f.write(filePreamble(mod.getFileName())) - f.write('\n'.join(mod.generate())) - addFileToMakefile(mod.getFileName(), quiet=quiet) -# Not ready to add integers to AssertArrays... - for iName in assertionShortNames : - addModToF90Include(mod.getName(),postFix=", only : " + 'assert'+iName) - #print('makeModuleInteger: done') - return - -# def makeModuleLogical(): -# mod = constructModule(baseName='AssertLogical1',foundFTypes=['logical']) -# with open(mod.getFileName(),'w') as f: -# f.write(filePreamble(mod.getFileName())) -# f.write('\n'.join(mod.generate())) -# print('makeModuleInteger: done') -# return - -def makeSupportModule(assertionShortNames=[],maxRank=5, quiet=False): -# print ('1000: aSN: ',assertionShortNames) - mod = constructSupportModule(assertionShortNames=assertionShortNames,maxRank=maxRank) - with open(mod.getFileName(),'w') as f: - f.write(filePreamble(mod.getFileName())) - f.write('\n'.join(mod.generate())) - addFileToMakefile(mod.getFileName(), quiet=quiet) -# for iName in assertionShortNames : -# addModToF90Include(mod.getName(),postFix=", only : " + 'assert'+iName) - #print('makeSupportModule: done') - return - -def makeInternalModule(assertionShortNames=[],maxRank=5, quiet=False): - for iAssertion in assertionShortNames : - mod = constructInternalModule(assertionShortName=iAssertion,maxRank=maxRank) - with open(mod.getFileName(),'w') as f: - f.write(filePreamble(mod.getFileName())) - f.write('\n'.join(mod.generate())) - addFileToMakefile(mod.getFileName(), quiet=quiet) -#??? -# Do I need to addModToF90Include? - -#???? -# for iName in assertionShortNames : -# addModToF90Include(mod.getName(),postFix=", only : " + 'assert'+iName) - #print('makeInternalModule: done') - return - - -def main(maxRank=5, quiet=False): - # Make the modules for the different types... - # - makeGeneratedInclude(includeFile="generated.inc") - #++ - makeModuleReal(maxRank=maxRank, quiet=quiet) - #++ - makeModuleComplex(maxRank=maxRank, quiet=quiet) - #? The following requires testing. - makeModuleInteger(maxRank=maxRank, quiet=quiet) - #? Just started... - #- makeModuleLogical() - - # Make the routines that do the work. - makeInternalModule(assertionShortNames=relationalOperatorShortNames,maxRank=maxRank, quiet=quiet) - - # Make the intermediate routines. - makeSupportModule(assertionShortNames=relationalOperatorShortNames,maxRank=maxRank, quiet=quiet) - - return - -if __name__ == "__main__": - main(maxRank=int(args.maxRank or 5), quiet=args.quiet if 'quiet' in args else False) diff --git a/tests/pFUnit-3.2.9/source/GeneratedSources.py b/tests/pFUnit-3.2.9/source/GeneratedSources.py deleted file mode 100755 index 4052d6a6..00000000 --- a/tests/pFUnit-3.2.9/source/GeneratedSources.py +++ /dev/null @@ -1,40 +0,0 @@ -#!/usr/bin/env python -# For python 2.6-2.7 -from __future__ import print_function -# For python2.5 -# from __future__ import with_statement - -import re -import sys - -includeFile="generated.inc" -cmakeIncludeFile="cmakeGenerated.inc" - -generatedFiles = [] -with open(includeFile,'r') as f: - l0 = f.readline() - lines = f.readlines() - generatedFiles = [(re.match(r'(.*)\+\= (.*)',line)).group(2) for line in lines] -# for line in lines: -# obj = re.match(r'(.*)\+\= (.*)',line) -# print (' : "'+obj.group()+'"') -# print ('1: "'+obj.group(2)+'"') -# print (generatedFiles) -#+++ print (''+' '.join(generatedFiles)) -# print ('\n'+'\n'.join(generatedFiles)) - -with open(cmakeIncludeFile,'w') as f: - for i in generatedFiles: - f.write('list(APPEND srcs '+i+' )\n') - - -# print (cmakeIncludeFile) -sys.stdout.write(cmakeIncludeFile) - - - - - - - - diff --git a/tests/pFUnit-3.2.9/source/MakeDependenciesInc b/tests/pFUnit-3.2.9/source/MakeDependenciesInc deleted file mode 100755 index edca0b75..00000000 --- a/tests/pFUnit-3.2.9/source/MakeDependenciesInc +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/bash - -# pFUnit source/MakeDependenciesInc - -# Construct the makefile include, setting off the MPI files in an -# ifdef USEMPI. - -# $1 is the file of dependencies, dependencies.tmp -# $2 is the output file, dependencies.inc - -export tmpFile=$1 -# outFile=$2 - -# tmpFile=./dependencies.tmp -outFile=./dependencies.inc - -#+echo MakeDependenciesInc: Writing to ${outFile} -cat ${tmpFile} | grep -iv Mpi\*.o > ${outFile}; - cat ${tmpFile} | grep -i pfunit\*.o | sed 's/[a-zA-Z0-9]*[m|M]pi[.a-zA-Z0-9]*//g' >> ${outFile}; - echo -e "\nifeq (\$(USEMPI),YES)\n" >> ${outFile}; - cat ${tmpFile} | grep -i Mpi\*.o >> ${outFile}; - echo -e "\nendif\n" >> ${outFile} - -# The following converts the occurrences of .o in ${outFile} to $(OBJ_EXT) -sed -i -e 's&\.o&$(OBJ_EXT)&g' ${outFile} - -\rm -f ${outFile}-e diff --git a/tests/pFUnit-3.2.9/source/MakeDependenciesTmp b/tests/pFUnit-3.2.9/source/MakeDependenciesTmp deleted file mode 100755 index 101359c6..00000000 --- a/tests/pFUnit-3.2.9/source/MakeDependenciesTmp +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/bash - -# pFUnit source/MakeDependenciesIncludeCollectUseStatements - -# Collect into $3 the USE statements from $2, the preprocessed version -# of $1. These are collected into the pattern: -# filename.o: usePredicate1.F90... -# -# $1 is the file.F90 -# $2 is the file_cpp.f90 -# $3 is dependencies.tmp - -# We do not automatically check to see if references are satisfied -# within the using file, so we can IGNORE those references by naming -# them here. -# -# Note: PrivateException is in Exception.F90, there is no -# PrivateException.F90 or PrivateException.o. -# -IGNORE="PrivateException" -# May need to consider case, however if we stick to our current coding -# style, we should be okay. - -# Have trouble with commented use statements... see grep -v "\!" below. -# Need to watch out for use statements that refer to tokens with use or used. -# Also may have some trouble with files/modules with "use" in their names. - -FILENAME=$1 -FILENAME_CPP=$2 -TMPFILE=$3 - -# echo MDICUS: ${FILENAME} ${FILENAME_CPP} ${TMPFILE} - - echo `echo ${FILENAME} | cut -f 1 -d. - `".o: " | tr -d "\n" >> ${TMPFILE}; - grep -i use ${FILENAME_CPP} | grep -v used | cut -d, -f1 - | sort | tr -s " \t\v" | uniq - | \ - egrep -v ${IGNORE} | \ - sed 's/use//g' | sed 's/_mod/.o/g' | egrep "\.o" | grep -v "\!\!" | tr -d "\n" | tr -s " \t\v" >> ${TMPFILE}; - echo -e "\n" >> ${TMPFILE}; diff --git a/tests/pFUnit-3.2.9/source/Mock.F90 b/tests/pFUnit-3.2.9/source/Mock.F90 deleted file mode 100644 index 072df6f9..00000000 --- a/tests/pFUnit-3.2.9/source/Mock.F90 +++ /dev/null @@ -1,54 +0,0 @@ - -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: Mock -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 12 May 2014 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 12 May 2014 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- - -module Mock_mod - - use MockRepository_mod - - implicit none - private - - public :: Mock - - type Mock - character(len=MAX_LEN_METHOD_NAME) :: name = '' - type(MockRepository) :: repository -! procedure(subI), pointer, nopass :: sub - contains - procedure registerCall - end type Mock - - -contains - -! function newMock(name,signature,mockRepo) result(mock) - - subroutine registerCall(this) - class(Mock), intent(inout) :: this - call this%repository%registerMockCallBy(this%name) - end subroutine registerCall - -end module Mock_mod - - diff --git a/tests/pFUnit-3.2.9/source/MockCall.F90 b/tests/pFUnit-3.2.9/source/MockCall.F90 deleted file mode 100644 index 1baf36ae..00000000 --- a/tests/pFUnit-3.2.9/source/MockCall.F90 +++ /dev/null @@ -1,60 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: MockCall -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module MockCall_mod - use Exception_mod - implicit none - private - - public :: MockCall - public :: newMockCall - integer, parameter :: MAXLEN_METHOD_NAME = 32 - type MockCall - character(len=MAXLEN_METHOD_NAME) :: methodName - class(*), pointer :: argument - contains - procedure :: expect - procedure :: getExpectedValue - end type MockCall - -contains - - function newMockCall(name) result(mCall) - character(len=*), intent(in) :: name - type (MockCall) :: mCall - - mCall%methodName = name - end function NewMockCall - - subroutine expect(this, expectedArgument) - class (MockCall), intent(inout) :: this - class(*), target, intent(in) :: expectedArgument - this%argument => expectedArgument - end subroutine expect - - function getExpectedValue(this) result(p) - class(MockCall), intent(in) :: this - class(*), pointer :: p - p => this%argument - end function getExpectedValue - -end module MockCall_mod diff --git a/tests/pFUnit-3.2.9/source/MockRepository.F90 b/tests/pFUnit-3.2.9/source/MockRepository.F90 deleted file mode 100644 index 196e72ce..00000000 --- a/tests/pFUnit-3.2.9/source/MockRepository.F90 +++ /dev/null @@ -1,288 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: MockRepository -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module MockRepository_mod - use Expectation_mod, only : Expectation, newExpectation - use Expectation_mod, only : Subject, newSubject, newSubjectNameOnly - use Expectation_mod, only : Predicate, newPredicate - use Expectation_mod, only : wasCalled, wasNotCalled, wasCalledOnce - - implicit none - private - - public :: MockRepository - public :: newMockRepository - public :: MockRepositoryPointer - public :: MAX_LEN_METHOD_NAME - public :: MAX_LEN_CALL_REGISTRATION - - integer, parameter :: MAX_LEN_METHOD_NAME = 32 - integer, parameter :: MAX_LEN_CALL_REGISTRATION = 32 - type MockRepository - ! mlr todo Allocatable strings are available... - ! mlr todo test under nag - character(len=MAX_LEN_METHOD_NAME) :: method = ' ' - type(Expectation) :: Expectations(2) - integer :: lastExpectation = 0 - ! character(len=MAX_LEN_CALL_REGISTRATION) :: callRegistry(2) ! make dynamic... - type(Expectation) :: callRegistry(2) - integer :: lastRegistration = 0 - - contains - procedure :: verifyMocking - - procedure :: expectCall - procedure :: hasCalled - - generic :: addExpectationThat => addExpectationThat_sub_ - generic :: addExpectationThat => addExpectationThat_subNameOnly_ - - procedure :: addExpectationThat_sub_ - procedure :: addExpectationThat_subNameOnly_ - - generic :: registerMockCallBy => registerMockCallBy_subName_ - - procedure :: registerMockCallBy_subName_ - - procedure :: verify - - ! final? - procedure :: delete - - end type MockRepository - - interface addExpectationThat_ - module procedure addExpectationThat_sub_ - module procedure addExpectationThat_subNameOnly_ - end interface addExpectationThat_ - - interface registerMockCallBy_ - module procedure registerMockCallBy_subName_ - end interface registerMockCallBy_ - - interface - subroutine subVoid - end subroutine subVoid - end interface - -! interface -! module procedure addExpectationThat_sub_ -! end interface - - class (MockRepository), pointer :: MockRepositoryPointer => null() - -contains - -!! Begin older code - - function newMockRepository() result(repository) - type (MockRepository), pointer :: repository -! type (MockRepository), allocatable, target :: repository - if ( associated(MockRepositoryPointer) ) then - print *,'MockRepository::ERROR::RepositoryAlreadyAllocated' - end if - allocate(repository) - MockRepositoryPointer => repository - repository%lastExpectation = 0 - repository%lastRegistration = 0 - end function newMockRepository - - subroutine delete (this) - class (MockRepository), intent(inout) :: this - - nullify(MockRepositoryPointer) - - end subroutine delete - - subroutine verifyMocking(this, object) - use Exception_mod - class (MockRepository), intent(inout) :: this - class (*) :: object - - if (trim(this%method) /= '') then - call throw('Expected method not called: method1() on object of class MockSUT.') - end if - - ! Only need to verify once. Finish it off... - call this%delete() - - end subroutine verifyMocking - - subroutine expectCall(this, obj, method) - class (MockRepository), intent(inout) :: this - class(*), intent(in) :: obj - character(len=*), intent(in) :: method - - this%method = method - end subroutine expectCall - - subroutine hasCalled(this, obj, method) - class (MockRepository), intent(inout) :: this - class(*), intent(in) :: obj - character(len=*), intent(in) :: method - - if (trim(method) == trim(this%method)) then - this%method='' - end if - end subroutine hasCalled - -!! End older code - - subroutine addExpectationThat_sub_(this,sub,pred) - class (MockRepository), intent(inout) :: this - procedure(subVoid), pointer, intent(in) :: sub -! procedure(subVoid), pointer, intent(in) :: subptr - type(Predicate), intent(in) :: pred - type(Expectation) exp - - exp = newExpectation( & - & newSubject( 'dummy-sub-name', sub), & - & pred ) - - ! & - this%lastExpectation = this%lastExpectation + 1 - this%Expectations(this%lastExpectation) = exp - - end subroutine addExpectationThat_sub_ - - subroutine addExpectationThat_subNameOnly_(this,subName,pred) - class (MockRepository), intent(inout) :: this - character(len=*), intent(in) :: subName -! procedure(subVoid), pointer, intent(in) :: sub -! procedure(subVoid), pointer, intent(in) :: subptr - type(Predicate), intent(in) :: pred - type(Expectation) exp - - exp = newExpectation( & - & newSubjectNameOnly( subName ), & - & pred ) - - ! & - this%lastExpectation = this%lastExpectation + 1 - this%Expectations(this%lastExpectation) = exp - - end subroutine addExpectationThat_subNameOnly_ - - subroutine registerMockCallBy_subName_(this,subName) - class (MockRepository), intent(inout) :: this - character(len=*), intent(in) :: subName -! print *,'reg200: ',subName,this%lastRegistration - ! Can we includ the calling sub here? For a better comparison with our Exp. list? - ! - this%lastRegistration = this%lastRegistration + 1 - this%callRegistry(this%lastRegistration) & - & = newExpectation( & ! mlr todo Expectation --> foundAction -- "Result" - & newSubjectNameOnly(subName), & - & wasCalled ) - end subroutine registerMockCallBy_subName_ - - subroutine verify(this) - use Exception_mod - class (MockRepository), intent(inout), target :: this - integer iExp, iReg - class (Expectation), pointer :: exp, reg - logical ok - integer nCalls - - ! Go through expectation logic. Note: Maybe use original list of strings approach. - ! Need to work out more complex logic. Ess. need logic analyzer. - ! Eventually, expectations should probably be trees. - - ! Maybe rework the following into "expected vs. found" for greater alignment - ! with existing usage in PFUNIT. Also consider existing capabilities in PFUNIT. - -! mlr todo -- verify should not be hardwired for the things it has to handle -! todo -- refactor expectations & foundActionResult -- recall interpreter implementation -! - - - do iExp=1,this%lastExpectation ! 'with' syntax? - exp => this%Expectations(iExp) - ok = .false. - -! if(exp%pred%name .eq. 'wasCalled')then -! ok = .false. -! do iReg=1,this%lastRegistration -! reg = this%callRegistry(iReg) -!! print *,'verify1000: ', & -!! & trim(exp%subj%name)//'='// & -!! & trim(reg%subj%name)//', '// & -!! & trim(exp%pred%name)//'='// & -!! & trim(reg%pred%name)//'.' -! if(exp%subj%name .eq. reg%subj%name) then -! if(exp%pred%name .eq. reg%pred%name) then -! !??? if(exp%pred .eq. reg%pred) then -! ok=.true. -! end if -! end if -! end do -! end if -! -! if(exp%pred%name .eq. 'wasNotCalled')then -! ok = .true. -! do iReg=1,this%lastRegistration -! reg = this%callRegistry(iReg) -! if(exp%subj%name .eq. reg%subj%name) then -! if(trim(reg%pred%name).eq.'wasCalled')then -! ok = .false. -! end if -! end if -! end do -! end if - - if( & - & (exp%pred%name .eq. 'wasCalled') .or. & - & (exp%pred%name .eq. 'wasCalledOnce') .or. & - & (exp%pred%name .eq. 'wasNotCalled') & - & )then - ok = .true. - nCalls = 0 - do iReg=1,this%lastRegistration - reg => this%callRegistry(iReg) - if(exp%subj%name .eq. reg%subj%name) then - if(trim(reg%pred%name).eq.'wasCalled')then - nCalls=nCalls+1 - end if - end if - end do - if(exp%pred%name .eq. 'wasCalled')then - ok = nCalls.ge.1 - else if(exp%pred%name .eq. 'wasCalledOnce')then - ok = nCalls.eq.1 - else if(exp%pred%name .eq. 'wasNotCalled')then - ok = nCalls.eq.0 - end if - - end if - - if(.not.ok)then - call throw('Expectations not met: "'// & - & trim(exp%subj%name)//'" "'//trim(exp%pred%name)//'" does not hold.') - end if - end do - - ! call throw('exception%verify: Not implemented') - - end subroutine verify - - -end module MockRepository_mod diff --git a/tests/pFUnit-3.2.9/source/MpiContext.F90 b/tests/pFUnit-3.2.9/source/MpiContext.F90 deleted file mode 100644 index b3ac2e48..00000000 --- a/tests/pFUnit-3.2.9/source/MpiContext.F90 +++ /dev/null @@ -1,339 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: MpiContext -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module MpiContext_mod - use ParallelContext_mod - use Exception_mod, only: throw - implicit none - private - - public :: MpiContext - public :: newMpiContext - - include 'mpif.h' - - type, extends(ParallelContext) :: MpiContext - private - integer :: mpiCommunicator = MPI_COMM_NULL - integer :: root = 0 - contains - procedure :: isActive - procedure :: getNumProcesses - procedure :: processRank - procedure :: isRootProcess - procedure :: makeSubcontext - procedure :: barrier - procedure :: getMpiCommunicator - procedure :: makeMap - procedure :: sum - procedure :: gatherString - procedure :: gatherInteger - procedure :: gatherLogical - procedure :: allReduce - procedure :: labelProcess - -!!$ final :: clean - end type MpiContext - - interface newMpiContext - module procedure newMpiContext_world - module procedure newMpiContext_comm - end interface - -contains - - ! Use MPI_COMM_WORLD - avoid except in main program - function newMpiContext_world() result(context) - type (MpiContext) :: context - context = newMpiContext(MPI_COMM_WORLD) - end function newMpiContext_world - - ! Make a duplicate of the communicator for internal use - function newMpiContext_comm(communicator) result(context) - type (MpiContext) :: context - integer, intent(in) :: communicator - integer :: ier - - call MPI_Comm_dup(communicator, context%mpiCommunicator, ier) - context%root = 0 - - end function newMpiContext_comm - - logical function isActive(this) - class (MpiContext), intent(in) :: this - - isActive = (this%mpiCommunicator /= MPI_COMM_NULL) - - end function isActive - - integer function getNumProcesses(this) - class (MpiContext), intent(in) :: this - - integer :: ier - call MPI_Comm_size(this%mpiCommunicator, getNumProcesses, ier) - if (ier /= MPI_SUCCESS) call throw('failure in MpiContext::numProcesses') - - end function getNumProcesses - - integer function processRank(this) - class (MpiContext), intent(in) :: this - - integer :: ier - call MPI_Comm_rank(this%mpiCommunicator, processRank, ier) - if (ier /= MPI_SUCCESS) call throw('failure in MpiContext::processRank') - - end function processRank - - logical function isRootProcess(this) - class (MpiContext), intent(in) :: this - - isRootProcess = (this%root == this%processRank()) - - end function isRootProcess - - ! Returns a new context which represents just a subset of the - ! processes in the current group. - function makeSubcontext(this, numSubprocesses) result(subContext) - use Exception_mod - class (MpiContext), intent(in) :: this - integer, intent(in) :: numSubprocesses - type (MpiContext) :: subContext - - integer, parameter :: NUM_SUBGROUPS = 1 - integer :: originalGroup, newGroups(NUM_SUBGROUPS) - integer :: ranges(3,NUM_SUBGROUPS) - integer :: newCommunicator - integer :: ier - integer npes - - if (numSubprocesses > this%getNumProcesses()) then - call throw('Insufficient processes to run this test.') - return - end if - if (numSubprocesses < 0) then - call throw('Must specify a nonnegative number of processes for MPI test.') - return - end if - - call Mpi_Comm_group(this%mpiCommunicator, originalGroup, ier) - - if (numSubprocesses == 0) then - npes = this%getNumProcesses() - else - npes = numSubprocesses - end if - - ranges(:,1) = [0, npes-1, 1] - - call MPI_Group_range_incl (originalGroup, NUM_SUBGROUPS, ranges, newGroups, ier) - call MPI_Comm_create(this%mpiCommunicator, newGroups(1), newCommunicator, ier) - - if (this%processRank() < npes) then - subContext%mpiCommunicator = newCommunicator - subContext%root = 0 - else - subContext%mpiCommunicator = MPI_COMM_NULL - subContext%root = -1 - end if - - - end function makeSubcontext - - subroutine barrier(this) - class (MpiContext), intent(in) :: this - integer :: ier - call Mpi_barrier(this%mpiCommunicator, ier) - if (ier /= MPI_SUCCESS) call throw('failure in MpiContext::barrier') - end subroutine barrier - - integer function getMpiCommunicator(this) result(mpiCommunicator) - class (MpiContext), intent(in) :: this - mpiCommunicator = this%mpiCommunicator - end function getMpiCommunicator - - integer function sum(this, value) - class (MpiContext), intent(in) :: this - integer, intent(in) :: value - - integer :: ier - integer :: tmp - - call mpi_allreduce(value, tmp, 1, MPI_INTEGER, MPI_SUM, & - & this%mpiCommunicator, ier) - sum = tmp - - end function sum - - subroutine makeMap(this, numEntries, counts, displacements) - class (MpiContext), intent(in) :: this - integer, intent(in) :: numEntries - integer, allocatable :: counts(:) - integer, allocatable :: displacements(:) - - integer :: p - integer :: npes - integer :: ier - - npes = this%getNumProcesses() - - allocate(counts(0:npes-1), displacements(0:npes-1)) - - call Mpi_AllGather(numEntries, 1, MPI_INTEGER, counts, 1, MPI_Integer, & - & this%mpiCommunicator, ier) - - displacements(0) = 0 - do p = 1, npes - 1 - displacements(p) = displacements(p-1) + counts(p-1) - end do - - end subroutine makeMap - - subroutine gatherString(this, values, list) - class (MpiContext), intent(in) :: this - character(len=*), intent(in) :: values(:) - character(len=*), intent(out) :: list(:) - - integer, allocatable :: counts(:), displacements(:) - - - integer :: numBytes, numEntries - integer :: ier - integer :: i, j, jp - character(len=1), allocatable :: sendBuffer(:) - character(len=1), allocatable :: recvBuffer(:) - character(len=len(list)) :: buf - - intrinsic :: sum - - if (size(list) == 0) return - - numBytes = len(list(1)) ! values may be size 0 on some processes, but not all - numEntries = size(values) * numBytes - - call this%makeMap(numEntries, counts, displacements) - - allocate(sendBuffer(max(numEntries,1))) - do i = 1, size(values) - do j = 1, numBytes - jp = j + (i-1)*numBytes - sendBuffer(jp:jp) = values(i)(j:j) - end do - end do - - allocate(recvBuffer(max(sum(counts),1))) - - call Mpi_GatherV( & - & sendBuffer, numEntries, MPI_CHARACTER, & - & recvBuffer, counts, displacements, MPI_CHARACTER, & - & this%root, this%mpiCommunicator, ier) - - if (this%isRootProcess()) then - do i = 1, sum(counts)/len(list(1)) - do j = 1, numBytes - jp = j+(i-1)*numBytes - buf(j:j) = recvBuffer(jp) - end do - list(i) = buf - end do - end if - - deallocate(sendBuffer, recvBuffer) - - deallocate(counts, displacements) - - end subroutine gatherString - - subroutine gatherInteger(this, values, list) - class (MpiContext), intent(in) :: this - integer, intent(in) :: values(:) - integer, intent(out) :: list(:) - - integer, allocatable :: counts(:), displacements(:) - integer :: ier - - call this%makeMap(size(values), counts, displacements) - call Mpi_allGatherV( & - & values, size(values), MPI_INTEGER, & - & list, counts, displacements, MPI_INTEGER, & - & this%mpiCommunicator, ier) - - deallocate(counts, displacements) - - end subroutine gatherInteger - - subroutine gatherLogical(this, values, list) - class (MpiContext), intent(in) :: this - logical, intent(in) :: values(:) - logical, intent(out) :: list(:) - - integer, allocatable :: counts(:), displacements(:) - integer :: ier - logical, allocatable :: values_(:) ! mpi hates 0 sized arrays - - call this%makeMap(size(values), counts, displacements) - - allocate(values_(max(1, size(values)))) - values_(:size(values)) = values - - call Mpi_AllgatherV( & - & values_, size(values), MPI_LOGICAL, & - & list, counts, displacements, MPI_LOGICAL, & - & this%mpiCommunicator, ier) - - deallocate(counts, displacements) - - end subroutine gatherLogical - - subroutine labelProcess(this, message) - class (MpiContext), intent(in) :: this - character(len=*), intent(inout) :: message - - integer, parameter :: MAXLEN_SUFFIX = 80 - character(len=MAXLEN_SUFFIX) :: suffix - - write(suffix,'(" (PE=",i0,")")') this%processRank() - - message = trim(message) // trim(suffix) - - end subroutine labelProcess - - logical function allReduce(this, q) result(anyQ) - class (MpiContext), intent(in) :: this - logical, intent(in) :: q - - integer :: ier - - call MPI_Allreduce(q, anyQ, 1, MPI_LOGICAL, MPI_LOR, & - & this%mpiCommunicator, ier) - - end function allReduce - - - subroutine clean(this) - type (MpiContext), intent(inout) :: this - integer :: ier -!!$ call debug(__LINE__,__FILE__) -!!$ call MPI_Comm_free(this%mpiCommunicator, ier) -!!$ call debug(__LINE__,__FILE__) - end subroutine clean - -end module MpiContext_mod diff --git a/tests/pFUnit-3.2.9/source/MpiStubs.F90 b/tests/pFUnit-3.2.9/source/MpiStubs.F90 deleted file mode 100644 index d70c79b1..00000000 --- a/tests/pFUnit-3.2.9/source/MpiStubs.F90 +++ /dev/null @@ -1,114 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: MpiStubs -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module MpiStubs_mod - implicit none - private - - public :: MPI_COMM_WORLD - public :: MPI_COMM_NULL - public :: MPI_COMM_SUCCESS - public :: MPI_Comm_rank - public :: MPI_Comm_size - public :: MPI_Comm_dup - public :: MPI_Comm_group - public :: MPI_Group_range_incl - public :: MPI_Comm_create - - integer, parameter :: MPI_COMM_WORLD = -1 - integer, parameter :: MPI_COMM_NULL = -1 - integer, parameter :: MPI_COMM_SUCCESS = 0 - - integer :: nextCommunicator = MPI_COMM_WORLD - -contains - - subroutine MPI_Comm_rank(comm, rank, ier) - integer, intent(in) :: comm - integer, intent(out) :: rank - integer, intent(out) :: ier - - rank = 0 - ier = MPI_COMM_SUCCESS - - end subroutine MPI_Comm_rank - - subroutine MPI_Comm_size(comm, size, ier) - integer, intent(in) :: comm - integer, intent(out) :: size - integer, intent(out) :: ier - - size = 1 - ier = MPI_COMM_SUCCESS - - end subroutine MPI_Comm_size - - subroutine MPI_Comm_dup(comm, newComm, ier) - integer, intent(in) :: comm - integer, intent(out) :: newComm - integer, intent(out) :: ier - - - newComm = newCommunicator() - ier = MPI_COMM_SUCCESS - - end subroutine MPI_Comm_dup - - subroutine MPI_Comm_group(comm, group, ier) - integer, intent(in) :: comm - integer, intent(out) :: group - integer, intent(out) :: ier - - group = 0 - ier = MPI_COMM_SUCCESS - - end subroutine MPI_Comm_group - - subroutine MPI_Group_range_incl(group, n, ranges, newGroups, ier) - integer, intent(in) :: group - integer, intent(in) :: n - integer, intent(in) :: ranges(3,n) - integer, intent(out) :: newGroups(n) - integer, intent(out) :: ier - - newGroups = 0 - ier = MPI_COMM_SUCCESS - - end subroutine MPI_Group_range_incl - - subroutine MPI_Comm_create(comm, group, newComm, ier) - integer, intent(in) :: comm - integer, intent(in) :: group - integer, intent(out) :: newComm - integer, intent(out) :: ier - - newComm = newCommunicator() - ier = MPI_COMM_SUCCESS - - end subroutine MPI_Comm_create - - integer function newCommunicator() - nextCommunicator = nextCommunicator + 1 - newCommunicator = nextCommunicator - end function newCommunicator - -end module MpiStubs_mod diff --git a/tests/pFUnit-3.2.9/source/MpiTestCase.F90 b/tests/pFUnit-3.2.9/source/MpiTestCase.F90 deleted file mode 100644 index ff07ccc0..00000000 --- a/tests/pFUnit-3.2.9/source/MpiTestCase.F90 +++ /dev/null @@ -1,143 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: MpiTestCase -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- - -module MpiTestCase_mod - use MpiContext_mod - use TestCase_mod - use AbstractTestParameter_mod - use MpiTestParameter_mod - use ParameterizedTestCase_mod, only: ParameterizedTestCase -!!$ use ParameterizedTestCase_mod, only: MAX_LEN_LABEL - implicit none - private - - public :: MpiTestCase - - type, abstract, extends(ParameterizedTestCase) :: MpiTestCase - integer :: processRank - type (MpiContext) :: context - type (MpiContext) :: parentContext - contains - procedure :: countTestCases => countTestCases_mpi - procedure :: run - procedure :: runBare - procedure :: getNumProcesses - procedure :: getNumProcessesRequested - procedure :: getProcessRank - procedure :: getMpiCommunicator - procedure :: getContext - end type MpiTestCase - -contains - - integer function countTestCases_mpi(this) result(countTestCases) - class (MpiTestCase), intent(in) :: this - countTestCases = 1 - end function countTestCases_mpi - - recursive subroutine run(this, tstResult, context) - use TestResult_mod, only: TestResult - use ParallelContext_mod - use Exception_mod - use SurrogateTestCase_mod - class (MpiTestCase), intent(inout) :: this - class (TestResult), intent(inout) :: tstResult - class (ParallelContext), intent(in) :: context - - select type (context) - type is (MpiContext) - this%parentContext = context - class default - call throw('MPI test cannot run in a non-MPI context.') - return - end select - - call tstResult%run(this%getSurrogate(), context) - - end subroutine run - - recursive subroutine runBare(this) - use Exception_mod - use ParallelException_mod - class (MpiTestCase), intent(inout) :: this - - logical :: discard - - ! create subcommunicator - this%context = this%parentContext%makeSubcontext(this%getNumProcessesRequested()) - - if (.not. anyExceptions(this%parentContext)) then - if (this%context%isActive()) then - call this%setUp() - - if (.not. anyExceptions(this%context)) then - call this%runMethod() - call this%tearDown() - end if - end if - else - ! only report context failure on root PE - if (.not. this%parentContext%isRootProcess()) then - discard = catch() - end if - end if - - call gather(this%parentContext) - - end subroutine runBare - - integer function getMpiCommunicator(this) result(mpiCommunicator) - class (MpiTestCase), intent(in) :: this - mpiCommunicator = this%context%getMpiCommunicator() - end function getMpiCommunicator - - integer function getNumProcesses(this) result(numProcesses) - class (MpiTestCase), intent(in) :: this - numProcesses = this%context%getNumProcesses() - end function getNumProcesses - - integer function getNumProcessesRequested(this) result(numProcessesRequested) - use Exception_mod - class (MpiTestCase), intent(in) :: this - select type (p => this%testParameter) - class is (MpiTestParameter) - numProcessesRequested = p%getNumProcessesRequested() - class default - call throw('Incorrect type of test parameter in MpiTestCase::getNumProcessesRequested()') - end select - end function getNumProcessesRequested - - integer function getProcessRank(this) result(processRank) - class (MpiTestCase), intent(in) :: this - processRank = this%context%processRank() - end function getProcessRank - - function getContext(this) result(context) - class (MpiTestCase), intent(in) :: this - class (MpiContext), allocatable :: context - - allocate(context, source=this%context) - - end function getContext - -end module MpiTestCase_mod diff --git a/tests/pFUnit-3.2.9/source/MpiTestMethod.F90 b/tests/pFUnit-3.2.9/source/MpiTestMethod.F90 deleted file mode 100644 index 7addc0c5..00000000 --- a/tests/pFUnit-3.2.9/source/MpiTestMethod.F90 +++ /dev/null @@ -1,107 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: MpiTestMethod -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module MpiTestMethod_mod - use Test_mod - use TestCase_mod - use MpiTestCase_mod - use MpiTestParameter_mod - implicit none - private - - public :: MpiTestMethod - public :: newMpiTestMethod - - interface newMpiTestMethod - module procedure newMpiTest_basic - module procedure newMpiTest_setUpTearDown - end interface newMpiTestMethod - -!!$ interface MpiTestMethod -!!$ module procedure newMpiTest_basic -!!$ module procedure newMpiTest_setUpTearDown -!!$ end interface MpiTestMethod - - type, extends(MpiTestCase) :: MpiTestMethod - procedure(mpiMethod), pointer :: userMethod => null() - procedure(mpiMethod), nopass, pointer :: userSetUp => null() - procedure(mpiMethod), nopass, pointer :: userTearDown => null() - contains - procedure :: runMethod - procedure :: setUp - procedure :: tearDown - end type MpiTestMethod - - abstract interface - subroutine mpiMethod(this) - import MpiTestMethod - class (MpiTestMethod), intent(inout) :: this - end subroutine mpiMethod - end interface - -contains - - function newMpiTest_basic(name, userMethod, numProcesses) result(mpiTest) - character(len=*), intent(in) :: name - procedure (runMethod) :: userMethod - integer, intent(in) :: numProcesses - type (MpiTestMethod) :: mpiTest - - call mpiTest%setName(name) - mpiTest%userMethod => userMethod - call mpiTest%setTestParameter(MpiTestParameter(numProcesses)) - - end function newMpiTest_basic - - function newMpiTest_setUpTearDown(name, userMethod, numProcesses, setUp, tearDown) result(mpiTest) - character(len=*), intent(in) :: name - procedure (runMethod) :: userMethod - integer, intent(in) :: numProcesses - type (MpiTestMethod) :: mpiTest - procedure (runMethod) :: setUp - procedure (runMethod) :: tearDown - - call mpiTest%setName(name) - mpiTest%userMethod => userMethod - call mpiTest%setTestParameter(MpiTestParameter(numProcesses)) - - mpiTest%userSetUp => setUp - mpiTest%userTearDown => tearDown - - end function newMpiTest_setUpTearDown - - subroutine runMethod(this) - class (MpiTestMethod), intent(inout) :: this - call this%userMethod() - end subroutine runMethod - - subroutine setUp(this) - class (MpiTestMethod), intent(inout) :: this - if (associated(this%userSetUp)) call this%userSetUp(this) - end subroutine setUp - - subroutine tearDown(this) - class (MpiTestMethod), intent(inout) :: this - if (associated(this%userTearDown)) call this%userTearDown(this) - end subroutine tearDown - -end module MpiTestMethod_mod diff --git a/tests/pFUnit-3.2.9/source/MpiTestParameter.F90 b/tests/pFUnit-3.2.9/source/MpiTestParameter.F90 deleted file mode 100644 index a943bbd4..00000000 --- a/tests/pFUnit-3.2.9/source/MpiTestParameter.F90 +++ /dev/null @@ -1,79 +0,0 @@ -module MpiTestParameter_mod - use AbstractTestParameter_mod - implicit none - private - - public :: MpiTestParameter - public :: newMpiTestParameter - - ! We can request as many processes as we like. - ! If available, actual = request. Otherwise throw an exception at run() - type, extends(AbstractTestParameter) :: MpiTestParameter - integer :: numProcessesRequested - contains - procedure :: setNumProcessesRequested - procedure :: getNumProcessesRequested - procedure :: toString - procedure :: toStringActual - end type MpiTestParameter - -!!$ interface MpiTestParameter -!!$ module procedure :: newMpiTestParameter -!!$ end interface MpiTestParameter - -contains - - ! Note that npes requested may not be available. - function newMpiTestParameter(numProcessesRequested) result(testParameter) - type (MpiTestParameter) :: testParameter - integer, intent(in) :: numProcessesRequested - - call testParameter%setNumProcessesRequested(numProcessesRequested) - - end function newMpiTestParameter - - pure subroutine setNumProcessesRequested(this, numProcessesRequested) - class (MpiTestParameter), intent(inout) :: this - integer, intent(in) :: numProcessesRequested - this%numProcessesRequested = numProcessesRequested - end subroutine setNumProcessesRequested - - - ! This function ensures that "npes = #" is included in the message string - ! for each exception. It should rarely be overridden. - function toStringActual(this) result(string) - class (MpiTestParameter), intent(in) :: this - character(:), allocatable :: string - - character(len=8) :: npesString - character(:), allocatable :: tmp - - write(npesString,'(i0)') this%numProcessesRequested - - string = 'npes=' // trim(npesString) - tmp = this%toString() - - if (len_trim(tmp) > 0) then - string = string // ' :: ' // trim(tmp) - end if - - end function toStringActual - - - ! Provide a default empty string. It is expected that this function - ! will be overridden for user defined test cases. - function toString(this) result(string) - class (MpiTestParameter), intent(in) :: this - character(:), allocatable :: string - - string = '' - - end function toString - - pure integer function getNumProcessesRequested(this) result(numProcessesRequested) - class (MpiTestParameter), intent(in) :: this - numProcessesRequested = this%numProcessesRequested - end function getNumProcessesRequested - - -end module MpiTestParameter_mod diff --git a/tests/pFUnit-3.2.9/source/ParallelContext.F90 b/tests/pFUnit-3.2.9/source/ParallelContext.F90 deleted file mode 100644 index 4c1d4dac..00000000 --- a/tests/pFUnit-3.2.9/source/ParallelContext.F90 +++ /dev/null @@ -1,116 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: ParallelContext -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! Default implementation is for a serial process -! Subclass for MPI operations -module ParallelContext_mod - implicit none - private - - public :: ParallelContext - - type, abstract :: ParallelContext - contains - procedure :: isActive - procedure :: isRootProcess - procedure(getNumProcesses), deferred :: getNumProcesses - procedure(processRank), deferred :: processRank - procedure(sum), deferred :: sum - generic :: gather => gatherString - generic :: gather => gatherInteger - generic :: gather => gatherLogical - procedure(gatherString), deferred :: gatherString - procedure(gatherInteger), deferred :: gatherInteger - procedure(gatherLogical), deferred :: gatherLogical - procedure :: labelProcess - procedure :: barrier - procedure(allReduceLogical), deferred :: allReduce - end type ParallelContext - - abstract interface - integer function getNumProcesses(this) - import ParallelContext - class(ParallelContext), intent(in) :: this - end function getNumProcesses - - integer function processRank(this) - import ParallelContext - class(ParallelContext), intent(in) :: this - end function processRank - - integer function sum(this, value) - import ParallelContext - class (ParallelContext), intent(in) :: this - integer, intent(in) :: value - end function sum - - subroutine gatherString(this, values, list) - import ParallelContext - class (ParallelContext), intent(in) :: this - character(len=*), intent(in) :: values(:) - character(len=*), intent(out) :: list(:) - end subroutine gatherString - - subroutine gatherInteger(this, values, list) - import ParallelContext - class (ParallelContext), intent(in) :: this - integer, intent(in) :: values(:) - integer, intent(out) :: list(:) - end subroutine gatherInteger - - subroutine gatherLogical(this, values, list) - import ParallelContext - class (ParallelContext), intent(in) :: this - logical, intent(in) :: values(:) - logical, intent(out) :: list(:) - end subroutine gatherLogical - - logical function allReduceLogical(this, q) result(anyQ) - import ParallelContext - class (ParallelContext), intent(in) :: this - logical, intent(in) :: q - end function allReduceLogical - - end interface - -contains - - logical function isActive(this) - class (ParallelContext), intent(in) :: this - isActive = .true. - end function isActive - - subroutine barrier(this) - class (ParallelContext), intent(in) :: this - end subroutine barrier - - logical function isRootProcess(this) - class (ParallelContext), intent(in) :: this - isRootProcess = .true. - end function isRootProcess - - subroutine labelProcess(this, message) - class (ParallelContext), intent(in) :: this - character(len=*), intent(inout) :: message - end subroutine labelProcess - -end module ParallelContext_mod diff --git a/tests/pFUnit-3.2.9/source/ParallelException.F90 b/tests/pFUnit-3.2.9/source/ParallelException.F90 deleted file mode 100644 index 91fc51b7..00000000 --- a/tests/pFUnit-3.2.9/source/ParallelException.F90 +++ /dev/null @@ -1,103 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: ParallelException -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module ParallelException_mod - use ParallelContext_mod - use Exception_mod - implicit none - private - - public :: anyExceptions - public :: getNumExceptions - public :: gather - - interface anyExceptions - module procedure anyExceptions_context - end interface anyExceptions - - interface getNumExceptions - module procedure getNumExceptions_context - end interface getNumExceptions - -contains - - logical function anyExceptions_context(context) result(anyExcept) - class (ParallelContext) :: context - -! logical, allocatable :: anyTable(:) - - anyExcept = context%allReduce(anyExceptions()) - end function anyExceptions_context - - integer function getNumExceptions_context(context) result(numExceptions) - class (ParallelContext) :: context - - integer, allocatable :: counts(:) - - allocate(counts(context%getNumProcesses())) - call context%gather([getNumExceptions()], counts) - numExceptions = sum(counts) - - end function getNumExceptions_context - - subroutine gather(context) - class (ParallelContext), intent(in) :: context - - type (ExceptionList) :: globalList - type (ExceptionList) :: localList -! character(len=MAXLEN_MESSAGE) :: msg - integer :: i - - integer :: totalExceptions, n - - totalExceptions = getNumExceptions(context) - if (totalExceptions > 0) then - - allocate(globalList%exceptions(totalExceptions)) - allocate(localList%exceptions(getNumExceptions())) - - n = getNumExceptions() - do i = 1, n - localList%exceptions(i) = catchNext() ! drains singleton exception list on all PEs - call context%labelProcess(localList%exceptions(i)%message) - end do - - call context%gather(localList%exceptions(:)%nullFlag, globalList%exceptions(:)%nullFlag) - call context%gather(localList%exceptions(:)%location%fileName, globalList%exceptions(:)%location%fileName) - call context%gather(localList%exceptions(:)%location%lineNumber, globalList%exceptions(:)%location%lineNumber) - call context%gather(localList%exceptions(:)%message, globalList%exceptions(:)%message) - - if (context%isRootProcess()) then ! rethrow - do i = 1, totalExceptions - associate(e => globalList%exceptions(i)) - call throw(e%message, e%location) - end associate - end do - end if - - deallocate(globalList%exceptions, localList%exceptions) - - end if - - end subroutine gather - -end module ParallelException_mod diff --git a/tests/pFUnit-3.2.9/source/ParameterizedTestCase.F90 b/tests/pFUnit-3.2.9/source/ParameterizedTestCase.F90 deleted file mode 100644 index 270098ac..00000000 --- a/tests/pFUnit-3.2.9/source/ParameterizedTestCase.F90 +++ /dev/null @@ -1,58 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: ParameterizedTestCase -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! 01 Jan 2014 - Added "hidden" method toStringActual() -! -!------------------------------------------------------------------------------- -module ParameterizedTestCase_mod - use TestCase_mod - use AbstractTestParameter_mod - implicit none - private - - public :: ParameterizedTestCase - public :: MAX_LEN_LABEL - - integer, parameter :: MAX_LEN_LABEL = 32 - type, abstract, extends(TestCase) :: ParameterizedTestCase - class (AbstractTestParameter), allocatable :: testParameter - contains - procedure :: getName ! override from TestCase - procedure :: setTestParameter - end type ParameterizedTestCase - -contains - - - function getName(this) result(name) - class (ParameterizedTestCase), intent(in) :: this - character(:), allocatable :: name - - name = trim(this%baseName()) // '[' // trim(this%testParameter%toStringActual()) // ']' - - end function getName - - subroutine setTestParameter(this, testParameter) - class (ParameterizedTestCase), intent(inout) :: this - class (AbstractTestParameter), intent(in) :: testParameter - allocate(this%testParameter, source=testParameter) - end subroutine setTestParameter - -end module ParameterizedTestCase_mod diff --git a/tests/pFUnit-3.2.9/source/Params.F90 b/tests/pFUnit-3.2.9/source/Params.F90 deleted file mode 100644 index 16de62b4..00000000 --- a/tests/pFUnit-3.2.9/source/Params.F90 +++ /dev/null @@ -1,47 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: Params -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- - -module Params_mod - use ISO_FORTRAN_ENV - implicit none - - integer, parameter, public :: MAX_LENGTH_NAME = 128 - - integer, parameter :: R32 = selected_real_kind(p=6) - integer, parameter :: R64 = selected_real_kind(p=14) - integer, parameter :: C32 = selected_real_kind(p=6) - integer, parameter :: C64 = selected_real_kind(p=14) - - integer, parameter :: I32 = INT32 - integer, parameter :: I64 = INT64 - -! integer, parameter :: I32 = selected_int_kind() -! integer, parameter :: I64 = selected_int_kind() - - integer, parameter :: NEQP=0, EQP=1, GTP=2, GEP=3, LTP=4, LEP=5, & - & RELEQP=6 - -contains - -end module Params_mod - diff --git a/tests/pFUnit-3.2.9/source/RemoteProxyTestCase.F90 b/tests/pFUnit-3.2.9/source/RemoteProxyTestCase.F90 deleted file mode 100644 index 394308ee..00000000 --- a/tests/pFUnit-3.2.9/source/RemoteProxyTestCase.F90 +++ /dev/null @@ -1,216 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: RemoteProxyTestCase -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module RemoteProxyTestCase_mod - use UnixProcess_mod - use Exception_mod - use TestCase_mod - implicit none - private - - public :: RemoteProxyTestCase - - type, extends(TestCase) :: RemoteProxyTestCase - private - type (UnixProcess), pointer :: process - integer :: clockStart - real :: maxTimeoutDuration - contains - procedure :: runMethod - procedure :: setStartTime - end type RemoteProxyTestCase - - interface RemoteProxyTestCase - module procedure newRemoteProxyTestCase - end interface RemoteProxyTestCase - - real, parameter :: MAX_TIME_TEST = 0.10 ! in seconds - -contains - - function newRemoteProxyTestCase(test, process, maxTimeoutDuration) result(proxy) - type (RemoteProxyTestCase) :: proxy - class (TestCase), intent(in) :: test - type (UnixProcess), target :: process - real, optional, intent(in) :: maxTimeoutDuration - - if(.not.present(maxTimeoutDuration))then - proxy%maxTimeoutDuration = MAX_TIME_TEST - else - proxy%maxTimeoutDuration = maxTimeoutDuration - end if - - call proxy%setName(test%getName()) - proxy%process => process - - end function newRemoteProxyTestCase - - subroutine runMethod(this) - use SourceLocation_mod - use UnixProcess_mod - use, intrinsic :: iso_c_binding - class (RemoteProxyTestCase), intent(inout) :: this - character(len=:), allocatable :: line - - character(len=:), allocatable :: message - character(len=:), allocatable :: fileName - - character(len=80) :: timeCommand - type (UnixProcess) :: timerProcess - integer :: numExceptions, iException - integer :: lineNumber - integer :: length - character(len=100) :: timeText - - call this%setStartTime() - - ! Software equivalent of a ticking time bomb: - ! Timer process sleeps for n milliseconds and then kills the remote test process. - ! If the appropriate messages are received in time, then this timer process is - ! safely stopped. - - write(timeCommand,'(a, f10.3,a,i0,a)') & - & "(sleep ",this%maxTimeoutDuration," && kill -9 ", this%process%getPid(),") > /dev/null 2>&1" - timerProcess = UnixProcess(trim(timeCommand), runInBackground=.true.) - - do - ! important to check status _before_ getLine() - line = this%process%getLine() - if (len(line) == 0) then - if (.not. this%process%isActive()) then - call throw('RUNTIME-ERROR: terminated before starting') - call timerProcess%terminate() - return - else - call timerProcess%terminate() - timerProcess = UnixProcess(trim(timeCommand), runInBackground=.true.) - cycle ! might just not be ready yet - end if - else - if ('started: '//trim(this%getName()) /= line) then - call throw('Incorrect start line in RemoteProxyTestCase.F90.') - return - end if - exit - end if - - end do - - ! Poll for exceptions or test finished - do - ! important to check status _before_ getLine() -! MLR Any guarantees on line? - line = this%process%getLine() - if (len(line) == 0) then - if (this%process%isActive()) then - call timerProcess%terminate() - call this%process%terminate() - call throw('RUNTIME-ERROR: active but no output?') - return - else ! process not active crashed or killed by child - if (timerProcess%isActive()) then - call timerProcess%terminate() - call this%process%terminate() - call throw('RUNTIME-ERROR: terminated during execution') - return - else ! child has completed - implies test was hung and processing terminated - write(timeText, '(a,f0.3,a)') & - 'RUNTIME-ERROR: hung (used more than ',& - this%maxTimeoutDuration, ' s)' - call throw(timeText) - return - end if - end if - - else ! have some output to process - - ! MLR Need to check on length of line. - - if (line(1:6) == 'DEBUG:' .or. line(1:7) == ' DEBUG:') then - print*,line ! re-emit - cycle - end if - - if (line == ('ended: ' // trim(this%getName()))) then - - call timerProcess%terminate() - return - -! 2014-0211-1843-18-UTC MLR Huh? Hard coding? Getting two errors here... Both Intel & GNU. -! It turns out that printing from processes can screw up the communications that go on here. - elseif (index(line, 'failed: numExceptions=') /= 0) then - - read(line(23:),*) numExceptions - - do iException = 1, numExceptions - line = contentScan(this%process%getline()) - read(line,*) length - - fileName = contentScan(this%process%getLine()) - line = contentScan(this%process%getLine()) - read(line,*) lineNumber - line = contentScan(this%process%getLine()) - read(line,*) length -! allocate(character(len=length) :: message) - line = this%process%getDelim(C_NULL_CHAR) - message = contentScan(line) - ! eat remaining linefeed - line= this%process%getLine() - call throw(trim(message), SourceLocation(fileName, lineNumber)) -! deallocate(message) - end do - cycle ! still need to process the end message - - else - print*,'Unexpected output in remote runner: <',line,'>' - call timerProcess%terminate() - call this%process%terminate() - call throw('ERROR: unexpected message: '//trim(line)) - return - - end if - end if - end do - - ! no path to here - - contains - - function contentScan(string) result(valueString) - character(len=*), intent(in) :: string - character(len=:), allocatable :: valueString - - integer :: i0, i1 - i0 = scan(string,'<') + 1 - i1 = scan(string,'>',back=.true.) - 1 - - valueString = string(i0:i1) - end function contentScan - - end subroutine runMethod - - subroutine setStartTime(this) - class (RemoteProxyTestCase), intent(inout) :: this - call system_clock(this%clockStart) - end subroutine setStartTime - -end module RemoteProxyTestCase_mod diff --git a/tests/pFUnit-3.2.9/source/ResultPrinter.F90 b/tests/pFUnit-3.2.9/source/ResultPrinter.F90 deleted file mode 100644 index 1f97aa06..00000000 --- a/tests/pFUnit-3.2.9/source/ResultPrinter.F90 +++ /dev/null @@ -1,203 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: ResultPrinter -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module ResultPrinter_mod - use Exception_mod - use TestListener_mod, only : TestListener - implicit none - private - - public :: ResultPrinter - public :: newResultPrinter - - type, extends(TestListener) :: ResultPrinter - integer :: unit - integer :: column - contains - procedure :: addFailure - procedure :: addError - procedure :: startTest - procedure :: endTest - procedure :: endRun - procedure :: print - procedure :: printHeader - procedure :: printFailures - procedure :: printFooter - procedure :: incrementColumn - end type ResultPrinter - - integer, parameter :: MAX_COLUMN = 80 - logical, parameter :: DEBUG = .false. -!!$ logical, parameter :: DEBUG = .true. - -contains - - function newResultPrinter(unit) - type (ResultPrinter) :: newResultPrinter - integer, intent(in) :: unit - - newResultPrinter%unit = unit - newResultPrinter%column = 0 - - end function newResultPrinter - - subroutine addFailure(this, testName, exceptions) - use Exception_mod - class (ResultPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - write(this%unit,'("F")', advance='no') - call this%incrementColumn() - - end subroutine addFailure - - subroutine addError(this, testName, exceptions) - use Exception_mod - class (ResultPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - write(this%unit,'("E")', advance='no') - call this%incrementColumn() - - end subroutine addError - - subroutine startTest(this, testName) - class (ResultPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - - write(this%unit,'(".")', advance='no') - call this%incrementColumn() - - if (DEBUG) then - write(this%unit,*)trim(testName) - call flush(this%unit) - end if - - end subroutine startTest - - subroutine endTest(this, testName) - class (ResultPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - - if (DEBUG) then - write(this%unit,*)trim(testName) - call flush(this%unit) - end if - - end subroutine endTest - - subroutine endRun(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (ResultPrinter), intent(inout) :: this - class (AbstractTestResult), intent(in) :: result - - call this%print(result) - - end subroutine endRun - - subroutine print(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (ResultPrinter), intent(in) :: this - class (AbstractTestResult), intent(in) :: result - - call this%printHeader(result%getRunTime()) - call this%printFailures('Error', result%getErrors()) - call this%printFailures('Failure', result%getFailures()) - call this%printFooter(result) - - end subroutine print - - subroutine printHeader(this, runTime) - class (ResultPrinter), intent(in) :: this - real, intent(in) :: runTime - - write(this%unit,*) - write(this%unit,'(a,1x,f12.3,1x,a)') 'Time: ', runTime, 'seconds' - write(this%unit,*)" " - - end subroutine printHeader - - subroutine printFailures(this, label, failures) -!? u TestResult_mod - use TestFailure_mod - use SourceLocation_mod - class (ResultPrinter), intent(in) :: this - character(len=*), intent(in) :: label - type (TestFailure), intent(in) :: failures(:) - - type (TestFailure) :: aFailedTest - integer :: i, j - character(len=300) :: locationString - - do i = 1, size(failures) - aFailedTest = failures(i) - - do j= 1, size(aFailedTest%exceptions) - locationString = aFailedTest%exceptions(j)%location%toString() - - write(this%unit,'(a)') label,' in: ', trim(aFailedTest%testName) - write(this%unit,'(a)') ' Location: ', trim(locationString) - write(this%unit,'(a,1x,a)') aFailedTest%exceptions(j)%getMessage() - write(this%unit,*)' ' - end do - end do - - end subroutine printFailures - - subroutine printFooter(this, result) - use AbstractTestResult_mod - class (ResultPrinter), intent(in) :: this - class (AbstractTestResult), intent(in) :: result - - if (result%wasSuccessful()) then - write(this%unit,*)"OK" - write(this%unit,'(a,i0,a)',advance='no')" (", result%runCount(), " test" - if (result%runCount() > 1) then - write(this%unit,'(a)')"s)" - else - write(this%unit,'(a)')")" - end if - else - write(this%unit,*)"FAILURES!!!" - write(this%unit,'(a,i0,a,i0,a,i0)')"Tests run: ", result%runCount(), & - & ", Failures: ",result%failureCount(), & - & ", Errors: ",result%errorCount() - - end if - - end subroutine printFooter - - subroutine incrementColumn(this) - class (ResultPrinter), intent(inout) :: this - - this%column = this%column + 1 - - if (this%column >= MAX_COLUMN) then - write(this%unit,*) ! newline - this%column = 0 - end if - - end subroutine incrementColumn - -end module ResultPrinter_mod diff --git a/tests/pFUnit-3.2.9/source/RobustRunner.F90 b/tests/pFUnit-3.2.9/source/RobustRunner.F90 deleted file mode 100644 index a086e13d..00000000 --- a/tests/pFUnit-3.2.9/source/RobustRunner.F90 +++ /dev/null @@ -1,322 +0,0 @@ - -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: RobustRunner -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module RobustRunner_mod - use Test_mod - use TestCase_mod - use BaseTestRunner_mod - use TestListener_mod - use UnixProcess_mod - implicit none - private - - public :: RobustRunner -#ifndef DEFERRED_LENGTH_CHARACTER - integer, parameter :: MAX_LENGTH_COMMAND=80 -#endif - - type, extends(BaseTestRunner) :: RobustRunner - private -#ifdef DEFERRED_LENGTH_CHARACTER - character(len=:), allocatable :: remoteRunCommand -#else - character(len=MAX_LENGTH_COMMAND) :: remoteRunCommand -#endif - integer :: numSkip - type (ListenerPointer), allocatable :: extListeners(:) - type (UnixProcess) :: remoteProcess - real :: maxLaunchDuration - real :: maxTimeoutDuration - contains - procedure :: run - procedure :: runWithResult - procedure :: startTest - procedure :: endTest - procedure :: endRun - procedure :: addFailure - procedure :: addError - procedure :: launchRemoteRunner - procedure :: createTestResult - end type RobustRunner - - interface RobustRunner -! module procedure newRobustRunner - module procedure newRobustRunner_extListeners - end interface RobustRunner - - type, extends(TestCase) :: TestCaseMonitor - private - type (UnixProcess), pointer :: process - contains - procedure :: runMethod - end type TestCaseMonitor - -!!! Inject dependency through constructor... - real, parameter :: MAX_TIME_LAUNCH = 5.00 ! in seconds - real, parameter :: MAX_TIME_TEST = 0.11 ! in seconds - -contains - -! function newRobustRunner(remoteRunCommand,maxLaunchDuration) result(runner) -! type (RobustRunner) :: runner -! character(len=*), intent(in) :: remoteRunCommand -! real, optional, intent(in) :: maxLaunchDuration -! -! if(.not.present(maxLaunchDuration))then -! runner%maxLaunchDuration = MAX_TIME_LAUNCH -! else -! runner%maxLaunchDuration = maxLaunchDuration -! end if -! -! runner%remoteRunCommand = trim(remoteRunCommand) -! allocate(runner%extListeners(0)) -! end function newRobustRunner - - function newRobustRunner_extListeners( & - & remoteRunCommand & - & ,extListeners & - & ,maxLaunchDuration & - & ,maxTimeoutDuration & - & ) result(runner) - type (RobustRunner) :: runner - character(len=*), intent(in) :: remoteRunCommand - type(ListenerPointer), optional, intent(in) :: extListeners(:) - - real, optional, intent(in) :: maxLaunchDuration - real, optional, intent(in) :: maxTimeoutDuration - - if(.not.present(maxLaunchDuration))then - runner%maxLaunchDuration = MAX_TIME_LAUNCH - else - runner%maxLaunchDuration = maxLaunchDuration - end if - - if(.not.present(maxTimeoutDuration))then - runner%maxTimeoutDuration = MAX_TIME_TEST - else - runner%maxTimeoutDuration = maxTimeoutDuration - end if - - if(present(extListeners))then - allocate(runner%extListeners(size(extListeners)), source=extListeners) - end if - - runner%remoteRunCommand = trim(remoteRunCommand) - runner%numSkip = 0 - - end function newRobustRunner_extListeners - - subroutine runMethod(this) - class (TestCaseMonitor), intent(inout) :: this - end subroutine runMethod - - function run(this, aTest, context) result(result) - use Test_mod - use TestSuite_mod - use TestResult_mod - use ParallelContext_mod - - type (TestResult) :: result - class (RobustRunner), target, intent(inout) :: this - class (Test), intent(inout) :: aTest - class (ParallelContext), intent(in) :: context - - result = this%createTestResult() - call result%setName(aTest%getName()) - call this%runWithResult(aTest, context, result) - - end function run - - subroutine runWithResult(this, aTest, context, result) - use Test_mod - use ParallelContext_mod - use TestResult_mod - use RemoteProxyTestCase_mod - use TestSuite_mod - use Exception_mod - class (RobustRunner), target, intent(inout) :: this - class (Test), intent(inout) :: aTest - class (ParallelContext), intent(in) :: context - type (TestResult), intent(inout) :: result - - type (TestCaseReference), allocatable :: testCases(:) - type (RemoteProxyTestCase) :: proxy - integer :: i - integer :: clockStart, clockStop, clockRate - - call system_clock(clockStart) - - do i=1,size(this%extListeners) - call result%addListener(this%extListeners(i)%pListener) - end do - call result%addListener( this ) ! - monitoring - - select type (aTest) - class is (TestSuite) -!!! if defined(PGI) || (defined(__INTEL_COMPILER) && (INTEL_13)) -#if (defined(__INTEL_COMPILER) && (INTEL_13)) - testCases = aTest%getTestCases() -#else - call aTest%getTestCases(testCases) -#endif - class is (TestCase) - allocate(testCases(1)) - allocate(testCases(1)%test, source= aTest) - class default - stop - end select - -! mlr q: set up named pipes or units to handle comm between remote processes - ! mlr q: and the root... being done at ukmet? - do i = 1, size(testCases) - if (.not. this%remoteProcess%isActive()) then - call this%launchRemoteRunner(numSkip=i-1) - end if - proxy = RemoteProxyTestCase( & - & testCases(i)%test & - & ,this%remoteProcess & - & ,maxTimeoutDuration=this%maxTimeoutDuration & - & ) - call proxy%run(result, context) - end do - - call system_clock(clockStop, clockRate) - - call result%addRunTime(real(clockStop - clockStart) / clockRate) - - ! Maybe push this call up into parent, i.e. loop over all of the listeners there... - if (context%isRootProcess()) then - do i=1,size(this%extListeners) - call this%extListeners(i)%pListener%endRun(result) - end do - end if - - end subroutine runWithResult - - subroutine launchRemoteRunner(this, numSkip) - use UnixProcess_mod - use Exception_mod - class (RobustRunner), intent(inout) :: this - integer, intent(in) :: numSkip - - character(len=:), allocatable :: command - - integer, parameter :: MAX_LEN=8 - character(len=MAX_LEN) :: suffix - - character(len=80) :: timeCommand - type (UnixProcess) :: timerProcess - character(len=:), allocatable :: line - character(len=100) :: throwMessage - - - write(suffix,'(i0)') numSkip - command = trim(this%remoteRunCommand) // ' -skip ' // suffix - - - this%remoteProcess = UnixProcess(command, runInBackground=.true.) - - ! Check for successful launch - prevents MPI launch time from counting against - ! first test's time limit. - write(timeCommand,'(a, f10.3,a,i0,a)') & - & "(sleep ",this%maxLaunchDuration," && kill -9 ", & - & this%remoteProcess%getPid(), & - & ") > /dev/null 2>&1" - timerProcess = UnixProcess(trim(timeCommand), runInBackground=.true.) - - do - line = this%remoteProcess%getLine() - if (len(line) == 0) then - if (.not. this%remoteProcess%isActive()) then - write(throwMessage,'(a,f0.3,a)') & - & ' (max launch duration = ',this%maxLaunchDuration,')' - call throw('RUNTIME-ERROR: terminated before starting'//trim(throwMessage)) - call timerProcess%terminate() - return - else -!!$ call timerProcess%terminate() -!!$ timerProcess = UnixProcess(trim(timeCommand), runInBackground=.true.) - cycle ! might just not be ready yet - end if - else - if ('*LAUNCHED*' /= line) then - call throw(& - & 'Failure to launch in RobustRunner. ' & - & //"Expected: '*LAUNCHED*' Found: '"//line//"'" ) - return - else - ! successfully launched - call timerProcess%terminate() - exit - end if - end if - end do - - end subroutine launchRemoteRunner - - ! No matter what, we don't want to rerun this test, so - ! we need to increment numSkip here. - subroutine startTest(this, testName) - class (RobustRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - - this%numSkip = this%numSkip + 1 - - end subroutine startTest - - subroutine endTest(this, testName) - class (RobustRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - end subroutine endTest - - subroutine endRun(this, result) - use AbstractTestResult_mod - class (RobustRunner), intent(inout) :: this - class (AbstractTestResult), intent(in) :: result - end subroutine endRun - - subroutine addFailure(this, testName, exceptions) - use Exception_mod - class (RobustRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - end subroutine addFailure - - subroutine addError(this, testName, exceptions) - use Exception_mod - class (RobustRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - end subroutine addError - - function createTestResult(this) result(tstResult) - use TestResult_mod - class (RobustRunner), intent(inout) :: this - type (TestResult) :: tstResult - - tstResult = newTestResult() - end function createTestResult - -end module RobustRunner_mod diff --git a/tests/pFUnit-3.2.9/source/SerialContext.F90 b/tests/pFUnit-3.2.9/source/SerialContext.F90 deleted file mode 100644 index eca8a52e..00000000 --- a/tests/pFUnit-3.2.9/source/SerialContext.F90 +++ /dev/null @@ -1,108 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: SerialContext -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module SerialContext_mod - use ParallelContext_mod - implicit none - private - - public :: SerialContext - public :: newSerialContext - public :: THE_SERIAL_CONTEXT - - type, extends(ParallelContext) :: SerialContext - contains - procedure :: getNumProcesses - procedure :: processRank - procedure :: sum - procedure :: gatherString - procedure :: gatherInteger - procedure :: gatherLogical - procedure :: allReduce -!TODO - NAG does not yet support FINAL keyword -!!$$ final :: clean - end type SerialContext - - type (SerialContext), parameter :: THE_SERIAL_CONTEXT = SerialContext() - -contains - - function newSerialContext() result(context) - type (SerialContext) :: context - end function newSerialContext - - integer function getNumProcesses(this) - class (SerialContext), intent(in) :: this - - getNumProcesses = 1 - - end function getNumProcesses - - integer function processRank(this) - class (SerialContext), intent(in) :: this - processRank = 0 - end function processRank - - integer function sum(this, value) - class (SerialContext), intent(in) :: this - integer, intent(in) :: value - - sum = value - - end function sum - - subroutine gatherString(this, values, list) - class (SerialContext), intent(in) :: this - character(len=*), intent(in) :: values(:) - character(len=*), intent(out) :: list(:) - - list = values - end subroutine gatherString - - subroutine gatherInteger(this, values, list) - class (SerialContext), intent(in) :: this - integer, intent(in) :: values(:) - integer, intent(out) :: list(:) - - list = values - - end subroutine gatherInteger - - subroutine gatherLogical(this, values, list) - class (SerialContext), intent(in) :: this - logical, intent(in) :: values(:) - logical, intent(out) :: list(:) - - list = values - end subroutine gatherLogical - - logical function allReduce(this, q) result(anyQ) - class (SerialContext), intent(in) :: this - logical, intent(in) :: q - anyQ = q - end function allReduce - - subroutine clean(this) - type (SerialContext), intent(inout) :: this - end subroutine clean - -end module SerialContext_mod diff --git a/tests/pFUnit-3.2.9/source/SourceLocation.F90 b/tests/pFUnit-3.2.9/source/SourceLocation.F90 deleted file mode 100644 index d88c79db..00000000 --- a/tests/pFUnit-3.2.9/source/SourceLocation.F90 +++ /dev/null @@ -1,74 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: SourceLocation -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! This module just provides a data type - not a class. -! Meant to be shared for easy access. - -module SourceLocation_mod - implicit none - private - - public :: SourceLocation - public :: UNKNOWN_SOURCE_LOCATION - public :: UNKNOWN_FILE_NAME - public :: UNKNOWN_LINE_NUMBER - - integer, parameter :: MAXLEN_FILE_NAME = 255 - character(len=MAXLEN_FILE_NAME), parameter :: UNKNOWN_FILE_NAME= '' - integer, parameter :: UNKNOWN_LINE_NUMBER = -1 - - type :: SourceLocation - character(len=MAXLEN_FILE_NAME) :: fileName = UNKNOWN_FILE_NAME - integer :: lineNumber = UNKNOWN_LINE_NUMBER - contains - procedure :: toString - end type SourceLocation - - type (SourceLocation), parameter :: UNKNOWN_SOURCE_LOCATION = & - & SourceLocation() - -contains - - function toString(this) result(string) - class (SourceLocation), intent(inout) :: this - character(len=300) :: string - integer :: status - - if (this%fileName == UNKNOWN_FILE_NAME) then - if (this%lineNumber == UNKNOWN_LINE_NUMBER) then - string = '' - else - write(string,'(a,":",i0)', iostat=status) trim(UNKNOWN_FILE_NAME), this%lineNumber - end if - else - if (this%lineNumber == UNKNOWN_LINE_NUMBER) then - string = trim(this%fileName) - else - write(string,'(a,":",i0)', iostat=status) trim(this%fileName), this%lineNumber - end if - end if - - string = '[' // trim(string) // ']' - - end function toString - -end module SourceLocation_mod diff --git a/tests/pFUnit-3.2.9/source/StringConversionUtilities.F90 b/tests/pFUnit-3.2.9/source/StringConversionUtilities.F90 deleted file mode 100644 index 7ffefc11..00000000 --- a/tests/pFUnit-3.2.9/source/StringConversionUtilities.F90 +++ /dev/null @@ -1,328 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: StringConversionUtilities -! -!> @brief -!! A collection of utilities used throughout the framework. -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 05 Sep 2014 - Added options for working with whitespace including -! ignore, trim, or keep. Note: trimAll trims both -! sides, while trimTrailingWhitespace is more like -! Fortran's trim. MLR -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! This module converts integers/real's to strings of a specific format -! for unit test diagnostics. Basically just a wrapper for Fortran -! formatting, but functional programming provides a better style in many -! situations. -! -! Further control of field width could be added at a later time. -! - -module StringConversionUtilities_mod - - use Params_mod, only : r32, r64 - use Params_mod, only : i32, i64 - - implicit none - private - - public :: toString - public :: appendWithSpace - public :: MAXLEN_STRING - public :: nullTerminate - public :: unlessScalar - public :: WhitespaceOptions, IGNORE_ALL, TRIM_ALL, KEEP_ALL, IGNORE_DIFFERENCES - public :: whitespacep, trimAll, trimTrailingWhitespace - - integer, parameter :: MAXLEN_STRING = 80 -! integer, parameter :: MAXLEN_STRING = 80*5 - - interface toString - module Procedure toString_real64Scalar - module Procedure toString_realScalar - module Procedure toString_complex64Scalar - module Procedure toString_complexScalar - module Procedure toString_integerScalar_i32 - module Procedure toString_integer1D_i32 - module Procedure toString_integerScalar_i64 - module Procedure toString_integer1D_i64 - end interface - - character(len=*), parameter :: r32fmtStr = 'SP,G14.7' - character(len=*), parameter :: r64fmtStr = 'SP,G14.7' - character(len=*), parameter :: r32fmt1 = '('//r32fmtStr//')' - character(len=*), parameter :: r64fmt1 = '('//r64fmtStr//')' - - character(len=*), parameter :: c32fmt1 = '("z=(",'//r32fmt1//',",",'//r32fmt1//',")")' - character(len=*), parameter :: c64fmt1 = '("z=(",'//r64fmt1//',",",'//r64fmt1//',")")' - -! enum, bind(c) :: WhitespaceOptions - type WhitespaceOptions - integer value - end type WhitespaceOptions - enum, bind(c) - enumerator :: IGNORE_ALL_, TRIM_ALL_, KEEP_ALL_, IGNORE_DIFFERENCES_ - end enum - type (WhitespaceOptions), parameter :: & - & IGNORE_ALL=WhitespaceOptions(IGNORE_ALL_), & - & TRIM_ALL =WhitespaceOptions(TRIM_ALL_), & - & KEEP_ALL =WhitespaceOptions(KEEP_ALL_), & - & IGNORE_DIFFERENCES =WhitespaceOptions(IGNORE_DIFFERENCES_) - -contains - - character(len=MAXLEN_STRING) function toString_complex64Scalar(value) result(buffer) - complex(kind=r64), intent(in) :: value - -! write(buffer,'(2(SP,G14.7))') value - write(buffer,c64fmt1) value - buffer = adjustL(buffer) - - end function toString_complex64Scalar - - character(len=MAXLEN_STRING) function toString_complexScalar(value) result(buffer) - complex, intent(in) :: value - -! write(buffer,'(2(SP,G14.7))') value - write(buffer,c32fmt1) value - buffer = adjustL(buffer) - - end function toString_complexScalar - - character(len=MAXLEN_STRING) function toString_real64Scalar(value) result(buffer) - real(kind=r64), intent(in) :: value - - write(buffer,'(SP,G14.7)') value -! write(buffer,r64fmt1) value - buffer = adjustL(buffer) - - end function toString_real64Scalar - - character(len=MAXLEN_STRING) function toString_realScalar(value) result(buffer) - real(kind=r32), intent(in) :: value - - write(buffer,'(SP,G14.7)') value -! print *,'r32fmt1: ',r32fmt1 -! print *,' : ','(SP,G14.7)' -! print *,'=? : ','(SP,G14.7)'.EQ.r32fmt1 -! write(buffer,r32fmt1) - buffer = adjustL(buffer) - - end function toString_realScalar - -!- character(len=MAXLEN_STRING) function toString_integerScalar(value) result(buffer) -!- integer, intent(in) :: value -!- character(len=20) :: fmt -!- -!- fmt = '(I0)' -!- write(buffer,trim(fmt)) value -!- buffer = adjustL(buffer) -!- -!- end function toString_integerScalar -!- -!- function toString_integer1D(arrayShape) result(string) -!- integer, intent(in) :: arrayShape(:) -!- character(len=MAXLEN_STRING) :: string -!- -!-! integer :: i -!- -!- select case (size(arrayShape)) ! rank -!- case (0) ! scalar -!- string = '0' -!- case (1) -!- write(string,'(i0)') arrayShape(1) -!- case (2:) -!- write(string,'(i0,14(",",i0:))') arrayShape(1:) -!- end select -!- -!- string = '[' // trim(string) // ']' -!- end function toString_integer1D - - character(len=MAXLEN_STRING) function toString_integerScalar_i32(value) result(buffer) - integer(kind=i32), intent(in) :: value - character(len=20) :: fmt - - fmt = '(I0)' - write(buffer,trim(fmt)) value - buffer = adjustL(buffer) - - end function toString_integerScalar_i32 - - function toString_integer1D_i32(arrayShape) result(string) - integer(kind=i32), intent(in) :: arrayShape(:) - character(len=MAXLEN_STRING) :: string - -! integer :: i - - select case (size(arrayShape)) ! rank - case (0) ! scalar - string = '0' - case (1) - write(string,'(i0)') arrayShape(1) - case (2:) - write(string,'(i0,14(",",i0:))') arrayShape(1:) - end select - - string = '[' // trim(string) // ']' - end function toString_integer1D_i32 - - character(len=MAXLEN_STRING) function toString_integerScalar_i64(value) result(buffer) - integer(kind=i64), intent(in) :: value - character(len=20) :: fmt - - fmt = '(I0)' - write(buffer,trim(fmt)) value - buffer = adjustL(buffer) - - end function toString_integerScalar_i64 - - function toString_integer1D_i64(arrayShape) result(string) - integer(kind=i64), intent(in) :: arrayShape(:) - character(len=MAXLEN_STRING) :: string - -! integer :: i - - select case (size(arrayShape)) ! rank - case (0) ! scalar - string = '0' - case (1) - write(string,'(i0)') arrayShape(1) - case (2:) - write(string,'(i0,14(",",i0:))') arrayShape(1:) - end select - - string = '[' // trim(string) // ']' - end function toString_integer1D_i64 - - - ! Joins two strings with a space separator unless first string is - ! empty. - function appendWithSpace(a, b) result(ab) - character(len=*), intent(in) :: a - character(len=*), intent(in) :: b - character(len=len_trim(a)+1+len_trim(b)) :: ab - - if (len_trim(a) > 0) then - ab = trim(a) // ' ' // trim(b) - else - ab = trim(b) - end if - - end function appendWithSpace - - function nullTerminate(string) result(nullTerminatedString) - use iso_c_binding - character(len=*), intent(in) :: string - character(len=:), allocatable :: nullTerminatedString - - nullTerminatedString = trim(string) // C_NULL_CHAR - - end function nullTerminate - - function unlessScalar(vShape,string) result(retString) - integer, intent(in), dimension(:) :: vShape - character(len=*), intent(in) :: string - character(len=:), allocatable :: retString - retString="" - if(size(vShape).ne.0)then - retString=string - end if - end function unlessScalar - - logical function whitespacep(c) - character, intent(in) :: c - integer, parameter :: iachar_spc = 32, iachar_tab = 9 - whitespacep = & - & iachar(c) .eq. iachar_spc .or. & - & iachar(c) .eq. iachar_tab - end function whitespacep - - function trimAll(s) result(trimmed) - character(len=*), intent(in) :: s - character(len=:), allocatable :: trimmed - integer :: i,lenS,leadingWhite,trailingWhite,lenTrimmed - - lenS = len(s) - - leadingWhite = 0 - do i = 1,lenS - if (whitespacep(s(i:i))) then - leadingWhite = leadingWhite + 1 - else - exit - end if - end do - - trailingWhite = 0 - do i = lenS,leadingWhite+1,-1 - if (whitespacep(s(i:i))) then - trailingWhite = trailingWhite + 1 - else - exit - end if - end do - lenTrimmed = lenS-leadingWhite-trailingWhite - - allocate(character(lenTrimmed) :: trimmed) - do i = 1,lenTrimmed - trimmed(i:i) = s(i+leadingWhite:i+leadingWhite) - end do - end function trimAll - - function trimTrailingWhitespace(s) result(trimmed) - character(len=*), intent(in) :: s - character(len=:), allocatable :: trimmed - integer :: i,lenS - integer :: trailingWhite,lenTrimmed - integer :: leadingWhite - - lenS = len(s) - - leadingWhite = 0 - do i = 1,lenS - if (whitespacep(s(i:i))) then - leadingWhite = leadingWhite + 1 - else - exit - end if - end do - - trailingWhite = 0 - do i = lenS,leadingWhite+1,-1 - if (whitespacep(s(i:i))) then - trailingWhite = trailingWhite + 1 - else - exit - end if - end do - - lenTrimmed = lenS-trailingWhite - allocate(character(lenTrimmed) :: trimmed) - do i = 1,lenTrimmed - trimmed(i:i) = s(i:i) - end do - - end function trimTrailingWhitespace - - - - - - - -end module StringConversionUtilities_mod diff --git a/tests/pFUnit-3.2.9/source/SubsetRunner.F90 b/tests/pFUnit-3.2.9/source/SubsetRunner.F90 deleted file mode 100644 index 2ea49e0c..00000000 --- a/tests/pFUnit-3.2.9/source/SubsetRunner.F90 +++ /dev/null @@ -1,182 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: SubsetRunner -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------ -! The purpose of this class is to support detection of SUT errors that -! crash the framework. The RobustRunner (better name?) class launches -! and monitors a separate process which runs a SubsetRunner. If the -! SubsetRunner crashes, then RobustRunner detects this and relaunches -! - skipping the earlier tests and the test that crashed. The -! algorithm is guaranteed to eventually provide a result for every -! test. -! -! Both RobustRunner and SubsetRunner work with a flat list of test -! cases obtained through TestSuite::getTestCases(). This greatly -! simplifies the task of managing the interactions between -! RobustRunner and SubsetRunner. -! ----------------------------------------------------------------------- - -module SubsetRunner_mod - use Test_mod - use BaseTestRunner_mod - implicit none - private - - public :: SubsetRunner - - - integer, parameter :: MAX_LEN_NAME=80 - type, extends(BaseTestRunner) :: SubsetRunner - private - integer :: numSkip - integer :: unit - contains - procedure :: run - procedure :: addFailure - procedure :: startTest - procedure :: endTest - procedure :: endRun - end type SubsetRunner - - interface SubsetRunner - module procedure newSubsetRunner_stdout - module procedure newSubsetRunner - end interface SubsetRunner - -contains - - function newSubsetRunner_stdout(numSkip) result(runner) - use, intrinsic :: iso_fortran_env, only: OUTPUT_UNIT - type (SubsetRunner) :: runner - integer, intent(in) :: numSkip - - runner%numSkip = numSkip - runner%unit = OUTPUT_UNIT - - end function newSubsetRunner_stdout - - function newSubsetRunner(numSkip, unit) result(runner) - type (SubsetRunner) :: runner - integer, intent(in) :: numSkip - integer, intent(in) :: unit - - runner%numSkip = numSkip - runner%unit = unit - - end function newSubsetRunner - - function run(this, aTest, context) result(result) - use, intrinsic :: iso_fortran_env, only: OUTPUT_UNIT - use Test_mod - use ParallelContext_mod - use TestCase_mod - use TestResult_mod - use TestSuite_mod - - type (TestResult) :: result - class (SubsetRunner), target, intent(inout) :: this - class (Test), intent(inout) :: aTest - class (ParallelContext), intent(in) :: context - - type (TestCaseReference), allocatable :: testCaseList(:) - integer :: i - - !print *,'a00000' - - select type (aTest) - class is (TestSuite) -!!!if defined(PGI) || (defined(__INTEL_COMPILER) && (INTEL_13)) -#if (defined(__INTEL_COMPILER) && (INTEL_13)) - !print *,'a10000' - testCaseList = aTest%getTestCases() -#else - call aTest%getTestCases(testCaseList) -#endif - - class is (TestCase) - allocate(testCaseList(1)) - allocate(testCaseList(1)%test, source= aTest) - class default - stop - end select - - result = newTestResult() - call result%setName(aTest%getName()) - call result%addListener( this ) - - ! This should be a named pipe - ! Note - uses F2008 extension: "newunit=..." - - write(this%unit,'(a)') '*LAUNCHED*' - - do i = this%numSkip + 1, size(testCaseList(:)) - call testCaseList(i)%test%run(result, context) - end do - - if (this%unit /= OUTPUT_UNIT) close(this%unit) - - end function run - - subroutine addFailure(this, testName, exceptions) - use Exception_mod - use, intrinsic :: iso_c_binding - class (SubsetRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - integer :: i - - write(this%unit,'(a,i0)')'failed: numExceptions=',size(exceptions) - do i = 1, size(exceptions) - associate(fileName => exceptions(i)%location%fileName, & - & lineNumber => exceptions(i)%location%lineNumber, & - & message => exceptions(i)%message) - write(this%unit,'(i0,a,i0,a)')i,' len(fileName)=< ',len_trim(fileName),' >' - write(this%unit,'(i0,a,a,a)')i,' fileName=< ',trim(fileName),' >' - write(this%unit,'(i0,a,i0,a)')i,' lineNumber=< ',lineNumber,' >' - write(this%unit,'(i0,a,i0,a)')i,' len(message)=< ',len_trim(message),' >' - write(this%unit,'(i0,a,a,a)')i,' message=< ',trim(message),' >'//C_NULL_CHAR - end associate - end do - - end subroutine addFailure - - subroutine startTest(this, testName) - class (SubsetRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - write(this%unit,'(a,a)')'started: ', trim(testName) - - end subroutine startTest - - subroutine endTest(this, testName) - class (SubsetRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - write(this%unit,'(a,a)')'ended: ', trim(testName) - end subroutine endTest - - subroutine endRun(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (SubsetRunner), intent(inout) :: this - class (AbstractTestResult), intent(in) :: result - end subroutine endRun - -end module SubsetRunner_mod diff --git a/tests/pFUnit-3.2.9/source/SurrogateTestCase.F90 b/tests/pFUnit-3.2.9/source/SurrogateTestCase.F90 deleted file mode 100644 index 3251da17..00000000 --- a/tests/pFUnit-3.2.9/source/SurrogateTestCase.F90 +++ /dev/null @@ -1,73 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: SurrogateTestCase -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! -! This module exists as part of the Surrogate design pattern which -! helps to circumvent circular dependenciens betwenn Fortran classes. -! In this case, the Test hierarchy depends upon TestResult. In turn -! TestResult depends on TestCase, which is a subclass of Test. -! -! This is a modified variant of the Surrogate pattern due to the -! injection within an inheritance hierarchy (i.e. between Test and -! TestCase). Since Fortran only supports single inheritance, the -! Multiple-Inheritance design pattern is also required. That portion -! is implemented in the TestCase module. - -module SurrogateTestCase_mod - implicit none - private - - public :: SurrogateTestCase - - type, abstract :: SurrogateTestCase - private - contains - procedure(getName), deferred :: getName - procedure(setName), deferred :: setName - procedure(runBare), deferred :: runBare - end type SurrogateTestCase - - abstract interface - - ! Run the SUT and assert the results - subroutine runBare(this) - import SurrogateTestCase - class (SurrogateTestCase), intent(inout) :: this - end subroutine runBare - - ! Return the name for TestCase (may need to move to Test) - function getName(this) result(name) - import SurrogateTestCase - class (SurrogateTestCase), intent(in) :: this - character(:), allocatable :: name - end function getName - - ! Set the test name for TestCase (may need to move to Test) - subroutine setName(this, name) - import SurrogateTestCase - class (SurrogateTestCase), intent(inout) :: this - character(len=*),intent(in) :: name - end subroutine setName - - end interface - -end module SurrogateTestCase_mod diff --git a/tests/pFUnit-3.2.9/source/Test.F90 b/tests/pFUnit-3.2.9/source/Test.F90 deleted file mode 100644 index 3ad537d7..00000000 --- a/tests/pFUnit-3.2.9/source/Test.F90 +++ /dev/null @@ -1,67 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: Test -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module Test_mod - implicit none - private - - ! Abstract class from which other Test classes inherit - type, public, abstract :: Test - integer :: placeholder - contains - procedure(countTestCases), deferred :: countTestCases - procedure(run), deferred :: run - procedure(getName), deferred :: getName - procedure :: setName - end type Test - - abstract interface - - integer function countTestCases(this) - import Test - class (Test), intent(in) :: this - end function countTestCases - - recursive subroutine run(this, tstResult, context) - use TestResult_mod - use ParallelContext_mod - import Test - class (Test), intent(inout) :: this - class (TestResult), intent(inout) :: tstResult - class (ParallelContext), intent(in) :: context - end subroutine run - - function getName(this) result(name) - import Test - class (Test), intent(in) :: this - character(:), allocatable :: name - end function getName - - end interface -contains - subroutine setName(this, name) - class (Test), intent(inout) :: this - character(len=*), intent(in) :: name - ! Default: Cannot change name - end subroutine setName - -end module Test_mod diff --git a/tests/pFUnit-3.2.9/source/TestCase.F90 b/tests/pFUnit-3.2.9/source/TestCase.F90 deleted file mode 100644 index 2765f76d..00000000 --- a/tests/pFUnit-3.2.9/source/TestCase.F90 +++ /dev/null @@ -1,200 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestCase -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! Serial TestCase -module TestCase_mod - use Exception_mod, only : throw - use Params_mod, only : MAX_LENGTH_NAME - use SurrogateTestCase_mod - use TestResult_mod - use Test_mod - - private - - public :: TestCase - public :: TestCaseReference - - type, extends(SurrogateTestCase) :: ConcreteSurrogate - private - class (TestCase), pointer :: tCase => null() - contains - procedure :: runBare => runBare_surrogate - procedure :: setName => setName_surrogate - procedure :: getName => getName_surrogate - end type ConcreteSurrogate - - type, abstract, extends(Test) :: TestCase - private - type (ConcreteSurrogate) :: surrogate -#ifdef DEFERRED_LENGTH_CHARACTER - character(:), allocatable :: name -#else - character(len=MAX_LENGTH_NAME) :: name -#endif - contains - procedure :: setSurrogate - procedure :: baseName - procedure :: getName - procedure :: setName - procedure :: countTestCases - procedure :: run - procedure :: runBare - procedure :: setUp - procedure :: tearDown - procedure :: getSurrogate - procedure :: runMethod - end type TestCase - - type TestCaseReference - class (TestCase), allocatable :: test - end type TestCaseReference - -contains - - function baseName(this) result(name) - class (TestCase), intent(in) :: this - character(:), allocatable :: name - name = this%name - end function baseName - - function getName(this) result(name) - class (TestCase), intent(in) :: this - character(:), allocatable :: name - name = this%baseName() - end function getName - - subroutine setName(this, name) - class (TestCase), intent(inout) :: this - character(len=*),intent(in) :: name - -#ifndef DEFERRED_LENGTH_CHARACTER - integer :: nameLength - - nameLength = len_trim( name ) - if (nameLength > MAX_LENGTH_NAME) then - call throw( 'TestCase.setName: Too long: ' // name ) - nameLength = MAX_LENGTH_NAME - end if - this%name = name(1:nameLength) -#else - this%name = trim(name) -#endif - - end subroutine setName - - integer function countTestCases(this) - class (TestCase), intent(in) :: this - countTestCases = 1 - end function countTestCases - -! Implement deferred method from class Test - recursive subroutine run(this, tstResult, context) - use SerialContext_mod - use TestResult_mod - use ParallelContext_mod - class (TestCase), intent(inout) :: this - class (TestResult), intent(inout) :: tstResult - class (ParallelContext), intent(in) :: context - - ! NAG 6.1 revealed that one cannot rely on surrogate - ! due to the non-TARGET for argument "this". - ! NAG provided the workaround with this inner procedure. - call inner_run(this, tstresult, context) - - contains - - recursive subroutine inner_run(this,tstresult,context) - class (TestCase), intent(inout), target :: this - class (TestResult), intent(inout) :: tstresult - class (ParallelContext), intent(in) :: context - class (SurrogateTestCase), allocatable :: surrogate - - ! Always run serial tests in a serial context. - if (context%isRootProcess()) then - allocate(surrogate,source=this%getSurrogate()) - call tstResult%run(surrogate, THE_SERIAL_CONTEXT) - end if - - call context%barrier() - - end subroutine inner_run - - end subroutine run - - recursive subroutine runBare(this) - use Exception_mod, only: noExceptions - class (TestCase), intent(inout) :: this - - call this%setUp() - if (noExceptions()) then - call this%runMethod() - call this%tearDown() - end if - - end subroutine runBare - - recursive subroutine runBare_surrogate(this) - class (ConcreteSurrogate), intent(inout) :: this - class (TestCase), pointer :: p - p => this%tCase - call p%runBare() - end subroutine runBare_surrogate - - function getName_surrogate(this) result(name) - class (ConcreteSurrogate), intent(in) :: this - character(:), allocatable :: name - name = this%tCase%getName() - end function getName_surrogate - - subroutine setName_surrogate(this, name) - class (ConcreteSurrogate), intent(inout) :: this - character(len=*),intent(in) :: name - call this%tCase%setName(trim(name)) - end subroutine setName_surrogate - - subroutine setUp(this) - class (TestCase), intent(inOut) :: this - end subroutine setUp - - subroutine tearDown(this) - class (TestCase), intent(inOut) :: this - end subroutine tearDown - - function getSurrogate(this) result(surrogate) - class (TestCase), target, intent(inout) :: this - class (SurrogateTestCase), pointer :: surrogate - call this%setSurrogate() - surrogate => this%surrogate - end function getSurrogate - - subroutine setSurrogate(this) - class (TestCase), target :: this - this%surrogate%tCase => this - end subroutine setSurrogate - - recursive subroutine runMethod(this) - use Exception_mod, only: throw - class (TestCase), intent(inout) :: this - call throw('TestCase::runMethod() must be overridden.') - end subroutine runMethod - -end module TestCase_mod diff --git a/tests/pFUnit-3.2.9/source/TestFailure.F90 b/tests/pFUnit-3.2.9/source/TestFailure.F90 deleted file mode 100644 index a99f9215..00000000 --- a/tests/pFUnit-3.2.9/source/TestFailure.F90 +++ /dev/null @@ -1,46 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestFailure -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module TestFailure_mod - use Exception_mod - implicit none - private - - public :: TestFailure - - type TestFailure - character(len=80) :: testName - type (Exception), allocatable :: exceptions(:) - end type TestFailure - -!!$ interface TestFailure -!!$ module procedure newTestFailure -!!$ end interface TestFailure -!!$ -!!$contains -!!$ -!!$ function newTestFailure(testName, list) -!!$ character(len=*), intent(in) :: testName -!!$ type (Exception), intent(in) :: exceptions(:) -!!$ end function newTestFailure - -end module TestFailure_mod diff --git a/tests/pFUnit-3.2.9/source/TestListener.F90 b/tests/pFUnit-3.2.9/source/TestListener.F90 deleted file mode 100644 index 8cd12d7b..00000000 --- a/tests/pFUnit-3.2.9/source/TestListener.F90 +++ /dev/null @@ -1,108 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestListener -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module TestListener_mod - implicit none - private - - public :: TestListener - public :: ListenerPointer - - type, abstract :: TestListener - private - logical :: useDebug = .false. - contains - procedure(addFailure), deferred :: addFailure - procedure(startTest), deferred :: startTest - procedure(endTest), deferred :: endTest -! procedure(startRun), deferred :: startRun ! make deferred when ready - procedure(endRun), deferred :: endRun ! make deferred when ready - procedure :: addError - procedure :: setDebug - procedure :: debug - end type TestListener - - type ListenerPointer - class (TestListener), pointer :: pListener - end type ListenerPointer - - abstract interface - subroutine addFailure(this, testName, exceptions) - use Exception_mod - import TestListener - class (TestListener), intent(inout) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - end subroutine addFailure - - subroutine startTest(this, testName) - import TestListener - class (TestListener), intent(inout) :: this - character(len=*), intent(in) :: testName - end subroutine startTest - - subroutine endTest(this, testName) - import TestListener - class (TestListener), intent(inout) :: this - character(len=*), intent(in) :: testName - end subroutine endTest - -! ! Stub for future implementation. -! subroutine startRun(this) -! import TestListener -! class (TestListener), intent(inout) :: this -! end subroutine startRun -! - ! Stub for future implementation. - subroutine endRun(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - import TestListener - class (TestListener), intent(inout) :: this - class (AbstractTestResult), intent(in) :: result - end subroutine endRun - - end interface - -contains - - ! Most scenarios in Fortran cannot diagnose true errors, so - ! an empty stub is provided here for convenience. - subroutine addError(this, testName, exceptions) - use Exception_mod, only: Exception - class (TestListener), intent(inout) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - end subroutine addError - - ! Promoted from BaseTestRunner.F90. Every listener can have debug - ! behaviors. - subroutine setDebug(this) - class (TestListener), intent(inout) :: this - this%useDebug = .true. - end subroutine setDebug - - logical function debug(this) - class (TestListener), intent(inout) :: this - debug = this%useDebug - end function debug - - end module TestListener_mod diff --git a/tests/pFUnit-3.2.9/source/TestMethod.F90 b/tests/pFUnit-3.2.9/source/TestMethod.F90 deleted file mode 100644 index f1965998..00000000 --- a/tests/pFUnit-3.2.9/source/TestMethod.F90 +++ /dev/null @@ -1,101 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestMethod -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module TestMethod_mod - use TestCase_mod, only: TestCase - implicit none - private - - public :: TestMethod - public :: newTestMethod - - type, extends(TestCase) :: TestMethod - procedure(empty), nopass, pointer :: userMethod => null() - procedure(empty), nopass, pointer :: userSetUp => null() - procedure(empty), nopass, pointer :: userTearDown => null() - contains - procedure :: runMethod - procedure :: setUp - procedure :: tearDown - end type TestMethod - - abstract interface - subroutine empty() - end subroutine empty - end interface - - interface newTestMethod - module procedure TestMethod_ - module procedure TestMethod_setUpTearDown - end interface newTestMethod - -! TODO: ifort 14.0.1 still has indirect issues with the following overload -!!$ interface TestMethod -!!$ module procedure TestMethod_ -!!$ module procedure TestMethod_setUpTearDown -!!$ end interface TestMethod - -contains - - function TestMethod_(name, method) result(this) - type (TestMethod) :: this - character(len=*), intent(in) :: name - procedure(empty) :: method - - call this%setName(name) - this%userMethod => method - - end function TestMethod_ - - function TestMethod_setUpTearDown(name, method, setUp, tearDown) result(this) - type (TestMethod) :: this - character(len=*), intent(in) :: name - procedure(empty) :: method - procedure(empty) :: setUp - procedure(empty) :: tearDown - - call this%setName(name) - this%userMethod => method - this%userSetUp => setUp - this%userTearDown => tearDown - - end function TestMethod_setUpTearDown - - recursive subroutine runMethod(this) - use Exception_mod, only: getNumExceptions - class (TestMethod), intent(inOut) :: this - - call this%userMethod() - - end subroutine runMethod - - subroutine setUp(this) - class (TestMethod), intent(inout) :: this - if (associated(this%userSetUp)) call this%userSetUp() - end subroutine setUp - - subroutine tearDown(this) - class (TestMethod), intent(inout) :: this - if (associated(this%userTearDown)) call this%userTearDown() - end subroutine tearDown - -end module TestMethod_mod diff --git a/tests/pFUnit-3.2.9/source/TestResult.F90 b/tests/pFUnit-3.2.9/source/TestResult.F90 deleted file mode 100644 index b0ae4865..00000000 --- a/tests/pFUnit-3.2.9/source/TestResult.F90 +++ /dev/null @@ -1,342 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestResult -! -!> @brief -!! -!! Note: A possible extension point for user-specialized TestResults. -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module TestResult_mod - use AbstractTestResult_mod - use SurrogateTestCase_mod - use TestListener_mod - use TestFailure_mod - - implicit none - private - - public :: TestResult - public :: newTestResult - -#ifndef DEFERRED_LENGTH_CHARACTER - integer, parameter :: MAX_LENGTH_NAME = 64 -#endif - - type, extends(AbstractTestResult) :: TestResult - private - integer :: numFailed = 0 - integer :: numErrors = 0 - integer :: numRun = 0 - integer :: numSuccesses = 0 - real :: runTime - type (ListenerPointer), allocatable :: listeners(:) - type (TestFailure), allocatable :: failures(:) - type (TestFailure), allocatable :: errors(:) - type (TestFailure), allocatable :: successes(:) -#ifdef DEFERRED_LENGTH_CHARACTER - character(:), allocatable :: name -#else - character(len=MAX_LENGTH_NAME) :: name -#endif - contains - procedure :: addFailure - procedure :: addError - procedure :: addSuccess - procedure :: zeroRunTime - procedure :: addRunTime - procedure :: getRunTime - procedure :: failureCount - procedure :: errorCount - procedure :: startTest - procedure :: endTest - procedure :: runCount - procedure :: run - procedure :: addListener - procedure :: wasSuccessful - procedure :: getSuccesses - procedure :: getErrors - procedure :: getFailures - procedure :: getIthFailure - procedure :: getName - procedure :: setName - end type TestResult - -contains - - function newTestResult(name) - type (TestResult) :: newTestResult - character(len=*), intent(in), optional :: name - allocate(newTestResult%listeners(0)) - allocate(newTestResult%failures(0)) - allocate(newTestResult%errors(0)) - allocate(newTestResult%successes(0)) - newTestResult%numFailed = 0 - newTestResult%numErrors = 0 - newTestResult%numRun = 0 - newTestResult%numSuccesses = 0 - newTestResult%runTime = 0 - if(present(name)) then - newTestResult%name = name - else - newTestResult%name = 'default_suite_name' - end if - end function newTestResult - - subroutine addFailure(this, aTest, exceptions) - use Exception_mod, only: Exception - use TestFailure_mod - class (TestResult), intent(inout) :: this - class (SurrogateTestCase), intent(in) :: aTest - type (Exception), intent(in) :: exceptions(:) - - integer :: i, n - type (TestFailure), allocatable :: tmp(:) - - n = this%numFailed - allocate(tmp(n)) - tmp(1:n) = this%failures(1:n) - deallocate(this%failures) - allocate(this%failures(n+1)) - this%failures(1:n) = tmp - deallocate(tmp) - this%failures(n+1) = TestFailure(aTest%getName(), exceptions) - - this%numFailed = n + 1 - do i = 1, size(this%listeners) - call this%listeners(i)%pListener%addFailure(aTest%getName(), exceptions) - end do - - end subroutine addFailure - - subroutine addError(this, aTest, exceptions) - use Exception_mod, only: Exception - use TestFailure_mod - class (TestResult), intent(inout) :: this - class (SurrogateTestCase), intent(in) :: aTest - type (Exception), intent(in) :: exceptions(:) - - integer :: i, n - type (TestFailure), allocatable :: tmp(:) - - n = this%numErrors - allocate(tmp(n)) - tmp(1:n) = this%errors(1:n) - deallocate(this%errors) - allocate(this%errors(n+1)) - this%errors(1:n) = tmp - deallocate(tmp) - this%errors(n+1) = TestFailure(aTest%getName(), exceptions) - - this%numErrors = n + 1 - do i = 1, size(this%listeners) - call this%listeners(i)%pListener%addError(aTest%getName(), exceptions) - end do - - end subroutine addError - - subroutine addSuccess(this, aTest) - use Exception_mod, only: Exception - use TestFailure_mod - class (TestResult), intent(inout) :: this - class (SurrogateTestCase), intent(in) :: aTest - -! integer :: i, n - integer :: n - type (TestFailure), allocatable :: tmp(:) - type (Exception), allocatable :: noExceptions(:) -! type (Exception) :: noExceptions(0) - - allocate(noExceptions(0)) - - n = this%numSuccesses - allocate(tmp(n)) - tmp(1:n) = this%successes(1:n) - deallocate(this%successes) - allocate(this%successes(n+1)) - this%successes(1:n) = tmp - deallocate(tmp) - this%successes(n+1) = TestFailure(aTest%getName(), noExceptions) - - this%numSuccesses = n + 1 - - end subroutine addSuccess - - integer function failureCount(this) - class (TestResult), intent(in) :: this - failureCount = this%numFailed - end function failureCount - - integer function errorCount(this) - class (TestResult), intent(in) :: this - errorCount = this%numErrors - end function errorCount - - subroutine startTest(this, aTest) - use StringConversionUtilities_mod, only : toString - class (TestResult), intent(inout) :: this - class (SurrogateTestCase), intent(in) :: aTest - - integer :: i - - - this%numRun = this%numRun + 1 - - !print *,'1000 starting: '//toString(this%numRun)//' '//trim(aTest%getName()) - - do i = 1, size(this%listeners) - call this%listeners(i)%pListener%startTest(aTest%getName()) - end do - - end subroutine startTest - - subroutine endTest(this, aTest) - class (TestResult), intent(inout) :: this - class (SurrogateTestCase), intent(in) :: aTest - - integer :: i - - do i = 1, size(this%listeners) - call this%listeners(i)%pListener%endTest(aTest%getName()) - end do - - end subroutine endTest - - integer function runCount(this) - class (TestResult), intent(in) :: this - runCount = this%numRun - end function runCount - -! only invoked for a "real" test, not suites etc. - recursive subroutine run(this, test, context) - use Exception_mod - use ParallelContext_mod - class (TestResult), intent(inout) :: this - class (SurrogateTestCase) :: test - class (ParallelContext), intent(in) :: context - - if (context%isRootProcess()) call this%startTest(test) - - call test%runBare() - - if (context%isRootProcess()) then - if (anyErrors()) then - call this%addError(test, getExceptions()) - elseif (anyExceptions()) then - call this%addFailure(test, getExceptions()) - else - call this%addSuccess(test) - end if - end if - - if (context%isRootProcess()) call this%endTest(test) - - end subroutine run - - subroutine addListener(this, listener) - use TestListener_mod, only: TestListener - class (TestResult), intent(inOut) :: this - class (TestListener), target, intent(in) :: listener - - integer :: n - - call extend(this%listeners) - n = size(this%listeners) - this%listeners(n)%pListener => listener - - contains - - subroutine extend(listeners) - type (ListenerPointer), allocatable, intent(inout) :: listeners(:) - type (ListenerPointer), allocatable :: temp(:) - integer :: n - - n = size(listeners) - temp = listeners - deallocate(listeners) - - allocate(listeners(n+1)) - listeners(:n) = temp - deallocate(temp) - - end subroutine extend - - end subroutine addListener - - function getIthFailure(this, i) result(failure) - class (TestResult), intent(in) :: this - integer, intent(in) :: i - type (TestFailure) :: failure - - failure = this%failures(i) - - end function getIthFailure - - logical function wasSuccessful(this) - class (TestResult), intent(in) :: this - wasSuccessful = (this%failureCount() == 0) .and. (this%errorCount() == 0) - end function wasSuccessful - - function getSuccesses(this) result(successes) - class (TestResult), intent(in) :: this - type (TestFailure), allocatable :: successes(:) - successes = this%successes - end function getSuccesses - - function getErrors(this) result(errors) - class (TestResult), intent(in) :: this - type (TestFailure), allocatable :: errors(:) - errors = this%errors - end function getErrors - - function getFailures(this) result(failures) - class (TestResult), intent(in) :: this - type (TestFailure), allocatable :: failures(:) - failures = this%failures - end function getFailures - - subroutine zeroRunTime(this) - class (TestResult), intent(inout) :: this - this%runTime = 0 - end subroutine zeroRunTime - - subroutine addRunTime(this, time) - class (TestResult), intent(inout) :: this - real, intent(in) :: time - this%runTime = this%runTime + time - end subroutine addRunTime - - function getRunTime(this) result(duration) - class (TestResult), intent(in) :: this - real :: duration - duration = this%runTime - end function getRunTime - - function getName(this) result(name) - class (TestResult), intent(in) :: this - character(:), allocatable :: name - name = this%name - end function getName - - subroutine setName(this, name) - class (TestResult), intent(inout) :: this - character(len=*),intent(in) :: name - - this%name = trim(name) - end subroutine setName - -end module TestResult_mod diff --git a/tests/pFUnit-3.2.9/source/TestRunner.F90 b/tests/pFUnit-3.2.9/source/TestRunner.F90 deleted file mode 100644 index 1bb5af36..00000000 --- a/tests/pFUnit-3.2.9/source/TestRunner.F90 +++ /dev/null @@ -1,144 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestRunner -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- - -module TestRunner_mod - use Test_mod - use BaseTestRunner_mod - use TestListener_mod - implicit none - private - - public :: TestRunner - public :: newTestRunner - - type, extends(BaseTestRunner) :: TestRunner - type (ListenerPointer), allocatable :: extListeners(:) - contains - procedure :: run - procedure :: createTestResult - procedure :: addFailure - procedure :: startTest - procedure :: endTest - procedure :: endRun - end type TestRunner - - interface newTestRunner - module procedure newTestRunner_default - module procedure newTestRunner_unit - end interface - -contains - - function newTestRunner_default() result(runner) -!mlr- use iso_fortran_env, only: OUTPUT_UNIT - type (TestRunner) :: runner - allocate(runner%extListeners(0)) - end function newTestRunner_default - - function newTestRunner_unit(extListeners) result(runner) - type(ListenerPointer), intent(in) :: extListeners(:) - type (TestRunner) :: runner - allocate(runner%extListeners(size(extListeners)), source=extListeners) - end function newTestRunner_unit - - function createTestResult(this) result(tstResult) - use TestResult_mod - class (TestRunner), intent(inout) :: this - type (TestResult) :: tstResult - - tstResult = newTestResult() - - end function createTestResult - - function run(this, aTest, context) result(result) - use Test_mod - use TestSuite_mod - use TestCase_mod - use TestResult_mod - use ParallelContext_mod - - type (TestResult) :: result - class (TestRunner), target, intent(inout) :: this - class (Test), intent(inout) :: aTest - class (ParallelContext), intent(in) :: context - - integer :: clockStart - integer :: clockStop - integer :: clockRate - integer :: i - - - call system_clock(clockStart) - - result = this%createTestResult() - call result%setName(aTest%getName()) -! Add the extListeners to the listeners list. - - do i=1,size(this%extListeners) - call result%addListener(this%extListeners(i)%pListener) - end do - call aTest%run(result, context) - call system_clock(clockStop, clockRate) - - call result%addRunTime(real(clockStop - clockStart) / clockRate) - -! Post run printing. Q: Should we do this for listeners too? -! E.g. and end-run method & move this up to basetestrunner... - -! e.g. call result%endRun()... - if (context%isRootProcess()) then - do i=1,size(this%extListeners) - call this%extListeners(i)%pListener%endRun(result) - end do - end if -!tc: 2+1 lists -- extListeners, listeners and in testresult too... - end function run - -! Recall, runner is also a listener and these will be called from -! TestResult, adding the ability to put in functionality here. In -! addition to other listeners added above. -! - subroutine startTest(this, testName) - class (TestRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - end subroutine startTest - - subroutine endTest(this, testName) - class (TestRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - end subroutine endTest - - subroutine endRun(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (TestRunner), intent(inout) :: this - class (AbstractTestResult), intent(in) :: result - end subroutine endRun - - subroutine addFailure(this, testName, exceptions) - use Exception_mod - class (TestRunner), intent(inout) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - end subroutine addFailure - -end module TestRunner_mod diff --git a/tests/pFUnit-3.2.9/source/TestSuite.F90 b/tests/pFUnit-3.2.9/source/TestSuite.F90 deleted file mode 100644 index cb261624..00000000 --- a/tests/pFUnit-3.2.9/source/TestSuite.F90 +++ /dev/null @@ -1,296 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: TestSuite -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module TestSuite_mod - use Exception_mod, only : throw - use Params_mod, only : MAX_LENGTH_NAME - use Test_mod - implicit none - private - - public :: TestSuite - public :: newTestSuite - - type TestReference - class (Test), allocatable :: pTest - end type TestReference - - type, extends(Test) :: TestSuite - private -#ifdef DEFERRED_LENGTH_CHARACTER - character(:), allocatable :: name -#else - character(MAX_LENGTH_NAME) :: name -#endif - type (TestReference), allocatable :: tests(:) - contains - procedure :: getName - procedure :: setName - procedure :: countTestCases - procedure :: run - procedure :: addTest - procedure :: getNumTests - procedure :: copy - generic :: assignment(=) => copy - procedure :: getTestCases - end type TestSuite - - interface newTestSuite - module procedure newTestSuite_unnamed - module procedure newTestSuite_named - end interface newTestSuite - -contains - - function newTestSuite_unnamed() result(newSuite) - type (TestSuite) :: newSuite - newSuite = newTestSuite_named('') - end function newTestSuite_unnamed - - function newTestSuite_named(name) result(newSuite) - type (TestSuite) :: newSuite - character(len=*), intent(in) :: name - - allocate(newSuite%tests(0)) - call newSuite%setName(name) - - end function newTestSuite_named - - recursive subroutine copy(this, b) - class (TestSuite), intent(out) :: this - type (TestSuite), intent(in) :: b - integer :: i, n - - call this%setName(b%getName()) - n = b%getNumTests() - - allocate(this%tests(n)) - do i = 1, n - allocate(this%tests(i)%ptest, source=b%tests(i)%ptest) - end do - - end subroutine copy - - recursive integer function countTestCases(this) - class (TestSuite), intent(in) :: this - integer :: i - - countTestCases = 0 - do i = 1, this%getNumTests() - countTestCases = countTestCases + this%tests(i)%pTest%countTestCases() - end do - - end function countTestCases - - recursive subroutine run(this, tstResult, context) - use ParallelContext_mod - use TestResult_mod - class (TestSuite), intent(inout) :: this - class (TestResult), intent(inout) :: tstResult - class (ParallelContext), intent(in) :: context - - integer :: i - - do i = 1, this%getNumTests() - call this%tests(i)%ptest%run(tstResult, context) - end do - - end subroutine run - - recursive subroutine addTest(this, aTest) - class (TestSuite), intent(inout) :: this - class (Test), intent(in) :: aTest -#ifdef DEFERRED_LENGTH_CHARACTER - character(:), allocatable :: name -#else - character(MAX_LENGTH_NAME) :: name - character(MAX_LENGTH_NAME) :: suiteName - character(MAX_LENGTH_NAME) :: testName - - integer :: suiteNameLength - integer :: testNameLength -#endif - call extend(this%tests) - allocate(this%tests(this%getNumTests())%pTest, source=aTest) -#ifdef DEFERRED_LENGTH_CHARACTER - name = this%getName() // '.' // this%tests(this%getNumTests())%pTest%getName() -#else - suiteName = this%getName() - suiteNameLength = len_trim( suiteName ) - testName = this%tests(this%getNumTests())%pTest%getName() - testNameLength = len_trim( testName ) - - ! +/-1 below for full stop character to be added - if (suiteNameLength + 1 + testNameLength > MAX_LENGTH_NAME) then - call throw( 'TestSuite.addTest: Too long: ' & - // suiteName(1:suiteNameLength) // '.' & - // testName(1:testNameLength) ) - testNameLength = min( testNameLength, MAX_LENGTH_NAME - 1) - suiteNameLength = min( suiteNameLength, & - MAX_LENGTH_NAME - 1 -testNameLength ) - end if - - write( name, '(A, ".", A)' ) suiteName(1:suiteNameLength), & - testName(1:testNameLength) -#endif - call this%tests(this%getNumTests())%pTest%setName(name) - - contains - - recursive subroutine extend(list) - type (TestReference), allocatable :: list(:) - type (TestReference), allocatable :: temp(:) - integer :: i, n - - n = size(list) - call move_alloc(from=list, to=temp) - - allocate(list(n+1)) - do i = 1, n - call kludge_move_alloc(from=temp(i)%ptest, to=list(i)%ptest) - end do - - deallocate(temp) - - end subroutine extend - - subroutine kludge_move_alloc(from, to) - class (Test), allocatable :: from - class (Test), allocatable :: to - call move_alloc(from=from, to=to) - end subroutine kludge_move_alloc - - end subroutine addTest - - pure integer function getNumTests(this) - class (TestSuite), intent(in) :: this - getNumTests = size(this%tests) - end function getNumTests - - function getName(this) result(name) - class (TestSuite), intent(in) :: this - character(:), allocatable :: name - name = trim(this%name) - end function getName - - subroutine setName(this, name) - class (TestSuite), intent(inout) :: this - character(len=*), intent(in) :: name -#ifndef DEFERRED_LENGTH_CHARACTER - integer nameLength - - nameLength = len_trim( name ) - if (nameLength > MAX_LENGTH_NAME) then - call throw( 'TestSuite.setName: Too long: ' // name ) - nameLength = MAX_LENGTH_NAME - end if - this%name = name(1:nameLength) -#else - this%name = trim(name) -#endif - end subroutine setName - -#if ((__INTEL_COMPILER) && (INTEL_13)) - recursive function getTestCases(this) result(testList) - use Exception_mod - use Test_mod - use TestCase_mod - class (TestSuite), intent(in) :: this - type (TestCaseReference), allocatable :: testList(:) - type (TestCaseReference), allocatable :: tmp(:) - - integer :: i, j - integer :: n, m - - allocate(testList(this%countTestCases())) - - n = 1 - do i = 1, size(this%tests) - associate (t => this%tests(i)%pTest) - select type (t) - class is (TestCase) - ! ifort 13.1 cannot handle direct assignment of polymorphic here - allocate(testList(n)%test, source=t) -!!$ testList(n) = TestCaseReference(t) - n = n + 1 - class is (TestSuite) - m = t%countTestCases() - ! ifort 13.1 is incorrectly handling assignment into subrange of tmpList - ! It reallocates the array and gets the wrong size as a result. - ! Forced to do explict loop over a temporary. - tmp = t%getTestCases() - do j = 1, m - allocate(testList(n+j-1)%test, source=tmp(j)%test) - end do -!!$ testList(n:n+m-1) = t%getTestCases() - n = n + m - class default - call throw('Unsupported Test subclass in TestSuite::getTestCases()') - end select - end associate - end do - - end function getTestCases -#else - subroutine getTestCases(this, testList) - use Exception_mod - use Test_mod - use TestCase_mod - class (TestSuite), intent(in) :: this - type (TestCaseReference), allocatable :: testList(:) - - integer :: n - - allocate(testList(this%countTestCases())) - - n = 0 - call accumulateTestCases(this, testList, n) - - contains - - recursive subroutine accumulateTestCases(this, testList, n) - class (TestSuite), intent(in) :: this - type (TestCaseReference), intent(inout) :: testList(:) - integer, intent(inout) :: n - - integer :: i, j - - do i = 1, size(this%tests) - - select type (t => this%tests(i)%pTest) - class is (TestCase) - n = n + 1 - allocate(testList(n)%test, source=t) - class is (TestSuite) - call accumulateTestCases(t, testList, n) - class default - call throw('Unsupported Test subclass in TestSuite::getTestCases()') - end select - - end do - - end subroutine accumulateTestCases - - end subroutine getTestCases -#endif - -end module TestSuite_mod diff --git a/tests/pFUnit-3.2.9/source/ThrowFundamentalTypes.F90 b/tests/pFUnit-3.2.9/source/ThrowFundamentalTypes.F90 deleted file mode 100644 index f7b93de1..00000000 --- a/tests/pFUnit-3.2.9/source/ThrowFundamentalTypes.F90 +++ /dev/null @@ -1,228 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: ThrowFundamentalTypes -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- - -module ThrowFundamentalTypes_mod - - use Params_mod - use StringConversionUtilities_mod - use Exception_mod - use SourceLocation_mod - - implicit none - private - - public :: locationFormat - public :: throwNonConformable - public :: throwDifferentValues - public :: throwDifferentValuesWithLocation - -!mlr-!!! Can we put these in one place? -!mlr- integer, parameter :: MAX_LEN_MSG = 1000 -!mlr- integer, parameter :: MAX_LEN_FLOAT = 25 -!mlr- integer, parameter :: MAX_LEN_INT = 15 -!mlr- -!mlr- integer, parameter :: L_INFINITY_NORM = 0 -!mlr- integer, parameter :: L1_NORM = 1 -!mlr- integer, parameter :: L2_NORM = 2 - -! interface locationFormat -! module procedure locationFormat -! end interface locationFormat - - interface throwDifferentValues - module procedure throwDifferentValues_ii - module procedure throwDifferentValues_ir - module procedure throwDifferentValues_rr - end interface throwDifferentValues - - interface throwDifferentValuesWithLocation - module procedure throwDifferentValuesWithLocation_ii - module procedure throwDifferentValuesWithLocation_ir - module procedure throwDifferentValuesWithLocation_rr - end interface throwDifferentValuesWithLocation - -contains - - ! Consider promoting to module level scope. - subroutine throwNonConformable(shapeExpected, shapeFound, location) - integer, intent(in) :: shapeExpected(:) - integer, intent(in) :: shapeFound(:) - type (SourceLocation), optional, intent(in) :: location - - call throw( & - & 'Assertion failed: non-conformable real arrays.' // new_line('$') //& - & ' expected shape: <['//trim(toString(shapeExpected))//']>' // new_line('$') //& - & ' but found shape: <['//trim(toString(shapeFound))//']>', & - & location=location & - & ) - end subroutine throwNonConformable - - subroutine compareElements(expected, found, i1, i2, location) - real, intent(in) :: expected, found - integer, intent(in) :: i1, i2 - type (SourceLocation), optional, intent(in) :: location - - ! the test - if (expected /= found) then - call throwDifferentValues(expected, found, i1, i2, 0.0, location=location) - end if - end subroutine compareElements - - subroutine throwDifferentValues_ii(iExpected, iFound, i1, i2, tolerance, location) - integer, intent(in) :: iExpected, iFound - integer, intent(in) :: i1, i2 - real, intent(in) :: tolerance - type (SourceLocation), optional, intent(in) :: location - - ! Check with team to see if this is okay. - call throwDifferentValues_rr(real(iExpected), real(iFound), i1, i2, tolerance, & - & location=location) - - end subroutine throwDifferentValues_ii - - subroutine throwDifferentValues_ir(iExpected, found, i1, i2, tolerance, location) - integer, intent(in) :: iExpected - real, intent(in) :: found - integer, intent(in) :: i1, i2 - real, intent(in) :: tolerance - type (SourceLocation), optional, intent(in) :: location - - ! Check with team to see if this is okay. - call throwDifferentValues_rr(real(iExpected), found, i1, i2, tolerance, & - & location=location) - - end subroutine throwDifferentValues_ir - - subroutine throwDifferentValues_rr(expected, found, i1, i2, tolerance, & - & location ) - real, intent(in) :: expected, found - integer, intent(in) :: i1, i2 - real, intent(in) :: tolerance - type (SourceLocation), optional, intent(in) :: location - - !mlr maybe move this to a larger scope... - integer, parameter :: MAXLEN_SHAPE = 80 - - ! "locationInArray" is not used in the original AssertEqual code. - character(len=MAXLEN_SHAPE) :: locationInArray - write(locationInArray,'("[",i0,", ",i0," ]")') i1, i2 - - call throw( & - & 'Assertion failed: unequal real 2D arrays.' // new_line('$') // & - & ' First difference at element <' // locationInArray // '>' // & - & trim(valuesReport(expected, found)) // & - & trim(differenceReport(found - expected, tolerance)), & - & location=location & -! & trim(differenceReport(found - expected, 0.)) & - & ) - - end subroutine throwDifferentValues_rr - - subroutine throwDifferentValuesWithLocation_ii( & - & iExpected, iFound, iLocation, tolerance, location ) - integer, intent(in) :: iExpected, iFound - integer, intent(in) :: iLocation(:) - real, intent(in) :: tolerance - type (SourceLocation), optional, intent(in) :: location - - ! Check with team to see if this is okay. - call throwDifferentValuesWithLocation_rr( & - & real(iExpected), real(iFound), iLocation, tolerance, location=location ) - - end subroutine throwDifferentValuesWithLocation_ii - - subroutine throwDifferentValuesWithLocation_ir( & - & iExpected, found, iLocation, tolerance, location) - integer, intent(in) :: iExpected - real, intent(in) :: found - integer, intent(in) :: iLocation(:) - real, intent(in) :: tolerance - type (SourceLocation), optional, intent(in) :: location - - ! Check with team to see if this is okay. ! Answer: meh... - call throwDifferentValuesWithLocation_rr( & - & real(iExpected), found, iLocation, tolerance, location=location) - - end subroutine throwDifferentValuesWithLocation_ir - - function locationFormat(iLocation) result (fmt) - integer, intent(in) :: iLocation(:) - - !mlr maybe move this to a larger scope... - integer, parameter :: MAXLEN_SHAPE = 80*2 - - character(len=MAXLEN_SHAPE) :: fmt - integer :: iLocationSize - - iLocationSize = size(iLocation) - - if (iLocationSize .eq. 0) then - fmt = '("[", i0, "]")' - else if (iLocationSize .eq. 1) then - fmt = '("[", i0, "]")' - else - write(fmt,*) '("[",',iLocationSize-1,'(i0,", "), i0, "]")' - end if - - end function locationFormat - - subroutine throwDifferentValuesWithLocation_rr( & - & expected, found, iLocation, tolerance, location) - real, intent(in) :: expected, found - integer, intent(in) :: iLocation(:) -! integer :: iLocationSize - real, intent(in) :: tolerance - type (SourceLocation), optional, intent(in) :: location - - !mlr maybe move this to a larger scope... - integer, parameter :: MAXLEN_SHAPE = 80*2 - - ! "location" is not used in the original AssertEqual code. - character(len=MAXLEN_SHAPE) :: locationInArray - - write(locationInArray, locationFormat(iLocation)) iLocation - - call throw( & - & 'Assertion failed: unequal arrays.' // new_line('$') // & - & ' First difference at element <' // trim(locationInArray) // '>' // & - & trim(valuesReport(expected, found)) // & - & trim(differenceReport(found - expected, tolerance)), & - & location=location & - & ) - - end subroutine throwDifferentValuesWithLocation_rr - - character(len=MAXLEN_MESSAGE) function valuesReport(expected, found) - real, intent(in) :: expected - real, intent(in) :: found - - valuesReport = 'expected: <' // trim(toString(expected)) // '> but found: <' // trim(toString(found)) // '>' - end function valuesReport - - character(len=MAXLEN_MESSAGE) function differenceReport(difference, tolerance) - real, intent(in) :: difference - real, intent(in) :: tolerance - differenceReport = ' difference: |' // trim(toString(difference)) // '| > tolerance:' // trim(toString(tolerance)) - end function differenceReport - -end module ThrowFundamentalTypes_mod diff --git a/tests/pFUnit-3.2.9/source/UnixPipeInterfaces.F90 b/tests/pFUnit-3.2.9/source/UnixPipeInterfaces.F90 deleted file mode 100644 index 9f5a8b86..00000000 --- a/tests/pFUnit-3.2.9/source/UnixPipeInterfaces.F90 +++ /dev/null @@ -1,97 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: UnixPipeInterfaces -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -!----------- -! This module provides Bind(C) interfaces for -! standard unix pipe utilities: popen(), fgets(), and pclose(). -! -! These utilities work at a very low level, and should generally not -! be used directly from a user application. E.g. strings must be null -! terminated. -! UnixProcess.F90 provides a (customized) higher-level interface that -! should be safer for routine use. -!------------- - -module UnixPipeInterfaces_mod - use, intrinsic :: ISO_C_BINDING - private - - public :: popen - public :: fgets - public :: pclose - public :: getline - public :: getdelim - public :: free - - ! error codes - public :: CLOSE_FAILED - - integer(C_INT), parameter :: CLOSE_FAILED = -1 - - interface - - function popen(command, mode) result(file) bind(C, name='popen') - use, intrinsic :: iso_c_binding - type (C_PTR) :: file - character(kind=C_CHAR), dimension(*), intent(in) :: command - character(kind=C_CHAR), dimension(*), intent(in) :: mode - end function popen - - function fgets(str, size, stream) bind(C, name='fgets') - use, intrinsic :: iso_c_binding - type (C_PTR) :: fgets - character(kind=C_CHAR), dimension(*), intent(inout) :: str - integer(kind=C_INT), value, intent(in) :: size - type (C_PTR), value :: stream - end function fgets - - function pclose(stream) bind(C, name='pclose') - use, intrinsic :: iso_c_binding - integer(C_INT) :: pclose - type (c_ptr), value :: stream - end function pclose - - function getline(linep, linecapp, stream) bind(C, name='getline') - use, intrinsic :: iso_c_binding - integer (kind=C_SIZE_T) :: getline - type (C_PTR) :: linep - integer (kind=C_SIZE_T) :: linecapp - type (C_PTR), value :: stream - end function getline - - function getdelim(linep, linecapp, delimeter, stream) bind(C, name='getdelim') - use, intrinsic :: iso_c_binding - integer (kind=C_SIZE_T) :: getdelim - type (C_PTR) :: linep - integer (kind=C_SIZE_T) :: linecapp - integer(kind=C_INT), value :: delimeter - type (C_PTR), value :: stream - end function getdelim - - subroutine free(ptr) bind(C, name='free') - use, intrinsic :: iso_c_binding - type (C_PTR), value :: ptr - end subroutine free - - end interface - -end module UnixPipeInterfaces_mod diff --git a/tests/pFUnit-3.2.9/source/UnixProcess.F90 b/tests/pFUnit-3.2.9/source/UnixProcess.F90 deleted file mode 100644 index e8a13229..00000000 --- a/tests/pFUnit-3.2.9/source/UnixProcess.F90 +++ /dev/null @@ -1,248 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: UnixProcess -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! This module encapsulates the ability to issue background system commands -! Unix pipes are used under the hood soo that results from such commands -! can be returned to the program for further processing. -! One can also check to see if the process has terminated, or optionally terminate -! the process. -! -! This is needed by the framework to manage a separate exeuctable that -! can be monitored for actual crashes as opposed to mere Assert -! failures. -! -! Although Fortran 2008 introduces the ability to spawn a process, it -! still provides no ability to return data directly back to the -! Fortran program. So, with much regret, this module represents a bit -! of a departure from standard conforming Fortran. It should be -! portable on any Unix system, and easily adapted to Windows by -! someone with relevant expertise. - -module UnixProcess_mod - use, intrinsic :: iso_c_binding - implicit none - private - - public :: UnixProcess -#if defined(Intel) || defined(PGI) - public :: execute_command_line -#endif - - - type UnixProcess - private - type (C_PTR) :: file = C_NULL_PTR - integer :: pid = -1 - contains - procedure :: getLine - procedure :: getDelim - procedure :: isActive - procedure :: terminate - procedure :: getPid - end type UnixProcess - - interface UnixProcess - module procedure newProcess - end interface UnixProcess - -contains - - function newProcess(command, runInBackground) result(process) - use UnixPipeInterfaces_mod, only: popen - use StringConversionUtilities_mod, only: nullTerminate - use Exception_mod, only: throw - type (UnixProcess) :: process - character(len=*), intent(in) :: command - logical, optional, intent(in) :: runInBackground - - character(len=:), allocatable :: fullCommand - character(len=:), allocatable :: mode - - integer, parameter :: MAX_LEN = 80 - character(len=:), allocatable :: string - - !print *,'z00000' - - fullCommand = makeCommand(command, runInBackground) - mode = nullTerminate('r') - - process%file = popen(fullCommand, mode) - if (.not. c_associated(process%file)) then - !print *,'z01000' - call throw('Unsuccessful call to popen.') - return - end if - - if (present(runInBackground)) then - if (runInBackground) then - string = process%getLine() - read(string,*) process%pid - else - process%pid = -1 - end if - end if - - end function newProcess - - ! Background commands must return a PID for further interactions. - ! Also commands need to be null-terminated to send to C procedures. - function makeCommand(baseCommand, runInBackground) result(command) - use StringConversionUtilities_mod, only: nullTerminate - character(len=:), allocatable :: command - character(len=*), intent(in) :: baseCommand - logical, optional, intent(in) :: runInBackground - - logical :: runInBackground_ - - runInBackground_ = .false. - if (present(runInBackground)) runInBackground_ = runInBackground - - command = baseCommand - if (runInBackground_) then - command = command // '& echo $!' - end if - command = nullTerminate(command) - end function makeCommand - - logical function isActive(this) - class (UnixProcess), intent(in) :: this - - integer, parameter :: MAX_LEN = 40 - character(len=MAX_LEN) :: command - integer :: stat, cstat - - !print *,'z02000',this%pid - - if (this%pid >=0) then - write(command, '("kill -0 ",i0," > /dev/null 2>&1")') this%pid - call execute_command_line(command, exitStat=stat, cmdStat=cstat) - !print *,'z03000',stat - isActive = (stat == 0) - else - isActive = .false. - end if - - end function isActive - - subroutine terminate(this) - class (UnixProcess), intent(inout) :: this - - integer, parameter :: MAX_LEN = 120 - character(len=MAX_LEN) :: command - integer :: stat, cstat - - if (this%pid >=0) then - write(command,'(a,i0,a)') "kill -15 `ps -ef 2> /dev/null | awk '$3 == ",this%pid," {print $2}'` > /dev/null 2>&1" - call execute_command_line(command, exitStat=stat, cmdStat=cstat) - write(command, '("kill -15 ",i0," > /dev/null 2>&1; ")') this%pid - call execute_command_line(command, exitStat=stat, cmdStat=cstat) - end if - - end subroutine terminate - - function getLine(this) result(line) - use UnixPipeInterfaces_mod, only: c_getLine => getLine - use UnixPipeInterfaces_mod, only: free - class (UnixProcess) :: this - character(len=:), allocatable :: line - - type (C_PTR) :: pBuffer - integer, parameter :: MAX_BUFFER_SIZE = 100000 - character(len=MAX_BUFFER_SIZE), pointer :: buffer - integer (kind=C_SIZE_T) :: length - integer (kind=C_SIZE_T) :: rc - - pBuffer = C_NULL_PTR - rc = c_getline(pBuffer, length, this%file) - if (length >= MAX_BUFFER_SIZE) then - print*,'Error - need to increase MAX_BUFFER_SIZE in UnixProcess::getLine().' - end if - - call c_f_pointer(pBuffer, buffer) - ! drop newline and delimeter - line = buffer(1:rc-1) - - call free(pBuffer) - - end function getLine - - function getDelim(this, delimeter) result(line) - use UnixPipeInterfaces_mod, only: c_getDelim => getDelim - use UnixPipeInterfaces_mod, only: free - character(len=:), allocatable :: line - class (UnixProcess) :: this - character(len=C_CHAR), intent(in) :: delimeter - - type (C_PTR) :: pBuffer - integer, parameter :: MAX_BUFFER_SIZE = 100000 - character(len=MAX_BUFFER_SIZE), pointer :: buffer - integer (kind=C_SIZE_T) :: length - integer (kind=C_SIZE_T) :: rc - - integer(kind=C_INT) :: useDelimeter - - - pBuffer = C_NULL_PTR - useDelimeter = ichar(delimeter) - rc = c_getdelim(pBuffer, length, useDelimeter, this%file) - if (length >= MAX_BUFFER_SIZE) then - print*,'Error - need to increase MAX_BUFFER_SIZE in UnixProcess::getLine().' - end if - - call c_f_pointer(pBuffer, buffer) - ! drop newline and delimeter - line = buffer(1:rc-1) - - call free(pBuffer) - - end function getDelim - - integer function getPid(this) result(pid) - class (UnixProcess), intent(in) :: this - pid = this%pid - end function getPid - - -#if defined(Intel) || defined(PGI) - subroutine execute_command_line(command, exitStat, cmdStat) -#if defined(Intel) - use ifport - implicit none -#else - implicit none -#include -#endif - character(len=*), intent(in) :: command - integer, optional, intent(out) :: exitStat - integer, optional, intent(out) :: cmdStat - - integer :: exitStat_ - - !print *,'z04000<'//trim(command)//'>' - exitStat_ = system(trim(command)) - if (present(exitStat)) exitStat = exitStat_ - if (present(cmdStat)) cmdStat = 0 - - end subroutine execute_command_line -#endif - -end module UnixProcess_mod diff --git a/tests/pFUnit-3.2.9/source/Utilities.py b/tests/pFUnit-3.2.9/source/Utilities.py deleted file mode 100755 index 451eda22..00000000 --- a/tests/pFUnit-3.2.9/source/Utilities.py +++ /dev/null @@ -1,60 +0,0 @@ -#!/usr/bin/env python - -def flattened(l): - "http://caolanmcmahon.com/posts/flatten_for_python/" - result = _flatten(l, lambda x: x) - while type(result) == list and len(result) and callable(result[0]): - if result[1] != []: - yield result[1] - result = result[0]([]) - yield result - -def _flatten(l, fn, val=[]): - "http://caolanmcmahon.com/posts/flatten_for_python/" - if type(l) != list: - return fn(l) - if len(l) == 0: - return fn(val) - return [lambda x: _flatten(l[0], \ - lambda y: _flatten(l[1:],fn,y), x), val] - -# Preprocessor-like functions - -def elideIfZero(test, insert): - if test == 0: - retString = '' - else: - retString = insert - return retString - -def testElideIfZero(): - print('0,test -> '+elideIfZero(0,'test'+',')) - print('1,test -> '+elideIfZero(1,'test'+',')) - -def ifZeroElse(test, ifTrue, ifFalse): - if test == 0: - return ifTrue - else: - return ifFalse - -def ifElseString(test, string1, string2): - retstr = '' - if test: - retstr = string1 - else: - retstr = string2 - return retstr - - - - -def main(): - a = [1,2,3,4,[5,[6,7]]] - print('a ',a) - print('f(a)', flattened(a)) - print('[f(a)]', list(flattened(a))) - return - -if __name__ == "__main__": - main() - diff --git a/tests/pFUnit-3.2.9/source/XmlPrinter.F90 b/tests/pFUnit-3.2.9/source/XmlPrinter.F90 deleted file mode 100644 index 82237b00..00000000 --- a/tests/pFUnit-3.2.9/source/XmlPrinter.F90 +++ /dev/null @@ -1,306 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: XmlPrinter -! -!> @brief -!! -!! -!! @author -!! Halvor Lund, SINTEF Energy Research -!! -!! @date -!! 30 Jan 2014 -!! -!! @note -!! Need to improve the handling of nested quotes. -! -! REVISION HISTORY: -! 2014 June 4 ML Rilee -! Added intermediate status output. Refactored prints to handle both single -! and arrays of Failure and Success. Exceptions can be printed too. Quotes -! are not handled well: need to consider going to """ and "'". -! May need to separate status reports from the end-of-run summary -! -!------------------------------------------------------------------------------- -module XmlPrinter_mod - use Exception_mod - use TestListener_mod - implicit none - private - - public :: XmlPrinter - public :: newXmlPrinter - - type, extends(TestListener) :: XmlPrinter - integer :: unit - integer :: privateUnit - contains - procedure :: addFailure - procedure :: addError - procedure :: startTest - procedure :: endTest - procedure :: endRun - procedure :: print - procedure :: printHeader - procedure :: printFailure - procedure :: printFailures - procedure :: printExceptions - procedure :: printSuccess - procedure :: printSuccesses - procedure :: printFooter - end type XmlPrinter - -contains - - function newXmlPrinter(unit) - type (XmlPrinter) :: newXmlPrinter - integer, intent(in) :: unit - - newXmlPrinter%unit = unit - - end function newXmlPrinter - - subroutine addFailure(this, testName, exceptions) - use Exception_mod - class (XmlPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - end subroutine addFailure - - subroutine addError(this, testName, exceptions) - use Exception_mod - class (XmlPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - type (Exception), intent(in) :: exceptions(:) - - end subroutine addError - - subroutine startTest(this, testName) - class (XmlPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - - end subroutine startTest - - subroutine endTest(this, testName) - class (XmlPrinter), intent(inOut) :: this - character(len=*), intent(in) :: testName - - end subroutine endTest - - subroutine endRun(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (XmlPrinter), intent(inOut) :: this - class (AbstractTestResult), intent(in) :: result - - call this%print(result) - end subroutine endRun - - subroutine print(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (XmlPrinter), intent(in) :: this - class (AbstractTestResult), intent(in) :: result - - call this%printHeader(result) - call this%printSuccesses(result%getSuccesses()) - call this%printFailures('error', result%getErrors()) - call this%printFailures('failure', result%getFailures()) - call this%printFooter(result) - - end subroutine print - - subroutine printHeader(this, result) - use AbstractTestResult_mod, only : AbstractTestResult - class (XmlPrinter), intent(in) :: this - class (AbstractTestResult), intent(in) :: result - - write(this%unit,'(a,a,a,i0,a,i0,a,i0,a,f0.4,a)') & - '' - - flush(this%unit) - - end subroutine printHeader - - subroutine printFailure(this, label, aFailedTest) - use TestFailure_mod - use SourceLocation_mod - class (XmlPrinter), intent(in) :: this - character(len=*), intent(in) :: label - type (TestFailure), intent(in) :: aFailedTest - - integer :: i, j - character(len=80) :: locationString - - call this%printExceptions(label,aFailedTest%testName,& - aFailedTest%exceptions) - - end subroutine printFailure - - subroutine printExceptions(this, label, testName, exceptions) - use TestFailure_mod - use SourceLocation_mod - class (XmlPrinter), intent(in) :: this - character(len=*), intent(in) :: label - character(len=*), intent(in) :: testName - type(Exception), intent(in) :: exceptions(:) - type(Exception) :: anException - - integer :: j - character(len=80) :: locationString - -!mlr testcase should likely be testname or testmethod or maybe test -!mlr Q? What does JUnit do? -!mlr Ask Halvor -- good for 3.0 - write(this%unit,'(a,a,a)') '' - do j= 1, size(exceptions) - anException = exceptions(j) - locationString = anException%location%toString() - - write(this%unit,'(a,a,a)',advance='no') '<', cleanXml(label),& - ' message="' - write(this%unit,'(a,a,a)',advance='no') & - 'Location: ', cleanXml(trim(locationString)), ', ' - write(this%unit,'(a)',advance='no') & - cleanXml(trim(exceptions(j)%getMessage())) - write(this%unit,*) '"/>' - end do - write(this%unit,'(a)') '' - - flush(this%unit) - - end subroutine printExceptions - - -!mlr old version - subroutine printFailure1(this, label, aFailedTest) - use TestFailure_mod - use SourceLocation_mod - class (XmlPrinter), intent(in) :: this - character(len=*), intent(in) :: label - type (TestFailure), intent(in) :: aFailedTest - type (Exception) :: anException - - integer :: i, j - character(len=80) :: locationString - -!mlr testcase should likely be testname or testmethod or maybe test -!mlr Q? What does JUnit do? -!mlr Ask Halvor -- good for 3.0 - write(this%unit,'(a,a,a)') '' - do j= 1, size(aFailedTest%exceptions) - anException = aFailedTest%exceptions(j) - locationString = anException%location%toString() - - write(this%unit,'(a,a,a)',advance='no') & - '<', cleanXml(label), ' message="' - write(this%unit,'(a,a,a)',advance='no') & - 'Location: ', cleanXml(trim(locationString)), ', ' - write(this%unit,'(a)',advance='no') & - cleanXml(trim(aFailedTest%exceptions(j)%getMessage())) - write(this%unit,*) '"/>' - end do - write(this%unit,'(a)') '' - - flush(this%unit) - - end subroutine printFailure1 - - subroutine printFailures(this, label, failures) - use TestFailure_mod - use SourceLocation_mod - class (XmlPrinter), intent(in) :: this - character(len=*), intent(in) :: label - type (TestFailure), intent(in) :: failures(:) - - integer :: i - character(len=80) :: locationString - - do i = 1, size(failures) - - call this%printFailure(label,failures(i)) - - end do - - end subroutine printFailures - - subroutine printTestName(this, testName) - use TestFailure_mod - class (XmlPrinter), intent(in) :: this - character(len=*), intent(in) :: testName - - write(this%unit,'(a,a,a)') '' - - flush(this%unit) - - end subroutine printTestName - - subroutine printSuccess(this, aSuccessTest) - use TestFailure_mod - class (XmlPrinter), intent(in) :: this - type (TestFailure) :: aSuccessTest - - integer :: i -! character(len=80) :: locationString - - write(this%unit,'(a,a,a)') '' - - flush(this%unit) - - end subroutine printSuccess - - subroutine printSuccesses(this, successes) - use TestFailure_mod - class (XmlPrinter), intent(in) :: this - type (TestFailure), intent(in) :: successes(:) - - integer :: i - - do i = 1, size(successes) - call this%printSuccess(successes(i)) - end do - - end subroutine printSuccesses - - subroutine printFooter(this, result) - use AbstractTestResult_mod - class (XmlPrinter), intent(in) :: this - class (AbstractTestResult), intent(in) :: result - - write(this%unit,'(a)') '' - - flush(this%unit) - - end subroutine printFooter - - function cleanXml(string_in) result(out) - character(len=*), intent(in) :: string_in - character(:), allocatable :: out - integer :: i - out = string_in - out = replaceAll(out, '<', '[') - out = replaceAll(out, '>', ']') - out = replaceAll(out, '"', "'") - end function cleanXml - - function replaceAll(string_in, search, replace) result(out) - character(len=*), intent(in) :: string_in - character, intent(in) :: search, replace - character(:), allocatable :: out - integer :: i - out = string_in - i = index(out, search) - do while(i /= 0) - out = out(:i-1) // replace // out(i+1:) - i = index(out, search) - end do - end function replaceAll -end module XmlPrinter_mod diff --git a/tests/pFUnit-3.2.9/source/pFUnit.F90 b/tests/pFUnit-3.2.9/source/pFUnit.F90 deleted file mode 100644 index 25259744..00000000 --- a/tests/pFUnit-3.2.9/source/pFUnit.F90 +++ /dev/null @@ -1,185 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: pFUnit -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -module pFUnit_mod - use SourceLocation_mod - use Exception_mod - use ParallelException_mod - use Expectation_mod - use Test_mod - use TestSuite_mod - use TestCase_mod - use TestMethod_mod - use AbstractTestParameter_mod - use ParameterizedTestCase_mod - use TestResult_mod - use TestRunner_mod - use BaseTestRunner_mod - use SubsetRunner_mod - - use TestListener_mod - use XmlPrinter_mod - use ResultPrinter_mod - use DebugListener_mod - -#ifdef BUILD_ROBUST - use RobustRunner_mod -#endif - use Assert_mod -! AssertReal mod - use ParallelContext_mod - use SerialContext_mod -#ifdef USE_MPI - use MpiContext_mod - use MpiTestCase_mod - use MpiTestParameter_mod - use MpiTestMethod_mod -#endif - implicit none - private - - public :: initialize - public :: finalize - - public :: SourceLocation - public :: Test - public :: TestSuite, newTestSuite - public :: TestMethod, newTestMethod - public :: TestResult - public :: TestRunner, newTestRunner - public :: BaseTestRunner - public :: SubsetRunner - - public :: ListenerPointer - public :: ResultPrinter - public :: newResultPrinter - public :: newXmlPrinter - public :: DebugListener - -#ifdef BUILD_ROBUST - public :: RobustRunner -#endif - public :: TestCase - public :: AbstractTestParameter - public :: ParameterizedTestCase - public :: ParallelContext - public :: SerialContext, newSerialContext -#ifdef USE_MPI - public :: MpiContext, newMpiContext - public :: MpiTestCase - public :: MpiTestParameter - public :: MpiTestMethod, newMpiTestMethod -#endif - - public :: assertFail - public :: assertTrue, assertFalse - public :: assertEqual - public :: assertAny - public :: assertAll - public :: assertNone - public :: assertNotAll - public :: assertLessThan, assertLessThanOrEqual - public :: assertGreaterThan, assertGreaterThanOrEqual - public :: assertRelativelyEqual - public :: assertExceptionRaised - public :: assertSameShape - public :: assertIsNan - public :: assertIsFinite - - public :: throw, catchNext, catch, anyExceptions - - public :: Expectation, Subject, Predicate - public :: wasCalled, wasNotCalled, wasCalledOnce - - ! Optional arguments for assertEqual - public :: WhitespaceOptions - public :: IGNORE_ALL, TRIM_ALL, KEEP_ALL, IGNORE_DIFFERENCES - - -#ifdef USE_MPI - logical :: useMpi_ -#endif - -contains - - subroutine initialize(useMpi) - logical, optional, intent(in) :: useMpi -#ifdef USE_MPI - include 'mpif.h' - integer :: error - - useMpi_ = .true. - if (present(useMpi)) useMpi_ = useMpi - - if (useMpi_) then - call mpi_init(error) - end if -#endif - call initializeGlobalExceptionList() - - end subroutine initialize - - subroutine finalize(successful) -#ifdef NAG - use f90_unix_proc, only: exit -#endif - logical, intent(in) :: successful - - logical :: allSuccessful - logical :: amRoot - -#ifdef USE_MPI - integer :: error - integer :: rank - include 'mpif.h' - - allSuccessful = successful - if (useMpi_) then - call MPI_Comm_rank(MPI_COMM_WORLD, rank, error) - amRoot = (rank == 0) - call MPI_Bcast(allSuccessful, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, error) - call mpi_finalize(error) - else - ! If using MPI-PFUNIT on serial code, ensure amRoot is set. - amRoot = .true. - end if -#else - amRoot = .true. - allSuccessful = successful -#endif - - if (.not. allSuccessful) then -#if defined(NAG) || defined(PGI) - call exit(-1) -#else - - if (amRoot) then - error stop '*** Encountered 1 or more failures/errors during testing. ***' - else - error stop - end if -#endif - end if - - end subroutine finalize - -end module pFUnit_mod diff --git a/tests/pFUnit-3.2.9/source/pFUnitPackage.F90 b/tests/pFUnit-3.2.9/source/pFUnitPackage.F90 deleted file mode 100644 index 35f44d47..00000000 --- a/tests/pFUnit-3.2.9/source/pFUnitPackage.F90 +++ /dev/null @@ -1,116 +0,0 @@ -!------------------------------------------------------------------------------- -! NASA/GSFC Advanced Software Technology Group -!------------------------------------------------------------------------------- -! MODULE: pFUnit -! -!> @brief -!! -!! -!! @author -!! Tom Clune, NASA/GSFC -!! -!! @date -!! 07 Nov 2013 -!! -!! @note -!! -! -! REVISION HISTORY: -! -! 07 Nov 2013 - Added the prologue for the compliance with Doxygen. -! -!------------------------------------------------------------------------------- -! -! This module packages pFUnit entities while simultaneously inserting -! a prefix on all names. Some developers may provide this explicit -! naming convention. Others may choose to use the vanilla pFUnit module that -! has no such prefix. -! -! The default prefix is "pf_", but just edit the #define below to suit -! your own preference. -! -! - -#ifndef PFUNIT_PREFIX -#define PFUNIT_PREFIX pf_ -#endif - -#define TOKEN(a) a -#define RENAME(item) TOKEN(PFUNIT_PREFIX)TOKEN(item) => item - -module pFUnit - - use pFUnit_mod, only: RENAME(initialize) - use pFUnit_mod, only: RENAME(finalize) - - use SourceLocation_mod, only: RENAME(SourceLocation) - use Exception_mod, only: RENAME(throw), RENAME(catch), RENAME(catchNext) - use Exception_mod, only: RENAME(anyExceptions) - use ParallelException_mod, only: RENAME(anyExceptions) - use Assert_mod, only: RENAME(assertFail) - use Assert_mod, only: RENAME(assertTrue), RENAME(assertFalse) - use Assert_mod, only: RENAME(assertSameShape) - use Assert_mod, only: RENAME(assertEqual) - use Assert_mod, only: RENAME(assertAny), RENAME(assertAll) - use Assert_mod, only: RENAME(assertNone), RENAME(assertNotAll) - use Assert_mod, only: RENAME(assertLessThan) - use Assert_mod, only: RENAME(assertLessThanOrEqual) - use Assert_mod, only: RENAME(assertGreaterThan) - use Assert_mod, only: RENAME(assertGreaterThanOrEqual) - use Assert_mod, only: RENAME(assertExceptionRaised) - - use Assert_mod, only: RENAME(assertIsNan) - use Assert_mod, only: RENAME(assertIsFinite) - - ! workaround for ifort 13.0 - use Test_mod, only: Test - - use Test_mod, only: RENAME(Test) - use TestCase_mod, only: RENAME(TestCase) - use TestSuite_mod, only: RENAME(TestSuite) - use TestSuite_mod, only: RENAME(newTestSuite) - use TestMethod_mod, only: RENAME(TestMethod) - use TestMethod_mod, only: RENAME(newTestMethod) - use TestResult_mod, only: RENAME(TestResult) - use BaseTestRunner_mod, only: RENAME(BaseTestRunner) - use TestRunner_mod, only: RENAME(TestRunner) - use TestRunner_mod, only: RENAME(newTestRunner) -#ifdef BUILD_ROBUST - use RobustRunner_mod, only: RENAME(RobustRunner) -#endif - - use TestListener_mod, only: RENAME(ListenerPointer) - use XmlPrinter_mod, only: RENAME(XmlPrinter) - use DebugListener_mod, only: RENAME(DebugListener) - - use ParallelContext_mod, only: RENAME(ParallelContext) - use SerialContext_mod, only: RENAME(SerialContext) - use SerialContext_mod, only: RENAME(newSerialContext) -#ifdef USE_MPI - use MpiContext_mod, only: RENAME(MpiContext) - use MpiContext_mod, only: RENAME(newMpiContext) - use MpiTestCase_mod, only: RENAME(MpiTestCase) - use MpiTestParameter_mod, only: RENAME(MpiTestParameter) - use MpiTestMethod_mod, only: RENAME(MpiTestMethod) - use MpiTestMethod_mod, only: RENAME(newMpiTestMethod) -#endif - - use AbstractTestParameter_mod, only: RENAME(AbstractTestParameter) - use ParameterizedTestCase_mod, only: RENAME(ParameterizedTestCase) - - implicit none - public ! Nothing private in this module, just renaming exports. - - ! workaround for ifort 13.0 - private :: Test -contains - - function run() result(a) - - integer :: a - a = 0 - - end function run - - -end module pFUnit From 213bd0f3d56866bf6ac3cdce5b02b74337e71523 Mon Sep 17 00:00:00 2001 From: Hugh Sorby Date: Mon, 2 Dec 2024 18:26:50 +1300 Subject: [PATCH 2/3] Replace pFUnit with a simpler testing framework. --- CMakeLists.txt | 2 +- src/bindings/CMakeLists.txt | 2 +- src/bindings/python/CMakeLists.txt | 12 +- src/lib/CMakeLists.txt | 3 + tests/CMakeLists.txt | 65 +- tests/lib/CMakeLists.txt | 16 - tests/lib/test_diagnostics.pf | 16 - tests/test_diagnostics.f90 | 42 + tests/testdriver.f90 | 2226 ++++++++++++++++++++++++++++ tests/testmain.in.f90 | 55 + 10 files changed, 2391 insertions(+), 48 deletions(-) delete mode 100644 tests/lib/CMakeLists.txt delete mode 100644 tests/lib/test_diagnostics.pf create mode 100644 tests/test_diagnostics.f90 create mode 100644 tests/testdriver.f90 create mode 100644 tests/testmain.in.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 97811bbc..dbff8e87 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,6 +1,6 @@ -cmake_minimum_required(VERSION 3.13) +cmake_minimum_required(VERSION 3.18) project(Aether VERSION 0.1.0 LANGUAGES Fortran C CXX) # Policy settings diff --git a/src/bindings/CMakeLists.txt b/src/bindings/CMakeLists.txt index c391a5f4..ee14df7e 100644 --- a/src/bindings/CMakeLists.txt +++ b/src/bindings/CMakeLists.txt @@ -12,7 +12,7 @@ if(SWIG_FOUND) add_project_config_parameter(Python_ROOT_DIR "" PATH "Define the root directory of a Python installation.") set(Python_ROOT_DIR ${AETHER_Python_ROOT_DIR}) - find_package(Python ${AETHER_PREFERRED_PYTHON_VERSION} COMPONENTS Interpreter Development NumPy) + find_package(Python ${AETHER_PREFERRED_PYTHON_VERSION} COMPONENTS Interpreter Development.Module NumPy) if(Python_FOUND) add_subdirectory(python) else() diff --git a/src/bindings/python/CMakeLists.txt b/src/bindings/python/CMakeLists.txt index ce3301ba..fd206cdd 100644 --- a/src/bindings/python/CMakeLists.txt +++ b/src/bindings/python/CMakeLists.txt @@ -5,7 +5,7 @@ set(ADDITIONAL_GENERATED_FILES) # SWIG has already been found at this point. include(${SWIG_USE_FILE}) -if(${Python_VERSION_MAJOR} STREQUAL "3") +if("${SWIG_VERSION}" VERSION_LESS "4.1.0") set(PYTHONLIBS_SWIG_FLAGS -py3 -relativeimport) endif() @@ -86,7 +86,7 @@ foreach(SWIG_INTERFACE ${INTERFACE_SRCS}) # so we add the release libraries here for all platforms. This probably means that # when we try and link to the debug version of the Python libraires on OSX and GNU/Linux # we will not succeed. But as this is rarely done it hopefully won't become an issue. - target_link_libraries(${MODULE_TARGET} Python::Python Python::NumPy aether_c) + target_link_libraries(${MODULE_TARGET} Python::Module Python::NumPy aether_c) set_target_properties(${MODULE_TARGET} PROPERTIES LIBRARY_OUTPUT_DIRECTORY ${PYTHON_PACKAGE_DIR} RUNTIME_OUTPUT_DIRECTORY ${PYTHON_PACKAGE_DIR} @@ -160,11 +160,3 @@ add_custom_command(TARGET ${SWIG_PYTHON_BINDINGS_TARGETS} POST_BUILD DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/__init__.py ${AETHER_README_FILE} ${SETUP_PRE_GEN_PY_FILE} COMMENT "Finalise preparation of Aether Python bindings." ) - -if (NOT IS_MULTI_CONFIG AND AETHER_BUILD_TYPE) - string(TOLOWER ${AETHER_BUILD_TYPE} LOWER_AETHER_BUILD_TYPE) - set(_BUILD_TYPE_PART ${LOWER_AETHER_BUILD_TYPE}_) -endif() - -find_program(VIRTUALENV_EXECUTABLE NAMES ${VIRTUALENV_PREFERRED_NAMES} virtualenv) -message(STATUS "${VIRTUALENV_EXECUTABLE} -p ${Python_EXECUTABLE} venv_${_BUILD_TYPE_PART}py${Python_VERSION_MAJOR}${Python_VERSION_MINOR}") diff --git a/src/lib/CMakeLists.txt b/src/lib/CMakeLists.txt index 0fed5c73..a3f4a288 100644 --- a/src/lib/CMakeLists.txt +++ b/src/lib/CMakeLists.txt @@ -43,6 +43,9 @@ add_library(aether STATIC ${LIB_SRCS}) set_target_properties(aether PROPERTIES Fortran_MODULE_DIRECTORY "${AETHER_MODULE_DIRECTORY}" POSITION_INDEPENDENT_CODE TRUE) + +target_include_directories(aether PUBLIC "${AETHER_MODULE_DIRECTORY}") + if (MSVC) target_compile_options(aether PRIVATE /heap-arrays0) endif () diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 70566462..008713dd 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -1,7 +1,64 @@ -add_subdirectory(pFUnit-3.2.9) +# Unit testing +set( + TESTS + "diagnostics" +) +set( + TEST_SRCS + "testdriver.f90" +) -# Include the config file so we can use the test creation function directly. -include("${CMAKE_CURRENT_BINARY_DIR}/pFUnit-3.2.9/pFUnitConfig.cmake") +set( + TEST_SUITE_USE_STATEMENT +) +set( + TEST_SUITE_LIST_STATEMENT +) -add_subdirectory(lib) +foreach(t IN LISTS TESTS) + string(MAKE_C_IDENTIFIER ${t} t) + list(APPEND TEST_SRCS "test_${t}.f90") + set(TEST_SUITE_USE_STATEMENT "${TEST_SUITE_USE_STATEMENT} use test_${t}, only : collect_${t}\n") + set(TEST_SUITE_LIST_STATEMENT "${TEST_SUITE_LIST_STATEMENT} new_testsuite(\"${t}\", collect_${t}), &\n") +endforeach() + +string(REGEX REPLACE ", &\n$" " &" TEST_SUITE_LIST_STATEMENT "${TEST_SUITE_LIST_STATEMENT}") +set(TEST_MAIN "${CMAKE_CURRENT_BINARY_DIR}/testmain.f90") +configure_file(testmain.in.f90 ${TEST_MAIN}) +list(APPEND TEST_SRCS ${TEST_MAIN}) + +add_executable( + "${PROJECT_NAME}-tester" + "${TEST_SRCS}" +) + +target_compile_definitions( + "${PROJECT_NAME}-tester" + PRIVATE + "WITH_QP=$" + "WITH_XDP=$" +) + +if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") + set_source_files_properties(testdriver.f90 PROPERTIES COMPILE_FLAGS -cpp) +endif () + +if (MSVC) + target_compile_options("${PROJECT_NAME}-tester" PUBLIC -fpp) +endif() + +target_link_libraries( + "${PROJECT_NAME}-tester" + PRIVATE + aether +) + +foreach(t IN LISTS TESTS) + set(_TEST_NAME "${PROJECT_NAME}/${t}") + add_test("${_TEST_NAME}" "${PROJECT_NAME}-tester" "${t}") + if(MSVC) + set(_TEST_PROPERTIES "PATH=$\;${FORTRAN_RUNTIME_PATH}") + set_tests_properties("${_TEST_NAME}" PROPERTIES ENVIRONMENT "${_TEST_PROPERTIES}" RANDOM_THING $) + endif() +endforeach() diff --git a/tests/lib/CMakeLists.txt b/tests/lib/CMakeLists.txt deleted file mode 100644 index 165f8ebc..00000000 --- a/tests/lib/CMakeLists.txt +++ /dev/null @@ -1,16 +0,0 @@ - -# Add all the files that make a single test, we could have multiple files testing -# the same module. Don't add test files into the same test that test different modules. -# These are all .pf files. -set(DIAGNOSTICS_TEST_SRCS - test_diagnostics.pf) - -# Make use of the pFUnit helper function to create a test. -# Arguments : - test_package_name: Name of the test package -# - test_sources : List of pf-files to be compiled -# - extra_sources : List of extra Fortran source code used for testing (if none, input empty string "") -# - extra_sources_c : List of extra C/C++ source code used for testing (if none, input empty string "") -add_pfunit_test(diagnostics_test ${DIAGNOSTICS_TEST_SRCS} "" "") -# Link the test to the aether library target. -target_link_libraries(diagnostics_test aether) -target_include_directories(diagnostics_test PRIVATE $) diff --git a/tests/lib/test_diagnostics.pf b/tests/lib/test_diagnostics.pf deleted file mode 100644 index 55dbf565..00000000 --- a/tests/lib/test_diagnostics.pf +++ /dev/null @@ -1,16 +0,0 @@ -@test -subroutine testSetDiagnostics() - use pfunit_mod - use diagnostics, only: get_diagnostics_on, set_diagnostics_on - implicit none - - logical :: state - - call get_diagnostics_on(state) - @assertFalse(state) - call set_diagnostics_on(.true.) - call get_diagnostics_on(state) - @assertTrue(state) - -end subroutine testSetDiagnostics - diff --git a/tests/test_diagnostics.f90 b/tests/test_diagnostics.f90 new file mode 100644 index 00000000..5bdbfa87 --- /dev/null +++ b/tests/test_diagnostics.f90 @@ -0,0 +1,42 @@ + +module test_diagnostics + use testdrive, only : new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_diagnostics + +contains + +!> Collect all exported unit tests +subroutine collect_diagnostics(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("test_set_and_get", test_set_and_get) & + ] + +end subroutine collect_diagnostics + +subroutine test_set_and_get(error) + use diagnostics, only: get_diagnostics_on, set_diagnostics_on + implicit none + + type(error_type), allocatable, intent(out) :: error + + logical :: level + + call get_diagnostics_on(level) + call check(error, .false., level) + if (allocated(error)) return + + call set_diagnostics_on(.true.) + call get_diagnostics_on(level) + call check(error, .true., level) + if (allocated(error)) return + +end subroutine test_set_and_get + +end module test_diagnostics + diff --git a/tests/testdriver.f90 b/tests/testdriver.f90 new file mode 100644 index 00000000..cc928112 --- /dev/null +++ b/tests/testdriver.f90 @@ -0,0 +1,2226 @@ +! This file is part of test-drive. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!# Enable support for quadruple precision +#ifndef WITH_QP +#define WITH_QP 0 +#endif + +!# Enable support for extended double precision +#ifndef WITH_XDP +#define WITH_XDP 0 +#endif + +!> Provides a light-weight procedural testing framework for Fortran projects. +!> +!> Testsuites are defined by a [[collect_interface]] returning a set of +!> [[unittest_type]] objects. To create a new test use the [[new_unittest]] +!> constructor, which requires a test identifier and a procedure with a +!> [[test_interface]] compatible signature. The error status is communicated +!> by the allocation status of an [[error_type]]. +!> +!> The necessary boilerplate code to setup the test entry point is just +!> +!>```fortran +!>program tester +!> use, intrinsic :: iso_fortran_env, only : error_unit +!> use testdrive, only : run_testsuite, new_testsuite, testsuite_type +!> use test_suite1, only : collect_suite1 +!> use test_suite2, only : collect_suite2 +!> implicit none +!> integer :: stat, is +!> type(testsuite_type), allocatable :: testsuites(:) +!> character(len=*), parameter :: fmt = '("#", *(1x, a))' +!> +!> stat = 0 +!> +!> testsuites = [ & +!> new_testsuite("suite1", collect_suite1), & +!> new_testsuite("suite2", collect_suite2) & +!> ] +!> +!> do is = 1, size(testsuites) +!> write(error_unit, fmt) "Testing:", testsuites(is)%name +!> call run_testsuite(testsuites(is)%collect, error_unit, stat) +!> end do +!> +!> if (stat > 0) then +!> write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" +!> error stop +!> end if +!> +!>end program tester +!>``` +!> +!> Every test is defined in a separate module using a ``collect`` function, which +!> is exported and added to the ``testsuites`` array in the test runner. +!> All test have a simple interface with just an allocatable [[error_type]] as +!> output to provide the test results. +!> +!>```fortran +!>module test_suite1 +!> use testdrive, only : new_unittest, unittest_type, error_type, check +!> implicit none +!> private +!> +!> public :: collect_suite1 +!> +!>contains +!> +!>!> Collect all exported unit tests +!>subroutine collect_suite1(testsuite) +!> !> Collection of tests +!> type(unittest_type), allocatable, intent(out) :: testsuite(:) +!> +!> testsuite = [ & +!> new_unittest("valid", test_valid), & +!> new_unittest("invalid", test_invalid, should_fail=.true.) & +!> ] +!> +!>end subroutine collect_suite1 +!> +!>subroutine test_valid(error) +!> type(error_type), allocatable, intent(out) :: error +!> ! ... +!>end subroutine test_valid +!> +!>subroutine test_invalid(error) +!> type(error_type), allocatable, intent(out) :: error +!> ! ... +!>end subroutine test_invalid +!> +!>end module test_suite1 +!>``` +!> +!> For an example setup checkout the ``test/`` directory in this project. +module testdrive + use, intrinsic :: iso_fortran_env, only : error_unit + implicit none + private + + public :: run_testsuite, run_selected, new_unittest, new_testsuite + public :: select_test, select_suite + public :: unittest_type, testsuite_type, error_type + public :: check, test_failed, skip_test + public :: test_interface, collect_interface + public :: get_argument, get_variable, to_string + + + !> Single precision real numbers + integer, parameter :: sp = selected_real_kind(6) + + !> Double precision real numbers + integer, parameter :: dp = selected_real_kind(15) + +#if WITH_XDP + !> Extended double precision real numbers + integer, parameter :: xdp = selected_real_kind(18) +#endif + +#if WITH_QP + !> Quadruple precision real numbers + integer, parameter :: qp = selected_real_kind(33) +#endif + + !> Char length for integers + integer, parameter :: i1 = selected_int_kind(2) + + !> Short length for integers + integer, parameter :: i2 = selected_int_kind(4) + + !> Length of default integers + integer, parameter :: i4 = selected_int_kind(9) + + !> Long length for integers + integer, parameter :: i8 = selected_int_kind(18) + + !> Error code for success + integer, parameter :: success = 0 + + !> Error code for failure + integer, parameter :: fatal = 1 + + !> Error code for skipped test + integer, parameter :: skipped = 77 + + !> Goto next line + character(len=*), parameter :: skip = new_line("a") // repeat(" ", 11) + + !> Error message + type :: error_type + + !> Error code + integer :: stat = success + + !> Payload of the error + character(len=:), allocatable :: message + + contains + + !> Escalate uncaught errors + final :: escalate_error + + end type error_type + + + interface check + module procedure :: check_stat + module procedure :: check_logical + module procedure :: check_float_sp + module procedure :: check_float_dp +#if WITH_XDP + module procedure :: check_float_xdp +#endif +#if WITH_QP + module procedure :: check_float_qp +#endif + module procedure :: check_float_exceptional_sp + module procedure :: check_float_exceptional_dp +#if WITH_XDP + module procedure :: check_float_exceptional_xdp +#endif +#if WITH_QP + module procedure :: check_float_exceptional_qp +#endif + module procedure :: check_complex_sp + module procedure :: check_complex_dp +#if WITH_XDP + module procedure :: check_complex_xdp +#endif +#if WITH_QP + module procedure :: check_complex_qp +#endif + module procedure :: check_complex_exceptional_sp + module procedure :: check_complex_exceptional_dp +#if WITH_XDP + module procedure :: check_complex_exceptional_xdp +#endif +#if WITH_QP + module procedure :: check_complex_exceptional_qp +#endif + module procedure :: check_int_i1 + module procedure :: check_int_i2 + module procedure :: check_int_i4 + module procedure :: check_int_i8 + module procedure :: check_bool + module procedure :: check_string + module procedure :: check_array_int + module procedure :: check_array_int_int + module procedure :: check_array_int_int_int + module procedure :: check_array_sp + module procedure :: check_array_dp + module procedure :: check_array_dp_dp + end interface check + + + interface to_string + module procedure :: integer_i1_to_string + module procedure :: integer_i2_to_string + module procedure :: integer_i4_to_string + module procedure :: integer_i8_to_string + module procedure :: real_sp_to_string + module procedure :: real_dp_to_string +#if WITH_XDP + module procedure :: real_xdp_to_string +#endif +#if WITH_QP + module procedure :: real_qp_to_string +#endif + module procedure :: complex_sp_to_string + module procedure :: complex_dp_to_string +#if WITH_XDP + module procedure :: complex_xdp_to_string +#endif +#if WITH_QP + module procedure :: complex_qp_to_string +#endif + end interface to_string + + + !> Implementation of check for not a number value, in case a compiler does not + !> provide the IEEE intrinsic ``ieee_is_nan`` (currently this is Intel oneAPI on MacOS) + interface is_nan + module procedure :: is_nan_sp + module procedure :: is_nan_dp +#if WITH_XDP + module procedure :: is_nan_xdp +#endif +#if WITH_QP + module procedure :: is_nan_qp +#endif + end interface is_nan + + + abstract interface + !> Entry point for tests + subroutine test_interface(error) + import :: error_type + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + end subroutine test_interface + end interface + + + !> Declaration of a unit test + type :: unittest_type + + !> Name of the test + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(test_interface), pointer, nopass :: test => null() + + !> Whether test is supposed to fail + logical :: should_fail = .false. + + end type unittest_type + + + abstract interface + !> Collect all tests + subroutine collect_interface(testsuite) + import :: unittest_type + + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + end subroutine collect_interface + end interface + + + !> Collection of unit tests + type :: testsuite_type + + !> Name of the testsuite + character(len=:), allocatable :: name + + !> Entry point of the test + procedure(collect_interface), pointer, nopass :: collect => null() + + end type testsuite_type + + + character(len=*), parameter :: fmt = '(1x, *(1x, a))' + + +contains + + + !> Driver for testsuite + recursive subroutine run_testsuite(collect, unit, stat, parallel) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + !> Run the tests in parallel + logical, intent(in), optional :: parallel + + type(unittest_type), allocatable :: testsuite(:) + integer :: it + logical :: parallel_ + + parallel_ = .true. + if(present(parallel)) parallel_ = parallel + + call collect(testsuite) + + !$omp parallel do schedule(dynamic) shared(testsuite, unit) reduction(+:stat) & + !$omp if (parallel_) + do it = 1, size(testsuite) + !$omp critical(testdrive_testsuite) + write(unit, '(1x, 3(1x, a), 1x, "(", i0, "/", i0, ")")') & + & "Starting", testsuite(it)%name, "...", it, size(testsuite) + !$omp end critical(testdrive_testsuite) + call run_unittest(testsuite(it), unit, stat) + end do + + end subroutine run_testsuite + + + !> Driver for selective testing + recursive subroutine run_selected(collect, name, unit, stat) + + !> Collect tests + procedure(collect_interface) :: collect + + !> Name of the selected test + character(len=*), intent(in) :: name + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(unittest_type), allocatable :: testsuite(:) + integer :: it + + call collect(testsuite) + + it = select_test(testsuite, name) + + if (it > 0 .and. it <= size(testsuite)) then + call run_unittest(testsuite(it), unit, stat) + else + write(unit, fmt) "Available tests:" + do it = 1, size(testsuite) + write(unit, fmt) "-", testsuite(it)%name + end do + stat = -huge(it) + end if + + end subroutine run_selected + + + !> Run a selected unit test + recursive subroutine run_unittest(test, unit, stat) + + !> Unit test + type(unittest_type), intent(in) :: test + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + type(error_type), allocatable :: error + character(len=:), allocatable :: message + + call test%test(error) + if (.not.test_skipped(error)) then + if (allocated(error) .neqv. test%should_fail) stat = stat + 1 + end if + call make_output(message, test, error) + !$omp critical(testdrive_testsuite) + write(unit, '(a)') message + !$omp end critical(testdrive_testsuite) + if (allocated(error)) then + call clear_error(error) + end if + + end subroutine run_unittest + + + pure function test_skipped(error) result(is_skipped) + + !> Error handling + type(error_type), intent(in), optional :: error + + !> Test was skipped + logical :: is_skipped + + is_skipped = .false. + if (present(error)) then + is_skipped = error%stat == skipped + end if + + end function test_skipped + + + !> Create output message for test (this procedure is pure and therefore cannot launch tests) + pure subroutine make_output(output, test, error) + + !> Output message for display + character(len=:), allocatable, intent(out) :: output + + !> Unit test + type(unittest_type), intent(in) :: test + + !> Error handling + type(error_type), intent(in), optional :: error + + character(len=:), allocatable :: label + character(len=*), parameter :: indent = repeat(" ", 7) // repeat(".", 3) // " " + + if (test_skipped(error)) then + output = indent // test%name // " [SKIPPED]" & + & // new_line("a") // " Message: " // error%message + return + end if + + if (present(error) .neqv. test%should_fail) then + if (test%should_fail) then + label = " [UNEXPECTED PASS]" + else + label = " [FAILED]" + end if + else + if (test%should_fail) then + label = " [EXPECTED FAIL]" + else + label = " [PASSED]" + end if + end if + output = indent // test%name // label + if (present(error)) then + output = output // new_line("a") // " Message: " // error%message + end if + end subroutine make_output + + + !> Select a unit test from all available tests + function select_test(tests, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available unit tests + type(unittest_type) :: tests(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(tests) + if (name == tests(it)%name) then + pos = it + exit + end if + end do + + end function select_test + + + !> Select a test suite from all available suites + function select_suite(suites, name) result(pos) + + !> Name identifying the test suite + character(len=*), intent(in) :: name + + !> Available test suites + type(testsuite_type) :: suites(:) + + !> Selected test suite + integer :: pos + + integer :: it + + pos = 0 + do it = 1, size(suites) + if (name == suites(it)%name) then + pos = it + exit + end if + end do + + end function select_suite + + + !> Register a new unit test + function new_unittest(name, test, should_fail) result(self) + + !> Name of the test + character(len=*), intent(in) :: name + + !> Entry point for the test + procedure(test_interface) :: test + + !> Whether test is supposed to error or not + logical, intent(in), optional :: should_fail + + !> Newly registered test + type(unittest_type) :: self + + self%name = name + self%test => test + if (present(should_fail)) self%should_fail = should_fail + + end function new_unittest + + + !> Register a new testsuite + function new_testsuite(name, collect) result(self) + + !> Name of the testsuite + character(len=*), intent(in) :: name + + !> Entry point to collect tests + procedure(collect_interface) :: collect + + !> Newly registered testsuite + type(testsuite_type) :: self + + self%name = name + self%collect => collect + + end function new_testsuite + + + subroutine check_stat(error, stat, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Status of operation + integer, intent(in) :: stat + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (stat /= success) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Non-zero exit code encountered", more) + end if + end if + + end subroutine check_stat + + + subroutine check_logical(error, expression, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Result of logical operator + logical, intent(in) :: expression + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (.not.expression) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Condition not fullfilled", more) + end if + end if + + end subroutine check_logical + + + subroutine check_float_dp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(dp), intent(in) :: actual + + !> Expected floating point value + real(dp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(dp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(dp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_dp + + + subroutine check_float_exceptional_dp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(dp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(actual)) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_float_exceptional_dp + + + subroutine check_float_sp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(sp), intent(in) :: actual + + !> Expected floating point value + real(sp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(sp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(sp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_sp + + + subroutine check_float_exceptional_sp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(sp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(actual)) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_float_exceptional_sp + + +#if WITH_XDP + subroutine check_float_xdp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(xdp), intent(in) :: actual + + !> Expected floating point value + real(xdp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(xdp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(xdp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_xdp + + + subroutine check_float_exceptional_xdp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(xdp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(actual)) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_float_exceptional_xdp +#endif + + +#if WITH_QP + subroutine check_float_qp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(qp), intent(in) :: actual + + !> Expected floating point value + real(qp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(qp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(qp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(expected) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_float_qp + + + subroutine check_float_exceptional_qp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + real(qp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(actual)) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_float_exceptional_qp +#endif + + + subroutine check_complex_dp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(dp), intent(in) :: actual + + !> Expected floating point value + complex(dp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(dp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(dp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(abs(expected)) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_dp + + + subroutine check_complex_exceptional_dp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(dp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_complex_exceptional_dp + + + subroutine check_complex_sp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(sp), intent(in) :: actual + + !> Expected floating point value + complex(sp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(sp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(sp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(abs(expected)) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_sp + + + subroutine check_complex_exceptional_sp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(sp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_complex_exceptional_sp + + +#if WITH_XDP + subroutine check_complex_xdp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(xdp), intent(in) :: actual + + !> Expected floating point value + complex(xdp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(xdp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(xdp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(abs(expected)) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_xdp + + + subroutine check_complex_exceptional_xdp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(xdp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_complex_exceptional_xdp +#endif + + +#if WITH_QP + subroutine check_complex_qp(error, actual, expected, message, more, thr, rel) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(qp), intent(in) :: actual + + !> Expected floating point value + complex(qp), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Allowed threshold for matching floating point values + real(qp), intent(in), optional :: thr + + !> Check for relative errors instead + logical, intent(in), optional :: rel + + logical :: relative + real(qp) :: diff, threshold + + call check(error, actual, message, more) + if (allocated(error)) return + + if (present(thr)) then + threshold = thr + else + threshold = epsilon(abs(expected)) + end if + + if (present(rel)) then + relative = rel + else + relative = .false. + end if + + if (relative) then + diff = abs(actual - expected) / abs(expected) + else + diff = abs(actual - expected) + end if + + if (diff > threshold) then + if (present(message)) then + call test_failed(error, message, more) + else + if (relative) then + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(int(diff*100))//"%)", & + more) + else + call test_failed(error, & + "Floating point value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual)//" "//& + "(difference: "//to_string(diff)//")", & + more) + end if + end if + end if + + end subroutine check_complex_qp + + + subroutine check_complex_exceptional_qp(error, actual, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found floating point value + complex(qp), intent(in) :: actual + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (is_nan(real(actual)) .or. is_nan(aimag(actual))) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, "Exceptional value 'not a number' found", more) + end if + end if + + end subroutine check_complex_exceptional_qp +#endif + + + subroutine check_int_i1(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i1), intent(in) :: actual + + !> Expected integer value + integer(i1), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Integer value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual), & + more) + end if + end if + + end subroutine check_int_i1 + + + subroutine check_int_i2(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i2), intent(in) :: actual + + !> Expected integer value + integer(i2), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Integer value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual), & + more) + end if + end if + + end subroutine check_int_i2 + + + subroutine check_int_i4(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i4), intent(in) :: actual + + !> Expected integer value + integer(i4), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Integer value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual), & + more) + end if + end if + + end subroutine check_int_i4 + + + subroutine check_int_i8(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found integer value + integer(i8), intent(in) :: actual + + !> Expected integer value + integer(i8), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Integer value missmatch", & + "expected "//to_string(expected)//" but got "//to_string(actual), & + more) + end if + end if + + end subroutine check_int_i8 + + + subroutine check_bool(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found boolean value + logical, intent(in) :: actual + + !> Expected boolean value + logical, intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected .neqv. actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Logical value missmatch", & + "expected "//merge("T", "F", expected)//" but got "//merge("T", "F", actual), & + more) + end if + end if + + end subroutine check_bool + + + subroutine check_string(error, actual, expected, message, more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> Found boolean value + character(len=*), intent(in) :: actual + + !> Expected boolean value + character(len=*), intent(in) :: expected + + !> A detailed message describing the error + character(len=*), intent(in), optional :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + if (expected /= actual) then + if (present(message)) then + call test_failed(error, message, more) + else + call test_failed(error, & + "Character value missmatch", & + "expected '"//expected//"' but got '"//actual//"'", & + more) + end if + end if + + end subroutine check_string + + subroutine check_array_int(error, actual, expected, message, more) + + type(error_type), allocatable, intent(out) :: error + + integer, intent(in) :: actual(:) + integer, intent(in) :: expected(:) + + character(len=*), intent(in), optional :: message + character(len=*), intent(in), optional :: more + + integer :: rank_A + integer :: rank_B + + rank_A = size(actual) + rank_B = size(expected) + + if (rank_A == 0 .or. rank_B == 0) then + call test_failed(error, "size of arrays not the same", & + "size difference '"//to_string(rank_A)//"' and '"//to_string(rank_B)//"'.", more) + end if + + if (rank_A .ne. rank_B) then + end if + + end subroutine check_array_int + + subroutine check_array_int_int(error, actual, expected, message, more) + + type(error_type), allocatable, intent(out) :: error + + integer, intent(in) :: actual(:,:) + integer, intent(in) :: expected(:,:) + + character(len=*), intent(in), optional :: message + character(len=*), intent(in), optional :: more + + integer :: i, j, rank_A1, rank_A2, rank_B1, rank_B2 + + rank_A1 = size(actual, 1) + rank_A2 = size(actual, 2) + rank_B1 = size(expected, 1) + rank_B2 = size(expected, 2) + + if (rank_A1 == 0 .or. rank_B1 == 0) then + call test_failed(error, "one of the arrays is scalar", & + "sizes are '"//to_string(rank_A1)//"' and '"//to_string(rank_B1)//"'.", more) + end if + + if (rank_A1 .ne. rank_B1 .or. rank_A2 .ne. rank_B2) then + call test_failed(error, "size of arrays not the same", & + "size difference '"//to_string(rank_A1)//"' and '"//to_string(rank_B1)//"'.", more) + end if + + do i = 1, rank_A1 + do j = 1, rank_A2 + if (expected(i, j) .ne. actual(i, j)) then + call test_failed(error, "mismatch in array content", & + "at index: ("//to_string(i)//", "//to_string(j)// ") the mismatch is: " & + //to_string(expected(i, j))//" <--> "//to_string(actual(i, j))//".", more) + end if + end do + end do + + end subroutine check_array_int_int + + subroutine check_array_int_int_int(error, actual, expected, message, more) + + type(error_type), allocatable, intent(out) :: error + + integer, intent(in) :: actual(:,:,:) + integer, intent(in) :: expected(:,:,:) + + character(len=*), intent(in), optional :: message + character(len=*), intent(in), optional :: more + + integer :: rank_A1, rank_A2, rank_A3 + integer :: rank_B1, rank_B2, rank_B3 + integer :: i, j, k + + rank_A1 = size(actual, 1) + rank_A2 = size(actual, 2) + rank_A3 = size(actual, 3) + rank_B1 = size(expected, 1) + rank_B2 = size(expected, 2) + rank_B3 = size(expected, 3) + + if (rank_A1 == 0 .or. rank_B1 == 0) then + call test_failed(error, "size of arrays not the same", & + "size difference '"//to_string(rank_A1)//"' and '"//to_string(rank_B1)//"'.", more) + end if + + if (rank_A1 .ne. rank_B1 .or. rank_A2 .ne. rank_B2 .or. rank_A3 .ne. rank_B3) then + call test_failed(error, "size of arrays not the same", & + "size difference ('"//to_string(rank_A1)//", "//to_string(rank_A2)//", "//& + to_string(rank_A3)//"') and ('"//to_string(rank_B1)//", "//to_string(rank_B2)//& + ", "//to_string(rank_B3)//"').", more) + end if + + do i = 1, rank_A1 + do j = 1, rank_A2 + do k = 1, rank_A3 + if (expected(i, j, k) .ne. actual(i, j, k)) then + call test_failed(error, "mismatch in array content", & + "at index: ("//to_string(i)//", "//to_string(j)//", "//to_string(k)//") the mismatch is: " & + //to_string(expected(i, j, k))//" <--> "//to_string(actual(i, j, k))//".", more) + end if + end do + end do + end do + + + end subroutine check_array_int_int_int + + subroutine check_array_sp(error, actual, expected, message, more, thr, rel) + + type(error_type), allocatable, intent(out) :: error + + real(kind=sp), intent(in) :: actual(:) + real(kind=sp), intent(in) :: expected(:) + + character(len=*), intent(in), optional :: message + character(len=*), intent(in), optional :: more + + real(sp), intent(in), optional :: thr + logical, intent(in), optional :: rel + + integer :: i, rank_A, rank_B + + rank_A = size(actual) + rank_B = size(expected) + + if (rank_A == 0 .or. rank_B == 0) then + call test_failed(error, "one of the arrays is scalar", & + "sizes are '"//to_string(rank_A)//"' and '"//to_string(rank_B)//"'.", more) + end if + + if (rank_A .ne. rank_B) then + call test_failed(error, "size of arrays not the same", & + "size difference '"//to_string(rank_A)//"' and '"//to_string(rank_B)//"'.", more) + end if + + do i = 1, rank_A + call check_float_sp(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + error%message = error%message // skip // "array mismatch at element index "//trim(to_string(i)) + return + end if + end do + + end subroutine check_array_sp + + subroutine check_array_dp(error, actual, expected, message, more, thr, rel) + + type(error_type), allocatable, intent(out) :: error + + real(kind=dp), intent(in) :: actual(:) + real(kind=dp), intent(in) :: expected(:) + + character(len=*), intent(in), optional :: message + character(len=*), intent(in), optional :: more + + real(dp), intent(in), optional :: thr + logical, intent(in), optional :: rel + + integer :: i, rank_A, rank_B + + rank_A = size(actual) + rank_B = size(expected) + + if (rank_A == 0 .or. rank_B == 0) then + call test_failed(error, "one of the arrays is scalar", & + "sizes are '"//to_string(rank_A)//"' and '"//to_string(rank_B)//"'.", more) + end if + + if (rank_A .ne. rank_B) then + call test_failed(error, "size of arrays not the same", & + "size difference '"//to_string(rank_A)//"' and '"//to_string(rank_B)//"'.", more) + end if + + do i = 1, rank_A + call check_float_dp(error, actual(i), expected(i), message, more, thr, rel) + if (allocated(error)) then + error%message = error%message // skip // "array mismatch at element index "//trim(to_string(i)) + return + end if + end do + + end subroutine check_array_dp + + subroutine check_array_dp_dp(error, actual, expected, message, more, thr, rel) + + type(error_type), allocatable, intent(out) :: error + + real(kind=dp), intent(in) :: actual(:,:) + real(kind=dp), intent(in) :: expected(:,:) + + character(len=*), intent(in), optional :: message + character(len=*), intent(in), optional :: more + + real(dp), intent(in), optional :: thr + logical, intent(in), optional :: rel + + integer :: i, j, rank_A1, rank_A2, rank_B1, rank_B2 + + rank_A1 = size(actual, 1) + rank_A2 = size(actual, 2) + rank_B1 = size(expected, 1) + rank_B2 = size(expected, 2) + + if (rank_A1 == 0 .or. rank_B1 == 0) then + call test_failed(error, "one of the arrays is scalar", & + "sizes are '"//to_string(rank_A1)//"' and '"//to_string(rank_B1)//"'.", more) + end if + + if (rank_A1 .ne. rank_B1 .or. rank_A2 .ne. rank_B2) then + call test_failed(error, "size of arrays not the same", & + "size difference '"//to_string(rank_A1)//"' and '"//to_string(rank_B1)//"'.", more) + end if + + do i = 1, rank_A1 + do j = 1, rank_A2 + call check_float_dp(error, actual(i, j), expected(i, j), message, more, thr, rel) + if (allocated(error)) then + error%message = error%message // skip // "array mismatch at element index ("//& + trim(to_string(i))//", "//trim(to_string(j))//")." + return + end if + end do + end do + + end subroutine check_array_dp_dp + + subroutine test_failed(error, message, more, and_more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> A detailed message describing the error + character(len=*), intent(in) :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Another line of error message + character(len=*), intent(in), optional :: and_more + + allocate(error) + error%stat = fatal + + error%message = message + if (present(more)) then + error%message = error%message // skip // more + end if + if (present(and_more)) then + error%message = error%message // skip // and_more + end if + + end subroutine test_failed + + + !> A test is skipped because certain requirements are not met to run the actual test + subroutine skip_test(error, message, more, and_more) + + !> Error handling + type(error_type), allocatable, intent(out) :: error + + !> A detailed message describing the error + character(len=*), intent(in) :: message + + !> Another line of error message + character(len=*), intent(in), optional :: more + + !> Another line of error message + character(len=*), intent(in), optional :: and_more + + call test_failed(error, message, more, and_more) + error%stat = skipped + + end subroutine skip_test + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= success) return + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= success) return + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= success) deallocate(arg) + end if + + end subroutine get_argument + + + !> Obtain the value of an environment variable + subroutine get_variable(var, val) + + !> Name of variable + character(len=*), intent(in) :: var + + !> Value of variable + character(len=:), allocatable, intent(out) :: val + + integer :: length, stat + + call get_environment_variable(var, length=length, status=stat) + if (stat /= success) return + + allocate(character(len=length) :: val, stat=stat) + if (stat /= success) return + + if (length > 0) then + call get_environment_variable(var, val, status=stat) + if (stat /= success) deallocate(val) + end if + + end subroutine get_variable + + + pure function integer_i1_to_string(val) result(string) + integer, parameter :: ik = i1 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function integer_i1_to_string + + + pure function integer_i2_to_string(val) result(string) + integer, parameter :: ik = i2 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function integer_i2_to_string + + + pure function integer_i4_to_string(val) result(string) + integer, parameter :: ik = i4 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function integer_i4_to_string + + + pure function integer_i8_to_string(val) result(string) + integer, parameter :: ik = i8 + !> Integer value to create string from + integer(ik), intent(in) :: val + !> String representation of integer + character(len=:), allocatable :: string + + integer, parameter :: buffer_len = range(val)+2 + character(len=buffer_len) :: buffer + integer :: pos + integer(ik) :: n + character(len=1), parameter :: numbers(-9:0) = & + ["9", "8", "7", "6", "5", "4", "3", "2", "1", "0"] + + if (val == 0_ik) then + string = numbers(0) + return + end if + + n = sign(val, -1_ik) + buffer = "" + pos = buffer_len + 1 + do while (n < 0_ik) + pos = pos - 1 + buffer(pos:pos) = numbers(mod(n, 10_ik)) + n = n/10_ik + end do + + if (val < 0_ik) then + pos = pos - 1 + buffer(pos:pos) = '-' + end if + + string = buffer(pos:) + end function integer_i8_to_string + + + pure function real_sp_to_string(val) result(string) + real(sp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 128 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + + end function real_sp_to_string + + + pure function real_dp_to_string(val) result(string) + real(dp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 128 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + + end function real_dp_to_string + + +#if WITH_XDP + pure function real_xdp_to_string(val) result(string) + real(xdp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 128 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + + end function real_xdp_to_string +#endif + + +#if WITH_QP + pure function real_qp_to_string(val) result(string) + real(qp), intent(in) :: val + character(len=:), allocatable :: string + integer, parameter :: buffer_len = 128 + character(len=buffer_len) :: buffer + + write(buffer, '(g0)') val + string = trim(buffer) + + end function real_qp_to_string +#endif + + + pure function complex_sp_to_string(val) result(string) + complex(sp), intent(in) :: val + character(len=:), allocatable :: string + + string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" + + end function complex_sp_to_string + + + pure function complex_dp_to_string(val) result(string) + complex(dp), intent(in) :: val + character(len=:), allocatable :: string + + string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" + + end function complex_dp_to_string + + +#if WITH_XDP + pure function complex_xdp_to_string(val) result(string) + complex(xdp), intent(in) :: val + character(len=:), allocatable :: string + + string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" + + end function complex_xdp_to_string +#endif + + +#if WITH_QP + pure function complex_qp_to_string(val) result(string) + complex(qp), intent(in) :: val + character(len=:), allocatable :: string + + string = "("//to_string(real(val))//", "//to_string(aimag(val))//")" + + end function complex_qp_to_string +#endif + + + !> Clear error type after it has been handled. + subroutine clear_error(error) + + !> Error handling + type(error_type), intent(inout) :: error + + if (error%stat /= success) then + error%stat = success + end if + + if (allocated(error%message)) then + deallocate(error%message) + end if + + end subroutine clear_error + + + !> Finalizer of the error type, in case the error is not correctly cleared it will + !> be escalated at runtime in a fatal way + subroutine escalate_error(error) + + !> Error handling + type(error_type), intent(inout) :: error + + if (error%stat /= success) then + write(error_unit, '(a)') "[Fatal] Uncaught error" + if (allocated(error%message)) then + write(error_unit, '(a, 1x, i0, *(1x, a))') & + "Code:", error%stat, "Message:", error%message + end if + error stop + end if + + end subroutine escalate_error + + + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_sp(val) result(is_nan) + !> Value to check + real(sp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_sp + + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_dp(val) result(is_nan) + !> Value to check + real(dp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_dp + +#if WITH_XDP + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_xdp(val) result(is_nan) + !> Value to check + real(xdp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_xdp +#endif + +#if WITH_QP + !> Determine whether a value is not a number without requiring IEEE arithmetic support + elemental function is_nan_qp(val) result(is_nan) + !> Value to check + real(qp), intent(in) :: val + !> Value is not a number + logical :: is_nan + + is_nan = .not.((val <= huge(val) .and. val >= -huge(val)) .or. abs(val) > huge(val)) + end function is_nan_qp +#endif + + +end module testdrive + diff --git a/tests/testmain.in.f90 b/tests/testmain.in.f90 new file mode 100644 index 00000000..34bc1acf --- /dev/null +++ b/tests/testmain.in.f90 @@ -0,0 +1,55 @@ +!> Driver for unit testing +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type, & + & select_suite, run_selected, get_argument +@TEST_SUITE_USE_STATEMENT@ + implicit none + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & +@TEST_SUITE_LIST_STATEMENT@ + ] + + call get_argument(1, suite_name) + call get_argument(2, test_name) + + if (allocated(suite_name)) then + is = select_suite(testsuites, suite_name) + if (is > 0 .and. is <= size(testsuites)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", testsuites(is)%name + call run_selected(testsuites(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(testsuites) + write(error_unit, fmt) "-", testsuites(is)%name + end do + error stop 1 + end if + else + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + end if + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + +end program tester + From 7350b322cf9219487c9df106662e7aaaf9450376 Mon Sep 17 00:00:00 2001 From: Hugh Sorby Date: Mon, 2 Dec 2024 18:54:26 +1300 Subject: [PATCH 3/3] Add documentation for new testing framework. --- documentation/testing.rst | 178 ++++++++++++++++++++++++------------- tests/CMakeLists.txt | 2 +- tests/test_diagnostics.f90 | 1 - 3 files changed, 116 insertions(+), 65 deletions(-) diff --git a/documentation/testing.rst b/documentation/testing.rst index 5aceee2c..a2cb7932 100644 --- a/documentation/testing.rst +++ b/documentation/testing.rst @@ -15,108 +15,160 @@ The pFUnit testing framework uses Python to manage some of the test generation, How to add a test ================= -All tests live under the *tests* tree and mirror what is in the source tree. -In the following example we are going to add a new testing module for the *diagnostics* module in the *lib* directory from the *src* tree. +All tests live under the *tests* directory. +In the following example we are going to add a new testing module for the *diagnostics* module which resides in the *src/lib* directory. Write test ---------- -To start we are first going to make sure we have the correct structure that matches the *src* tree. -Starting from the root directory of the lungsim repository we need to make sure that the directory:: +To start we create the testing module. +Because we want to test the diagnostics module from the library we will create a test file named *test_diagnostics.f90* in the *tests* directory. +With your favourite text editor create a file named *test_diagnostics.f90*. +We could choose *vi* for this task as shown below but any text editor will work:: - tests/lib + vi tests/test_diagnostics.f90 -exists and if not create it, from the command line on UNIX based oses this can be done with the *mkdir* command:: +Into this file we will write our test for the module. +First, we are going to add declare a module called *test_diagnostics*:: - mkdir tests/lib + module test_diagnostics -Once the directory structure is correct we then create the testing module. -Because we want to test the diagnostics module from the library we will create a test file named *test_diagnostics.pf* in the *tests/lib* directory. -The *pf* extension indicates that this file is a hybrid Python fortran file, this file is a preprocessor input file which is Fortran free format file with preprocessor directives added. -To create the test a Python script will generate a valid Fortran file from directives written into this file. -With your favourite text editor create a file named *test_diagnostics.pf*. -We could choose *vi* for this task as shown below but any text editor will work:: + !> We will add framework declarations and code here. - vi tests/lib/test_diagnostics.pf + !> Then we will write our test(s) here. -Into this file we will write our first test for the module. -This test will check that the diagnositcs flag has been set when using the *set_diagnostics_on* subroutine:: + end module test_diagnostics - @test - subroutine testSetDiagnostics() - use pfunit_mod - use diagnostics, only: get_diagnostics_on, set_diagnostics_on - implicit none +Into this module, we have to add some boiler plate code to declare our test to the framework and make it findable:: - logical :: state + use testdrive, only : new_unittest, unittest_type, error_type, check + implicit none + private - call get_diagnostics_on(state) - @assertFalse(state) - call set_diagnostics_on(.true.) - call get_diagnostics_on(state) - @assertTrue(state) +In this chunk of code we can see that we are using the *new_unittest, unittest_type, error_type, check* subroutines from the *testdrive* module. +We will also declare a helper subroutine to provide a list of test names to the framework:: - end subroutine testSetDiagnostics + public :: collect_diagnostics -With our test written we now need to add this into the CMake build generation system. +Now we can start with defining the *collect_diagnostics* subroutine and our test(s). +We are going to call our test *test_set_and_get*, and this is what our *collect_diagnostics* subroutine will report to the framework:: + !> Collect all exported unit tests + subroutine collect_diagnostics(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -Add test to CMake ------------------ + testsuite = [ & + new_unittest("test_set_and_get", test_set_and_get) & + ] + + end subroutine collect_diagnostics + +Next we define the *test_set_and_get* test:: + + subroutine test_set_and_get(error) + use diagnostics, only: get_diagnostics_on, set_diagnostics_on + implicit none + + type(error_type), allocatable, intent(out) :: error + + logical :: level + + call get_diagnostics_on(level) + call check(error, .false., level) + if (allocated(error)) return + + call set_diagnostics_on(.true.) + call get_diagnostics_on(level) + call check(error, .true., level) + if (allocated(error)) return + + end subroutine test_set_and_get + +The complete *tests_diagnostics.f90* file looks like this:: + + module test_diagnostics + use testdrive, only : new_unittest, unittest_type, error_type, check + implicit none + private + + public :: collect_diagnostics -The first task to do when adding a test to the CMake files is to check that a CMake file exists. -When adding a test to a new directory, as we are doing here, there won't be a CMake file for us to use. -To fix this we first need to tell CMake that a new subdirectory is available. -We do this by adding a *sub_directory* command into an existing *CMakeLists.txt* file in a parent directory of the directory we have just added a test to. -In our example we would edit the file (any text editor will do, don't feel you need to use *vi*):: + contains - vi tests/CMakeLists.txt + !> Collect all exported unit tests + subroutine collect_diagnostics(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) -and add the line at the bottom of the file:: + testsuite = [ & + new_unittest("test_set_and_get", test_set_and_get) & + ] - add_subdirectory(lib) + end subroutine collect_diagnostics -Then we need to create a new *CMakeLists.txt* (the capitalisation of this file is important) file in the *tests/lib* directory (any text editor will do, don't feel you need to use *vi*):: + subroutine test_set_and_get(error) + use diagnostics, only: get_diagnostics_on, set_diagnostics_on + implicit none - vi tests/lib/CMakeLists.txt + type(error_type), allocatable, intent(out) :: error -and add the following to create an executable test that will work with CTest (we will also be able to execute this test directly):: + logical :: level - # Add all the files that make a single test, we could have multiple files testing - # the same module. Don't add test files into the same test that test different modules. - # These are all .pf files. - set(DIAGNOSTICS_TEST_SRCS - test_diagnostics.pf) + call get_diagnostics_on(level) + call check(error, .false., level) + if (allocated(error)) return - # Make use of the pFUnit helper function to create a test. - # Arguments : - test_package_name: Name of the test package - # - test_sources : List of pf-files to be compiled - # - extra_sources : List of extra Fortran source code used for testing (if none, input empty string "") - # - extra_sources_c : List of extra C/C++ source code used for testing (if none, input empty string "") - add_pfunit_test(diagnostics_test ${DIAGNOSTICS_TEST_SRCS} "" "") - # Link the test to the aether library target. - target_link_libraries (diagnostics_test aether) - target_include_directories(diagnostics_test PRIVATE $) + call set_diagnostics_on(.true.) + call get_diagnostics_on(level) + call check(error, .true., level) + if (allocated(error)) return + + end subroutine test_set_and_get + + end module test_diagnostics + +With our test written we now need to add this into the CMake build generation system. + + +Add test to CMake +----------------- + +In the file *tests/CMakeLists.txt* we need to add the name of our new test, which is *diagnostics* in this case, to the list of tests. +At the top of this file there is a statement to define a variable named *TESTS*, looking something like this:: + + set( + TESTS + # Other tests may already be present, if so they will appear here separated by white-space. + ) + +When we add the *diagnostics* test the variable definition should look like this:: + + + set( + TESTS + # Other tests may already be present, if so they will appear here separated by white-space. + "diagnostics" + ) + +That is all we need to do to add our test into the testing framework. -With our test added to the test framework we can now build and run our test. Build and run test ------------------ The test we have just completed will be built when we build the configuration from the build directory by default. That is if we execute the *BUILD_ALL* build target for IDEs like Visual Studio or on *Makefile* generation builds we would simple issue the command *make* in the build directory. -We can also build our test directly be building the target *diagnostics_test*, for *Makefile* generation builds we would issue the command:: - - make diagnostics_test To run the test we can execute the ctest command from the command line in the build directory with the following arguments:: - ctest -R diagnostics_test + ctest -R diagnostics_test we will also execute all tests if we execute the command:: - ctest + ctest A handy flag to add to both of these commands is the *--verbose* flag. -This gives us the details output from each test and not just the summary statement. +This gives us the detailed output from each test and not just the summary statement:: + ctest -V diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 008713dd..e33a372b 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -55,7 +55,7 @@ target_link_libraries( ) foreach(t IN LISTS TESTS) - set(_TEST_NAME "${PROJECT_NAME}/${t}") + set(_TEST_NAME "${PROJECT_NAME}/${t}_test") add_test("${_TEST_NAME}" "${PROJECT_NAME}-tester" "${t}") if(MSVC) set(_TEST_PROPERTIES "PATH=$\;${FORTRAN_RUNTIME_PATH}") diff --git a/tests/test_diagnostics.f90 b/tests/test_diagnostics.f90 index 5bdbfa87..2bb13b14 100644 --- a/tests/test_diagnostics.f90 +++ b/tests/test_diagnostics.f90 @@ -39,4 +39,3 @@ subroutine test_set_and_get(error) end subroutine test_set_and_get end module test_diagnostics -