diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 33089ae..b48a629 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -18,7 +18,7 @@ jobs: steps: - name: Checkout repository - uses: actions/checkout@v4 + uses: actions/checkout@v6 - name: Build and Test run: | make -f ./make/vm-x86-gfortran-gcc.mk check diff --git a/.github/workflows/trigger-project-workflow.yaml b/.github/workflows/trigger-project-workflow.yaml index 4d0a8f6..ccb7a55 100644 --- a/.github/workflows/trigger-project-workflow.yaml +++ b/.github/workflows/trigger-project-workflow.yaml @@ -2,7 +2,7 @@ name: Trigger Review Project on: pull_request_target: - types: ["opened", "synchronize", "reopened", "edited", "review_requested", "review_request_removed"] + types: ["opened", "synchronize", "reopened", "edited", "review_requested", "review_request_removed", "closed"] pull_request_review: pull_request_review_comment: diff --git a/.gitignore b/.gitignore index f738173..815c880 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ # Default build directory _build/ +build/ # Virtual environment .venv/ diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..28a1d9f --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,112 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +# +# This is the top-level CMake build file for the Shared Unified Model +# Library +# +cmake_minimum_required(VERSION 3.20 FATAL_ERROR) + +# Shumlib version numbers are the 4-digit year followed by 2-digit +# month and an additional digit signifying the release count within +# that specified month. This should be specified in major.minor.patch +# format used by CMake and then recombined to allow it to be passed to +# shumlib via a pre-processor definition +project(shumlib LANGUAGES C Fortran + VERSION 2026.01.1 + DESCRIPTION "Met Office Shared Unifed Model Library" + HOMEPAGE_URL "https://github.com/MetOffice/shumlib") + +string(CONCAT SHUMLIB_VERSION + ${PROJECT_VERSION_MAJOR} + ${PROJECT_VERSION_MINOR} + ${PROJECT_VERSION_PATCH}) + +set(CMAKE_C_STANDARD 99) +set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/modules) + +# Include helper and setup routines +include(GNUInstallDirs) +include(cmake/PreventInSourceBuilds.cmake) +include(cmake/ShumAddSublibrary.cmake) +include(cmake/ShumFruit.cmake) +include(cmake/ShumOptions.cmake) +include(cmake/ShumVersions.cmake) +include(cmake/PkgConfig.cmake) + + +# Build rules for shumlib +add_library(shum) + +add_shum_sublibraries(shum + TARGETS + shum_byteswap + shum_constants + shum_data_conv + shum_fieldsfile + shum_fieldsfile_class + shum_horizontal_field_interp + shum_kinds + shum_latlon_eq_grids + shum_number_tools + shum_spiral_search + shum_string_conv + shum_thread_utils + shum_wgdos_packing) + +configure_shum_versions() + +target_compile_definitions(shum + PUBLIC + ${SHUM_DEFINES}) + +# Install shumlib and the C header files for the sub-libraries that +# have them +install(TARGETS shum + FILE_SET byteswap_headers + FILE_SET data_conv_headers + FILE_SET spiral_search_headers + FILE_SET thread_utils_headers + FILE_SET wgdos_packing_headers +) + +# Install the Fortran module files +install(DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY} + DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) + +# Unit tests and framework +if(BUILD_TESTS) + enable_testing() + add_library(fruit) + + # Set a relative RPATH to ensure that the unit tests continue to + # work even after being installed + list(APPEND CMAKE_INSTALL_RPATH "$ORIGIN") + list(APPEND CMAKE_INSTALL_RPATH "$ORIGIN/../${CMAKE_INSTALL_LIBDIR}") + add_executable(shumlib-tests) + + target_compile_definitions(shumlib-tests + PUBLIC + ${SHUM_DEFINES}) + + target_include_directories(shumlib-tests + PUBLIC ${CMAKE_Fortran_MODULE_DIRECTORY}) + target_link_libraries(shumlib-tests PUBLIC fruit shum) + + add_subdirectory(fruit) + setup_shum_fruit() + + install(TARGETS fruit) + install(TARGETS shumlib-tests) + + add_test(NAME shumlib-tests + COMMAND $) + + # Always set the shumlib directory to /tmp + set_property(TEST shumlib-tests + APPEND PROPERTY + ENVIRONMENT SHUM_TMPDIR=/tmp) + +endif() diff --git a/CMakePresets.json b/CMakePresets.json new file mode 100644 index 0000000..fe7e172 --- /dev/null +++ b/CMakePresets.json @@ -0,0 +1,70 @@ +{ + "version": 2, + "configurePresets": [ + { + "name": "debug", + "displayName": "Debug", + "generator": "Unix Makefiles", + "binaryDir": "build/debug", + "cacheVariables": { + "CMAKE_BUILD_TYPE": "Debug" + } + }, + { + "name": "debug-gcc", + "displayName": "GCC Debug", + "inherits": "debug", + "cacheVariables": { + "CMAKE_BUILD_TYPE": "Debug", + "CMAKE_C_COMPILER": "gcc", + "CMAKE_Fortran_COMPILER": "gfortran", + "CMAKE_C_FLAGS_INIT": "-g -Wall -Wextra -Werror -Wformat=2 -Winit-self -Wfloat-equal -Wpointer-arith -Wbad-function-cast -Wcast-qual -Wcast-align -Wconversion -Wlogical-op -Wstrict-prototypes -Wmissing-declarations -Wredundant-decls -Wnested-externs -Woverlength-strings -Wshadow -Wall -Wextra -Wpedantic -fdiagnostics-show-option", + "CMAKE_Fortran_FLAGS_INIT": "-g -std=f2018 -pedantic -pedantic-errors -fno-range-check -Wall -Wextra -Werror -Wno-compare-reals -Wconversion -Wno-unused-dummy-argument -Wno-c-binding-type -fdiagnostics-show-option" + } + }, + { + "name": "debug-cce", + "displayName": "Cray CCE Debug", + "inherits": "debug", + "cacheVariables": { + "CMAKE_BUILD_TYPE": "Debug", + "CMAKE_C_COMPILER": "cc", + "CMAKE_Fortran_COMPILER": "ftn", + "CMAKE_C_FLAGS_INIT": "-g -Weverything -Wno-vla -Wno-padded -Wno-missing-noreturn -Wno-declaration-after-statement -Werror -pedantic -pedantic-errors -fdiagnostics-show-option -DSHUM_X86_INTRINSIC", + "CMAKE_Fortran_FLAGS_INIT": "-g -M E287,E5001,1077" + } + }, + { + "name": "debug-nvhpc", + "displayName": "nvidia HPC Debug", + "inherits": "debug", + "cacheVariables": { + "CMAKE_BUILD_TYPE": "Debug", + "CMAKE_C_COMPILER": "nvcc", + "CMAKE_Fortran_COMPILER": "nvfortran", + "CMAKE_C_FLAGS_INIT": "-g", + "CMAKE_Fortran_FLAGS_INIT": "-g" + } + } + ], + "buildPresets": [ + { + "name": "debug-gcc", + "displayName": "GCC Debug Build", + "configurePreset": "debug", + "configuration": "Debug" + }, + { + "name": "debug-cce", + "displayName": "Cray CCE Debug Build", + "configurePreset": "debug", + "configuration": "Debug" + }, + { + "name": "debug-nvhpc", + "displayName": "nvidia HPC Debug Build", + "configurePreset": "debug", + "configuration": "Debug" + } + ] +} diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index c34eb45..b47eb66 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -3,3 +3,5 @@ | GitHub user | Real Name | Affiliation | Date | | ----------- | --------- | ----------- | ---- | | james-bruten-mo | James Bruten | Met Office | 2025-12-09 | +| t00sa | Sam Clarke-Green | Met Office | 2026-02-10 | +| jennyhickson | Jenny Hickson | Met Office | 2026-03-02 | diff --git a/cmake/PkgConfig.cmake b/cmake/PkgConfig.cmake new file mode 100644 index 0000000..947fb43 --- /dev/null +++ b/cmake/PkgConfig.cmake @@ -0,0 +1,20 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ + +if(ENABLE_PKGCONFIG) + # Create and install a pkg-config file + # + # This will only work correctly if the --install-prefix argument is + # used when CMake is first run and the files are generated. It will + # break if a different --prefix location is passed to cmake --install + # + configure_file(${CMAKE_CURRENT_SOURCE_DIR}/cmake/${PROJECT_NAME}.pc.in + ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc + @ONLY) + + install(FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME}.pc + DESTINATION ${CMAKE_INSTALL_LIBDIR}/pkgconfig) +endif() diff --git a/cmake/PreventInSourceBuilds.cmake b/cmake/PreventInSourceBuilds.cmake new file mode 100644 index 0000000..7d1c50c --- /dev/null +++ b/cmake/PreventInSourceBuilds.cmake @@ -0,0 +1,23 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +# This function will prevent in-source builds +function(AssureOutOfSourceBuilds) + # Make sure the user doesn't perform in-source builds by tricking + # the build system through the use of symlinks + get_filename_component(srcdir "${CMAKE_SOURCE_DIR}" REALPATH) + get_filename_component(bindir "${CMAKE_BINARY_DIR}" REALPATH) + + # Disallow in-source builds + if ("${srcdir}" STREQUAL "${bindir}") + message("######################################################") + message("Warning: in-source builds are disabled") + message("Please create a separate build directory and run cmake from there") + message("######################################################") + message(FATAL_ERROR "Quitting configuration") + endif () +endfunction() + +AssureOutOfSourceBuilds() diff --git a/cmake/ShumAddSublibrary.cmake b/cmake/ShumAddSublibrary.cmake new file mode 100644 index 0000000..c951db0 --- /dev/null +++ b/cmake/ShumAddSublibrary.cmake @@ -0,0 +1,35 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ + +# Add shumlib sublibraries +# +# Each section of shumlib is in its own subdiretory with its own +# CMakeLists.txt file in its src/ directory. Add each src directory +# and add the name of the sublibrary to a list for subsequnt use with +# the regression testing framework. +macro(add_shum_sublibraries libname) + + set(multiValueArgs TARGETS) + cmake_parse_arguments(arg_sublibs + "" "" "${multiValueArgs}" + ${ARGN}) + + set(CMAKE_SHUM_SUBLIBS "") + + message(STATUS "Adding shublib sub-libraries to ${libname}") + + foreach(sublib IN LISTS arg_sublibs_TARGETS) + if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/${sublib}/src/CMakeLists.txt) + message(VERBOSE "Including ${sublib}") + add_subdirectory(${CMAKE_CURRENT_SOURCE_DIR}/${sublib}/src) + list(APPEND CMAKE_SHUM_SUBLIBS ${sublib}) + else() + message(FATAL_ERROR "Unable to add ${sublib}") + endif() + + endforeach() + +endmacro() diff --git a/cmake/ShumFruit.cmake b/cmake/ShumFruit.cmake new file mode 100644 index 0000000..118e6c5 --- /dev/null +++ b/cmake/ShumFruit.cmake @@ -0,0 +1,46 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ + +# Setup fruit unit testing for shumlib +# +# Take the accumluted list of shumlib subdirectories and use it to +# generate the top-level driver for the regression suite. +# +macro(setup_shum_fruit) + + message(STATUS "Creating shumlib regression tests") + + list(LENGTH CMAKE_SHUM_SUBLIBS fruit_count) + if(${fruit_count} EQUAL 0) + message(FATAL_ERROR "No regression tests set") + endif() + unset(fruit_count) + + set(SHUM_FRUIT_USE "! Use shumlib modules") + set(SHUM_FRUIT_CALLS "! Call shumlib unit tests") + + foreach(SHUM_LIBNAME IN LISTS CMAKE_SHUM_SUBLIBS) + # Build the variables that pull in each of the test modules ready + # to process the driver template + + if(EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/${SHUM_LIBNAME}/test/CMakeLists.txt) + message(VERBOSE "Adding ${SHUM_LIBNAME} unit tests") + + set(SHUM_FRUIT_USE "${SHUM_FRUIT_USE}\nUSE fruit_test_${SHUM_LIBNAME}_mod") + set(SHUM_FRUIT_CALLS "${SHUM_FRUIT_CALLS}\nCALL fruit_test_${SHUM_LIBNAME}") + + add_subdirectory(${CMAKE_CURRENT_SOURCE_DIR}/${SHUM_LIBNAME}/test) + endif() + + endforeach() + + configure_file(fruit/fruit_driver.f90.in + fruit_driver.f90) + + target_sources(shumlib-tests PRIVATE + "${CMAKE_CURRENT_BINARY_DIR}/fruit_driver.f90") + +endmacro() diff --git a/cmake/ShumOptions.cmake b/cmake/ShumOptions.cmake new file mode 100644 index 0000000..c6a931b --- /dev/null +++ b/cmake/ShumOptions.cmake @@ -0,0 +1,52 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ + +# Library type options +option(BUILD_SHARED_LIBS "Build using shared libraries" ON) + +# Data options +option(IEEE_ARITHMETIC "Use Fortran intrinsic IEEE features" OFF) +option(NAN_BY_BITS "Check NaNs by bitwise inspection" OFF) +option(DENORMAL_BY_BITS "Check denormals by bitwise inspect" OFF) + +# Build options +option(BUILD_OPENMP "Build with OpenMP parallelisation" ON) +option(BUILD_FTHREADS "Build with Fortran OpenMP everywhere" OFF) +option(BUILD_TESTS "Build fruit unit tests" ON) + +# Build a list of preprocessor settings based on options +set(SHUM_DEFINES "SHUMLIB_VERSION=${SHUMLIB_VERSION}") +list(APPEND SHUM_DEFINES "SHUMLIB_CMAKE=1") + +# Install options +option(ENABLE_PKGCONFIG "Install a pkg-config description" ON) + +if(IEEE_ARITHMETIC) + message(VERBOSE "Enabling shumlib IEEE arithmetic") + list(APPEND SHUM_DEFINES "HAS_IEEE_ARITHMETIC") +endif() + +if(NAN_BY_BITS) + message(VERBOSE "Enabling shumlib evaluate NaNs by bits") + list(APPEND SHUM_DEFINES "EVAL_NAN_BY_BITS") +endif() + +if(DENORMAL_BY_BITS) + message(VERBOSE "Enabling shumlib evaluate denormals by bits") + list(APPEND SHUM_DEFINES "EVAL_DENORMAL_BY_BITS") +endif() + +if(BUILD_OPENMP) + # FIXME: this probably needs newer version of cmake on the Cray + find_package(OpenMP 3.0 REQUIRED) + + if(BUILD_FTHREADS) + message(VERBOSE "Using shumlib with Fortran OpenMP threading") + list(APPEND SHUM_DEFINES + SHUM_USE_C_OPENMP_VIA_THREAD_UTILS="shum_use_c_openmp_via_thread_util") + endif() + +endif() diff --git a/cmake/ShumVersions.cmake b/cmake/ShumVersions.cmake new file mode 100644 index 0000000..edc7904 --- /dev/null +++ b/cmake/ShumVersions.cmake @@ -0,0 +1,36 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ + +# Create shumlib version files from templates +# +# Replace the previous versioning which used preprocessor macros and +# pure Makefiles with templating of the module file. +macro(configure_shum_versions) + + message(STATUS "Creating shumlib version functions") + + foreach(SHUM_LIBNAME IN LISTS CMAKE_SHUM_SUBLIBS) + message(VERBOSE "Versioning ${SHUM_LIBNAME}") + configure_file(common/src/f_version_mod.f90.in + "f_${SHUM_LIBNAME}_version_mod.f90") + + target_sources(shum PRIVATE + "${CMAKE_CURRENT_BINARY_DIR}/f_${SHUM_LIBNAME}_version_mod.f90") + + endforeach() + + # FIXME: remove hardwiring? + target_include_directories(shum + PUBLIC + common/src) + + target_sources(shum PRIVATE + common/src/shumlib_version.c) + + unset(SHUM_LIBNAME) + unset(SHUM_VERSION_DEFINES) + +endmacro() diff --git a/cmake/shumlib.pc.in b/cmake/shumlib.pc.in new file mode 100644 index 0000000..6150d96 --- /dev/null +++ b/cmake/shumlib.pc.in @@ -0,0 +1,11 @@ +Name: shumlib +Version: @PROJECT_VERSION@ +Description: @PROJECT_DESCRIPTION@ +URL: @CMAKE_PROJECT_HOMEPAGE_URL@ + +# Use pcfiledir to make package relocatable +libdir=${pcfiledir}/../ +includedir=${pcfiledir}/../../@CMAKE_INSTALL_INCLUDEDIR@ + +Libs: -L${libdir} -lshum +Cflags: -I${includedir} diff --git a/common/src/f_version_mod.f90.in b/common/src/f_version_mod.f90.in new file mode 100644 index 0000000..3877e08 --- /dev/null +++ b/common/src/f_version_mod.f90.in @@ -0,0 +1,12 @@ +MODULE f_@SHUM_LIBNAME@_version_mod +USE, INTRINSIC :: ISO_C_BINDING +IMPLICIT NONE +INTERFACE + FUNCTION get_@SHUM_LIBNAME@_version() RESULT(version) & + BIND(C, name='GET_SHUMLIB_VERSION') + IMPORT :: C_INT64_T + IMPLICIT NONE + INTEGER(KIND=C_INT64_T) :: version + END FUNCTION get_@SHUM_LIBNAME@_version +END INTERFACE +END MODULE f_@SHUM_LIBNAME@_version_mod diff --git a/common/src/shumlib_version.c b/common/src/shumlib_version.c index ecc804f..6bcc723 100644 --- a/common/src/shumlib_version.c +++ b/common/src/shumlib_version.c @@ -32,5 +32,15 @@ #include "precision_bomb.h" #include "shumlib_version.h" +#if !defined(SHUMLIB_CMAKE) + int64_t GET_SHUMLIB_VERSION(SHUMLIB_LIBNAME) { return SHUMLIB_VERSION;} + +#else + +int64_t GET_SHUMLIB_VERSION(void) { + return SHUMLIB_VERSION; +} + +#endif diff --git a/common/src/shumlib_version.h b/common/src/shumlib_version.h index 2661127..8671df5 100644 --- a/common/src/shumlib_version.h +++ b/common/src/shumlib_version.h @@ -25,9 +25,9 @@ /* Check the macro we need is defined. * This should happen outside the include guard, else only the top level library - * is validated + * is validated. */ -#if !defined(SHUMLIB_LIBNAME) +#if !defined(SHUMLIB_LIBNAME) && !defined(SHUMLIB_CMAKE) #error "Please define 'SHUMLIB_LIBNAME' when including this header" #endif @@ -37,6 +37,8 @@ #include +#if !defined(SHUMLIB_CMAKE) + /* Master definition of version number (uses YYYYMMX format) * where "X" is the release number in month "MM" of year "YYYY" */ @@ -51,9 +53,26 @@ #define SHUMLIB_XSTRING_EXPANSION(str) get_##str##_version #define GET_SHUMLIB_VERSION(libname) SHUMLIB_XSTRING_EXPANSION(libname)(void) +#else /* Using CMake features */ + +/* Master definition of version number (uses YYYYMMX format) + * where "X" is the release number in month "MM" of year "YYYY" + */ +#if !defined(SHUMLIB_VERSION) +#error Need to define SHUMLIB_VERSION macro #endif +extern int64_t GET_SHUMLIB_VERSION(void); + +#endif /* SHUMLIB_CMAKE */ +#endif /* SHUMLIB_VERSION_H */ + +#if !defined(SHUMLIB_CMAKE) /* The prototype should be OUTSIDE the include guard, because it is preprocessed * to a different function in every include instance. */ extern int64_t GET_SHUMLIB_VERSION(SHUMLIB_LIBNAME); + +#endif /* !SHUMLIB_CMAKE */ + + diff --git a/fortitude.toml b/fortitude.toml index c9645eb..eb7272a 100644 --- a/fortitude.toml +++ b/fortitude.toml @@ -1,16 +1,12 @@ [check] -exclude = ['.venv'] +exclude = [ + '.venv', + 'fruit/fruit.f90', + 'fruit/fruit_mpi.f90', +] ignore = [ - 'C002', # interface-implicit-typing 'C003', # implicit-external-procedures - 'C061', # missing-intent 'C071', # assumed-size 'C072', # assumed-size-character-intent - 'C081', # initialisation-in-declaration - 'C121', # use-all - 'C141', # missing-exit-or-cycle-label 'E001', # syntax-error - 'MOD011', # old-style-array-literal - 'MOD021', # deprecated-relational-operator - 'S061', # unnamed-end-statement ] diff --git a/fruit/CMakeLists.txt b/fruit/CMakeLists.txt new file mode 100644 index 0000000..c1441ed --- /dev/null +++ b/fruit/CMakeLists.txt @@ -0,0 +1,9 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ + +target_sources(fruit + PRIVATE + fruit.f90) diff --git a/fruit/fruit.f90 b/fruit/fruit.f90 index d240133..66fef6f 100644 --- a/fruit/fruit.f90 +++ b/fruit/fruit.f90 @@ -230,7 +230,7 @@ function integer32Equal (number1, number2 ) result (resultValue) resultValue = .false. - if ( number1 .eq. number2 ) then + if ( number1 == number2 ) then resultValue = .true. else resultValue = .false. @@ -243,7 +243,7 @@ function integer64Equal (number1, number2 ) result (resultValue) resultValue = .false. - if ( number1 .eq. number2 ) then + if ( number1 == number2 ) then resultValue = .true. else resultValue = .false. @@ -256,7 +256,7 @@ function stringEqual (str1, str2 ) result (resultValue) resultValue = .false. - if ( str1 .eq. str2 ) then + if ( str1 == str2 ) then resultValue = .true. end if end function stringEqual @@ -971,7 +971,8 @@ end subroutine fruit_hide_dots_ subroutine run_test_case_named_( tc, tc_name ) interface subroutine tc() - end subroutine + implicit none + end subroutine tc end interface character(*), intent(in) :: tc_name @@ -996,7 +997,7 @@ subroutine tc() !$OMP BARRIER - if ( initial_failed_assert_count .eq. failed_assert_count ) then + if ( initial_failed_assert_count == failed_assert_count ) then ! If no additional assertions failed during the run of this test case ! then the test case was successful successful_case_count = successful_case_count+1 @@ -1015,7 +1016,8 @@ end subroutine run_test_case_named_ subroutine run_test_case_( tc ) interface subroutine tc() - end subroutine + implicit none + end subroutine tc end interface call run_test_case_named_( tc, '_unnamed_' ) @@ -1100,12 +1102,12 @@ end subroutine add_fail_unit_ subroutine obsolete_isAllSuccessful_(result) logical, intent(out) :: result call obsolete_ ('subroutine isAllSuccessful is changed to function is_all_successful.') - result = (failed_assert_count .eq. 0 ) + result = (failed_assert_count == 0 ) end subroutine obsolete_isAllSuccessful_ subroutine is_all_successful(result) logical, intent(out) :: result - result= (failed_assert_count .eq. 0 ) + result= (failed_assert_count == 0 ) end subroutine is_all_successful ! Private, helper routine to wrap lines of success/failed marks @@ -1117,7 +1119,7 @@ subroutine output_mark_( chr ) !$omp critical (FRUIT_OMP_ADD_OUTPUT_MARK) linechar_count = linechar_count + 1 - if ( linechar_count .lt. MAX_MARKS_PER_LINE ) then + if ( linechar_count < MAX_MARKS_PER_LINE ) then write(stdout,"(A1)",ADVANCE='NO') chr else write(stdout,"(A1)",ADVANCE='YES') chr diff --git a/fruit/fruit_driver.f90.in b/fruit/fruit_driver.f90.in new file mode 100644 index 0000000..571b51e --- /dev/null +++ b/fruit/fruit_driver.f90.in @@ -0,0 +1,21 @@ +PROGRAM fruit_driver +USE iso_c_binding +USE fruit +@SHUM_FRUIT_USE@ +IMPLICIT NONE +INTERFACE +SUBROUTINE c_exit(status) BIND(c,NAME="exit") +IMPORT :: C_INT +IMPLICIT NONE +INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: status +END SUBROUTINE +END INTERFACE +INTEGER :: status +CALL init_fruit +@SHUM_FRUIT_CALLS@ +CALL fruit_summary +CALL fruit_finalize +CALL get_failed_count(status) +CALL c_exit(INT(status,KIND=C_INT)) +END PROGRAM fruit_driver + diff --git a/shum_byteswap/src/CMakeLists.txt b/shum_byteswap/src/CMakeLists.txt new file mode 100644 index 0000000..3e2df18 --- /dev/null +++ b/shum_byteswap/src/CMakeLists.txt @@ -0,0 +1,17 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + c_shum_byteswap.c + f_shum_byteswap.f90) + +target_sources(shum + PUBLIC + FILE_SET byteswap_headers + TYPE HEADERS + FILES + c_shum_byteswap.h + c_shum_byteswap_opt.h) diff --git a/shum_byteswap/test/CMakeLists.txt b/shum_byteswap/test/CMakeLists.txt new file mode 100644 index 0000000..11df039 --- /dev/null +++ b/shum_byteswap/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_byteswap.f90) diff --git a/shum_byteswap/test/fruit_test_shum_byteswap.f90 b/shum_byteswap/test/fruit_test_shum_byteswap.f90 index 770c96e..439f9cf 100644 --- a/shum_byteswap/test/fruit_test_shum_byteswap.f90 +++ b/shum_byteswap/test/fruit_test_shum_byteswap.f90 @@ -21,10 +21,30 @@ !******************************************************************************* MODULE fruit_test_shum_byteswap_mod -USE fruit +USE fruit, ONLY: assert_equals, assert_true, run_test_case, set_case_name USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_BOOL -USE f_shum_ztables_mod +USE f_shum_ztables_mod, ONLY: & + z0000000000000040, z0000000000000840, z0000000000001040, & + z0000000000001440, z0000000000001840, z0000000000001C40, & + z0000000000002040, z0000000000002240, z0000000000002440, & + z000000000000F03F, z0000000001000000, z0000000002000000, & + z0000000003000000, z0000000004000000, z0000000005000000, & + z0000000006000000, z0000000007000000, z0000000008000000, & + z0000000009000000, z000000000A000000, z00000040, & + z0000004000000000, z00000041, z0000084000000000, & + z0000104000000000, z00001041, z0000144000000000, & + z0000184000000000, z00001C4000000000, z0000204000000000, & + z00002041, z0000224000000000, z0000244000000000, & + z00004040, z0000803F, z00008040, & + z0000A040, z0000C040, z0000E040, & + z0000F03F00000000, z01000000, z0100000000000000, & + z02000000, z0200000000000000, z03000000, & + z0300000000000000, z04000000, z0400000000000000, & + z05000000, z0500000000000000, z06000000, & + z0600000000000000, z07000000, z0700000000000000, & + z08000000, z0800000000000000, z09000000, & + z0900000000000000, z0A000000, z0A00000000000000 IMPLICIT NONE PRIVATE diff --git a/shum_constants/src/CMakeLists.txt b/shum_constants/src/CMakeLists.txt new file mode 100644 index 0000000..d0356bc --- /dev/null +++ b/shum_constants/src/CMakeLists.txt @@ -0,0 +1,13 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_chemistry_constants_mod.f90 + f_shum_conversions_mod.f90 + f_shum_planet_earth_constants_mod.f90 + f_shum_ztables.f90 + f_shum_rel_mol_mass_mod.f90 + f_shum_water_constants_mod.f90) diff --git a/shum_constants/test/CMakeLists.txt b/shum_constants/test/CMakeLists.txt new file mode 100644 index 0000000..87e2694 --- /dev/null +++ b/shum_constants/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_constants.f90) diff --git a/shum_data_conv/src/CMakeLists.txt b/shum_data_conv/src/CMakeLists.txt new file mode 100644 index 0000000..ca3eee1 --- /dev/null +++ b/shum_data_conv/src/CMakeLists.txt @@ -0,0 +1,16 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + c_shum_data_conv.c + f_shum_data_conv.f90) + +target_sources(shum + PUBLIC + FILE_SET data_conv_headers + TYPE HEADERS + FILES + c_shum_data_conv.h) diff --git a/shum_fieldsfile/src/CMakeLists.txt b/shum_fieldsfile/src/CMakeLists.txt new file mode 100644 index 0000000..1fe08c3 --- /dev/null +++ b/shum_fieldsfile/src/CMakeLists.txt @@ -0,0 +1,11 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_fieldsfile.f90 + f_shum_stashmaster.f90 + f_shum_fixed_length_header_indices.f90 + f_shum_lookup_indices.f90) diff --git a/shum_fieldsfile/src/f_shum_fieldsfile.f90 b/shum_fieldsfile/src/f_shum_fieldsfile.f90 index 790a46d..a25d3e7 100644 --- a/shum_fieldsfile/src/f_shum_fieldsfile.f90 +++ b/shum_fieldsfile/src/f_shum_fieldsfile.f90 @@ -276,7 +276,7 @@ FUNCTION unique_id_to_ff(id) RESULT(ff) ! returning the last element in the list NULLIFY(ff) -END FUNCTION +END FUNCTION unique_id_to_ff !------------------------------------------------------------------------------! @@ -1989,8 +1989,8 @@ END FUNCTION f_shum_write_fixed_length_header FUNCTION commit_fixed_length_header(ff, message) RESULT(STATUS) IMPLICIT NONE -TYPE(ff_type) :: ff -CHARACTER(LEN=*) :: message +TYPE(ff_type), INTENT(IN OUT) :: ff +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=INT64) :: STATUS INTEGER(KIND=INT64), ALLOCATABLE :: swap_header(:) @@ -2044,7 +2044,7 @@ END FUNCTION commit_fixed_length_header FUNCTION get_next_free_position(ff) RESULT(POSITION) IMPLICIT NONE -TYPE(ff_type) :: ff +TYPE(ff_type), INTENT(IN) :: ff INTEGER(KIND=INT64) :: POSITION POSITION = f_shum_fixed_length_header_len + 1 @@ -2133,8 +2133,8 @@ END FUNCTION get_next_free_position FUNCTION get_next_populated_position(ff, start) RESULT(POSITION) IMPLICIT NONE -TYPE(ff_type) :: ff -INTEGER(KIND=INT64) :: start +TYPE(ff_type), INTENT(IN) :: ff +INTEGER(KIND=INT64), INTENT(IN) :: start INTEGER(KIND=INT64) :: POSITION POSITION = HUGE(0_int64) @@ -3059,8 +3059,8 @@ END FUNCTION f_shum_write_lookup FUNCTION commit_lookup(ff, message) RESULT(STATUS) IMPLICIT NONE -TYPE(ff_type) :: ff -CHARACTER(LEN=*) :: message +TYPE(ff_type), INTENT(IN OUT) :: ff +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=INT64) :: STATUS INTEGER(KIND=INT64) :: start diff --git a/shum_fieldsfile/test/CMakeLists.txt b/shum_fieldsfile/test/CMakeLists.txt new file mode 100644 index 0000000..8ff6e5c --- /dev/null +++ b/shum_fieldsfile/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_fieldsfile.f90) diff --git a/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 b/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 index 7fcb6d1..eac5cd6 100644 --- a/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 +++ b/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 @@ -21,7 +21,8 @@ !******************************************************************************* MODULE fruit_test_shum_fieldsfile_mod -USE fruit +USE fruit, ONLY: assert_equals, assert_false, assert_true, get_failed_count, & + run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL @@ -38,7 +39,7 @@ SUBROUTINE c_exit(status) BIND(c,NAME="exit") IMPORT :: C_INT IMPLICIT NONE INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: status -END SUBROUTINE +END SUBROUTINE c_exit END INTERFACE !------------------------------------------------------------------------------! @@ -89,11 +90,14 @@ SUBROUTINE fruit_test_shum_fieldsfile STATUS=get_env_status) ! If the variable exists call again to read it in -IF (get_env_status == 0) THEN +IF (get_env_status == 0 .AND. shum_tmpdir_len > 0) THEN ALLOCATE(CHARACTER(shum_tmpdir_len) :: shum_tmpdir) CALL GET_ENVIRONMENT_VARIABLE("SHUM_TMPDIR", & VALUE=shum_tmpdir, & STATUS=get_env_status) +ELSE + ! Force an error if variable has zero length + get_env_status = 1 END IF ! Now check the status (not an ELSE IF, because that way we can catch the ! failed status of either the first or second call @@ -153,7 +157,7 @@ SUBROUTINE test_end_to_end_direct_write_file IMPLICIT NONE INTEGER(KIND=int64) :: status -CHARACTER(LEN=500) :: message = "" +CHARACTER(LEN=500) :: message INTEGER(KIND=int64) :: ff_id CHARACTER(LEN=*), PARAMETER :: tempfile="fruit_test_fieldsfile_direct.ff" @@ -223,6 +227,8 @@ SUBROUTINE test_end_to_end_direct_write_file LOGICAL(KIND=bool) :: check +message = "" + ! Get the number of failed tests prior to this test starting CALL get_failed_count(failures_at_entry) @@ -875,7 +881,7 @@ SUBROUTINE test_end_to_end_sequential_write_file IMPLICIT NONE INTEGER(KIND=int64) :: status -CHARACTER(LEN=500) :: message = "" +CHARACTER(LEN=500) :: message INTEGER(KIND=int64) :: ff_id CHARACTER(LEN=*), PARAMETER :: tempfile="fruit_test_fieldsfile_sequential.ff" @@ -945,6 +951,8 @@ SUBROUTINE test_end_to_end_sequential_write_file LOGICAL(KIND=bool) :: check +message = "" + ! Get the number of failed tests prior to this test starting CALL get_failed_count(failures_at_entry) @@ -1551,7 +1559,7 @@ SUBROUTINE test_stashmaster_read IMPLICIT NONE INTEGER(KIND=int64) :: status -CHARACTER(LEN=500) :: message = "" +CHARACTER(LEN=500) :: message CHARACTER(LEN=1) :: newline TYPE(shum_STASHmaster), ALLOCATABLE :: STASHmaster(:) @@ -1566,6 +1574,8 @@ SUBROUTINE test_stashmaster_read INTEGER(KIND=int64) :: packing_codes(10) LOGICAL(KIND=bool) :: check +message = "" + ! Get the number of failed tests prior to this test starting CALL get_failed_count(failures_at_entry) diff --git a/shum_fieldsfile_class/src/CMakeLists.txt b/shum_fieldsfile_class/src/CMakeLists.txt new file mode 100644 index 0000000..41532f1 --- /dev/null +++ b/shum_fieldsfile_class/src/CMakeLists.txt @@ -0,0 +1,10 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_ff_status.f90 + f_shum_field.f90 + f_shum_file.f90) diff --git a/shum_fieldsfile_class/src/f_shum_field.f90 b/shum_fieldsfile_class/src/f_shum_field.f90 index 4ca496f..04658b3 100644 --- a/shum_fieldsfile_class/src/f_shum_field.f90 +++ b/shum_fieldsfile_class/src/f_shum_field.f90 @@ -223,7 +223,7 @@ END FUNCTION get_lookup FUNCTION set_int_lookup_by_index(self, num_index, value_to_set) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(INOUT) :: self - INTEGER(KIND=int64) :: value_to_set, num_index + INTEGER(KIND=int64), INTENT(IN) :: value_to_set, num_index TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup .OR. num_index < 1_int64) THEN @@ -243,7 +243,8 @@ END FUNCTION set_int_lookup_by_index FUNCTION get_int_lookup_by_index(self, num_index, value_to_get) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: value_to_get, num_index + INTEGER(KIND=int64), INTENT(IN) :: num_index + INTEGER(KIND=int64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup .OR. num_index < 1_int64) THEN @@ -263,8 +264,8 @@ END FUNCTION get_int_lookup_by_index FUNCTION set_real_lookup_by_index(self, num_index, value_to_set) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(INOUT) :: self - INTEGER(KIND=int64) :: num_index - REAL(KIND=real64) :: value_to_set + INTEGER(KIND=int64), INTENT(IN) :: num_index + REAL(KIND=real64), INTENT(IN) :: value_to_set TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup + len_real_lookup .OR. & @@ -289,8 +290,8 @@ END FUNCTION set_real_lookup_by_index FUNCTION get_real_lookup_by_index(self, num_index, value_to_get) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: num_index - REAL(KIND=real64) :: value_to_get + INTEGER(KIND=int64), INTENT(IN) :: num_index + REAL(KIND=real64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup + len_real_lookup .OR. & @@ -317,7 +318,7 @@ FUNCTION get_stashcode(self, stashcode) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbuser4 IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: stashcode + INTEGER(KIND=int64), INTENT(OUT) :: stashcode TYPE(shum_ff_status_type) :: status ! Return status object IF (self%lookup_int(lbuser4) /= um_imdi) THEN @@ -338,7 +339,7 @@ FUNCTION get_timestring(self, timestring) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbyr, lbmon, lbdat, lbhr, lbmin, lbsec IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - CHARACTER(LEN=16) :: timestring + CHARACTER(LEN=16), INTENT(OUT) :: timestring INTEGER(KIND=int64) :: yr, mon, dat, hr, min, sec TYPE(shum_ff_status_type) :: status ! Return status object @@ -380,7 +381,7 @@ FUNCTION get_level_number(self, level_number) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lblev IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: level_number + INTEGER(KIND=int64), INTENT(OUT) :: level_number TYPE(shum_ff_status_type) :: status ! Return status object level_number = self%lookup_int(lblev) @@ -395,7 +396,7 @@ FUNCTION get_level_eta(self, level_eta) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: blev IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: level_eta + REAL(KIND=real64), INTENT(OUT) :: level_eta TYPE(shum_ff_status_type) :: status ! Return status object ! SHUMlib stores parameters containing the index in the 64-word lookup @@ -413,7 +414,7 @@ END FUNCTION get_level_eta FUNCTION get_real_fctime(self, real_fctime) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: real_fctime + REAL(KIND=real64), INTENT(OUT) :: real_fctime TYPE(shum_ff_status_type) :: status ! Return status object real_fctime = self%fctime_real @@ -428,7 +429,7 @@ FUNCTION get_lbproc(self, proc) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbproc IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: proc + INTEGER(KIND=int64), INTENT(OUT) :: proc TYPE(shum_ff_status_type) :: status ! Return status object proc = self%lookup_int(lbproc) @@ -485,7 +486,7 @@ FUNCTION get_longitudes(self, longitudes) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self REAL(KIND=real64), ALLOCATABLE :: temp_longitudes(:) - REAL(KIND=real64), ALLOCATABLE :: longitudes(:) + REAL(KIND=real64), INTENT(OUT), ALLOCATABLE :: longitudes(:) TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%longitudes)) THEN @@ -532,7 +533,7 @@ FUNCTION get_latitudes(self, latitudes) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self REAL(KIND=real64), ALLOCATABLE :: temp_latitudes(:) - REAL(KIND=real64), ALLOCATABLE :: latitudes(:) + REAL(KIND=real64), INTENT(OUT), ALLOCATABLE :: latitudes(:) TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%latitudes)) THEN @@ -553,8 +554,8 @@ END FUNCTION get_latitudes FUNCTION get_coords(self, x, y, coords) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: x, y - REAL(KIND=real64) :: coords(2) + INTEGER(KIND=int64), INTENT(IN) :: x, y + REAL(KIND=real64), INTENT(OUT) :: coords(2) TYPE(shum_ff_status_type) :: status ! Return status object IF (x < 1_int64 .OR. x > SIZE(self%longitudes)) THEN @@ -584,7 +585,7 @@ FUNCTION get_pole_location(self, pole_location) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: bplon, bplat IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: pole_location(2) + REAL(KIND=real64), INTENT(OUT) :: pole_location(2) TYPE(shum_ff_status_type) :: status ! Return status object ! SHUMlib stores parameters containing the index in the 64-word lookup @@ -634,7 +635,7 @@ FUNCTION get_rdata(self, rdata) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbrow, lbnpt IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: rdata(self%lookup_int(lbnpt), & + REAL(KIND=real64), INTENT(OUT) :: rdata(self%lookup_int(lbnpt), & self%lookup_int(lbrow)) TYPE(shum_ff_status_type) :: status ! Return status object @@ -655,8 +656,8 @@ END FUNCTION get_rdata FUNCTION get_rdata_by_location(self, x, y, rdata) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: x, y - REAL(KIND=real64) :: rdata + INTEGER(KIND=int64), INTENT(IN) :: x, y + REAL(KIND=real64), INTENT(OUT) :: rdata TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%rdata)) THEN @@ -714,7 +715,7 @@ FUNCTION get_idata(self, idata) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbrow, lbnpt IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: idata(self%lookup_int(lbnpt), & + INTEGER(KIND=int64), INTENT(OUT) :: idata(self%lookup_int(lbnpt), & self%lookup_int(lbrow)) TYPE(shum_ff_status_type) :: status ! Return status object @@ -735,8 +736,8 @@ END FUNCTION get_idata FUNCTION get_idata_by_location(self, x, y, idata) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: x, y - INTEGER(KIND=int64) :: idata + INTEGER(KIND=int64), INTENT(IN) :: x, y + INTEGER(KIND=int64), INTENT(OUT) :: idata TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%idata)) THEN diff --git a/shum_fieldsfile_class/src/f_shum_file.f90 b/shum_fieldsfile_class/src/f_shum_file.f90 index 12f6e05..d010212 100644 --- a/shum_fieldsfile_class/src/f_shum_file.f90 +++ b/shum_fieldsfile_class/src/f_shum_file.f90 @@ -138,8 +138,8 @@ FUNCTION open_file(self, fname, num_lookup, overwrite) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self CHARACTER(LEN=*), INTENT(IN) :: fname -INTEGER(KIND=INT64), OPTIONAL :: num_lookup -LOGICAL(KIND=bool), OPTIONAL :: overwrite +INTEGER(KIND=INT64), INTENT(IN), OPTIONAL :: num_lookup +LOGICAL(KIND=bool), INTENT(IN), OPTIONAL :: overwrite TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=INT64) :: lookup_size LOGICAL :: exists, read_only @@ -231,11 +231,13 @@ FUNCTION read_header(self) RESULT(STATUS) INTEGER(KIND=INT64), PARAMETER :: fieldsfile_type = 3 INTEGER(KIND=INT64), PARAMETER :: ancil_type = 4 -LOGICAL :: is_variable_resolution = .FALSE. +LOGICAL :: is_variable_resolution LOGICAL :: grid_supported TYPE(shum_ff_status_type) :: STATUS ! Return status object +is_variable_resolution = .FALSE. + ! Read in compulsory headers STATUS%icode = f_shum_read_fixed_length_header( & self%file_identifier, & @@ -929,7 +931,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(tmp_field_data_r64(cols, rows)) - tmp_field_data_r64 = RESHAPE(field_data_r64, (/cols, rows/)) + tmp_field_data_r64 = RESHAPE(field_data_r64, [cols, rows]) STATUS = self%fields(field_number)%set_data(tmp_field_data_r64) IF (STATUS%icode /= shumlib_success) THEN WRITE(STATUS%message, '(A,I0)') 'Error setting data for field ', & @@ -948,7 +950,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(tmp_field_data_i64(cols, rows)) - tmp_field_data_i64 = RESHAPE(field_data_i64, (/cols, rows/)) + tmp_field_data_i64 = RESHAPE(field_data_i64, [cols, rows]) STATUS = self%fields(field_number)%set_data(tmp_field_data_i64) IF (STATUS%icode /= shumlib_success) THEN WRITE(STATUS%message, '(A,I0)') 'Error setting data for field ', & @@ -1002,7 +1004,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) ! Promote to 64-bit ALLOCATE(tmp_field_data_r64(cols, rows)) ALLOCATE(tmp_field_data_r32(cols, rows)) - tmp_field_data_r32 = RESHAPE(field_data_r32, (/cols, rows/)) + tmp_field_data_r32 = RESHAPE(field_data_r32, [cols, rows]) DO j_value = 1, rows DO i_value = 1, cols tmp_field_data_r64(i_value,j_value) = tmp_field_data_r32( & @@ -1030,7 +1032,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) ! Promote to 64-bit ALLOCATE(tmp_field_data_i64(cols, rows)) ALLOCATE(tmp_field_data_i32(cols, rows)) - tmp_field_data_i32 = RESHAPE(field_data_i32, (/cols, rows/)) + tmp_field_data_i32 = RESHAPE(field_data_i32, [cols, rows]) DO j_value = 1, rows DO i_value = 1, cols tmp_field_data_i64(i_value, j_value) = tmp_field_data_i32( & @@ -1693,7 +1695,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(field_data_r64(rows*cols)) - field_data_r64 = RESHAPE(tmp_field_data_r64, (/cols * rows/)) + field_data_r64 = RESHAPE(tmp_field_data_r64, [cols * rows]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & @@ -1713,7 +1715,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(field_data_i64(rows*cols)) - field_data_i64 = RESHAPE(tmp_field_data_i64, (/rows * cols/)) + field_data_i64 = RESHAPE(tmp_field_data_i64, [rows * cols]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & @@ -1776,7 +1778,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) END DO END DO - field_data_r32 = RESHAPE(tmp_field_data_r32, (/rows*cols/)) + field_data_r32 = RESHAPE(tmp_field_data_r32, [rows*cols]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & field_data_r32, & @@ -1803,7 +1805,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) i_value,j_value), INT32) END DO END DO - field_data_i32 = RESHAPE(tmp_field_data_i32, (/rows*cols/)) + field_data_i32 = RESHAPE(tmp_field_data_i32, [rows*cols]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & field_data_i32, & @@ -1906,7 +1908,7 @@ FUNCTION get_fixed_length_header(self, fixed_length_header) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: fixed_length_header(f_shum_fixed_length_header_len) +INTEGER(KIND=INT64), INTENT(OUT) :: fixed_length_header(f_shum_fixed_length_header_len) TYPE(shum_ff_status_type) :: STATUS ! Return status object fixed_length_header = self%fixed_length_header @@ -1921,7 +1923,7 @@ FUNCTION set_fixed_length_header_by_index(self, num_index, value_to_set) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index, value_to_set +INTEGER(KIND=INT64), INTENT(IN) :: num_index, value_to_set TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (num_index < 1_int64 .OR. num_index > f_shum_fixed_length_header_len) & @@ -1942,7 +1944,8 @@ FUNCTION get_fixed_length_header_by_index(self, num_index, value_to_get) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index, value_to_get +INTEGER(KIND=INT64), INTENT(IN) :: num_index +INTEGER(KIND=INT64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (num_index < 1_int64 .OR. num_index > f_shum_fixed_length_header_len) & @@ -1994,7 +1997,7 @@ FUNCTION get_integer_constants(self, integer_constants) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64), ALLOCATABLE :: integer_constants(:) +INTEGER(KIND=INT64), INTENT(IN OUT), ALLOCATABLE :: integer_constants(:) INTEGER(KIND=INT64) :: s_ic TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2024,7 +2027,7 @@ FUNCTION set_integer_constants_by_index(self, num_index, value_to_set) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index, value_to_set +INTEGER(KIND=INT64), INTENT(IN) :: num_index, value_to_set TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%integer_constants)) THEN @@ -2048,7 +2051,8 @@ FUNCTION get_integer_constants_by_index(self, num_index, value_to_get) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index, value_to_get +INTEGER(KIND=INT64), INTENT(IN) :: num_index +INTEGER(KIND=INT64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%integer_constants)) THEN @@ -2103,7 +2107,7 @@ FUNCTION get_real_constants(self, real_constants) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: real_constants(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: real_constants(:) INTEGER(KIND=INT64) :: s_rc TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2133,8 +2137,8 @@ FUNCTION set_real_constants_by_index(self, num_index, value_to_set) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index -REAL(KIND=REAL64) :: value_to_set +INTEGER(KIND=INT64), INTENT(IN) :: num_index +REAL(KIND=REAL64), INTENT(IN) :: value_to_set TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%real_constants)) THEN @@ -2158,8 +2162,8 @@ FUNCTION get_real_constants_by_index(self, num_index, value_to_get) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index -REAL(KIND=REAL64) :: value_to_get +INTEGER(KIND=INT64), INTENT(IN) :: num_index +REAL(KIND=REAL64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%real_constants)) THEN @@ -2219,7 +2223,7 @@ FUNCTION get_level_dependent_constants(self, level_dependent_constants) & ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: level_dependent_constants(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: level_dependent_constants(:,:) INTEGER(KIND=INT64) :: s_ldc1,s_ldc2 TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2287,7 +2291,7 @@ FUNCTION get_row_dependent_constants(self, row_dependent_constants) & ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: row_dependent_constants(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: row_dependent_constants(:,:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_rdc1,s_rdc2 @@ -2359,7 +2363,7 @@ FUNCTION get_column_dependent_constants(self, column_dependent_constants) & ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: column_dependent_constants(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: column_dependent_constants(:,:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_cdc1,s_cdc2 @@ -2429,7 +2433,7 @@ FUNCTION get_additional_parameters(self, additional_parameters) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: additional_parameters(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: additional_parameters(:,:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_ap1, s_ap2 @@ -2496,7 +2500,7 @@ FUNCTION get_extra_constants(self, extra_constants) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: extra_constants(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: extra_constants(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_ec @@ -2560,7 +2564,7 @@ FUNCTION get_temp_histfile(self, temp_histfile) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: temp_histfile(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: temp_histfile(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_thf @@ -2594,7 +2598,7 @@ FUNCTION set_compressed_index(self, num_index, compressed_index) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index +INTEGER(KIND=INT64), INTENT(IN) :: num_index REAL(KIND=REAL64), INTENT(IN) :: compressed_index(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2654,8 +2658,8 @@ FUNCTION get_compressed_index(self, num_index, compressed_index) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index -REAL(KIND=REAL64), ALLOCATABLE :: compressed_index(:) +INTEGER(KIND=INT64), INTENT(IN) :: num_index +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: compressed_index(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_ci @@ -2734,7 +2738,7 @@ FUNCTION get_field(self, field_number, field) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self INTEGER(KIND=INT64), INTENT(IN) :: field_number -TYPE(shum_field_type) :: field +TYPE(shum_field_type), INTENT(OUT) :: field TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (field_number > self%num_fields) THEN @@ -2781,7 +2785,7 @@ FUNCTION find_field_indices_in_file(self, found_field_indices, & INTEGER(KIND=INT64), OPTIONAL, INTENT(IN) :: max_returned_fields ! Returned list -INTEGER(KIND=INT64), ALLOCATABLE :: found_field_indices(:) +INTEGER(KIND=INT64), INTENT(IN OUT), ALLOCATABLE :: found_field_indices(:) ! Internal variables TYPE(shum_field_type) :: current_field @@ -2930,7 +2934,7 @@ FUNCTION find_fields_in_file(self, found_fields, max_returned_fields, & INTEGER(KIND=INT64), OPTIONAL, INTENT(IN) :: max_returned_fields ! Returned list -TYPE(shum_field_type), ALLOCATABLE :: found_fields(:) +TYPE(shum_field_type), INTENT(IN OUT), ALLOCATABLE :: found_fields(:) ! Local message string CHARACTER(LEN=256) :: cmessage @@ -3042,7 +3046,7 @@ FUNCTION find_forecast_time(self, found_fctime, stashcode) RESULT(STATUS) INTEGER(KIND=INT64), INTENT(IN) :: stashcode ! Returned list -REAL(KIND=REAL64), ALLOCATABLE :: found_fctime(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: found_fctime(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -3075,7 +3079,7 @@ END FUNCTION find_forecast_time FUNCTION set_filename(self, fname) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -CHARACTER(LEN=*) :: fname +CHARACTER(LEN=*), INTENT(IN) :: fname TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (ALLOCATED(self%filename)) DEALLOCATE(self%filename) @@ -3090,7 +3094,7 @@ END FUNCTION set_filename FUNCTION get_filename(self, fname) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -CHARACTER(LEN=*) :: fname +CHARACTER(LEN=*), INTENT(OUT) :: fname TYPE(shum_ff_status_type) :: STATUS ! Return status object ! return empty string if filename is not allocated @@ -3205,7 +3209,7 @@ FUNCTION add_field(self, new_field) RESULT(STATUS) ! in the file. IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -TYPE(shum_field_type) :: new_field +TYPE(shum_field_type), INTENT(IN) :: new_field ! Internal variables TYPE(shum_field_type), ALLOCATABLE :: tmp_fields(:) diff --git a/shum_fieldsfile_class/test/CMakeLists.txt b/shum_fieldsfile_class/test/CMakeLists.txt new file mode 100644 index 0000000..26189eb --- /dev/null +++ b/shum_fieldsfile_class/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_fieldsfile_class.f90) diff --git a/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 b/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 index 0756b06..70dd892 100644 --- a/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 +++ b/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_fieldsfile_class_mod -USE fruit +USE fruit, ONLY: assert_equals, get_failed_count, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL @@ -39,7 +39,7 @@ SUBROUTINE c_exit(status) BIND(c,NAME="exit") IMPORT :: C_INT IMPLICIT NONE INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: status -END SUBROUTINE +END SUBROUTINE c_exit END INTERFACE !------------------------------------------------------------------------------! @@ -89,11 +89,14 @@ SUBROUTINE fruit_test_shum_fieldsfile_class STATUS=get_env_status) ! If the variable exists call again to read it in -IF (get_env_status == 0) THEN +IF (get_env_status == 0 .AND. shum_tmpdir_len > 0) THEN ALLOCATE(CHARACTER(shum_tmpdir_len) :: shum_tmpdir) CALL GET_ENVIRONMENT_VARIABLE("SHUM_TMPDIR", & VALUE=shum_tmpdir, & STATUS=get_env_status) +ELSE + ! Force an error if variable has zero length + get_env_status = 1 END IF ! Now check the status (not an ELSE IF, because that way we can catch the ! failed status of either the first or second call diff --git a/shum_horizontal_field_interp/src/CMakeLists.txt b/shum_horizontal_field_interp/src/CMakeLists.txt new file mode 100644 index 0000000..a910f25 --- /dev/null +++ b/shum_horizontal_field_interp/src/CMakeLists.txt @@ -0,0 +1,8 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_horizontal_field_interp.f90) diff --git a/shum_horizontal_field_interp/test/CMakeLists.txt b/shum_horizontal_field_interp/test/CMakeLists.txt new file mode 100644 index 0000000..244b63a --- /dev/null +++ b/shum_horizontal_field_interp/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_horizontal_field_interp.f90) diff --git a/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 b/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 index 533ad70..0e3c9fd 100644 --- a/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 +++ b/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_horizontal_field_interp_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_BOOL USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT diff --git a/shum_kinds/src/CMakeLists.txt b/shum_kinds/src/CMakeLists.txt new file mode 100644 index 0000000..976ab5d --- /dev/null +++ b/shum_kinds/src/CMakeLists.txt @@ -0,0 +1,12 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_kinds.F90) + +set_source_files_properties( + f_shum_kinds.F90 + PROPERTIES Fortran_PREPROCESS ON) diff --git a/shum_kinds/test/CMakeLists.txt b/shum_kinds/test/CMakeLists.txt new file mode 100644 index 0000000..4c60f93 --- /dev/null +++ b/shum_kinds/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_kinds.f90) diff --git a/shum_kinds/test/fruit_test_shum_kinds.f90 b/shum_kinds/test/fruit_test_shum_kinds.f90 index af1bd2b..0790928 100644 --- a/shum_kinds/test/fruit_test_shum_kinds.f90 +++ b/shum_kinds/test/fruit_test_shum_kinds.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_kinds_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL diff --git a/shum_latlon_eq_grids/src/CMakeLists.txt b/shum_latlon_eq_grids/src/CMakeLists.txt new file mode 100644 index 0000000..56c4ba6 --- /dev/null +++ b/shum_latlon_eq_grids/src/CMakeLists.txt @@ -0,0 +1,8 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_latlon_eq_grids.f90) diff --git a/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 b/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 index a1022bb..e7c19c0 100644 --- a/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 +++ b/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 @@ -101,7 +101,7 @@ FUNCTION f_shum_lltoeq_arg64 & REAL(KIND=real64), INTENT(OUT) :: phi_eq(SIZE(phi)) ! Lat (eq) REAL(KIND=real64), INTENT(OUT) :: lambda_eq(SIZE(phi)) ! Long (eq) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status REAL(KIND=real64) :: a_lambda @@ -225,7 +225,7 @@ FUNCTION f_shum_lltoeq_arg64_single & REAL(KIND=real64) :: phi_eq_arr(1) REAL(KIND=real64) :: lambda_eq_arr(1) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status phi_arr(1) = phi @@ -255,7 +255,7 @@ FUNCTION f_shum_lltoeq_arg32 & REAL(KIND=real32), INTENT(OUT) :: phi_eq(SIZE(phi)) ! Lat (eq) REAL(KIND=real32), INTENT(OUT) :: lambda_eq(SIZE(phi)) ! Long (eq) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -315,7 +315,7 @@ FUNCTION f_shum_lltoeq_arg32_single & REAL(KIND=real64) :: phi_pole64 REAL(KIND=real64) :: lambda_pole64 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -354,7 +354,7 @@ FUNCTION f_shum_eqtoll_arg64 & REAL(KIND=real64), INTENT(OUT) :: phi(SIZE(phi_eq)) ! Lat (lat-lon) REAL(KIND=real64), INTENT(OUT) :: lambda(SIZE(phi_eq)) ! Long (lat-lon) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status REAL(KIND=real64) :: a_lambda @@ -478,7 +478,7 @@ FUNCTION f_shum_eqtoll_arg64_single & REAL(KIND=real64) :: phi_arr(1) REAL(KIND=real64) :: lambda_arr(1) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status phi_eq_arr(1) = phi_eq @@ -508,7 +508,7 @@ FUNCTION f_shum_eqtoll_arg32 & REAL(KIND=real32), INTENT(OUT) :: phi(SIZE(phi_eq)) ! Lat (lat-lon) REAL(KIND=real32), INTENT(OUT) :: lambda(SIZE(phi_eq)) ! Long (lat-lon) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -568,7 +568,7 @@ FUNCTION f_shum_eqtoll_arg32_single & REAL(KIND=real64) :: phi_pole64 REAL(KIND=real64) :: lambda_pole64 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -606,7 +606,7 @@ FUNCTION f_shum_w_coeff_arg64 & REAL(KIND=real64), INTENT(OUT) :: coeff1(SIZE(lambda)) ! Rotation coeff 1 REAL(KIND=real64), INTENT(OUT) :: coeff2(SIZE(lambda)) ! Rotation coeff 2 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status REAL(KIND=real64) :: a_lambda @@ -723,7 +723,7 @@ FUNCTION f_shum_w_coeff_arg32 & REAL(KIND=real32), INTENT(OUT) :: coeff1(SIZE(lambda)) ! Rotation coeff 1 REAL(KIND=real32), INTENT(OUT) :: coeff2(SIZE(lambda)) ! Rotation coeff 2 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -777,7 +777,7 @@ FUNCTION f_shum_w_eqtoll_arg64 & REAL(KIND=real64), INTENT(OUT) :: v(SIZE(coeff1)) ! Wind U compt (lat-lon) REAL(KIND=real64), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status LOGICAL :: l_mdi ! Was an mdi value provided? @@ -830,7 +830,7 @@ FUNCTION f_shum_w_eqtoll_arg32 & REAL(KIND=real32), INTENT(OUT) :: v(SIZE(coeff1)) ! Wind U compt (lat-lon) REAL(KIND=real32), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status REAL(KIND=real64) :: coeff1_64(SIZE(coeff1)) @@ -892,7 +892,7 @@ FUNCTION f_shum_w_lltoeq_arg64 & REAL(KIND=real64), INTENT(OUT) :: v_eq(SIZE(coeff1)) ! Wind U compt (eq) REAL(KIND=real64), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status LOGICAL :: l_mdi ! Was an mdi value provided? @@ -945,7 +945,7 @@ FUNCTION f_shum_w_lltoeq_arg32 & REAL(KIND=real32), INTENT(OUT) :: v_eq(SIZE(coeff1)) ! Wind U compt (eq) REAL(KIND=real32), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status diff --git a/shum_latlon_eq_grids/test/CMakeLists.txt b/shum_latlon_eq_grids/test/CMakeLists.txt new file mode 100644 index 0000000..d74da9e --- /dev/null +++ b/shum_latlon_eq_grids/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_latlon_eq_grids.f90) diff --git a/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 b/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 index 97b214f..b9f88b2 100644 --- a/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 +++ b/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_latlon_eq_grids_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE IMPLICIT NONE diff --git a/shum_number_tools/src/CMakeLists.txt b/shum_number_tools/src/CMakeLists.txt new file mode 100644 index 0000000..eb99cde --- /dev/null +++ b/shum_number_tools/src/CMakeLists.txt @@ -0,0 +1,16 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_is_inf.F90 + f_shum_is_nan.F90 + f_shum_is_denormal.F90) + +set_source_files_properties( + f_shum_is_inf.F90 + f_shum_is_nan.F90 + f_shum_is_denormal.F90 + PROPERTIES Fortran_PREPROCESS ON) diff --git a/shum_number_tools/src/f_shum_is_denormal.F90 b/shum_number_tools/src/f_shum_is_denormal.F90 index 66a5282..9123c78 100644 --- a/shum_number_tools/src/f_shum_is_denormal.F90 +++ b/shum_number_tools/src/f_shum_is_denormal.F90 @@ -209,15 +209,15 @@ LOGICAL FUNCTION f_shum_has_denormal32(x) ! Loop over elements of x and determine if any are infinite ! Exit immediately if any are found -DO ix=1,SIZE(x) +HAS_INF: DO ix=1,SIZE(x) f_shum_has_denormal32 = f_shum_is_denormal32(x(ix)) - IF (f_shum_has_denormal32) EXIT -END DO + IF (f_shum_has_denormal32) EXIT HAS_INF +END DO HAS_INF END FUNCTION f_shum_has_denormal32 ! To use for multi-dimensional arrays you can call f_shum_has_denormal with the -! array reshaped, e.g. f_shum_has_denormal(RESHAPE(x, (/SIZE(x)/))) +! array reshaped, e.g. f_shum_has_denormal(RESHAPE(x, [SIZE(x)])) !*************************************************************************** ! 2D Array 64-bit version @@ -232,7 +232,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_2d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_2d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_2d @@ -249,7 +249,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_2d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_2d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_2d @@ -266,7 +266,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_3d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_3d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_3d @@ -283,7 +283,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_3d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_3d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_3d @@ -300,7 +300,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_4d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_4d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_4d @@ -317,7 +317,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_4d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_4d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_4d @@ -334,7 +334,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_5d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_5d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_5d @@ -351,7 +351,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_5d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_5d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_5d diff --git a/shum_number_tools/src/f_shum_is_inf.F90 b/shum_number_tools/src/f_shum_is_inf.F90 index 8f6c787..b9fa03a 100644 --- a/shum_number_tools/src/f_shum_is_inf.F90 +++ b/shum_number_tools/src/f_shum_is_inf.F90 @@ -180,15 +180,15 @@ LOGICAL FUNCTION f_shum_has_inf32(x) ! Loop over elements of x and determine if any are infinite ! Exit immediately if any are found -DO ix=1,SIZE(x) +HAS_INF: DO ix=1,SIZE(x) f_shum_has_inf32 = f_shum_is_inf32(x(ix)) - IF (f_shum_has_inf32) EXIT -END DO + IF (f_shum_has_inf32) EXIT HAS_INF +END DO HAS_INF END FUNCTION f_shum_has_inf32 ! To use for multi-dimensional arrays you can call f_shum_has_inf with the array -! reshaped, e.g. f_shum_has_inf(RESHAPE(x, (/SIZE(x)/))) +! reshaped, e.g. f_shum_has_inf(RESHAPE(x, [SIZE(x)])) !*************************************************************************** ! 2D Array 64-bit version @@ -203,7 +203,7 @@ LOGICAL FUNCTION f_shum_has_inf64_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_2d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_2d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_2d @@ -220,7 +220,7 @@ LOGICAL FUNCTION f_shum_has_inf32_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_2d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_2d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_2d @@ -237,7 +237,7 @@ LOGICAL FUNCTION f_shum_has_inf64_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_3d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_3d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_3d @@ -254,7 +254,7 @@ LOGICAL FUNCTION f_shum_has_inf32_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_3d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_3d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_3d @@ -271,7 +271,7 @@ LOGICAL FUNCTION f_shum_has_inf64_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_4d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_4d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_4d @@ -288,7 +288,7 @@ LOGICAL FUNCTION f_shum_has_inf32_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_4d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_4d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_4d @@ -305,7 +305,7 @@ LOGICAL FUNCTION f_shum_has_inf64_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_5d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_5d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_5d @@ -322,7 +322,7 @@ LOGICAL FUNCTION f_shum_has_inf32_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_5d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_5d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_5d diff --git a/shum_number_tools/src/f_shum_is_nan.F90 b/shum_number_tools/src/f_shum_is_nan.F90 index 21d98f7..2fcf7d4 100644 --- a/shum_number_tools/src/f_shum_is_nan.F90 +++ b/shum_number_tools/src/f_shum_is_nan.F90 @@ -220,15 +220,15 @@ LOGICAL FUNCTION f_shum_has_nan32(x) ! Loop over elements of x and determine if any are NaNs ! Exit immediately if any are found -DO ix=1,SIZE(x) +HAS_NAN: DO ix=1,SIZE(x) f_shum_has_nan32 = f_shum_is_nan32(x(ix)) - IF (f_shum_has_nan32) EXIT -END DO + IF (f_shum_has_nan32) EXIT HAS_NAN +END DO HAS_NAN END FUNCTION f_shum_has_nan32 ! To use for multi-dimensional arrays you can call f_shum_has_nan with the array -! reshaped, e.g. f_shum_has_nan(RESHAPE(x, (/SIZE(x)/))) +! reshaped, e.g. f_shum_has_nan(RESHAPE(x, [SIZE(x)])) !*************************************************************************** ! 2D Array 64-bit version @@ -243,7 +243,7 @@ LOGICAL FUNCTION f_shum_has_nan64_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_2d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_2d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_2d @@ -260,7 +260,7 @@ LOGICAL FUNCTION f_shum_has_nan32_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_2d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_2d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_2d @@ -277,7 +277,7 @@ LOGICAL FUNCTION f_shum_has_nan64_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_3d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_3d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_3d @@ -294,7 +294,7 @@ LOGICAL FUNCTION f_shum_has_nan32_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_3d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_3d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_3d @@ -311,7 +311,7 @@ LOGICAL FUNCTION f_shum_has_nan64_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_4d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_4d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_4d @@ -328,7 +328,7 @@ LOGICAL FUNCTION f_shum_has_nan32_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_4d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_4d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_4d @@ -345,7 +345,7 @@ LOGICAL FUNCTION f_shum_has_nan64_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_5d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_5d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_5d @@ -362,7 +362,7 @@ LOGICAL FUNCTION f_shum_has_nan32_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_5d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_5d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_5d diff --git a/shum_number_tools/test/CMakeLists.txt b/shum_number_tools/test/CMakeLists.txt new file mode 100644 index 0000000..01b0047 --- /dev/null +++ b/shum_number_tools/test/CMakeLists.txt @@ -0,0 +1,16 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE + c_fruit_test_shum_number_tools.c + fruit_test_shum_number_tools.F90) + +set_source_files_properties( + fruit_test_shum_number_tools.F90 + PROPERTIES Fortran_PREPROCESS ON) + +target_include_directories(shumlib-tests + PUBLIC + ${CMAKE_CURRENT_SOURCE_DIR}) diff --git a/shum_number_tools/test/fruit_test_shum_number_tools.F90 b/shum_number_tools/test/fruit_test_shum_number_tools.F90 index eb0b0bb..82b467c 100644 --- a/shum_number_tools/test/fruit_test_shum_number_tools.F90 +++ b/shum_number_tools/test/fruit_test_shum_number_tools.F90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_number_tools_mod -USE fruit +USE fruit, ONLY: assert_false, assert_not_equals, assert_true, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL @@ -40,7 +40,7 @@ FUNCTION c_test_generate_finf() BIND(c,NAME="c_test_generate_finf") IMPORT :: C_FLOAT IMPLICIT NONE REAL(KIND=C_FLOAT) :: c_test_generate_finf - END FUNCTION + end function c_test_generate_finf END INTERFACE !------------------------------------------------------------------------------! @@ -50,7 +50,7 @@ FUNCTION c_test_generate_dinf() BIND(c,NAME="c_test_generate_dinf") IMPORT :: C_DOUBLE IMPLICIT NONE REAL(KIND=C_DOUBLE) :: c_test_generate_dinf - END FUNCTION + end function c_test_generate_dinf END INTERFACE !------------------------------------------------------------------------------! @@ -60,7 +60,7 @@ FUNCTION c_test_generate_fnan() BIND(c,NAME="c_test_generate_fnan") IMPORT :: C_FLOAT IMPLICIT NONE REAL(KIND=C_FLOAT) :: c_test_generate_fnan - END FUNCTION + end function c_test_generate_fnan END INTERFACE !------------------------------------------------------------------------------! @@ -70,7 +70,7 @@ FUNCTION c_test_generate_dnan() BIND(c,NAME="c_test_generate_dnan") IMPORT :: C_DOUBLE IMPLICIT NONE REAL(KIND=C_DOUBLE) :: c_test_generate_dnan - END FUNCTION + end function c_test_generate_dnan END INTERFACE !------------------------------------------------------------------------------! @@ -80,8 +80,8 @@ SUBROUTINE c_test_generate_fdenormal(denormal_float) & BIND(c,NAME="c_test_generate_fdenormal") IMPORT :: C_FLOAT IMPLICIT NONE - REAL(KIND=C_FLOAT) :: denormal_float - END SUBROUTINE + REAL(KIND=C_FLOAT), INTENT(OUT) :: denormal_float + end subroutine c_test_generate_fdenormal END INTERFACE !------------------------------------------------------------------------------! @@ -91,8 +91,8 @@ SUBROUTINE c_test_generate_ddenormal(denormal_double) & BIND(c,NAME="c_test_generate_ddenormal") IMPORT :: C_DOUBLE IMPLICIT NONE - REAL(KIND=C_DOUBLE) :: denormal_double - END SUBROUTINE + REAL(KIND=C_DOUBLE), INTENT(OUT) :: denormal_double + end subroutine c_test_generate_ddenormal END INTERFACE !------------------------------------------------------------------------------! diff --git a/shum_spiral_search/src/CMakeLists.txt b/shum_spiral_search/src/CMakeLists.txt new file mode 100644 index 0000000..e6b01c2 --- /dev/null +++ b/shum_spiral_search/src/CMakeLists.txt @@ -0,0 +1,16 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_spiral_search.f90 + c_shum_spiral_search.f90) + +target_sources(shum + PUBLIC + FILE_SET spiral_search_headers + TYPE HEADERS + FILES + c_shum_spiral_search.h) diff --git a/shum_spiral_search/test/CMakeLists.txt b/shum_spiral_search/test/CMakeLists.txt new file mode 100644 index 0000000..84aa571 --- /dev/null +++ b/shum_spiral_search/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_spiral_search.f90) diff --git a/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 b/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 index 0333c94..5fb7142 100644 --- a/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 +++ b/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_spiral_search_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_BOOL @@ -130,7 +130,7 @@ SUBROUTINE sample_6x6_data_32 & LOGICAL(KIND=bool), INTENT(OUT) :: lsm(36) LOGICAL(KIND=bool), INTENT(OUT) :: unres_mask(36) INTEGER(KIND=int32), INTENT(OUT) :: index_unres(5) -REAL(KIND=real32) :: planet_radius +REAL(KIND=real32), INTENT(OUT) :: planet_radius REAL(KIND=real64) :: latitude_64(6) REAL(KIND=real64) :: longitude_64(6) @@ -173,13 +173,13 @@ SUBROUTINE test_spiral6_search_arg64 INTEGER(KIND=int64) :: index_unres(no_point_unres) INTEGER(KIND=int64) :: indices(no_point_unres) -LOGICAL(KIND=bool) :: is_land_field = .TRUE. -LOGICAL(KIND=bool) :: constrained = .FALSE. -LOGICAL(KIND=bool) :: cyclic_domain = .FALSE. +LOGICAL(KIND=bool) :: is_land_field +LOGICAL(KIND=bool) :: constrained +LOGICAL(KIND=bool) :: cyclic_domain -REAL(KIND=real64) :: constrained_max_dist = 200000.0 +REAL(KIND=real64), PARAMETER :: constrained_max_dist = 200000.0 REAL(KIND=real64) :: planet_radius -REAL(KIND=real64) :: dist_step = 3.0 +REAL(KIND=real64), PARAMETER :: dist_step = 3.0 INTEGER(KIND=int64) :: result_land(no_point_unres) INTEGER(KIND=int64) :: result_land_con(no_point_unres) @@ -190,6 +190,10 @@ SUBROUTINE test_spiral6_search_arg64 CHARACTER(LEN=400) :: message CHARACTER(LEN=200) :: case_info +is_land_field = .TRUE. +constrained = .FALSE. +cyclic_domain = .FALSE. + ! Retrieve the set of data points to be tested CALL sample_6x6_data(lats, lons, lsm, unres_mask, index_unres, planet_radius ) @@ -281,13 +285,13 @@ SUBROUTINE test_spiral6_search_arg32 INTEGER(KIND=int32) :: index_unres(no_point_unres) INTEGER(KIND=int32) :: indices(no_point_unres) -LOGICAL(KIND=bool) :: is_land_field = .TRUE. -LOGICAL(KIND=bool) :: constrained = .FALSE. -LOGICAL(KIND=bool) :: cyclic_domain = .FALSE. +LOGICAL(KIND=bool) :: is_land_field +LOGICAL(KIND=bool) :: constrained +LOGICAL(KIND=bool) :: cyclic_domain REAL(KIND=real32) :: planet_radius -REAL(KIND=real32) :: constrained_max_dist = 200000.0 -REAL(KIND=real32) :: dist_step = 3.0 +REAL(KIND=real32), PARAMETER :: constrained_max_dist = 200000.0 +REAL(KIND=real32), PARAMETER :: dist_step = 3.0 INTEGER(KIND=int32) :: result_land(no_point_unres) INTEGER(KIND=int32) :: result_land_con(no_point_unres) @@ -298,6 +302,10 @@ SUBROUTINE test_spiral6_search_arg32 CHARACTER(LEN=400) :: message CHARACTER(LEN=200) :: case_info +is_land_field = .TRUE. +constrained = .FALSE. +cyclic_domain = .FALSE. + ! Retrieve the set of data points to be tested - should find 32bit version CALL sample_6x6_data(lats, lons, lsm, unres_mask, index_unres, & planet_radius ) diff --git a/shum_string_conv/src/CMakeLists.txt b/shum_string_conv/src/CMakeLists.txt new file mode 100644 index 0000000..1253803 --- /dev/null +++ b/shum_string_conv/src/CMakeLists.txt @@ -0,0 +1,8 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_string_conv.f90) diff --git a/shum_string_conv/src/f_shum_string_conv.f90 b/shum_string_conv/src/f_shum_string_conv.f90 index f6b56f7..85b1710 100644 --- a/shum_string_conv/src/f_shum_string_conv.f90 +++ b/shum_string_conv/src/f_shum_string_conv.f90 @@ -77,7 +77,7 @@ FUNCTION c_strlen_integer_cstr(cstr) IMPLICIT NONE -CHARACTER(KIND=C_CHAR,LEN=1), TARGET :: cstr(*) +CHARACTER(KIND=C_CHAR,LEN=1), INTENT(IN), TARGET :: cstr(*) INTEGER(KIND=C_INT64_T) :: c_strlen_integer_cstr c_strlen_integer_cstr = INT(c_std_strlen(cstr), KIND=C_INT64_T) @@ -95,7 +95,8 @@ FUNCTION c2f_string_cstr(cstr, cstr_len) IMPLICIT NONE -INTEGER(KIND=C_INT64_T) :: cstr_len, i +INTEGER(KIND=C_INT64_T), INTENT(IN) :: cstr_len +INTEGER(KIND=C_INT64_T) :: i CHARACTER(KIND=C_CHAR,LEN=1), INTENT(IN) :: cstr(cstr_len) CHARACTER(LEN=cstr_len) :: c2f_string_cstr @@ -114,7 +115,8 @@ FUNCTION c2f_string_cptr(cptr, cstr_len) IMPLICIT NONE -INTEGER(KIND=C_INT64_T) :: cstr_len, i +INTEGER(KIND=C_INT64_T), INTENT(IN) :: cstr_len +INTEGER(KIND=C_INT64_T) :: i TYPE(C_PTR), INTENT(IN) :: cptr CHARACTER(KIND=C_CHAR, LEN=1), POINTER :: fptr(:) CHARACTER(LEN=cstr_len) :: c2f_string_cptr diff --git a/shum_string_conv/test/CMakeLists.txt b/shum_string_conv/test/CMakeLists.txt new file mode 100644 index 0000000..07e2419 --- /dev/null +++ b/shum_string_conv/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_string_conv.f90) diff --git a/shum_string_conv/test/fruit_test_shum_string_conv.f90 b/shum_string_conv/test/fruit_test_shum_string_conv.f90 index fe0ef5a..efe9ebf 100644 --- a/shum_string_conv/test/fruit_test_shum_string_conv.f90 +++ b/shum_string_conv/test/fruit_test_shum_string_conv.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_string_conv_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case, set_case_name USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_CHAR, C_NULL_CHAR, C_PTR, C_LOC diff --git a/shum_thread_utils/src/CMakeLists.txt b/shum_thread_utils/src/CMakeLists.txt new file mode 100644 index 0000000..a68418b --- /dev/null +++ b/shum_thread_utils/src/CMakeLists.txt @@ -0,0 +1,15 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + f_shum_thread_utils.f90) + +target_sources(shum + PUBLIC + FILE_SET thread_utils_headers + TYPE HEADERS + FILES + c_shum_thread_utils.h) diff --git a/shum_thread_utils/test/CMakeLists.txt b/shum_thread_utils/test/CMakeLists.txt new file mode 100644 index 0000000..3b966ef --- /dev/null +++ b/shum_thread_utils/test/CMakeLists.txt @@ -0,0 +1,12 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE + fruit_test_shum_thread_utils.f90 + c_fruit_test_shum_thread_utils.c) + +target_include_directories(shumlib-tests + PUBLIC + ${CMAKE_CURRENT_SOURCE_DIR}) diff --git a/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 b/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 index 6b08d02..8b1b966 100644 --- a/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 +++ b/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_thread_utils_mod -USE fruit +USE fruit, ONLY: assert_true, run_test_case, set_case_name USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT64_T, C_INT32_T, C_FLOAT, & C_DOUBLE, C_BOOL !$ USE omp_lib @@ -135,7 +135,7 @@ SUBROUTINE c_test_inpar(test_ret,par) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: par + INTEGER(KIND=C_INT64_T), INTENT(OUT) :: par END SUBROUTINE c_test_inpar @@ -149,7 +149,7 @@ SUBROUTINE c_test_threadid(test_ret,tid) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: tid + INTEGER(KIND=C_INT64_T), INTENT(OUT) :: tid END SUBROUTINE c_test_threadid @@ -163,7 +163,7 @@ SUBROUTINE c_test_numthreads(test_ret,numthreads) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: numthreads + INTEGER(KIND=C_INT64_T), INTENT(OUT) :: numthreads END SUBROUTINE c_test_numthreads @@ -177,7 +177,7 @@ SUBROUTINE c_test_threadflush(test_ret,shared1) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: shared1 + INTEGER(KIND=C_INT64_T), INTENT(IN) :: shared1 END SUBROUTINE c_test_threadflush diff --git a/shum_wgdos_packing/src/CMakeLists.txt b/shum_wgdos_packing/src/CMakeLists.txt new file mode 100644 index 0000000..b8f6743 --- /dev/null +++ b/shum_wgdos_packing/src/CMakeLists.txt @@ -0,0 +1,16 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shum + PRIVATE + c_shum_wgdos_packing.f90 + f_shum_wgdos_packing.f90) + +target_sources(shum + PUBLIC + FILE_SET wgdos_packing_headers + TYPE HEADERS + FILES + c_shum_wgdos_packing.h) diff --git a/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 b/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 index c0756d1..e50fc75 100644 --- a/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 +++ b/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 @@ -147,7 +147,7 @@ FUNCTION f_shum_read_wgdos_header_arg64( & cols = INT(cols_32, KIND=int64) rows = INT(rows_32, KIND=int64) -END FUNCTION +END FUNCTION f_shum_read_wgdos_header_arg64 !------------------------------------------------------------------------------! diff --git a/shum_wgdos_packing/test/CMakeLists.txt b/shum_wgdos_packing/test/CMakeLists.txt new file mode 100644 index 0000000..d71c79a --- /dev/null +++ b/shum_wgdos_packing/test/CMakeLists.txt @@ -0,0 +1,6 @@ +# ------------------------------------------------------------------------------ +# (c) Crown copyright Met Office. All rights reserved. +# The file LICENCE, distributed with this code, contains details of the terms +# under which the code may be used. +# ------------------------------------------------------------------------------ +target_sources(shumlib-tests PRIVATE fruit_test_shum_wgdos_packing.f90) diff --git a/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 b/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 index 6900b53..b7a5e23 100644 --- a/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 +++ b/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_wgdos_packing_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_LOC, C_F_POINTER @@ -197,9 +197,9 @@ END SUBROUTINE sample_unpacked_data_1d SUBROUTINE sample_packed_data(sample) IMPLICIT NONE -INTEGER(KIND=int32) :: sample(21) -INTEGER(KIND=int32), POINTER :: sample_pointer(:) -INTEGER(KIND=int64), TARGET :: sample64(11) +INTEGER(KIND=int32), INTENT(OUT) :: sample(21) +INTEGER(KIND=int32), POINTER :: sample_pointer(:) +INTEGER(KIND=int64), TARGET :: sample64(11) ! Define the data as a 64-bit array. The reason for this is that although the ! packing algorithm represents the data as 32-bit, the actual array is just a