diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md new file mode 100644 index 0000000..d8e2960 --- /dev/null +++ b/.github/pull_request_template.md @@ -0,0 +1,83 @@ +# PR Summary + +Code Reviewer: + + + + + + + + + +## Code Quality Checklist + +(_Some checks are automatically carried out via the CI pipeline_) + +- [ ] I have performed a self-review of my own code +- [ ] My code follows the project's style guidelines +- [ ] Comments have been included that aid undertanding and enhance the + readability of the code +- [ ] My changes generate no new warnings + +## Testing + +- [ ] I have tested this change locally, using the rose-stem suite +- [ ] If any tests fail (rose-stem or CI) the reason is understood and + acceptable (eg. kgo changes) +- [ ] I have added tests to cover new functionality as appropriate (eg. system + tests, unit tests, etc.) + + + +### trac.log + + + +## Security Considerations + +- [ ] This change does not introduce security vulnerabilities +- [ ] I have reviewed the code for potential security issues +- [ ] Sensitive data is properly handled (if applicable) +- [ ] Authentication and authorisation are properly implemented (if applicable) + +## Performance Impact + +- [ ] Performance of the code has been considered and, if applicable, suitable + performance measurements have been conducted + +## AI Assistance and Attribution + +- [ ] Some of the content of this change has been produced with the assistance + of _Generative AI tool name_ (e.g., Met Office Github Copilot Enterprise, + Github Copilot Personal, ChatGPT GPT-4, etc) and I have followed the + [Simulation Systems AI policy](https://metoffice.github.io/simulation-systems/FurtherDetails/ai.html)(including attribution labels) + + + +## Documentation + +- [ ] Where appropriate I have updated documentation related to this change and + confirmed that it builds correctly + +# Code Review + + + +- [ ] All dependencies have been resolved +- [ ] Related Issues have been properly linked and addressed +- [ ] CLA compliance has been confirmed +- [ ] Code quality standards have been met +- [ ] Tests are adequate and have passed +- [ ] Documentation is complete and accurate +- [ ] Security considerations have been addressed +- [ ] Performance impact is acceptable diff --git a/.github/workflows/check-cr-approved.yaml b/.github/workflows/check-cr-approved.yaml new file mode 100644 index 0000000..9b66712 --- /dev/null +++ b/.github/workflows/check-cr-approved.yaml @@ -0,0 +1,11 @@ +name: Check CR approved + +on: + pull_request_review: + types: [submitted, edited, dismissed] + workflow_dispatch: + +jobs: + check_cr_approved: + if: ${{ github.event.pull_request.number }} + uses: MetOffice/growss/.github/workflows/check-cr-approved.yaml@main diff --git a/.github/workflows/checks.yaml b/.github/workflows/checks.yaml new file mode 100644 index 0000000..cebc29e --- /dev/null +++ b/.github/workflows/checks.yaml @@ -0,0 +1,66 @@ +--- +name: Quality + +on: # yamllint disable-line rule:truthy + push: + branches: + - main + - 'releases/**' + pull_request: + types: [opened, synchronize, reopened] + workflow_dispatch: + +concurrency: + group: ${{ github.ref }} + cancel-in-progress: ${{ github.ref != 'refs/heads/main' }} + +permissions: read-all + +jobs: + + check-shumlib: + runs-on: ubuntu-latest + timeout-minutes: 5 + + steps: + - name: Checkout repository + uses: actions/checkout@v4 + - name: Setup uv + uses: astral-sh/setup-uv@v6 + - name: Install dependencies + run: uv sync + - name: Fortran + # See: fortitude.toml + run: | + uv run fortitude check --respect-gitignore --show-fixes --statistics . + - name: C + # See: CPPLINT.cfg + if: always() + run: | + uv run cpplint --recursive --extensions=c,h \ + --exclude=.git --exclude=.venv . + + # - name: Detect changes in doc + # id: doc_changes + # run: | + # if git diff --name-only ${{ github.sha }} ${{ github.event.before }} | grep '^doc/'; then + # echo "doc_changed=true" >> $GITHUB_OUTPUT + # else + # echo "doc_changed=false" >> $GITHUB_OUTPUT + # fi + - name: RestructuredText + # if: steps.doc_changes.outputs.doc_changed == 'true' + working-directory: ./doc + run: uv run sphinx-lint . + - name: Link Checks + # if: steps.doc_changes.outputs.doc_changed == 'true' + working-directory: ./doc + run: | + uv run sphinx-build -q -b linkcheck \ + -d _build/doctrees . _build/linkcheck || true + echo "== Ignored and Redirected links, if any ==" + jq -c 'select([.status] | inside(["ignored", "redirected"]))' \ + _build/linkcheck/output.json + + - name: Minimize uv cache + run: uv cache prune --ci diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml new file mode 100644 index 0000000..b48a629 --- /dev/null +++ b/.github/workflows/ci.yaml @@ -0,0 +1,24 @@ +--- +name: CI +on: # yamllint disable-line rule:truthy + push: + branches: + - main + - 'releases/**' + pull_request: + types: [opened, synchronize, reopened] + workflow_dispatch: + +permissions: read-all + +jobs: + build-shumlib: + runs-on: ubuntu-latest + timeout-minutes: 5 + + steps: + - name: Checkout repository + uses: actions/checkout@v6 + - name: Build and Test + run: | + make -f ./make/vm-x86-gfortran-gcc.mk check diff --git a/.github/workflows/cla-check.yaml b/.github/workflows/cla-check.yaml new file mode 100644 index 0000000..3d28d73 --- /dev/null +++ b/.github/workflows/cla-check.yaml @@ -0,0 +1,10 @@ +name: Legal + +on: + pull_request_target: + +jobs: + cla: + uses: MetOffice/growss/.github/workflows/cla-check.yaml@main + with: + runner: 'ubuntu-24.04' diff --git a/.github/workflows/docs.yaml b/.github/workflows/docs.yaml new file mode 100644 index 0000000..302c347 --- /dev/null +++ b/.github/workflows/docs.yaml @@ -0,0 +1,68 @@ +--- +name: Docs + +on: # yamllint disable-line rule:truthy + push: + branches: + - main + - 'releases/**' + pull_request: + types: [opened, synchronize, reopened] + paths: + - 'doc/**' + - '.github/workflows/docs.yaml' + workflow_dispatch: + +permissions: read-all + +jobs: + + build-docs: + runs-on: ubuntu-latest + timeout-minutes: 3 + + steps: + - name: Checkout repository + uses: actions/checkout@v4 + - name: Setup uv + uses: astral-sh/setup-uv@v6 + - name: Install dependencies + run: uv sync + - name: Build docs + run: uv run make clean html + working-directory: ./doc + - id: permissions + name: Set permissions + run: | + chmod -c -R +rX "./doc/_build/html/" + - name: Upload artifacts + uses: actions/upload-pages-artifact@v4 + with: + name: github-pages + path: ./doc/_build/html + - name: Minimize uv cache + run: uv cache prune --ci + + # Deploy job + deploy: + if: github.ref == 'refs/heads/main' && github.event_name != 'pull_request' + # Add a dependency to the build job + needs: build-docs + + # Grant GITHUB_TOKEN the permissions required to make a Pages deployment + permissions: + pages: write # to deploy to Pages + id-token: write # to verify the deployment originates from an appropriate source + + # Deploy to the github-pages environment + environment: + name: github-pages + url: ${{ steps.deployment.outputs.page_url }} + + # Specify runner + deployment step + runs-on: ubuntu-latest + steps: + - name: Deploy to GitHub Pages + id: deployment + uses: actions/deploy-pages@v4 # or specific "vX.X.X" version tag for this action + diff --git a/.github/workflows/track-review-project.yaml b/.github/workflows/track-review-project.yaml new file mode 100644 index 0000000..639477c --- /dev/null +++ b/.github/workflows/track-review-project.yaml @@ -0,0 +1,17 @@ +name: Track Review Project + +on: + workflow_run: + workflows: [Trigger Review Project] + types: + - completed + +permissions: + actions: read + contents: read + pull-requests: write + +jobs: + track_review_project: + uses: MetOffice/growss/.github/workflows/track-review-project.yaml@main + secrets: inherit diff --git a/.github/workflows/trigger-project-workflow.yaml b/.github/workflows/trigger-project-workflow.yaml new file mode 100644 index 0000000..ccb7a55 --- /dev/null +++ b/.github/workflows/trigger-project-workflow.yaml @@ -0,0 +1,17 @@ +name: Trigger Review Project + +on: + pull_request_target: + types: ["opened", "synchronize", "reopened", "edited", "review_requested", "review_request_removed", "closed"] + pull_request_review: + pull_request_review_comment: + +permissions: + actions: read + contents: read + pull-requests: write + +jobs: + trigger_project_workflow: + uses: MetOffice/growss/.github/workflows/trigger-project-workflow.yaml@main + secrets: inherit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..815c880 --- /dev/null +++ b/.gitignore @@ -0,0 +1,54 @@ +# Copied from github c++ template + +# Default build directory +_build/ +build/ + +# Virtual environment +.venv/ +uv.lock + +# From old svn repository +*_version_mod.f90 + +# Prerequisites +*.d + +# Compiled Object files +*.slo +*.lo +*.o +*.obj + +# Precompiled Headers +*.gch +*.pch + +# Linker files +*.ilk + +# Debugger Files +*.pdb + +# Compiled Dynamic libraries +*.so +*.dylib +*.dll + +# Fortran module files +*.mod +*.smod + +# Compiled Static libraries +*.lai +*.la +*.a +*.lib + +# Executables +*.exe +*.out +*.app + +# debug information files +*.dwo diff --git a/.python-version b/.python-version new file mode 100644 index 0000000..7eebfaf --- /dev/null +++ b/.python-version @@ -0,0 +1 @@ +3.12.11 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 new file mode 100644 index 0000000..b47eb66 --- /dev/null +++ b/CONTRIBUTORS.md @@ -0,0 +1,7 @@ +# Contributors + +| 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/CPPLINT.cfg b/CPPLINT.cfg new file mode 100644 index 0000000..dc23e57 --- /dev/null +++ b/CPPLINT.cfg @@ -0,0 +1,6 @@ +set noparent +linelength=120 +filter=-whitespace +filter=-build/include_subdir,-build/include,-build/header_guard +filter=-readability/braces,-readability/multiline_comment + diff --git a/LICENCE b/LICENCE new file mode 100644 index 0000000..5f36cd7 --- /dev/null +++ b/LICENCE @@ -0,0 +1,28 @@ +BSD 3-Clause Licence + +Crown Copyright (c) Met Office + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile index c9674b6..3433e91 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ # Main makefile storing common options for building all libraries, by triggering # individual makefiles from each library directory -#-------------------------------------------------------------------------------- +#------------------------------------------------------------------------------- # The intention is that the user points "make" at one of the platform specific # files, which include this file at the end; here we try to ensure that this @@ -197,11 +197,15 @@ else NUMTOOLS_PREREQ= endif +# Kinds +#--------------- +KINDS=shum_kinds +KINDS_PREREQ= # All libs vars #-------------- ALL_LIBS_VARS=CONSTS BSWAP STR_CONV DATA_CONV PACK THREAD_UTILS LLEQ \ - FFILE HORIZ_INTERP SPIRAL FFCLASS NUMTOOLS + FFILE HORIZ_INTERP SPIRAL FFCLASS NUMTOOLS KINDS ALL_LIBS=$(foreach lib,${ALL_LIBS_VARS},${${lib}}) # Forward targets (targets with "VAR" names) diff --git a/README.md b/README.md new file mode 100644 index 0000000..3ad0632 --- /dev/null +++ b/README.md @@ -0,0 +1,47 @@ +# Shumlib + +[![CI](https://github.com/MetOffice/shumlib/actions/workflows/ci.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/ci.yaml) +[![Docs](https://github.com/MetOffice/shumlib/actions/workflows/docs.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/docs.yaml) +[![Quality](https://github.com/MetOffice/shumlib/actions/workflows/checks.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/checks.yaml) + +Shumlib is the collective name for a set of libraries which are used by the UM; +the UK Met Office's Unified Model, that may be of use to external tools or +applications where identical functionality is desired. The hope of the project +is to enable developers to quickly and easily access parts of the UM code that +are commonly duplicated elsewhere, at the same time benefiting from any +improvements or optimisations that might be made in support of the UM itself. + +## Contributing Guidelines + +Welcome! + +The following links are here to help set clear expectations for everyone +contributing to this project. By working together under a shared understanding, +we can continuously improve the project while creating a friendly, inclusive +space for all contributors. + +### Contributors Licence Agreement + +Please see the +[Momentum Contributors Licence Agreement](https://github.com/MetOffice/Momentum/blob/main/CLA.md) + +Agreement of the CLA can be shown by adding yourself to the CONTRIBUTORS file +alongside this one, and is a requirement for contributing to this project. + +### Code of Conduct + +Please be aware of and follow the +[Momentum Code of Coduct](https://github.com/MetOffice/Momentum/blob/main/docs/CODE_OF_CONDUCT.md) + +### Working Practices + +This project is managed as part of the Simulation Systems group of repositories. + +Please follow the Simulation Systems +[Working Practices.](https://metoffice.github.io/simulation-systems/index.html) + +Questions are encouraged in the Simulation Systems +[Discussions.](https://github.com/MetOffice/simulation-systems/discussions) + +Please be aware of and follow the Simulation Systems +[AI Policy.](https://metoffice.github.io/simulation-systems/FurtherDetails/ai.html) 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/Makefile-version b/common/src/Makefile-version index 3ad6566..f3b5132 100644 --- a/common/src/Makefile-version +++ b/common/src/Makefile-version @@ -5,11 +5,11 @@ # This file then performs a few tasks: # * The C version files and precision-bomb header are compiled to produce # a bespoke version function (named get_VERSION_LIBNAME_version) -# * A suitable C header file containing the prototype for the above C +# * A suitable C header file containing the prototype for the above C # function is created # * It also produces a fortran module (VERSION_LIBNAME_version_mod) which # provides an interface to the above C function (with the same name) -# * Lastly it stores the list of objects which are needed at library compile +# * Lastly it stores the list of objects which are needed at library compile # time for the including Makefile to pickup (VERSION_OBJECTS[_PIC]) and the # names of generated files for it to remove on "clean" (VERSION_CLEAN) #-------------------------------------------------------------------------------- diff --git a/common/src/c_shum_compile_diag_suspend.h b/common/src/c_shum_compile_diag_suspend.h index 35add52..9e7a717 100644 --- a/common/src/c_shum_compile_diag_suspend.h +++ b/common/src/c_shum_compile_diag_suspend.h @@ -43,16 +43,35 @@ #define SHUM_COMPILE_DIAG_SUSPEND_H +#include "c_shum_compiler_select.h" + #define SHUM_EXEC_PRAGMA(pragma_string) _Pragma(#pragma_string) #define SHUM_EXEC_PRAGMA_STRINGIFY(string) #string -/* Deal with GCC */ -#if defined(__GNUC__) && !defined(__clang__) +/* Choose method */ + +#if defined(SHUM_HAS_GNU_EXTENSIONS) +#define SHUM_DIAG_USE_GNU_METHOD +#endif + +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#define SHUM_DIAG_USE_CLANG_METHOD +#endif + +/* Favour Clang method if both are availible */ + +#if defined(SHUM_DIAG_USE_GNU_METHOD) && defined(SHUM_DIAG_USE_CLANG_METHOD) +#undef SHUM_DIAG_USE_GNU_METHOD +#endif + +/* Deal with GCC and derivatives */ + +#if defined(SHUM_DIAG_USE_GNU_METHOD) /* we are using GCC */ -#if (__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 8)) +#if (SHUM_HAS_GNU_EXTENSIONS < 40800) /* older versions of GCC (<4.8) cannot suspend checking, so we must turn it off * completely. Call SHUM_COMPILE_DIAG_GLOBAL_SUSPEND from the top of the unit, @@ -79,9 +98,9 @@ #endif -/* Deal with Clang */ +/* Deal with Clang & Clang derivatives */ -#if defined(__clang__) +#if defined(SHUM_DIAG_USE_CLANG_METHOD) /* we are using Clang - which supports suspending checking */ diff --git a/common/src/c_shum_compiler_select.h b/common/src/c_shum_compiler_select.h new file mode 100644 index 0000000..0ca8d99 --- /dev/null +++ b/common/src/c_shum_compiler_select.h @@ -0,0 +1,148 @@ +/* *********************************COPYRIGHT**********************************/ +/* (C) Crown copyright Met Office. All rights reserved. */ +/* For further details please refer to the file LICENCE.txt */ +/* which you should have received as part of this distribution. */ +/* *********************************COPYRIGHT**********************************/ +/* */ +/* This file is part of the UM Shared Library project. */ +/* */ +/* The UM Shared Library is free software: you can redistribute it */ +/* and/or modify it under the terms of the Modified BSD License, as */ +/* published by the Open Source Initiative. */ +/* */ +/* The UM Shared Library is distributed in the hope that it will be */ +/* useful, but WITHOUT ANY WARRANTY; without even the implied warranty */ +/* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* Modified BSD License for more details. */ +/* */ +/* You should have received a copy of the Modified BSD License */ +/* along with the UM Shared Library. */ +/* If not, see . */ +/******************************************************************************/ +/* Description: */ +/* */ +/* Global macros for compiler detection */ +/* */ +/* Information: */ +/* */ +/* Header file providing definitions of macros to test compiler versions and */ +/* compatibility. */ +/* */ +/******************************************************************************/ + +#if !defined(C_SHUM_COMPILER_SELECT_H) +#define C_SHUM_COMPILER_SELECT_H + +/******************************************************************************/ + +/* detect GNU compiler */ + +#if defined(__GNUC__) +#if defined(__GNUC_PATCHLEVEL__) +#define SHUM_IS_GNU_COMPILER (__GNUC__ * 10000 \ + + __GNUC_MINOR__ * 100 \ + + __GNUC_PATCHLEVEL__) +#define SHUM_HAS_GNU_EXTENSIONS (__GNUC__ * 10000 \ + + __GNUC_MINOR__ * 100 \ + + __GNUC_PATCHLEVEL__) +#else +#define SHUM_IS_GNU_COMPILER (__GNUC__ * 10000 \ + + __GNUC_MINOR__ * 100) +#define SHUM_HAS_GNU_EXTENSIONS (__GNUC__ * 10000 \ + + __GNUC_MINOR__ * 100) +#endif +#endif + +/******************************************************************************/ + +/* detect Clang compiler */ + +#if defined(__clang__) +#define SHUM_IS_CLANG_COMPILER (__clang_major__ * 10000 \ + + __clang_minor__ * 100 \ + + __clang_patchlevel__) +#define SHUM_HAS_CLANG_EXTENSIONS (__clang_major__ * 10000 \ + + __clang_minor__ * 100 \ + + __clang_patchlevel__) +#endif + +/******************************************************************************/ + +/* detect Intel compiler */ + +#if defined(__INTEL_COMPILER) +#if (__INTEL_COMPILER < 2021) || (__INTEL_COMPILER == 202110) \ + || (__INTEL_COMPILER == 202111) +#if defined(__INTEL_COMPILER_UPDATE) +#define SHUM_IS_INTEL_COMPILER ((__INTEL_COMPILER/100) * 10000 \ + + (__INTEL_COMPILER/10 % 10) * 100 \ + + __INTEL_COMPILER_UPDATE) +#else +#define SHUM_IS_INTEL_COMPILER ((__INTEL_COMPILER/100) * 10000 \ + + (__INTEL_COMPILER/10 % 10) * 100 \ + + (__INTEL_COMPILER % 10)) +#endif +#else +#define SHUM_IS_INTEL_COMPILER (__INTEL_COMPILER * 10000 \ + + __INTEL_COMPILER_UPDATE * 100) +#endif +#endif + + +#if defined(__INTEL_LLVM_COMPILER) +#if __INTEL_LLVM_COMPILER < 1000000L +#define SHUM_IS_INTEL_COMPILER ((__INTEL_LLVM_COMPILER/100) * 10000 \ + + (__INTEL_LLVM_COMPILER/10 % 10) * 100 \ + +(__INTEL_LLVM_COMPILER % 10)) +#else +#define SHUM_IS_INTEL_COMPILER ((__INTEL_LLVM_COMPILER/10000) * 10000 \ + + (__INTEL_LLVM_COMPILER/100 % 100) * 100 \ + +(__INTEL_LLVM_COMPILER % 100)) +#endif +#endif + +/******************************************************************************/ + +/* detect Cray compiler */ + +#if defined(_CRAYC) +#if defined(_RELEASE_PATCHLEVEL) +#define SHUM_IS_CRAY_COMPILER (_RELEASE_MAJOR * 10000 \ + + _RELEASE_MINOR * 100 \ + + _RELEASE_PATCHLEVEL) +#else +#define SHUM_IS_CRAY_COMPILER (_RELEASE_MAJOR * 10000 \ + + _RELEASE_MINOR * 100) +#endif +#endif + +#if defined(__cray__) +#define SHUM_IS_CRAY_COMPILER (__clang_major__ * 10000 \ + + __clang_minor__ * 100 \ + + __clang_patchlevel__) +#endif + +/******************************************************************************/ + +/* Remove GNU false-positives */ + +#if defined(SHUM_IS_GNU_COMPILER) +#if defined(SHUM_IS_CRAY_COMPILER) || defined(SHUM_IS_INTEL_COMPILER) \ + || defined(SHUM_IS_CLANG_COMPILER) +#undef SHUM_IS_GNU_COMPILER +#endif +#endif + +/******************************************************************************/ + +/* Remove Clang false-positives */ + +#if defined(SHUM_IS_CLANG_COMPILER) +#if defined(SHUM_IS_CRAY_COMPILER) || defined(SHUM_IS_INTEL_COMPILER) +#undef SHUM_IS_CLANG_COMPILER +#endif +#endif + +/******************************************************************************/ + +#endif 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 ebfb8ea..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,11 +37,13 @@ #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" */ #if !defined(SHUMLIB_VERSION) -#define SHUMLIB_VERSION 2022111 +#define SHUMLIB_VERSION 2025101 #endif /* 2-stage expansion which will replace in the including code: @@ -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/doc/API-SHUM-BYTESWAP.rst b/doc/API_REF/API-SHUM-BYTESWAP.rst similarity index 96% rename from doc/API-SHUM-BYTESWAP.rst rename to doc/API_REF/API-SHUM-BYTESWAP.rst index 952c4ff..d652669 100644 --- a/doc/API-SHUM-BYTESWAP.rst +++ b/doc/API_REF/API-SHUM-BYTESWAP.rst @@ -1,20 +1,20 @@ -API Reference: shum_byteswap ----------------------------- +shum_byteswap +------------- -When performing reads from disk there are two different orders in which the -individual bytes making up a word/record can be read; these forms are known as +When performing reads from disk there are two different orders in which the +individual bytes making up a word/record can be read; these forms are known as "big endian" or "little endian" byte ordering, taken from the "end" of the word -where the read is started from (and the fact that bytes correspond to larger +where the read is started from (and the fact that bytes correspond to larger values at one end of the word). If the machine's default byte ordering is opposite to the one for a given file, -the data read in (or written) will not convert to the intended values correctly. +the data read in (or written) will not convert to the intended values correctly. This library allows the ordering of data to be swapped before writing or after reading to solve this issue. The UM uses exclusively big-endian input/output files and so often needs to perform swapping when run on little-endian machines. -Note that this library is intended as an *alternative* to any compiler provided -non-standard swapping functionality, and as such they should not be used +Note that this library is intended as an *alternative* to any compiler provided +non-standard swapping functionality, and as such they should not be used together. Fortran Functions/Subroutines @@ -23,7 +23,7 @@ Fortran Functions/Subroutines ``get_shum_byteswap_version`` ''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -41,7 +41,7 @@ allows access to the Shumlib version number used when compiling the library. ``f_shum_byteswap`` ''''''''''''''''''' -This function performs an in-place byteswap on a provided array. +This function performs an in-place byteswap on a provided array. **Available via module** ``f_shum_byteswap_mod`` @@ -67,7 +67,7 @@ This function performs an in-place byteswap on a provided array. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. **Notes** @@ -150,7 +150,7 @@ This function performs an in-place byteswap of an array. **Return Value** ``(int64_t)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. **Notes** @@ -176,6 +176,6 @@ This function should be used to test whether or not a swap is required. **Return Value** ``endianness (enum)`` The native endianism of the machine. An enum taking 2 possible - values defined in ``c_shum_byteswap.h``; ``bigEndian`` and - ``littleEndian``. + values defined in ``c_shum_byteswap.h``; ``bigEndian`` and + ``littleEndian``. diff --git a/doc/API-SHUM-CONSTANTS.rst b/doc/API_REF/API-SHUM-CONSTANTS.rst similarity index 99% rename from doc/API-SHUM-CONSTANTS.rst rename to doc/API_REF/API-SHUM-CONSTANTS.rst index af15559..26ee377 100644 --- a/doc/API-SHUM-CONSTANTS.rst +++ b/doc/API_REF/API-SHUM-CONSTANTS.rst @@ -1,5 +1,5 @@ -API Reference: shum_constants -------------------------------------------- +shum_constants +-------------- Fortran Modules %%%%%%%%%%%%%%% diff --git a/doc/API-SHUM-FIELDSFILE-CLASSES.rst b/doc/API_REF/API-SHUM-FIELDSFILE-CLASSES.rst similarity index 99% rename from doc/API-SHUM-FIELDSFILE-CLASSES.rst rename to doc/API_REF/API-SHUM-FIELDSFILE-CLASSES.rst index 42806d4..c089fc9 100644 --- a/doc/API-SHUM-FIELDSFILE-CLASSES.rst +++ b/doc/API_REF/API-SHUM-FIELDSFILE-CLASSES.rst @@ -1,5 +1,5 @@ -API Reference: UM File and Field classes ----------------------------------------- +UM File and Field classes +------------------------- This API is **experimental**; it provides a higher-level way of reading and writing fieldsfiles over the functions provided in ``shum_fieldsfile``. There @@ -14,16 +14,16 @@ Public Variables: ``shum_ff_status_type`` As well as providing the variables detailed below, this module also has overloaded operators for ``==``, ``>``, ``<``, ``>=``, ``<=`` and ``/=`` to -allow the ``icode`` inside the status object to be compared with a raw integer, -or with other status objects, e.g. ``IF (status /= 0_int64)`` is equivalent +allow the ``icode`` inside the status object to be compared with a raw integer, +or with other status objects, e.g. ``IF (status /= 0_int64)`` is equivalent to ``IF (status%icode /= 0_int64)``. ``icode (shum_ff_status_type)`` -An integer return code from the method. This will be zero for success; a +An integer return code from the method. This will be zero for success; a non-zero value indicates an issue. In cases where there is a distinction -between a warning and a fatal error, warnings have a negative icode and +between a warning and a fatal error, warnings have a negative icode and errors positive icode. @@ -607,7 +607,7 @@ This method gets the column-dependent constants in the file object. ``status (shum_ff_status_type)`` Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In all cases the ``message`` variable + not present in the file. In all cases the ``message`` variable in the object will contain further information. @@ -843,7 +843,7 @@ for example: ``icode = um_file%get_field(found_field_indices(1_int64), local_field)`` -where ``found_field_indices`` is a list of indices matching the criteria and +where ``found_field_indices`` is a list of indices matching the criteria and ``local_field`` is a field of type ``shum_field_type``. In this case the field corresponding to the first index of ``found_field_indices`` is retrieved. diff --git a/doc/API-SHUM-FIELDSFILE.rst b/doc/API_REF/API-SHUM-FIELDSFILE.rst similarity index 96% rename from doc/API-SHUM-FIELDSFILE.rst rename to doc/API_REF/API-SHUM-FIELDSFILE.rst index 5df87b3..dd173f3 100644 --- a/doc/API-SHUM-FIELDSFILE.rst +++ b/doc/API_REF/API-SHUM-FIELDSFILE.rst @@ -1,5 +1,5 @@ -API Reference: shum_fieldsfile ------------------------------- +shum_fieldsfile +--------------- Fortran Functions/Subroutines %%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -7,7 +7,7 @@ Fortran Functions/Subroutines ``get_shum_fieldsfile_version`` '''''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -26,7 +26,7 @@ allows access to the Shumlib version number used when compiling the library. '''''''''''''''''''' This function is used to open an existing FieldsFile (or variant thereof) - see -the routine ``f_shum_create_file`` for creating a new file. +the routine ``f_shum_create_file`` for creating a new file. **Available via module** ``f_shum_fieldsfile_mod`` @@ -40,7 +40,7 @@ the routine ``f_shum_create_file`` for creating a new file. **Outputs** ``ff_id (64-bit INTEGER)`` - A value which acts as an identifier for the file, the value + A value which acts as an identifier for the file, the value itself is arbitrary but must be passed to all other operations which need to reference the file opened here. @@ -51,7 +51,7 @@ the routine ``f_shum_create_file`` for creating a new file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_create_file`` @@ -80,7 +80,7 @@ the routine ``f_shum_open_file`` for opening an existing file. **Outputs** ``ff_id (64-bit INTEGER)`` - A value which acts as an identifier for the file, the value + A value which acts as an identifier for the file, the value itself is arbitrary but must be passed to all other operations which need to reference the file opened here. @@ -91,7 +91,7 @@ the routine ``f_shum_open_file`` for opening an existing file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_close_file`` @@ -117,7 +117,7 @@ This function closes access to a previously opened file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_read_fixed_length_header`` @@ -148,7 +148,7 @@ This function reads in and returns the fixed length header from the file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_read_integer_constants`` @@ -170,16 +170,16 @@ This function reads in and returns the integer constants from the file. **Input & Output** ``integer_constants (64-bit INTEGER)`` The integer constants, a 1D ``ALLOCATABLE`` array which will become - ``ALLOCATED`` to the correct size following the call (if it was + ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_real_constants`` @@ -201,16 +201,16 @@ This function reads in and returns the real constants from the file. **Input & Output** ``real_constants (64-bit REAL)`` The real constants, a 1D ``ALLOCATABLE`` array which will become - ``ALLOCATED`` to the correct size following the call (if it was + ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_level_dependent_constants`` @@ -231,17 +231,17 @@ This function reads in and returns the level dependent constants from the file. **Input & Output** ``level_dependent_constants (64-bit REAL)`` - The level dependent constants, a 2D ``ALLOCATABLE`` array which - will become ``ALLOCATED`` to the correct size following the call + The level dependent constants, a 2D ``ALLOCATABLE`` array which + will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_row_dependent_constants`` @@ -262,17 +262,17 @@ This function reads in and returns the row dependent constants from the file. **Input & Output** ``row_dependent_constants (64-bit REAL)`` - The row dependent constants, a 2D ``ALLOCATABLE`` array which - will become ``ALLOCATED`` to the correct size following the call + The row dependent constants, a 2D ``ALLOCATABLE`` array which + will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_column_dependent_constants`` @@ -293,17 +293,17 @@ This function reads in and returns the column dependent constants from the file. **Input & Output** ``column_dependent_constants (64-bit REAL)`` - The column dependent constants, a 2D ``ALLOCATABLE`` array which - will become ``ALLOCATED`` to the correct size following the call + The column dependent constants, a 2D ``ALLOCATABLE`` array which + will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_additional_parameters`` @@ -324,17 +324,17 @@ This function reads in and returns the additional parameters from the file. **Input & Output** ``column_dependent_constants (64-bit REAL)`` - The additional parameters, a 2D ``ALLOCATABLE`` array which - will become ``ALLOCATED`` to the correct size following the call + The additional parameters, a 2D ``ALLOCATABLE`` array which + will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_extra_constants`` @@ -355,17 +355,17 @@ This function reads in and returns the extra constants from the file. **Input & Output** ``extra_constants (64-bit REAL)`` - The extra constants, a 1D ``ALLOCATABLE`` array which - will become ``ALLOCATED`` to the correct size following the call + The extra constants, a 1D ``ALLOCATABLE`` array which + will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_temp_histfile`` @@ -386,17 +386,17 @@ This function reads in and returns the temporary historyfile from the file. **Input & Output** ``temp_histfile (64-bit REAL)`` - The temp_histfile, a 1D ``ALLOCATABLE`` array which - will become ``ALLOCATED`` to the correct size following the call + The temp_histfile, a 1D ``ALLOCATABLE`` array which + will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_compressed_index`` @@ -420,18 +420,18 @@ This function reads in and returns the compressed indices from the file. **Input & Output** ``compressed_index (64-bit REAL)`` - The compressed index (one of 3 depending on the value of ``index``), - a 1D ``ALLOCATABLE`` array which will become ``ALLOCATED`` to the - correct size following the call (if it was already ``ALLOCATED`` + The compressed index (one of 3 depending on the value of ``index``), + a 1D ``ALLOCATABLE`` array which will become ``ALLOCATED`` to the + correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_lookup`` @@ -450,17 +450,17 @@ This function reads in and returns the compressed indices from the file. **Input & Output** ``lookup (64-bit REAL)`` - The lookup table, a 2D ``ALLOCATABLE`` array which will become - ``ALLOCATED`` to the correct size following the call (if it was + The lookup table, a 2D ``ALLOCATABLE`` array which will become + ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). ``message (CHARACTER(LEN=*))`` Error message buffer. **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. ``f_shum_read_field_data`` @@ -482,32 +482,32 @@ This function reads in and returns the compressed indices from the file. **Input & Output** ``field_data`` - The field data, a 1D ``ALLOCATABLE`` array which will become + The field data, a 1D ``ALLOCATABLE`` array which will become ``ALLOCATED`` to the correct size following the call (if it was already ``ALLOCATED`` it will first be ``DEALLOCATED``). The type of ``field_data`` may be either ``INTEGER`` or ``REAL`` and can be either 32-bit or 64-bit. Which combination of these is correct - depends on the data and packing types of the field, which you can - determine by examining the lookup table yourself. Passing a - ``field_data`` array that does not match the type and precision + depends on the data and packing types of the field, which you can + determine by examining the lookup table yourself. Passing a + ``field_data`` array that does not match the type and precision indicated by the lookup will result in an error (*unless* the optional ``ignore_dtype`` flag is passed (see below)). ``message (CHARACTER(LEN=*))`` Error message buffer. ``ignore_dtype (optional, LOGICAL)`` If provided and set to true (default if not provided is false) the - type and precision of the ``field_data`` variable will be used + type and precision of the ``field_data`` variable will be used regardless of what the lookup specifies. This means that for example - a field which should be 64-bit ``REAL`` data can be read into a - 32-bit ``INTEGER`` array (as raw bytes; to retrieve the true + a field which should be 64-bit ``REAL`` data can be read into a + 32-bit ``INTEGER`` array (as raw bytes; to retrieve the true ``REAL`` values later each pair of values would need to be combined and then changed into a ``REAL`` representation using ``TRANSFER``) - + **Return Value** ``status (64-bit INTEGER)`` - Exit status; ``0`` means success, anything above ``0`` means an + Exit status; ``0`` means success, anything above ``0`` means an error has occurred, and a value of ``-1`` means this component was - not present in the file. In both unsuccessful cases the ``message`` + not present in the file. In both unsuccessful cases the ``message`` argument will contain further information. @@ -537,15 +537,15 @@ This function writes a fixed length header array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. **Notes** - Unlike many of the other routines, no writing to disk actually takes + Unlike many of the other routines, no writing to disk actually takes place upon calling this command. The fixed length header is committed to disk when the file is closed. Also note that any positional elements of the fixed length header passed here are discarded (as the - API will ensure positional elements always reflect the written + API will ensure positional elements always reflect the written structure of the file). @@ -576,7 +576,7 @@ This function writes an integer constants array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_real_constants`` @@ -606,7 +606,7 @@ This function writes a real constants array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_level_dependent_constants`` @@ -625,8 +625,8 @@ This function writes a level dependent constants array to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``level_dependent_constants (64-bit REAL)`` - The level dependent constants (a 2D array of any size is allowed, - but see the file format definition for details of the expected + The level dependent constants (a 2D array of any size is allowed, + but see the file format definition for details of the expected dimensions for different fieldsfile variants). **Input & Output** @@ -636,7 +636,7 @@ This function writes a level dependent constants array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_row_dependent_constants`` @@ -655,8 +655,8 @@ This function writes a row dependent constants array to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``row_dependent_constants (64-bit REAL)`` - The row dependent constants (a 2D array of any size is allowed, - but see the file format definition for details of the expected + The row dependent constants (a 2D array of any size is allowed, + but see the file format definition for details of the expected dimensions for different fieldsfile variants). **Input & Output** @@ -666,7 +666,7 @@ This function writes a row dependent constants array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_column_dependent_constants`` @@ -685,8 +685,8 @@ This function writes a column dependent constants array to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``column_dependent_constants (64-bit REAL)`` - The column dependent constants (a 2D array of any size is allowed, - but see the file format definition for details of the expected + The column dependent constants (a 2D array of any size is allowed, + but see the file format definition for details of the expected dimensions for different fieldsfile variants). **Input & Output** @@ -696,7 +696,7 @@ This function writes a column dependent constants array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_additional_parameters`` @@ -715,8 +715,8 @@ This function writes an additional parameters array to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``additional_parameters (64-bit REAL)`` - The additional parameters (a 2D array of any size is allowed, - but see the file format definition for details of the expected + The additional parameters (a 2D array of any size is allowed, + but see the file format definition for details of the expected dimensions for different fieldsfile variants). **Input & Output** @@ -726,7 +726,7 @@ This function writes an additional parameters array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_extra_constants`` @@ -745,8 +745,8 @@ This function writes an extra constants array to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``extra_constants (64-bit REAL)`` - The extra constants (a 1D array of any length is allowed, - but see the file format definition for details of the expected + The extra constants (a 1D array of any length is allowed, + but see the file format definition for details of the expected lengths for different fieldsfile variants). **Input & Output** @@ -756,7 +756,7 @@ This function writes an extra constants array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_temp_histfile`` @@ -775,8 +775,8 @@ This function writes a temp histfile array to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``temp_histfile (64-bit REAL)`` - The temp histfile (a 1D array of any length is allowed, - but see the file format definition for details of the expected + The temp histfile (a 1D array of any length is allowed, + but see the file format definition for details of the expected lengths for different fieldsfile variants). **Input & Output** @@ -786,7 +786,7 @@ This function writes a temp histfile array to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_compressed_index`` @@ -805,8 +805,8 @@ This function writes one of 3 compressed index arrays to a file. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``compressed_index (64-bit REAL)`` - The compressed index (a 1D array of any length is allowed, - but see the file format definition for details of the expected + The compressed index (a 1D array of any length is allowed, + but see the file format definition for details of the expected lengths for different fieldsfile variants). ``index (64-bit INTEGER)`` Indicates which of the 3 compressed index headers should be written @@ -819,7 +819,7 @@ This function writes one of 3 compressed index arrays to a file. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_write_lookup`` @@ -840,9 +840,9 @@ are written and processed prior to writing the data). The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``lookup (64-bit INTEGER)`` - The lookup (a 2D array which must have a first dimension of + The lookup (a 2D array which must have a first dimension of ``f_shum_lookup_dim1_len``, and a second dimension corresponding - to the number of fields which must not exceed the number passed + to the number of fields which must not exceed the number passed to ``f_shum_create_file``). ``start_index (64-bit INTEGER)`` The position in the file's lookup table where the first element @@ -857,10 +857,10 @@ are written and processed prior to writing the data). **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. - **Notes** + **Notes** Unlike many of the other routines, no writing to disk actually takes place upon calling this command. The lookup is committed to disk when the file is closed. Also note that any positional elements of the @@ -888,7 +888,7 @@ to be written in any order. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``max_points (64-bit INTEGER)`` - The number of 64-bit (8-byte) words which will be setup in the + The number of 64-bit (8-byte) words which will be setup in the lookup table for each field. ``n_land_points (optional 64-bit INTEGER)`` If provided, gives an alternative ``max_points`` value to use for @@ -904,7 +904,7 @@ to be written in any order. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. @@ -912,9 +912,9 @@ to be written in any order. ''''''''''''''''''''''''''' This function writes the data for a single field. There are two different ways -to manage the writing of field data; "direct" or "sequential". The syntax used -for this command is dependent on which of the writing methods are in use for -the given file. A file being written via the "direct" method will have had +to manage the writing of field data; "direct" or "sequential". The syntax used +for this command is dependent on which of the writing methods are in use for +the given file. A file being written via the "direct" method will have had previous calls to ``f_shum_write_lookup`` and ``f_shum_precalc_data_positions``, whereas a file using the "sequential" method will not. @@ -931,24 +931,24 @@ whereas a file using the "sequential" method will not. The identifier for the file; this must be a value returned by an earlier call to ``f_shum_open_file`` or ``f_shum_create_file``. ``index (64-bit INTEGER)`` - Indicates the index into the lookup table corresponding to the + Indicates the index into the lookup table corresponding to the field data being passed (and where it should be written to). ``lookup (64-bit INTEGER)`` The lookup of the field corresponding to the data being passed. ``field_data`` - The field data, a 1D array which may be either ``INTEGER`` or - ``REAL`` and can be either 32-bit or 64-bit. Which combination - of these is correct depends on the data and packing types of the - field, which should be specified in the lookup table. Passing a - ``field_data`` array that does not match the type and precision + The field data, a 1D array which may be either ``INTEGER`` or + ``REAL`` and can be either 32-bit or 64-bit. Which combination + of these is correct depends on the data and packing types of the + field, which should be specified in the lookup table. Passing a + ``field_data`` array that does not match the type and precision indicated by the lookup will result in an error (*unless* the optional ``ignore_dtype`` flag is also passed (see below)). ``ignore_dtype (optional, LOGICAL)`` If provided and set to true (default if not provided is false) the - type and precision of the ``field_data`` variable will be used + type and precision of the ``field_data`` variable will be used regardless of what the lookup specifies. This means that for example - a field which should be 64-bit ``REAL`` data can be written as a - 32-bit ``INTEGER`` array (as raw bytes; to retrieve the true + a field which should be 64-bit ``REAL`` data can be written as a + 32-bit ``INTEGER`` array (as raw bytes; to retrieve the true ``REAL`` values later each pair of values would need to be combined and then changed into a ``REAL`` representation using ``TRANSFER``) @@ -959,7 +959,7 @@ whereas a file using the "sequential" method will not. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. @@ -983,7 +983,7 @@ structure with the results. this module). It must have 99999 elements and after the call to this function any indices (stash codes) which have an entry in the given STASHmaster file will have been populated, e.g. if the - variable ``STASHm`` contains this argument, the grid code for + variable ``STASHm`` contains this argument, the grid code for STASH code 16004 would be ``STASHm(16004) % record % grid``. **Outputs** @@ -993,7 +993,7 @@ structure with the results. **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. ``f_shum_add_new_stash_record`` @@ -1015,7 +1015,7 @@ by the above routine). ``STASHmaster (TYPE(shum_STASHmaster), 1D array length 99999)`` A Pointer array of type ``shum_STASHmaster`` (also provided by this module). It must have 99999 elements and after the call to - this function the index at the computed stash codes will have + this function the index at the computed stash codes will have been populated. ``model (64-bit INTEGER)`` @@ -1029,7 +1029,7 @@ by the above routine). ``space (64-bit INTEGER)`` ``point (64-bit INTEGER)`` - + ``time (64-bit INTEGER)`` ``grid (64-bit INTEGER)`` @@ -1085,7 +1085,7 @@ by the above routine). **Return Value** ``status (64-bit INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. diff --git a/doc/API-SHUM-HORIZONTAL-FIELD-INTERP.rst b/doc/API_REF/API-SHUM-HORIZONTAL-FIELD-INTERP.rst similarity index 99% rename from doc/API-SHUM-HORIZONTAL-FIELD-INTERP.rst rename to doc/API_REF/API-SHUM-HORIZONTAL-FIELD-INTERP.rst index 99bb6df..5db8abd 100644 --- a/doc/API-SHUM-HORIZONTAL-FIELD-INTERP.rst +++ b/doc/API_REF/API-SHUM-HORIZONTAL-FIELD-INTERP.rst @@ -1,5 +1,5 @@ -API Reference: shum_horizontal_field_interp -------------------------------------------- +shum_horizontal_field_interp +---------------------------- Fortran Functions/Subroutines %%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -7,7 +7,7 @@ Fortran Functions/Subroutines ``get_shum_horizontal_field_interp_version`` '''''''''''''''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -53,7 +53,7 @@ of the 4 surrounding source grid points needed to calculate the target value. ``cyclic (64-bit LOGICAL)`` =T, then source data is cyclic =F, then source data is non-cyclic - + **Outputs** ``index_b_l(points) (64-bit INTEGER)`` Index of bottom left corner of source gridbox @@ -197,7 +197,7 @@ and is not intended for direct use. ``points (64-bit INTEGER)`` Total number of points on target grid ``ixp1(points (64-bit INTEGER)`` - Longitudinal index plus + Longitudinal index plus ``ix(points) (64-bit INTEGER)`` Longitudinal index ``iy(points) (64-bit INTEGER)`` @@ -257,7 +257,7 @@ This routine is for Cartesian grids. X coords of source grid in m ``y_srce(points_phi_srce) (64-bit REAL)`` Y coords of source grid in m - + **Outputs** ``index_b_l(points) (64-bit INTEGER)`` Index of bottom left corner of source gridbox diff --git a/doc/API-SHUM-LATLON-EQ-GRIDS.rst b/doc/API_REF/API-SHUM-LATLON-EQ-GRIDS.rst similarity index 92% rename from doc/API-SHUM-LATLON-EQ-GRIDS.rst rename to doc/API_REF/API-SHUM-LATLON-EQ-GRIDS.rst index 8a14b7f..568da31 100644 --- a/doc/API-SHUM-LATLON-EQ-GRIDS.rst +++ b/doc/API_REF/API-SHUM-LATLON-EQ-GRIDS.rst @@ -1,5 +1,5 @@ -API Reference: shum_latlon_eq_grids ------------------------------------ +shum_latlon_eq_grids +-------------------- Fortran Functions/Subroutines %%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -7,7 +7,7 @@ Fortran Functions/Subroutines ``get_shum_latlon_eq_grids_version`` '''''''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -26,7 +26,7 @@ allows access to the Shumlib version number used when compiling the library. ``f_shum_latlon_to_eq`` ''''''''''''''''''''''' -This function calculates latitude & longitude on equatorial latitude-longitude +This function calculates latitude & longitude on equatorial latitude-longitude (eq) grid defined by a translated and/or rotated pole. It is used in regional models from input arrays of latitude & longitude on standard grid. Both input and output latitudes & longitudes are in degrees. @@ -39,11 +39,11 @@ standard grid. Both input and output latitudes & longitudes are in degrees. **Inputs** ``phi, lambda (REAL, 64- or 32-bit)`` - Standard latitude & longitude (degrees) (1D array or scalar). + Standard latitude & longitude (degrees) (1D array or scalar). All arrays are dimensioned using the SIZE of the first input array. ``phi_pole, lambda_pole (REAL, 64- or 32-bit)`` Latitude & longitude of rotated pole (degrees). - + **Outputs** ``phi_eq (REAL, 64- or 32-bit)`` Latitude on equatorial (rotated) grid (degrees) (1D array or scalar). @@ -57,11 +57,11 @@ standard grid. Both input and output latitudes & longitudes are in degrees. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred, in which case the ``message`` argument will contain + occurred, in which case the ``message`` argument will contain information about the problem. **Notes** - The arguments here must be either *all* 32-bit or *all* 64-bit + The arguments here must be either *all* 32-bit or *all* 64-bit (but *not* a mixture of the two). @@ -69,7 +69,7 @@ standard grid. Both input and output latitudes & longitudes are in degrees. ''''''''''''''''''''''' This function calculates latitude & longitude on standard grid from values of -latitude & longitude on equatorial (eq) grid defined by a translated and/or +latitude & longitude on equatorial (eq) grid defined by a translated and/or rotated pole as used in regional models. Both input and output latitudes & longitudes are in degrees. @@ -81,7 +81,7 @@ Both input and output latitudes & longitudes are in degrees. **Inputs** ``phi_eq, lambda_eq (REAL, 64- or 32-bit)`` - Latitude & longitude on equatorial (rotated) grid (1D array or scalar). + Latitude & longitude on equatorial (rotated) grid (1D array or scalar). All arrays are dimensioned using the SIZE of the first input array. ``phi_pole, lambda_pole (REAL, 64- or 32-bit)`` Latitude & longitude of rotated pole (degrees). @@ -110,8 +110,8 @@ Both input and output latitudes & longitudes are in degrees. ``f_shum_latlon_eq_vector_coeff`` ''''''''''''''''''''''''''''''''' -This function calculates pairs of coefficients needed to translate u and v -vector components of wind between equatorial (eq) latitude-longitude grid and +This function calculates pairs of coefficients needed to translate u and v +vector components of wind between equatorial (eq) latitude-longitude grid and standard (ll) latitude-longitude grid (or vice versa). Input latitudes & longitudes are in degrees. It can in principle be applied to any pair of vector components. @@ -124,9 +124,9 @@ It can in principle be applied to any pair of vector components. **Inputs** ``lambda (REAL, 64 or 32-bit)`` - Longitudes on standard lat-lon grid (1D array). + Longitudes on standard lat-lon grid (1D array). All arrays are dimensioned using the SIZE of the first input array. - ``lambda_eq (REAL, 64 or 32-bit)`` + ``lambda_eq (REAL, 64 or 32-bit)`` Longitudes on equatorial lat-lon grid (1D array). ``phi_pole (REAL, 64 or 32-bit)`` Latitude of pole of equatorial (rotated) grid (1 value). @@ -144,23 +144,23 @@ It can in principle be applied to any pair of vector components. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred, in which case the ``message`` argument will contain + occurred, in which case the ``message`` argument will contain information about the problem. **Notes** - The arguments here may be either *all* 32-bit or *all* 64-bit + The arguments here may be either *all* 32-bit or *all* 64-bit (but *not* a mixture of the two). - These coeff1, coeff2 must be calculated for this rotation set + These coeff1, coeff2 must be calculated for this rotation set (lambda, lambda_eq, phi_pole, lambda_pole) before the vector rotation - functions ``f_shum_latlon_to_eq_vector`` + functions ``f_shum_latlon_to_eq_vector`` or ``f_shum_eq_to_latlon_vector`` are used. ``f_shum_eq_to_latlon_vector`` '''''''''''''''''''''''''''''' -This function calculates u & v vector components of wind on standard -latitude-longitude (ll) grid by rotating wind components on equatorial +This function calculates u & v vector components of wind on standard +latitude-longitude (ll) grid by rotating wind components on equatorial latitude-longitude (eq) grid. It can in principle be applied to any pair of vector components. @@ -172,8 +172,8 @@ It can in principle be applied to any pair of vector components. **Inputs** ``coeff1, coeff2 (REAL, 64- or 32-bit)`` - Pairs of rotation coefficients (1D arrays). - All arrays are dimensioned using the SIZE of the first input array. + Pairs of rotation coefficients (1D arrays). + All arrays are dimensioned using the SIZE of the first input array. N.B. These must have been calculated or saved for THIS rotation set (lambda, lambda_eq, phi_pole, lambda_pole) prior to using this function. ``u_eq (REAL, 64- or 32-bit)`` @@ -181,7 +181,7 @@ It can in principle be applied to any pair of vector components. ``v_eq (REAL, 64- or 32-bit)`` v vector component on equatorial lat-lon grid (1D array). ``mdi (REAL, OPTIONAL, 64- or 32-bit)`` - Missing data indicator value; any values in either input field + Missing data indicator value; any values in either input field which have this value will be output unrotated as missing data. **Outputs** @@ -197,14 +197,14 @@ It can in principle be applied to any pair of vector components. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred, in which case the ``message`` argument will contain + occurred, in which case the ``message`` argument will contain information about the problem. **Notes** - The arguments here may be either *all* 32-bit or *all* 64-bit - (but *not* a mixture of the two). + The arguments here may be either *all* 32-bit or *all* 64-bit + (but *not* a mixture of the two). Reminder: The rotation coefficients must have been calculated or saved - for THIS rotation set (lambda, lambda_eq, phi_pole, lambda_pole) + for THIS rotation set (lambda, lambda_eq, phi_pole, lambda_pole) prior to using this function. @@ -212,7 +212,7 @@ It can in principle be applied to any pair of vector components. '''''''''''''''''''''''''''''' This function calculates u & v vector components of wind on equatorial (rotated) -latitude-longitude (eq) grid by rotating wind components on standard +latitude-longitude (eq) grid by rotating wind components on standard latitude-longitude (ll) grid. It can in principle be applied to any pair of vector components. @@ -224,8 +224,8 @@ It can in principle be applied to any pair of vector components. **Inputs** ``coeff1, coeff2 (REAL, 64- or 32-bit)`` - Pairs of rotation coefficients (1D arrays). - All arrays are dimensioned using the SIZE of the first input array. + Pairs of rotation coefficients (1D arrays). + All arrays are dimensioned using the SIZE of the first input array. N.B. These must have been calculated or saved for THIS rotation set (lambda, lambda_eq, phi_pole, lambda_pole) prior to using this function. ``u (REAL, 64- or 32-bit)`` @@ -233,7 +233,7 @@ It can in principle be applied to any pair of vector components. ``v (REAL, 32- or 64-bit)`` v vector component on standard lat-lon grid (1D array). ``mdi (REAL, OPTIONAL, 64- or 32-bit)`` - Missing data indicator value; any values in either input field + Missing data indicator value; any values in either input field which have this value will be output unrotated as missing data. **Outputs** @@ -256,29 +256,29 @@ It can in principle be applied to any pair of vector components. The arguments here may be either *all* 32-bit or *all* 64-bit (but *not* a mixture of the two). Reminder: The rotation coefficients must have been calculated or saved - for THIS rotation set (lambda, lambda_eq, phi_pole, lambda_pole) + for THIS rotation set (lambda, lambda_eq, phi_pole, lambda_pole) prior to using this function. C Functions %%%%%%%%%%% -These grid transformations are currently only available as FORTRAN functions. +These grid transformations are currently only available as FORTRAN functions. Unified Model Implementation %%%%%%%%%%%%%%%%%%%%%%%%%%%% -These 5 shumlib functions replace the 5 control/grids lat-lon to equatorial -grid transformation subroutines ``lltoeq, eqtoll, w_coeff, w_eqtoll & -w_lltoeq`` respectively. +These 5 shumlib functions replace the 5 control/grids lat-lon to equatorial +grid transformation subroutines ``lltoeq, eqtoll, w_coeff, w_eqtoll & +w_lltoeq`` respectively. -In the Unified Model the shumlib functions are invoked through a new set of -subroutine wrappers in module ``control/grids/latlon_eq_rotation_mod.F90`` -named ``rotate_latlon_to_eq, rotate_eq_to_latlon, eq_latlon_vector_coeffs, -vector_eq_to_latlon & vector_latlon_to_eq``. +In the Unified Model the shumlib functions are invoked through a new set of +subroutine wrappers in module ``control/grids/latlon_eq_rotation_mod.F90`` +named ``rotate_latlon_to_eq, rotate_eq_to_latlon, eq_latlon_vector_coeffs, +vector_eq_to_latlon & vector_latlon_to_eq``. -E.g. +E.g. ``USE latlon_eq_rotation_mod, ONLY: rotate_eq_to_latlon, rotate_latlon_to_eq`` -while the wrapper accesses shumlib via +while the wrapper accesses shumlib via ``USE f_shum_latlon_eq_grids_mod, ONLY: f_shum_latlon_to_eq`` etc. diff --git a/doc/API-SHUM-NUMBER-TOOLS.rst b/doc/API_REF/API-SHUM-NUMBER-TOOLS.rst similarity index 96% rename from doc/API-SHUM-NUMBER-TOOLS.rst rename to doc/API_REF/API-SHUM-NUMBER-TOOLS.rst index 211ca72..93e8fd5 100644 --- a/doc/API-SHUM-NUMBER-TOOLS.rst +++ b/doc/API_REF/API-SHUM-NUMBER-TOOLS.rst @@ -1,5 +1,5 @@ -API Reference: shum_number_tools --------------------------------- +shum_number_tools +----------------- There are certain special classes of number which may be encountered when working with floating point arithmatic. These are "NaN" (not a number), @@ -28,7 +28,7 @@ Fortran Functions/Subroutines ``get_shum_number_tools_version`` ''''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -46,7 +46,7 @@ allows access to the Shumlib version number used when compiling the library. ``f_shum_is_denormal`` '''''''''''''''''''''' -This function tests a given floating-point number to determine if it is denormal. +This function tests a given floating-point number to determine if it is denormal. **Available via module** ``f_shum_is_denormal_mod`` @@ -66,7 +66,7 @@ This function tests a given floating-point number to determine if it is denormal ''''''''''''''''''''''' This function tests a given floating-point array to determine if any element of -it is denormal. +it is denormal. **Available via module** ``f_shum_is_denormal_mod`` @@ -89,8 +89,8 @@ it is denormal. ``f_shum_is_inf`` ''''''''''''''''' -This function tests a given floating-point number to determine if it is an -infinity. +This function tests a given floating-point number to determine if it is an +infinity. **Available via module** ``f_shum_is_inf_mod`` @@ -110,7 +110,7 @@ infinity. '''''''''''''''''' This function tests a given floating-point array to determine if any element of -it is an infinity. +it is an infinity. **Available via module** ``f_shum_has_inf_mod`` @@ -133,7 +133,7 @@ it is an infinity. ``f_shum_is_nan`` ''''''''''''''''' -This function tests a given floating-point number to determine if it is a NaN. +This function tests a given floating-point number to determine if it is a NaN. **Available via module** ``f_shum_is_nan_mod`` @@ -153,7 +153,7 @@ This function tests a given floating-point number to determine if it is a NaN. '''''''''''''''''' This function tests a given floating-point array to determine if any element of -it is a NaN. +it is a NaN. **Available via module** ``f_shum_has_nan_mod`` diff --git a/doc/API-SHUM-SPIRAL-SEARCH.rst b/doc/API_REF/API-SHUM-SPIRAL-SEARCH.rst similarity index 95% rename from doc/API-SHUM-SPIRAL-SEARCH.rst rename to doc/API_REF/API-SHUM-SPIRAL-SEARCH.rst index 153f7b9..d2df5c5 100644 --- a/doc/API-SHUM-SPIRAL-SEARCH.rst +++ b/doc/API_REF/API-SHUM-SPIRAL-SEARCH.rst @@ -1,5 +1,5 @@ -API Reference: shum_spiral_search ---------------------------------- +shum_spiral_search +------------------ Fortran Functions/Subroutines %%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -7,7 +7,7 @@ Fortran Functions/Subroutines ``get_shum_spiral_search_version`` '''''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -29,12 +29,12 @@ allows access to the Shumlib version number used when compiling the library. This function calculates values for unresolved points. using a spiral search method, which finds the closest point by distance (in m) Method: Uses the Haversine formula to calculate the distances. -Searches in steps of 3*minimum local distance for each unresolved point until -it finds a resolved point. For land points in a field that is not "land only" +Searches in steps of 3*minimum local distance for each unresolved point until +it finds a resolved point. For land points in a field that is not "land only" a 200km constraint is applied - if there is no resolved land point within this distance, it uses the closest resolved sea point value instead. -For Global (cyclic) domains, if hit an edge it calculates the distances of -every point in the domain as it can't cope with looping over the edges. +For Global (cyclic) domains, if hit an edge it calculates the distances of +every point in the domain as it can't cope with looping over the edges. This will cause the scheme to take much longer to run, however this is unlikely to happen often. @@ -71,7 +71,7 @@ ancillary file fields with the land-sea mask. True if grid has cyclic (wraparound) edges. ``unres_mask (LOGICAL, KIND=C_BOOL, size=points_phi*points_lambda)`` Mask of grid locations of points to be resolved by spiral search. - + **Outputs** ``indices (INTEGER, 64- or 32-bit, size=no_point_unres)`` Grid locations returned as result of spiral search. @@ -83,11 +83,11 @@ ancillary file fields with the land-sea mask. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred, in which case the ``message`` argument will contain + occurred, in which case the ``message`` argument will contain information about the problem. **Notes** - The arguments here must be either *all* 32-bit or *all* 64-bit + The arguments here must be either *all* 32-bit or *all* 64-bit (but *not* a mixture of the two) and logicals must be kind=C_BOOL. C Functions @@ -114,7 +114,7 @@ to the Shumlib version number used when compiling the library. ``c_shum_spiral_search_algorithm`` '''''''''''''''''''''''''''''''''' -This is the C interface to the Fortran routine (see the description of it +This is the C interface to the Fortran routine (see the description of it above under ``f_shum_spiral_search_algorithm``. **Required header/s** @@ -122,7 +122,7 @@ above under ``f_shum_spiral_search_algorithm``. **Syntax** ``c_shum_spiral_search_algorithm(lsm, index_unres, no_point_unres, no_point_unres, points_phi, points_lambda, lats, lons, is_land_field, constrained, constrained_max_dist, dist_step, cyclic_domain, unres_mask, indices, planet_radius, cmessage, message_len)`` - + **Arguments** ``lsm (bool*)`` Land-sea mask (1D array of length points_phi*points_lambda). @@ -142,30 +142,30 @@ above under ``f_shum_spiral_search_algorithm``. ``constrained_max_dist (double*)`` If constrained, gives the maximum distance (in m) to constraint by. ``dist_step(double*)`` - Adjusts the distance step size of the iterations done whilst searching. + Adjusts the distance step size of the iterations done whilst searching. ``cyclic_domain (bool*)`` True if grid has cyclic (wraparound) edges. ``unres_mask (bool*)`` - Mask of grid locations (1D array of length points_phi*points_lambda) + Mask of grid locations (1D array of length points_phi*points_lambda) of points to be resolved by spiral search. ``message (char*)`` Error message buffer. ``message_len (int64_t*)`` - Length of error message buffer. + Length of error message buffer. **Return Value** ``(int64_t)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. Unified Model Implementation %%%%%%%%%%%%%%%%%%%%%%%%%%%% -This shumlib function replaces the spiral circle search subroutine -``SPIRAL_CIRCLE_SEARCH`` called in subroutine ``rcf_spiral_circle_s``. -In the Unified Model the shumlib function is invoked through a module -E.g. +This shumlib function replaces the spiral circle search subroutine +``SPIRAL_CIRCLE_SEARCH`` called in subroutine ``rcf_spiral_circle_s``. +In the Unified Model the shumlib function is invoked through a module +E.g. ``USE hum_spiral_search_mod, ONLY: f_shum_spiral_search_algorithm`` while the logicals require ``USE , INTRINSIC :: ISO_C_BINDING, ONLY: C_BOOL``. diff --git a/doc/API-SHUM-STRING-CONV.rst b/doc/API_REF/API-SHUM-STRING-CONV.rst similarity index 94% rename from doc/API-SHUM-STRING-CONV.rst rename to doc/API_REF/API-SHUM-STRING-CONV.rst index f16235b..76fd840 100644 --- a/doc/API-SHUM-STRING-CONV.rst +++ b/doc/API_REF/API-SHUM-STRING-CONV.rst @@ -1,12 +1,12 @@ -API Reference: shum_string_conv -------------------------------- +shum_string_conv +---------------- Foreword: Fortran Vs. C String Representation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -This module deals with the differences in how character/string data is +This module deals with the differences in how character/string data is represented between the two languages. Fortran ``CHARACTER`` variables are -fixed length whilst C ``char`` variables can be any length (with a terminating +fixed length whilst C ``char`` variables can be any length (with a terminating ``NULL`` character signifying the end of the string). Fortran Functions/Subroutines @@ -15,7 +15,7 @@ Fortran Functions/Subroutines ``get_shum_string_conv_version`` '''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -33,9 +33,9 @@ allows access to the Shumlib version number used when compiling the library. ``f_shum_strlen`` ''''''''''''''''' -This function returns the length of a C type string (in Fortran this is -represented by a 1-dimensional array with the ``C_CHAR`` kind from -``ISO_C_BINDING`` and comprised of single (``LEN=1``) ``CHARACTER`` values). +This function returns the length of a C type string (in Fortran this is +represented by a 1-dimensional array with the ``C_CHAR`` kind from +``ISO_C_BINDING`` and comprised of single (``LEN=1``) ``CHARACTER`` values). The function calls through the the C intrinsic ``strlen`` directly, so it will return the length up to the null-character (which terminates strings in C). @@ -48,13 +48,13 @@ return the length up to the null-character (which terminates strings in C). **Inputs** ``c_string (C_CHAR CHARACTER array)`` The C type string object (see above for explanation). - + **Return Value** ``length (64-bit INTEGER)`` The length of the input string object up to the null character. **Notes** - The C string object provided as input should contain the null + The C string object provided as input should contain the null character (if returned by a call to C code it should do) otherwise the returned length will be incorrect. @@ -87,7 +87,7 @@ and a C type string (see the description of ``f_shum_strlen`` for details). ``f_shum_c2f_string`` ''''''''''''''''''''' -This function converts between a C type string (see the description of +This function converts between a C type string (see the description of ``f_shum_strlen`` for details). **Available via module** @@ -98,25 +98,25 @@ This function converts between a C type string (see the description of **Inputs** ``c_obj (C_CHAR CHARACTER array or C_PTR)`` - The C type string to convert; this can be either a C type string + The C type string to convert; this can be either a C type string object as discussed above, or a C pointer to a C string object. ``c_string_len (64-bit INTEGER)`` - This gives the length of ``c_obj`` (and ``f_string``). If - ``c_obj`` is a C string object (i.e. *not* a pointer) and - ``f_string`` is ``ALLOCATABLE`` this argument may be omitted; - ``f_string`` will be allocated to fit the contents of the C string + This gives the length of ``c_obj`` (and ``f_string``). If + ``c_obj`` is a C string object (i.e. *not* a pointer) and + ``f_string`` is ``ALLOCATABLE`` this argument may be omitted; + ``f_string`` will be allocated to fit the contents of the C string up to the null character. **Return Value** ``f_string (CHARACTER)`` A Fortran character variable. If ``c_string_len`` is provided it must be that length, otherwise it must be ``ALLOCATABLE`` and will - be allocated to the length required to hold the C string contents. + be allocated to the length required to hold the C string contents. C Functions %%%%%%%%%%% -There are no C interfaces for the main functions in this library since they +There are no C interfaces for the main functions in this library since they all relate to treatment of C like string objects in *Fortran*. An interface does exist for the function that returns the Shumlib version number, as this is automatically added to all Shumlib libraries. diff --git a/doc/API-SHUM-THREAD-UTILS.rst b/doc/API_REF/API-SHUM-THREAD-UTILS.rst similarity index 97% rename from doc/API-SHUM-THREAD-UTILS.rst rename to doc/API_REF/API-SHUM-THREAD-UTILS.rst index ec5f6a8..e97b813 100644 --- a/doc/API-SHUM-THREAD-UTILS.rst +++ b/doc/API_REF/API-SHUM-THREAD-UTILS.rst @@ -1,7 +1,7 @@ -API Reference: shum_thread_utils ---------------------------------- +shum_thread_util +---------------- -Fortran Functions/Subroutines +Fortran Functions/Subroutine %%%%%%%%%%%%%%%%%%%%%%%%%%%%% ``get_shum_thread_utils_version`` @@ -297,8 +297,8 @@ each receive a contiguous sub-range. needed within the parallel region. ``par_ftn_ptr ()`` - A function pointer to the code to execute in the parallel region. - See additional notes below for more details on the + A function pointer to the code to execute in the parallel region. + See additional notes below for more details on the ```` specification. ``istart (const int64_t *)`` @@ -324,19 +324,19 @@ each receive a contiguous sub-range. value. ``struct_ptr (void **)`` - The first argument is ``struct_ptr``, the pointer passed on + The first argument is ``struct_ptr``, the pointer passed on from the parent (``f_shum_startOMPparallelfor``). ``istart (const int64_t *const restrict)`` The second argument is a pointer to a value derived from the - ``istart`` value passed to the parent. Rather than directly + ``istart`` value passed to the parent. Rather than directly pass the value, it is modified such that the iteration range passed to the parent is divided into a different sub-range for each thread. ``iend (const int64_t *const restrict)`` The third argument is a pointer to a value derived from the - ``iend`` value passed to the parent. Rather than directly + ``iend`` value passed to the parent. Rather than directly pass the value, it is modified such that the iteration range passed to the parent is divided into a different sub-range for each thread. diff --git a/doc/API-SHUM-WGDOS-PACKING.rst b/doc/API_REF/API-SHUM-WGDOS-PACKING.rst similarity index 97% rename from doc/API-SHUM-WGDOS-PACKING.rst rename to doc/API_REF/API-SHUM-WGDOS-PACKING.rst index b9ac6e4..cfd5e5e 100644 --- a/doc/API-SHUM-WGDOS-PACKING.rst +++ b/doc/API_REF/API-SHUM-WGDOS-PACKING.rst @@ -1,5 +1,5 @@ -API Reference: shum_wgdos_packing ---------------------------------- +shum_wgdos_packing +------------------ Fortran Functions/Subroutines %%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -7,7 +7,7 @@ Fortran Functions/Subroutines ``get_shum_wgdos_packing_version`` '''''''''''''''''''''''''''''''''' -All Shumlib libraries expose a module and function named in this format; it +All Shumlib libraries expose a module and function named in this format; it allows access to the Shumlib version number used when compiling the library. **Available via module** @@ -38,7 +38,7 @@ sizes to use for allocating the return arrays of the unpacking routine below. **Inputs** ``packed_field (32-bit INTEGER)`` The packed field data, a 1D array. - + **Outputs** ``num_words (INTEGER)`` Total number of (32-bit) words in packed array. @@ -56,7 +56,7 @@ sizes to use for allocating the return arrays of the unpacking routine below. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. **Notes** @@ -83,7 +83,7 @@ value in the process. ``field (64-bit REAL)`` The unpacked field data (which may be either a 1D or 2D array). ``stride (INTEGER)`` - If ``field`` is 1D this must be provided to indicate the stride (or + If ``field`` is 1D this must be provided to indicate the stride (or row length) for the packing to use. ``accuracy (INTEGER)`` Packing accuracy (power of 2). @@ -102,7 +102,7 @@ value in the process. ``n_packed_words (INTEGER)`` This must be provided unless ``packed_field`` is an unallocated ``ALLOCATABLE``. It will receive the number of elements of - ``packed_field`` containing the packed data (i.e. + ``packed_field`` containing the packed data (i.e. ``packed_field(1:n_packed_words)`` which may be less than the full extent of the array). @@ -113,7 +113,7 @@ value in the process. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. **Notes** @@ -144,7 +144,7 @@ any missing points with a given value and returning the unpacked array. ``field (64-bit REAL)`` The unpacked field data (which may be either a 1D or 2D array). ``stride (INTEGER)`` - If ``field`` is 1D this must be provided to indicate the stride (or + If ``field`` is 1D this must be provided to indicate the stride (or row length) for the unpacking to use. **Input & Output** @@ -154,7 +154,7 @@ any missing points with a given value and returning the unpacked array. **Return Value** ``status (INTEGER)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. **Notes** @@ -214,7 +214,7 @@ sizes to use for allocating the return arrays of the unpacking routine below. **Return Value** ``(int64_t)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. @@ -257,7 +257,7 @@ value in the process. **Return Value** ``status (int64_t)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. @@ -295,6 +295,6 @@ any missing points with a given value and returning the unpacked array. **Return Value** ``status (int64_t)`` Exit status; ``0`` means success, anything else means an error has - occurred and in that case the ``message`` argument will contain + occurred and in that case the ``message`` argument will contain information about the problem. diff --git a/doc/API_REF/CONTENTS.rst b/doc/API_REF/CONTENTS.rst new file mode 100644 index 0000000..d345978 --- /dev/null +++ b/doc/API_REF/CONTENTS.rst @@ -0,0 +1,20 @@ +API reference +============= + +.. toctree:: + :maxdepth: 1 + :hidden: + :caption: API Reference + + API-SHUM-BYTESWAP + API-SHUM-CONSTANTS + API-SHUM-FIELDSFILE-CLASSES + API-SHUM-FIELDSFILE + API-SHUM-HORIZONTAL-FIELD-INTERP + API-SHUM-LATLON-EQ-GRIDS + API-SHUM-NUMBER-TOOLS + API-SHUM-SPIRAL-SEARCH + API-SHUM-STRING-CONV + API-SHUM-THREAD-UTILS + API-SHUM-WGDOS-PACKING + TECHNICAL-SHUM-THREAD-UTILS diff --git a/doc/TECHNICAL-SHUM-THREAD-UTILS.rst b/doc/API_REF/TECHNICAL-SHUM-THREAD-UTILS.rst similarity index 98% rename from doc/TECHNICAL-SHUM-THREAD-UTILS.rst rename to doc/API_REF/TECHNICAL-SHUM-THREAD-UTILS.rst index 7e4318d..acd9c10 100644 --- a/doc/TECHNICAL-SHUM-THREAD-UTILS.rst +++ b/doc/API_REF/TECHNICAL-SHUM-THREAD-UTILS.rst @@ -61,7 +61,7 @@ This ensures it is possible to select the use of only the Fortan OpenMP runtime If possible, provide a Fortran implementation of the OpenMP parallelism as well, using the wrappers in the ``shum_thread_utils``. An example of such use is given below. -:: +.. code-block:: c #if defined(_OPENMP) && defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) @@ -102,7 +102,7 @@ This restriction is required to simplify the implementation of automated testing Any OpenMP if-def pair must not also include a logical test on a third macro. If this functionality is required, find an appropriate nesting of ``#if defined()`` tests. For example instead of: -:: +.. code-block:: c #if defined(_OPENMP) && defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) && defined(OTHER) /* do stuff */ @@ -110,7 +110,7 @@ For example instead of: Use: -:: +.. code-block:: c #if defined(_OPENMP) && defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) #if defined(OTHER) @@ -136,7 +136,7 @@ This can be used equivalently to how the ``!$`` sentinel would be in Fortran. You cannot hide the use of the ``_OPENMP`` & ``SHUM_USE_C_OPENMP_VIA_THREAD_UTILS`` macros through the definition of a third macro dependent on them. For example, you must not define and use a new macro in place of the two original macros, as shown here: -:: +.. code-block:: c #define USE_THREAD_UTILS defined(_OPENMP) && defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) @@ -153,7 +153,7 @@ This section will detail how to correctly use the shum_thread_utils module from To access the ``f_shum_thread_utils`` routines, the ``c_shum_thread_utils.h`` header must be included in your code as shown in the code example below. -:: +.. code-block:: c #include #include @@ -171,7 +171,7 @@ the code with the ``_OPENMP`` pre-processing macro, as none of the OpenMP is exp However, one may choose to use protect the inclusion anyway, perhaps to allow preprocessing to switching between ``f_shum_thread_utils``, direct OpenMP, and no OpenMP - as shown in the example below. -:: +.. code-block:: c #include #include @@ -200,4 +200,4 @@ direct OpenMP, and no OpenMP - as shown in the example below. Note of course that this is a highly contrived example - if the OpenMP header were available it would be perfectly safe to include it in non-OpenMP builds. Additionally, calls to find the thread number are safe regardless of whether OpenMP is enabled or not; and we have no parallel regions in this example anyway! -But it does serve to illustrate conceptually how a more complex case may work. \ No newline at end of file +But it does serve to illustrate conceptually how a more complex case may work. diff --git a/doc/DEVELOP.rst b/doc/DEVELOP.rst index 9b12d31..873d769 100644 --- a/doc/DEVELOP.rst +++ b/doc/DEVELOP.rst @@ -243,7 +243,7 @@ commands that compile each object should specify the output include directory are picked up correctly. Some libraries may require a pre-processing step, in which case the makefile -will generate the required ``.f90`` file by pre-processing the proveded +will generate the required ``.f90`` file by pre-processing the proveded ``.F90`` file. Structure of the testing makefiles @@ -344,7 +344,7 @@ routine is as follows. Firstly, have the routine report the Shumlib version and its name, details of where this module comes from can be found in the later "Version Inclusion" -section. +section. .. parsed-literal:: @@ -357,7 +357,7 @@ section. WRITE(OUTPUT_UNIT, "()") WRITE(OUTPUT_UNIT, "(A,I0)") & - "Testing at Shumlib version: ", version + "Testing at Shumlib version: ", version Next, each test case (which should be defined as a ``SUBROUTINE`` elsewhere in @@ -438,7 +438,7 @@ Where the arguments have the following meanings: against and considered "correct"). **var_2** - Variable containing the *tested* value (i.e. the value which is being + Variable containing the *tested* value (i.e. the value which is being validated by the test). **dim1**, **dim2** diff --git a/doc/INSTALL.rst b/doc/INSTALL.rst index 1288882..cad941b 100644 --- a/doc/INSTALL.rst +++ b/doc/INSTALL.rst @@ -190,7 +190,7 @@ this option in conjunction with the build location options (see above) to produce multiple output directories. For instance suppose we are building multiple libraries for and wish to install to a non-default location: -.. parsed-literal:: +.. parsed-literal:: export LIBDIR_OUT=/home/wilfred/shumlib/openmp export SHUM_OPENMP=true @@ -210,13 +210,13 @@ Preprocessed options Some libraries may contain pre-processed options. Shumlib should build sucessfully with the defaults provided by the makefile. However, ocassionally users may wish to -select specific options from the command line for portability and/or performance +select specific options from the command line for portability and/or performance reasons. In these cases, the default options can be overridden with environment variables. These environment valiables can be set either to true or false. The currently supported options (environment variables) are: - - ``SHUM_HAS_IEEE_ARITHMETIC``: if true, allows the build to make use of + - ``SHUM_HAS_IEEE_ARITHMETIC``: if true, allows the build to make use of functionality from the intrinsic ``IEEE_ARITHMETIC`` Fortran module. - ``SHUM_EVAL_NAN_BY_BITS``: if true, forces the interrogation of the sepcial NaN @@ -230,11 +230,11 @@ The currently supported options (environment variables) are: if it would otherwise be availible. -Similarly to how multiple versions of shumlib could be build with differing OpenMP +Similarly to how multiple versions of shumlib could be build with differing OpenMP options above, we can select different pre-processing options for different builds too: -.. parsed-literal:: +.. parsed-literal:: export LIBDIR_OUT=/home/wilfred/shumlib/ieee_arithmetic export SHUM_HAS_IEEE_ARITHMETIC=true @@ -252,10 +252,10 @@ Group/Site Make Scripts %%%%%%%%%%%%%%%%%%%%%%% You can also find bash scripts which handle (and provide traceability for) the -entire set of builds for a given site, in the ``scripts`` directory. - -Taking the Met Office script as an example, it consists of a series of +entire set of builds for a given site, in the ``scripts`` directory. + +Taking the Met Office script as an example, it consists of a series of commands that build Shumlib using different combinations of compilers with -appropriate setup commands to provide the correct environments, as well as -producing both OpenMP and non-OpenMP variants. A script like this may well +appropriate setup commands to provide the correct environments, as well as +producing both OpenMP and non-OpenMP variants. A script like this may well be overkill for smaller installations. diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 0000000..d4bb2cb --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,20 @@ +# Minimal makefile for Sphinx documentation +# + +# You can set these variables from the command line, and also +# from the environment for the first two. +SPHINXOPTS ?= +SPHINXBUILD ?= sphinx-build +SOURCEDIR = . +BUILDDIR = _build + +# Put it first so that "make" without argument is like "make help". +help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) + +.PHONY: help Makefile + +# Catch-all target: route all unknown targets to Sphinx using the new +# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). +%: Makefile + @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) diff --git a/doc/_static/MO_SQUARE_black_mono_for_light_backg_RBG.png b/doc/_static/MO_SQUARE_black_mono_for_light_backg_RBG.png new file mode 100755 index 0000000..371795c Binary files /dev/null and b/doc/_static/MO_SQUARE_black_mono_for_light_backg_RBG.png differ diff --git a/doc/_static/MO_SQUARE_for_dark_backg_RBG.png b/doc/_static/MO_SQUARE_for_dark_backg_RBG.png new file mode 100755 index 0000000..8100137 Binary files /dev/null and b/doc/_static/MO_SQUARE_for_dark_backg_RBG.png differ diff --git a/doc/_static/custom.css b/doc/_static/custom.css new file mode 100644 index 0000000..4c10700 --- /dev/null +++ b/doc/_static/custom.css @@ -0,0 +1,26 @@ +/* import the standard theme css */ +/* @import url("styles/theme.css"); +@import url("basic.css"); */ + +/* Office Science Colours */ +html[data-theme="light"] { + --pst-color-primary: #0f79be; + --pst-color-secondary: #e2a022; + --pst-color-accent: #e2a022; +} + +html[data-theme="dark"] { + --pst-color-primary: #359bc0; + --pst-color-secondary: #eac45f; + --pst-color-accent: #eac45f; + + /* Overwrite visited colour to be AAA contrast compliant */ + a:visited { + color: #be90ea; + } + + /* Reset the overridden hover colour */ + a:visited:hover { + color: var(--pst-color-link-hover); + } +} diff --git a/doc/_templates/crown-copyright.html b/doc/_templates/crown-copyright.html new file mode 100644 index 0000000..d0614ad --- /dev/null +++ b/doc/_templates/crown-copyright.html @@ -0,0 +1,12 @@ +{# Displays the copyright information (which is defined in conf.py). #} +{% if show_copyright and copyright %} +

+ {% if hasdoc('copyright') %} + {% trans path=pathto('copyright'), copyright=copyright|e %}© Crown Copyright, {{ copyright }}{% endtrans %} +
+ {% else %} + {% trans copyright=copyright|e %}© Crown Copyright, {{ copyright }}{% endtrans %} +
+ {% endif %} +

+{% endif %} diff --git a/doc/_templates/show-accessibility.html b/doc/_templates/show-accessibility.html new file mode 100644 index 0000000..9a9e012 --- /dev/null +++ b/doc/_templates/show-accessibility.html @@ -0,0 +1,4 @@ +{# Displays a link to the .rst source of the current page. #} +
+ {{ "Accessibility" }} +
diff --git a/doc/conf.py b/doc/conf.py new file mode 100644 index 0000000..433e1bf --- /dev/null +++ b/doc/conf.py @@ -0,0 +1,105 @@ +# ----------------------------------------------------------------------------- +# (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. +# ----------------------------------------------------------------------------- + +# Configuration file for the Sphinx documentation builder. +# +# This file only contains a selection of the most common options. For a full +# list see the documentation: +# https://www.sphinx-doc.org/en/master/usage/configuration.html + +# -- Path setup -------------------------------------------------------------- + +# If extensions (or modules to document with autodoc) are in another directory, +# add these directories to sys.path here. If the directory is relative to the +# documentation root, use os.path.abspath to make it absolute, like shown here. +# + +# -- Project information ----------------------------------------------------- + +project = 'Shumlib' +copyright = 'Met Office' +author = 'Simulation Systems and Deployment Team' + + +# -- General configuration --------------------------------------------------- + +# Add any Sphinx extension module names here, as strings. They can be +# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom +# ones. +extensions = [ + 'sphinx_sitemap' +] + +language = "en" + +# Added to use dropdowns with command: pip install sphinx-design +extensions = [ + 'sphinx_design', + 'sphinx_copybutton', + 'sphinxcontrib.rsvgconverter', +] + +# Add any paths that contain templates here, relative to this directory. +templates_path = ['_templates'] + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +# This pattern also affects html_static_path and html_extra_path. +exclude_patterns = [".venv"] + +html_static_path = ["_static"] +html_css_files = ["custom.css"] +# -- Options for HTML output ------------------------------------------------- + +html_sidebars = { + "INSTALL": [], + "DEVELOP": [], +} +# The theme to use for HTML and HTML Help pages. See the documentation for +# a list of builtin themes. +# +html_theme = 'pydata_sphinx_theme' + +html_last_updated_fmt = '%Y-%m-%d %H:%M' +html_theme_options = { + "footer_start": ["crown-copyright", "last-updated"], + "footer_center": ["show-accessibility"], + "footer_end": ["sphinx-version", "theme-version"], + "navigation_with_keys": False, + "show_toc_level": 2, + "show_prev_next": True, + "navbar_align": "content", + "logo": { + "text": "Shumlib", + "image_light": "_static/MO_SQUARE_black_mono_for_light_backg_RBG.png", + "image_dark": "_static/MO_SQUARE_for_dark_backg_RBG.png", + }, + "icon_links": [ + { + "name": "GitHub", + "url": "https://github.com/MetOffice/shumlib", + "icon": "fa-brands fa-github" + }, + { + "name": "GitHub Discussions", + "url": "https://github.com/MetOffice/simulation-systems/discussions", + "icon": "far fa-comments", + }, + ], +} + +html_context = { + "default_mode": "auto", +} +# Hide the link which shows the rst markup +html_show_sourcelink = False + +# -- Options for linkcheck builder ------------------------------------------- +linkcheck_anchors = False +linkcheck_ignore = [ + r'.*\.py$', # Ignores URLs ending with .py + r'https://github.com/MetOffice/um*', +] diff --git a/doc/README.rst b/doc/index.rst similarity index 92% rename from doc/README.rst rename to doc/index.rst index 87ed73a..4d0e82e 100644 --- a/doc/README.rst +++ b/doc/index.rst @@ -7,7 +7,7 @@ What is Shumlib? Shumlib is the collective name for a set of libraries which are used by the UM; the UK Met Office's Unified Model, that may be of use to external tools or applications where identical functionality is desired. The hope of the project -is to enable developers to quickly and easily access parts of the UM code that +is to enable developers to quickly and easily access parts of the UM code that are commonly duplicated elsewhere, at the same time benefiting from any improvements or optimisations that might be made in support of the UM itself. @@ -17,7 +17,7 @@ Shumlib Licensing Although the UM has a restricted commercial licence, code that is moved into Shumlib has been assessed and re-classified under the more permissive BSD 3-Clause licence. The aim of this is to allow maximum flexibility and as few -barriers to usage as possible. However we would still encourage the feedback of +barriers to usage as possible. However we would still encourage the feedback of modifications and developments (particularly bugfixes) rather than modified redistribution. @@ -29,8 +29,15 @@ installation/build guide which details how to configure and build Shumlib (``INSTALL.rst``), a series of API Reference guides which describe the exposed interfaces for each library (``API-SHUM-\*.rst``), and a Developer's Guide which contains more in-depth information for developers of Shumlib itself -(``DEVELOP.rst``). Additionally, there are some technical papers +(``DEVELOP.rst``). Additionally, there are some technical papers (``TECHNICAL-\*.rst``) which go into more in-depth technical detail about some aspects of Shumlib, which are not necessarily required knowledge for all developers or users. +.. toctree:: + :maxdepth: 2 + :hidden: + + INSTALL + DEVELOP + API_REF/CONTENTS diff --git a/fortitude.toml b/fortitude.toml new file mode 100644 index 0000000..eb7272a --- /dev/null +++ b/fortitude.toml @@ -0,0 +1,12 @@ +[check] +exclude = [ + '.venv', + 'fruit/fruit.f90', + 'fruit/fruit_mpi.f90', +] +ignore = [ + 'C003', # implicit-external-procedures + 'C071', # assumed-size + 'C072', # assumed-size-character-intent + 'E001', # syntax-error +] 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 4d201c6..66fef6f 100644 --- a/fruit/fruit.f90 +++ b/fruit/fruit.f90 @@ -186,8 +186,8 @@ end function equalEpsilon64 function real32Equal (number1, number2 ) result (resultValue) real(kind=real32) , intent (in) :: number1, number2 - real(kind=real32) :: epsilon - logical(kind=bool) :: resultValue + real(kind=real32) :: epsilon + logical(kind=bool) :: resultValue resultValue = .false. epsilon = 1E-6 @@ -195,7 +195,7 @@ function real32Equal (number1, number2 ) result (resultValue) ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -206,8 +206,8 @@ end function real32Equal function real64Equal (number1, number2 ) result (resultValue) real(kind=real64) , intent (in) :: number1, number2 - real(kind=real64) :: epsilon - logical(kind=bool) :: resultValue + real(kind=real64) :: epsilon + logical(kind=bool) :: resultValue resultValue = .false. epsilon = 1E-6 @@ -215,7 +215,7 @@ function real64Equal (number1, number2 ) result (resultValue) ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -226,24 +226,24 @@ end function real64Equal function integer32Equal (number1, number2 ) result (resultValue) integer(kind=int32) , intent (in) :: number1, number2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. - if ( number1 .eq. number2 ) then + if ( number1 == number2 ) then resultValue = .true. - else + else resultValue = .false. end if end function integer32Equal function integer64Equal (number1, number2 ) result (resultValue) integer(kind=int64) , intent (in) :: number1, number2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. - if ( number1 .eq. number2 ) then + if ( number1 == number2 ) then resultValue = .true. else resultValue = .false. @@ -252,18 +252,18 @@ end function integer64Equal function stringEqual (str1, str2 ) result (resultValue) character(*) , intent (in) :: str1, str2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. - if ( str1 .eq. str2 ) then + if ( str1 == str2 ) then resultValue = .true. end if end function stringEqual function logicalEqual (l1, l2 ) result (resultValue) logical(kind=bool), intent (in) :: l1, l2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. @@ -300,7 +300,7 @@ module fruit character (len = 50) :: xml_filename_work = XML_FN_WORK_DEF integer, parameter :: MAX_NUM_FAILURES_IN_XML = 10 - integer, parameter :: XML_LINE_LENGTH = 2670 + integer, parameter :: XML_LINE_LENGTH = 2670 !! xml_line_length >= max_num_failures_in_xml * (msg_length + 1) + 50 integer, parameter :: STRLEN_T = 12 @@ -593,7 +593,7 @@ module fruit module procedure add_fail_ module procedure add_fail_unit_ end interface - + public :: addFail interface addFail module procedure add_fail_ @@ -732,12 +732,12 @@ module fruit interface fruit_if_case_failed module procedure fruit_if_case_failed_ end interface - + public :: fruit_hide_dots interface fruit_hide_dots module procedure fruit_hide_dots_ end interface - + public :: fruit_show_dots interface fruit_show_dots module procedure fruit_show_dots_ @@ -801,16 +801,16 @@ subroutine init_fruit_xml_(rank) write(XML_OPEN, '( "failures=""1"" " )', advance = "no") write(XML_OPEN, '( "name=""", a, """ ")', advance = "no") "name of test suite" write(XML_OPEN, '( "id=""1"">")') - + write(XML_OPEN, & & '(" ")') & & "dummy_testcase", "dummy_classname", "0" - + write(XML_OPEN, '(a)', advance = "no") " " write(XML_OPEN, '(" ")') - + write(XML_OPEN, '(" ")') write(XML_OPEN, '("")') close(XML_OPEN) @@ -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 @@ -1298,7 +1300,7 @@ subroutine make_error_msg_ (var1, var2, if_is, message) logical, intent(in) :: if_is character(*), intent(in), optional :: message - msg = '[' // trim(strip(case_name)) // ']: ' + msg = '[' // trim(strip(case_name)) // ']: ' if (if_is) then msg = trim(msg) // 'Expected' else @@ -1489,7 +1491,7 @@ end subroutine assert_false_ subroutine assert_eq_logical_(var1, var2, message) logical(kind=bool), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message if (var1 .neqv. var2) then @@ -1507,7 +1509,7 @@ subroutine assert_eq_1d32_logical_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i logical(kind=bool), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (var1(i) .neqv. var2(i)) then @@ -1525,7 +1527,7 @@ subroutine assert_eq_2d32_logical_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j logical(kind=bool), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1545,7 +1547,7 @@ subroutine assert_eq_1d64_logical_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i logical(kind=bool), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (var1(i) .neqv. var2(i)) then @@ -1563,7 +1565,7 @@ subroutine assert_eq_2d64_logical_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j logical(kind=bool), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1582,7 +1584,7 @@ end subroutine assert_eq_2d64_logical_ subroutine assert_eq_string_(var1, var2, message) character (len = *), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message if (trim(strip(var1)) /= trim(strip(var2))) then @@ -1600,7 +1602,7 @@ subroutine assert_eq_1d32_string_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i character (len = *), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (trim(strip(var1(i))) /= trim(strip(var2(i)))) then @@ -1618,7 +1620,7 @@ subroutine assert_eq_2d32_string_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j character (len = *), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1638,7 +1640,7 @@ subroutine assert_eq_1d64_string_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i character (len = *), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (trim(strip(var1(i))) /= trim(strip(var2(i)))) then @@ -1656,7 +1658,7 @@ subroutine assert_eq_2d64_string_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j character (len = *), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1675,7 +1677,7 @@ end subroutine assert_eq_2d64_string_ subroutine assert_eq_int32_(var1, var2, message) integer(kind=int32), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message if (var1 /= var2) then @@ -1693,7 +1695,7 @@ subroutine assert_eq_1d32_int32_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i integer(kind=int32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (var1(i) /= var2(i)) then @@ -1711,7 +1713,7 @@ subroutine assert_eq_2d32_int32_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j integer(kind=int32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1731,7 +1733,7 @@ subroutine assert_eq_1d64_int32_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i integer(kind=int32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (var1(i) /= var2(i)) then @@ -1749,7 +1751,7 @@ subroutine assert_eq_2d64_int32_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j integer(kind=int32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1768,7 +1770,7 @@ end subroutine assert_eq_2d64_int32_ subroutine assert_eq_int64_(var1, var2, message) integer(kind=int64), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message if (var1 /= var2) then @@ -1786,7 +1788,7 @@ subroutine assert_eq_1d32_int64_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i integer(kind=int64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (var1(i) /= var2(i)) then @@ -1804,7 +1806,7 @@ subroutine assert_eq_2d32_int64_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j integer(kind=int64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1824,7 +1826,7 @@ subroutine assert_eq_1d64_int64_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i integer(kind=int64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if (var1(i) /= var2(i)) then @@ -1842,7 +1844,7 @@ subroutine assert_eq_2d64_int64_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j integer(kind=int64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1861,7 +1863,7 @@ end subroutine assert_eq_2d64_int64_ subroutine assert_eq_real32_(var1, var2, message) real(kind=real32), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message if ((var1 < var2) .or. (var1 > var2)) then @@ -1896,7 +1898,7 @@ subroutine assert_eq_1d32_real32_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i real(kind=real32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if ((var1(i) < var2(i)) .or. (var1(i) > var2(i))) then @@ -1932,7 +1934,7 @@ subroutine assert_eq_2d32_real32_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j real(kind=real32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -1972,7 +1974,7 @@ subroutine assert_eq_1d64_real32_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i real(kind=real32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if ((var1(i) < var2(i)) .or. (var1(i) > var2(i))) then @@ -2008,7 +2010,7 @@ subroutine assert_eq_2d64_real32_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j real(kind=real32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -2047,7 +2049,7 @@ end subroutine assert_eq_2d64_real32_in_range_ subroutine assert_eq_real64_(var1, var2, message) real(kind=real64), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message if ((var1 < var2) .or. (var1 > var2)) then @@ -2082,7 +2084,7 @@ subroutine assert_eq_1d32_real64_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i real(kind=real64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if ((var1(i) < var2(i)) .or. (var1(i) > var2(i))) then @@ -2118,7 +2120,7 @@ subroutine assert_eq_2d32_real64_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j real(kind=real64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -2158,7 +2160,7 @@ subroutine assert_eq_1d64_real64_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i real(kind=real64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message do i = 1, n if ((var1(i) < var2(i)) .or. (var1(i) > var2(i))) then @@ -2194,7 +2196,7 @@ subroutine assert_eq_2d64_real64_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j real(kind=real64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message do j = 1, m do i = 1, n @@ -2233,7 +2235,7 @@ end subroutine assert_eq_2d64_real64_in_range_ subroutine assert_not_equals_logical_(var1, var2, message) logical(kind=bool), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2257,7 +2259,7 @@ subroutine assert_not_equals_1d32_logical_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i logical(kind=bool), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2281,7 +2283,7 @@ subroutine assert_not_equals_2d32_logical_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j logical(kind=bool), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2307,7 +2309,7 @@ subroutine assert_not_equals_1d64_logical_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i logical(kind=bool), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2331,7 +2333,7 @@ subroutine assert_not_equals_2d64_logical_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j logical(kind=bool), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2356,7 +2358,7 @@ end subroutine assert_not_equals_2d64_logical_ subroutine assert_not_equals_string_(var1, var2, message) character (len = *), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2380,7 +2382,7 @@ subroutine assert_not_equals_1d32_string_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i character (len = *), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2404,7 +2406,7 @@ subroutine assert_not_equals_2d32_string_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j character (len = *), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2430,7 +2432,7 @@ subroutine assert_not_equals_1d64_string_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i character (len = *), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2454,7 +2456,7 @@ subroutine assert_not_equals_2d64_string_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j character (len = *), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2479,7 +2481,7 @@ end subroutine assert_not_equals_2d64_string_ subroutine assert_not_equals_int32_(var1, var2, message) integer(kind=int32), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2503,7 +2505,7 @@ subroutine assert_not_equals_1d32_int32_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i integer(kind=int32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2527,7 +2529,7 @@ subroutine assert_not_equals_2d32_int32_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j integer(kind=int32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2553,7 +2555,7 @@ subroutine assert_not_equals_1d64_int32_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i integer(kind=int32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2577,7 +2579,7 @@ subroutine assert_not_equals_2d64_int32_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j integer(kind=int32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2602,7 +2604,7 @@ end subroutine assert_not_equals_2d64_int32_ subroutine assert_not_equals_int64_(var1, var2, message) integer(kind=int64), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2626,7 +2628,7 @@ subroutine assert_not_equals_1d32_int64_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i integer(kind=int64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2650,7 +2652,7 @@ subroutine assert_not_equals_2d32_int64_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j integer(kind=int64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2676,7 +2678,7 @@ subroutine assert_not_equals_1d64_int64_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i integer(kind=int64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2700,7 +2702,7 @@ subroutine assert_not_equals_2d64_int64_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j integer(kind=int64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2725,7 +2727,7 @@ end subroutine assert_not_equals_2d64_int64_ subroutine assert_not_equals_real32_(var1, var2, message) real(kind=real32), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2772,7 +2774,7 @@ subroutine assert_not_equals_1d32_real32_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i real(kind=real32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2820,7 +2822,7 @@ subroutine assert_not_equals_2d32_real32_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j real(kind=real32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2872,7 +2874,7 @@ subroutine assert_not_equals_1d64_real32_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i real(kind=real32), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2920,7 +2922,7 @@ subroutine assert_not_equals_2d64_real32_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j real(kind=real32), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -2971,7 +2973,7 @@ end subroutine assert_not_equals_2d64_real32_in_range_ subroutine assert_not_equals_real64_(var1, var2, message) real(kind=real64), intent (in) :: var1, var2 - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -3018,7 +3020,7 @@ subroutine assert_not_equals_1d32_real64_(var1, var2, n, message) integer(kind=int32), intent (in) :: n integer(kind=int32) :: i real(kind=real64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -3066,7 +3068,7 @@ subroutine assert_not_equals_2d32_real64_(var1, var2, n, m, message) integer(kind=int32), intent (in) :: n, m integer(kind=int32) :: i, j real(kind=real64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -3118,7 +3120,7 @@ subroutine assert_not_equals_1d64_real64_(var1, var2, n, message) integer(kind=int64), intent (in) :: n integer(kind=int64) :: i real(kind=real64), intent (in) :: var1(n), var2(n) - + character(len = *), intent (in), optional :: message logical :: same_so_far @@ -3166,7 +3168,7 @@ subroutine assert_not_equals_2d64_real64_(var1, var2, n, m, message) integer(kind=int64), intent (in) :: n, m integer(kind=int64) :: i, j real(kind=real64), intent (in) :: var1(n, m), var2(n, m) - + character(len = *), intent (in), optional :: message logical :: same_so_far 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/fruit/fruit_f90_generator.rb b/fruit/fruit_f90_generator.rb index 20ddd14..cfcd87d 100755 --- a/fruit/fruit_f90_generator.rb +++ b/fruit/fruit_f90_generator.rb @@ -4,7 +4,7 @@ def generate_assertation(t, dim, has_range, equals = "1") #---- variable type ------ t_def = { "logical" => "logical(kind=bool)", - "string" => "character (len = *)", + "string" => "character (len = *)", "int32" => "integer(kind=int32)", "int64" => "integer(kind=int64)", "real32" => "real(kind=real32)", @@ -18,7 +18,7 @@ def generate_assertation(t, dim, has_range, equals = "1") t_eq = { "logical" => ".eqv.", } t_eq.default = "==" - + t_ne = { "logical" => ".neqv.", } t_ne.default = "/=" @@ -60,9 +60,9 @@ def generate_assertation(t, dim, has_range, equals = "1") ij = "(i, j)" ij_1st = "(1, 1)" nm = "(n, m)" - loop_from = " do j = 1, m" + "\n" + + loop_from = " do j = 1, m" + "\n" + " do i = 1, n" - loop_to = " enddo" + "\n" + + loop_to = " enddo" + "\n" + " enddo" pre_message = "'2d array #{trouble}, ' // " elsif dim == "1d64" @@ -113,7 +113,7 @@ def generate_assertation(t, dim, has_range, equals = "1") del_def_line = "#{del_def[t]}, intent (in) :: delta" condition = "abs(var1#{ij} - var2#{ij}) > delta" end - + #----- returns ------ if (equals) interface_eq = " module procedure " + name + "\n" @@ -183,11 +183,11 @@ def generate_assertation(t, dim, has_range, equals = "1") def many_assert() types = %w/ logical string int32 int64 real32 real64 / dims = %w/ 0d 1d32 2d32 1d64 2d64 / - + interface_eq = "" interface_neq = "" f90str = "" - + [1, nil].each{|if_equals| types.each {|t| dims.each {|dim| @@ -197,9 +197,9 @@ def many_assert() end range_loop.each{|has_range| - a_interface_eq, a_interface_neq, a_f90str = + a_interface_eq, a_interface_neq, a_f90str = generate_assertation(t, dim, has_range, if_equals) - + interface_eq += a_interface_eq interface_neq += a_interface_neq f90str += a_f90str diff --git a/fruit/fruit_f90_generator_3.4.1.rb b/fruit/fruit_f90_generator_3.4.1.rb index 451a0b3..da9084e 100755 --- a/fruit/fruit_f90_generator_3.4.1.rb +++ b/fruit/fruit_f90_generator_3.4.1.rb @@ -4,7 +4,7 @@ def generate_assertation(t, dim, has_range, equals = "1") #---- variable type ------ t_def = { "logical" => "logical", - "string" => "character (len = *)", + "string" => "character (len = *)", "int" => "integer", "real" => "real", "double" => "double precision", @@ -19,7 +19,7 @@ def generate_assertation(t, dim, has_range, equals = "1") t_eq = { "logical" => ".eqv.", } t_eq.default = "==" - + t_ne = { "logical" => ".neqv.", } t_ne.default = "/=" @@ -45,7 +45,7 @@ def generate_assertation(t, dim, has_range, equals = "1") elsif dim == "1d" name = base_name + "1d_" + t + "_" size = "n, " - integers_def = " integer, intent (in) :: n" + "\n" + + integers_def = " integer, intent (in) :: n" + "\n" + " integer :: i" ij = "(i)" ij_1st = "(1)" @@ -56,14 +56,14 @@ def generate_assertation(t, dim, has_range, equals = "1") elsif dim == "2d" name = base_name + "2d_" + t + "_" size = "n, m, " - integers_def = " integer, intent (in) :: n, m" + "\n" + + integers_def = " integer, intent (in) :: n, m" + "\n" + " integer :: i, j" ij = "(i, j)" ij_1st = "(1, 1)" nm = "(n, m)" - loop_from = " do j = 1, m" + "\n" + + loop_from = " do j = 1, m" + "\n" + " do i = 1, n" - loop_to = " enddo" + "\n" + + loop_to = " enddo" + "\n" + " enddo" pre_message = "'2d array #{trouble}, ' // " else @@ -95,7 +95,7 @@ def generate_assertation(t, dim, has_range, equals = "1") del_def_line = "#{del_def[t]}, intent (in) :: delta" condition = "abs(var1#{ij} - var2#{ij}) > delta" end - + #----- returns ------ if (equals) interface_eq = " module procedure " + name + "\n" @@ -165,11 +165,11 @@ def generate_assertation(t, dim, has_range, equals = "1") def many_assert() types = %w/ logical string int real double complex / dims = %w/ 0d 1d 2d / - + interface_eq = "" interface_neq = "" f90str = "" - + [1, nil].each{|if_equals| types.each {|t| dims.each {|dim| @@ -179,9 +179,9 @@ def many_assert() end range_loop.each{|has_range| - a_interface_eq, a_interface_neq, a_f90str = + a_interface_eq, a_interface_neq, a_f90str = generate_assertation(t, dim, has_range, if_equals) - + interface_eq += a_interface_eq interface_neq += a_interface_neq f90str += a_f90str diff --git a/fruit/fruit_f90_source.txt b/fruit/fruit_f90_source.txt index c006266..9f8cba4 100644 --- a/fruit/fruit_f90_source.txt +++ b/fruit/fruit_f90_source.txt @@ -186,8 +186,8 @@ contains function real32Equal (number1, number2 ) result (resultValue) real(kind=real32) , intent (in) :: number1, number2 - real(kind=real32) :: epsilon - logical(kind=bool) :: resultValue + real(kind=real32) :: epsilon + logical(kind=bool) :: resultValue resultValue = .false. epsilon = 1E-6 @@ -195,7 +195,7 @@ contains ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -206,8 +206,8 @@ contains function real64Equal (number1, number2 ) result (resultValue) real(kind=real64) , intent (in) :: number1, number2 - real(kind=real64) :: epsilon - logical(kind=bool) :: resultValue + real(kind=real64) :: epsilon + logical(kind=bool) :: resultValue resultValue = .false. epsilon = 1E-6 @@ -215,7 +215,7 @@ contains ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -226,20 +226,20 @@ contains function integer32Equal (number1, number2 ) result (resultValue) integer(kind=int32) , intent (in) :: number1, number2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. if ( number1 .eq. number2 ) then resultValue = .true. - else + else resultValue = .false. end if end function integer32Equal function integer64Equal (number1, number2 ) result (resultValue) integer(kind=int64) , intent (in) :: number1, number2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. @@ -252,7 +252,7 @@ contains function stringEqual (str1, str2 ) result (resultValue) character(*) , intent (in) :: str1, str2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. @@ -263,7 +263,7 @@ contains function logicalEqual (l1, l2 ) result (resultValue) logical(kind=bool), intent (in) :: l1, l2 - logical(kind=bool) :: resultValue + logical(kind=bool) :: resultValue resultValue = .false. @@ -300,7 +300,7 @@ module fruit character (len = 50) :: xml_filename_work = XML_FN_WORK_DEF integer, parameter :: MAX_NUM_FAILURES_IN_XML = 10 - integer, parameter :: XML_LINE_LENGTH = 2670 + integer, parameter :: XML_LINE_LENGTH = 2670 !! xml_line_length >= max_num_failures_in_xml * (msg_length + 1) + 50 integer, parameter :: STRLEN_T = 12 @@ -429,7 +429,7 @@ module fruit module procedure add_fail_ module procedure add_fail_unit_ end interface - + public :: addFail interface addFail module procedure add_fail_ @@ -568,12 +568,12 @@ module fruit interface fruit_if_case_failed module procedure fruit_if_case_failed_ end interface - + public :: fruit_hide_dots interface fruit_hide_dots module procedure fruit_hide_dots_ end interface - + public :: fruit_show_dots interface fruit_show_dots module procedure fruit_show_dots_ @@ -637,16 +637,16 @@ contains write(XML_OPEN, '( "failures=""1"" " )', advance = "no") write(XML_OPEN, '( "name=""", a, """ ")', advance = "no") "name of test suite" write(XML_OPEN, '( "id=""1"">")') - + write(XML_OPEN, & & '(" ")') & & "dummy_testcase", "dummy_classname", "0" - + write(XML_OPEN, '(a)', advance = "no") " " write(XML_OPEN, '(" ")') - + write(XML_OPEN, '(" ")') write(XML_OPEN, '("")') close(XML_OPEN) @@ -1134,7 +1134,7 @@ contains logical, intent(in) :: if_is character(*), intent(in), optional :: message - msg = '[' // trim(strip(case_name)) // ']: ' + msg = '[' // trim(strip(case_name)) // ']: ' if (if_is) then msg = trim(msg) // 'Expected' else diff --git a/fruit/fruit_f90_source_3.4.1.txt b/fruit/fruit_f90_source_3.4.1.txt index 1310e04..c487a99 100644 --- a/fruit/fruit_f90_source_3.4.1.txt +++ b/fruit/fruit_f90_source_3.4.1.txt @@ -24,9 +24,9 @@ module fruit_util private - + public :: equals, to_s, strip - + interface equals module procedure equalEpsilon module procedure floatEqual @@ -131,24 +131,24 @@ contains !------------------------ ! test if 2 values are close !------------------------ - !logical function equals (number1, number2) + !logical function equals (number1, number2) ! real, intent (in) :: number1, number2 - ! + ! ! return equalEpsilon (number1, number2, epsilon(number1)) ! !end function equals function equalEpsilon (number1, number2, epsilon ) result (resultValue) - real , intent (in) :: number1, number2, epsilon - logical :: resultValue + real , intent (in) :: number1, number2, epsilon + logical :: resultValue resultValue = .false. ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -160,8 +160,8 @@ contains function floatEqual (number1, number2 ) result (resultValue) real , intent (in) :: number1, number2 - real :: epsilon - logical :: resultValue + real :: epsilon + logical :: resultValue resultValue = .false. epsilon = 1E-6 @@ -169,7 +169,7 @@ contains ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -180,8 +180,8 @@ contains function doublePrecisionEqual (number1, number2 ) result (resultValue) double precision , intent (in) :: number1, number2 - real :: epsilon - logical :: resultValue + real :: epsilon + logical :: resultValue resultValue = .false. epsilon = 1E-6 @@ -190,7 +190,7 @@ contains ! test very small number1 if ( abs(number1) < epsilon .and. abs(number1 - number2) < epsilon ) then resultValue = .true. - else + else if ((abs(( number1 - number2)) / number1) < epsilon ) then resultValue = .true. else @@ -201,20 +201,20 @@ contains function integerEqual (number1, number2 ) result (resultValue) integer , intent (in) :: number1, number2 - logical :: resultValue + logical :: resultValue resultValue = .false. if ( number1 .eq. number2 ) then resultValue = .true. - else + else resultValue = .false. end if end function integerEqual function stringEqual (str1, str2 ) result (resultValue) character(*) , intent (in) :: str1, str2 - logical :: resultValue + logical :: resultValue resultValue = .false. @@ -225,7 +225,7 @@ contains function logicalEqual (l1, l2 ) result (resultValue) logical, intent (in) :: l1, l2 - logical :: resultValue + logical :: resultValue resultValue = .false. @@ -252,7 +252,7 @@ module fruit character (len = 50) :: xml_filename_work = XML_FN_WORK_DEF integer, parameter :: MAX_NUM_FAILURES_IN_XML = 10 - integer, parameter :: XML_LINE_LENGTH = 2670 + integer, parameter :: XML_LINE_LENGTH = 2670 !! xml_line_length >= max_num_failures_in_xml * (msg_length + 1) + 50 integer, parameter :: STRLEN_T = 12 @@ -381,7 +381,7 @@ module fruit module procedure add_fail_ module procedure add_fail_unit_ end interface - + public :: addFail interface addFail module procedure add_fail_ @@ -520,12 +520,12 @@ module fruit interface fruit_if_case_failed module procedure fruit_if_case_failed_ end interface - + public :: fruit_hide_dots interface fruit_hide_dots module procedure fruit_hide_dots_ end interface - + public :: fruit_show_dots interface fruit_show_dots module procedure fruit_show_dots_ @@ -589,16 +589,16 @@ contains write(XML_OPEN, '( "failures=""1"" " )', advance = "no") write(XML_OPEN, '( "name=""", a, """ ")', advance = "no") "name of test suite" write(XML_OPEN, '( "id=""1"">")') - + write(XML_OPEN, & & '(" ")') & & "dummy_testcase", "dummy_classname", "0" - + write(XML_OPEN, '(a)', advance = "no") " " write(XML_OPEN, '(" ")') - + write(XML_OPEN, '(" ")') write(XML_OPEN, '("")') close(XML_OPEN) @@ -1086,7 +1086,7 @@ contains logical, intent(in) :: if_is character(*), intent(in), optional :: message - msg = '[' // trim(strip(case_name)) // ']: ' + msg = '[' // trim(strip(case_name)) // ']: ' if (if_is) then msg = trim(msg) // 'Expected' else diff --git a/make/meto-x86-gfortran-gcc.mk b/make/meto-azspice-gfortran-gcc.mk similarity index 96% rename from make/meto-x86-gfortran-gcc.mk rename to make/meto-azspice-gfortran-gcc.mk index 3f27e07..3af10ca 100644 --- a/make/meto-x86-gfortran-gcc.mk +++ b/make/meto-azspice-gfortran-gcc.mk @@ -15,7 +15,7 @@ FPPFLAGS_BASE=-C -P -undef -nostdinc # Any other flags (to be passed to all preprocessing commands) FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option # IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true +SHUM_HAS_IEEE_ARITHMETIC ?= false ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) @@ -45,7 +45,7 @@ FCFLAGS_OPENMP=-fopenmp FCFLAGS_NOOPENMP= # Any other flags (to be passed to all compilation commands) FCFLAGS_EXTRA=-std=f2008ts -pedantic -pedantic-errors -fno-range-check \ - -Wall -Wextra -Werror -Wno-compare-reals -Wno-conversion \ + -Wall -Wextra -Werror -Wno-compare-reals -Wconversion \ -Wno-unused-dummy-argument -Wno-c-binding-type \ -fdiagnostics-show-option # Flag used to set PIC (Position-independent-code; required by dynamic lib @@ -101,7 +101,7 @@ AR=ar -rc # Set the name of this platform; this will be included as the name of the # top-level directory in the build -PLATFORM=meto-x86-gfortran-gcc +PLATFORM=meto-azspce-gfortran-gcc # Proceed to include the rest of the common makefile include Makefile diff --git a/make/meto-ex1a-crayftn12.0.1+-craycc.mk b/make/meto-ex1a-crayftn12.0.1+-craycc.mk index 23d5a6c..7cb5962 100644 --- a/make/meto-ex1a-crayftn12.0.1+-craycc.mk +++ b/make/meto-ex1a-crayftn12.0.1+-craycc.mk @@ -9,10 +9,6 @@ MAKE=make # Note that on the EX1A only Dynamic linking is supported SHUM_BUILD_STATIC=false -# To prevent spiral search being compiled with a multithreaded -# library it can't use, set openmp off for Cray EX1A builds -SHUM_OPENMP=false - # Fortran #-------- FPP=cpp diff --git a/make/meto-ex1a-gfortran-gcc.mk b/make/meto-ex1a-gfortran-gcc.mk index bb30a80..d17f4b1 100644 --- a/make/meto-ex1a-gfortran-gcc.mk +++ b/make/meto-ex1a-gfortran-gcc.mk @@ -47,11 +47,11 @@ FCFLAGS_OPENMP=-fopenmp FCFLAGS_NOOPENMP= # Any other flags (to be passed to all compilation commands) FCFLAGS_EXTRA=-std=f2008ts -pedantic -pedantic-errors -fno-range-check \ - -Wall -Wextra -Werror -Wno-compare-reals -Wno-conversion \ + -Wall -Wextra -Werror -Wno-compare-reals -Wconversion \ -Wno-unused-dummy-argument -Wno-c-binding-type \ -Wno-unused-function -fdiagnostics-show-option # Flags to set paths for the dynamic library builds -LDFLAGS= -Wl,-rpath,/opt/cray/pe/gcc/10.3.0/snos/lib64 +LDFLAGS= -Wl,-rpath,/opt/cray/pe/gcc/10.3.0/snos/lib64 -Wl,--as-needed # Flag used to set PIC (Position-independent-code; required by dynamic lib # and so will only be passed to compile objects destined for the dynamic lib) FCFLAGS_PIC=-fPIC ${LDFLAGS} diff --git a/make/meto-x86-ifort12+-clang.mk b/make/meto-x86-ifort12+-clang.mk deleted file mode 100644 index c732fda..0000000 --- a/make/meto-x86-ifort12+-clang.mk +++ /dev/null @@ -1,15 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Note that the below are overrides for the main ifort config, due to changes -# in some of the supported flags - -# Also note that it's possible this config will work for versions earlier -# than ifort 12 - this was just the earliest version available for testing - -# At ifort 15 the option to enable OpenMP was changed to -qopenmp -FCFLAGS_OPENMP=-openmp - -# Pickup the remaining config details from the more recent config -include make/meto-x86-ifort15+-clang.mk - diff --git a/make/meto-x86-ifort12+-gcc.mk b/make/meto-x86-ifort12+-gcc.mk deleted file mode 100644 index 2879ab8..0000000 --- a/make/meto-x86-ifort12+-gcc.mk +++ /dev/null @@ -1,14 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Note that the below are overrides for the main ifort config, due to changes -# in some of the supported flags - -# Also note that it's possible this config will work for versions earlier -# than ifort 12 - this was just the earliest version available for testing - -# At ifort 15 the option to enable OpenMP was changed to -qopenmp -FCFLAGS_OPENMP=-openmp - -# Pickup the remaining config details from the more recent config -include make/meto-x86-ifort15+-gcc.mk diff --git a/make/meto-x86-ifort15+-clang.mk b/make/meto-x86-ifort15+-clang.mk deleted file mode 100644 index 75c9c3e..0000000 --- a/make/meto-x86-ifort15+-clang.mk +++ /dev/null @@ -1,101 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=ifort -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC=-fp-model precise -# Flag used to set OpenMP (passed to all compilation commands) -FCFLAGS_OPENMP ?= -qopenmp -# Flag used to unset OpenMP (passed to all compilation commands) -FCFLAGS_NOOPENMP= -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA=-standard-semantics -assume nostd_mod_proc_name -std03 -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-fPIC -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-shared -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC= -FCFLAGS_DYNAMIC_TRAIL=-Wl,-rpath=${LIBDIR_OUT}/lib -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC=-Bstatic -FCFLAGS_STATIC_TRAIL= - -# C -#-- -# Compiler command -CC=clang -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_OPENMP=-Wno-source-uses-openmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_OPENMP=-Wno-source-uses-openmp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_NOOPENMP=-Wno-source-uses-openmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_NOOPENMP=-Wno-source-uses-openmp -endif - -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-std=c99 -Weverything -Werror -Wno-vla -Wno-padded \ - -Wno-missing-noreturn -pedantic -pedantic-errors \ - -fdiagnostics-show-option -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-fPIC - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-x86-ifort-clang - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/make/meto-x86-ifort15+-gcc.mk b/make/meto-x86-ifort15+-gcc.mk deleted file mode 100644 index c1c960a..0000000 --- a/make/meto-x86-ifort15+-gcc.mk +++ /dev/null @@ -1,103 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=ifort -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC=-fp-model precise -# Flag used to set OpenMP (passed to all compilation commands) -FCFLAGS_OPENMP ?= -qopenmp -# Flag used to unset OpenMP (passed to all compilation commands) -FCFLAGS_NOOPENMP= -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA=-standard-semantics -assume nostd_mod_proc_name -std03 -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-fPIC -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-shared -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC= -FCFLAGS_DYNAMIC_TRAIL=-Wl,-rpath=${LIBDIR_OUT}/lib -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC=-Bstatic -FCFLAGS_STATIC_TRAIL= - -# C -#-- -# Compiler command -CC=gcc -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_OPENMP=-fopenmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_OPENMP=-fopenmp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -endif - -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-std=c99 -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 \ - -fdiagnostics-show-option -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-fPIC - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-x86-ifort-gcc - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/make/meto-x86-nagfor-gcc.mk b/make/meto-x86-nagfor-gcc.mk deleted file mode 100644 index 361210b..0000000 --- a/make/meto-x86-nagfor-gcc.mk +++ /dev/null @@ -1,115 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# SHUM_OPENMP is tested in this file, but is not set by default until the main -# makefile is included. We therefore need to set a default here. -SHUM_OPENMP ?= true - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=nagfor -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -FCFLAGS_OPENMP= -# Flag used to unset OpenMP (passed to all compilation commands) -FCFLAGS_NOOPENMP= -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA=-ieee=full -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-pic -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-Wl,-shared -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC= -ifeq (${SHUM_OPENMP}, true) -FCFLAGS_DYNAMIC_TRAIL=-lgomp -Wl,-Wl,,-rpath=${LIBDIR_OUT}/lib -else ifeq (${SHUM_OPENMP}, false) -FCFLAGS_DYNAMIC_TRAIL=-Wl,-Wl,,-rpath=${LIBDIR_OUT}/lib -endif -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC=-Bstatic -ifeq (${SHUM_OPENMP}, true) -FCFLAGS_STATIC_TRAIL=-Bdynamic -lgomp -Wl,-Wl,,-rpath=${LIBDIR_OUT}/lib -else ifeq (${SHUM_OPENMP}, false) -FCFLAGS_STATIC_TRAIL=-Bdynamic -Wl,-Wl,,-rpath=${LIBDIR_OUT}/lib -endif - -# C -#-- -# Compiler command -CC=gcc -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_OPENMP=-fopenmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_OPENMP=-fopenmp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -endif - -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-std=c99 -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 \ - -fdiagnostics-show-option -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-fPIC - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-x86-nagfor-gcc - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/make/meto-x86-portland-gcc.mk b/make/meto-x86-portland-gcc.mk deleted file mode 100644 index 4bf7201..0000000 --- a/make/meto-x86-portland-gcc.mk +++ /dev/null @@ -1,115 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# SHUM_OPENMP is tested in this file, but is not set by default until the main -# makefile is included. We therefore need to set a default here. -SHUM_OPENMP ?= true - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= false -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=pgfortran -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -FCFLAGS_OPENMP= -# Flag used to unset OpenMP (passed to all compilation commands) -FCFLAGS_NOOPENMP= -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA=-Mallocatable=03 -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-fPIC -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-shared -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC= -ifeq (${SHUM_OPENMP}, true) -FCFLAGS_DYNAMIC_TRAIL=-lgomp -Wl,-rpath=${LIBDIR_OUT}/lib -else ifeq (${SHUM_OPENMP}, false) -FCFLAGS_DYNAMIC_TRAIL=-Wl,-rpath=${LIBDIR_OUT}/lib -endif - -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC=-Bstatic -Bstatic_pgi -ifeq (${SHUM_OPENMP}, true) -FCFLAGS_STATIC_TRAIL=-Bdynamic -lnuma -lgomp -else ifeq (${SHUM_OPENMP}, false) -FCFLAGS_STATIC_TRAIL=-Bdynamic -lnuma -endif - -# C -#-- -# Compiler command -CC=gcc -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_OPENMP=-fopenmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_OPENMP=-fopenmp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -endif -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-std=c99 -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 \ - -fdiagnostics-show-option -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-fPIC - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-x86-portland-gcc - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/make/meto-xc40-crayftn8.3.4+-craycc.mk b/make/meto-xc40-crayftn8.3.4+-craycc.mk deleted file mode 100644 index 2d151a8..0000000 --- a/make/meto-xc40-crayftn8.3.4+-craycc.mk +++ /dev/null @@ -1,16 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Note that the below are overrides for the main cce config, due to changes -# in some of the supported flags - -# Also note that it's possible this config will work for versions earlier -# than CCE 8.3.4 - this was just the earliest version available for testing - -# At CCE 8.4.0 a new "-herror_on_warning" flag was added for crayftn, but -# won't work at earlier versions (so this line omits it) -FCFLAGS_EXTRA=-O2 -Ovector1 -hfp0 -hflex_mp=strict -hipa1 -hnopgas_runtime \ - -hnocaf -M E287,E5001 - -# Pickup the remaining config details from the more recent config -include make/meto-xc40-crayftn8.4.0+-craycc.mk diff --git a/make/meto-xc40-crayftn8.4.0+-craycc.mk b/make/meto-xc40-crayftn8.4.0+-craycc.mk deleted file mode 100644 index e40c67b..0000000 --- a/make/meto-xc40-crayftn8.4.0+-craycc.mk +++ /dev/null @@ -1,105 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=ftn -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -FCFLAGS_OPENMP=-h omp -# Flag used to unset OpenMP (passed to all compilation commands) -FCFLAGS_NOOPENMP=-h noomp -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA ?= -O2 -Ovector1 -hfp0 -hflex_mp=strict -hipa1 -hnopgas_runtime \ - -hnocaf -herror_on_warning -M E287,E5001 -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-h pic -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-shared -L${CRAYLIBS_X86_64} -lomp -lmodules -ifdef SHUM_OPENMP -ifeq (${SHUM_OPENMP}, false) -FCFLAGS_SHARED=-shared -L${CRAYLIBS_X86_64} -lmodules -endif -endif -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC=-dynamic -FCFLAGS_DYNAMIC_TRAIL=-Wl,-rpath=${LIBDIR_OUT}/lib -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC=-static -FCFLAGS_STATIC_TRAIL= - -# C -#-- -# Compiler command -CC=cc -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_OPENMP=-homp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_OPENMP=-homp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_NOOPENMP=-h noomp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_NOOPENMP=-h noomp -endif - -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-O3 -h c99 -hconform -hstdc -hnotolerant -hnognu -hnopgas_runtime -herror_on_warning -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-h pic - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-xc40-crayftn-craycc - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/make/meto-xc40-gfortran-gcc.mk b/make/meto-xc40-gfortran-gcc.mk deleted file mode 100644 index c6d377b..0000000 --- a/make/meto-xc40-gfortran-gcc.mk +++ /dev/null @@ -1,106 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=ftn -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -FCFLAGS_OPENMP=-fopenmp -# Flag used to unset OpenMP (passed to all compilation commands) -FCFLAGS_NOOPENMP= -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA=-std=f2008ts -pedantic -pedantic-errors -fno-range-check \ - -Wall -Wextra -Werror -Wno-compare-reals -Wno-conversion \ - -Wno-unused-dummy-argument -Wno-c-binding-type \ - -Wno-unused-function -fdiagnostics-show-option -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-fPIC -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-shared -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC=-dynamic -FCFLAGS_DYNAMIC_TRAIL=-Wl,-rpath=${LIBDIR_OUT}/lib -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC= -FCFLAGS_STATIC_TRAIL= - -# C -#-- -# Compiler command -CC=cc -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_OPENMP=-fopenmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_OPENMP=-fopenmp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -CCFLAGS_NOOPENMP=-Wno-unknown-pragmas -endif - -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-std=c99 -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 \ - -fdiagnostics-show-option -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-fPIC - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-xc40-gfortran-gcc - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/make/meto-xc40-ifort-icc.mk b/make/meto-xc40-ifort-icc.mk deleted file mode 100644 index 3c6aec4..0000000 --- a/make/meto-xc40-ifort-icc.mk +++ /dev/null @@ -1,99 +0,0 @@ -# Platform specific settings -#------------------------------------------------------------------------------- - -# Make -#----- -# Make command -MAKE=make - -# Fortran -#-------- -FPP=cpp -# Any flags required to make the preprocessor function correctly -FPPFLAGS_BASE=-C -P -undef -nostdinc -# Any other flags (to be passed to all preprocessing commands) -FPPFLAGS_EXTRA=-Wall -Wtraditional -Werror -fdiagnostics-show-option -# IEEE Arithmetic -SHUM_HAS_IEEE_ARITHMETIC ?= true -ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, true) -FPPFLAGS_IEEE=-DHAS_IEEE_ARITHMETIC -else ifeq (${SHUM_HAS_IEEE_ARITHMETIC}, false) -FPPFLAGS_IEEE= -endif -SHUM_EVAL_NAN_BY_BITS ?= true -ifeq (${SHUM_EVAL_NAN_BY_BITS}, true) -FPPFLAGS_ENBB=-DEVAL_NAN_BY_BITS -else ifeq (${SHUM_EVAL_NAN_BY_BITS}, false) -FPPFLAGS_ENBB= -endif -SHUM_EVAL_DENORMAL_BY_BITS ?= true -ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, true) -FPPFLAGS_EDBB=-DEVAL_DENORMAL_BY_BITS -else ifeq (${SHUM_EVAL_DENORMAL_BY_BITS}, false) -FPPFLAGS_EDBB= -endif -# Combine the preprocessor flags -FPPFLAGS=${FPPFLAGS_BASE} ${FPPFLAGS_IEEE} ${FPPFLAGS_ENBB} ${FPPFLAGS_EDBB} ${FPPFLAGS_EXTRA} -# Compiler command -FC=ftn -# Precision flags (passed to all compilation commands) -FCFLAGS_PREC=-fp-model precise -# Flag used to set OpenMP (passed to all compilation commands) -SHUM_USE_C_OPENMP_VIA_THREAD_UTILS ?= false -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -FCFLAGS_OPENMP=-qopenmp -DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -FCFLAGS_OPENMP=-qopenmp -endif -# Flag used to unset OpenMP (passed to all compilation commands) -ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, true) -FCFLAGS_NOOPENMP=-DSHUM_USE_C_OPENMP_VIA_THREAD_UTILS=shum_use_c_openmp_via_thread_utils -D_OPENMP -else ifeq (${SHUM_USE_C_OPENMP_VIA_THREAD_UTILS}, false) -FCFLAGS_NOOPENMP= -endif - -# Any other flags (to be passed to all compilation commands) -FCFLAGS_EXTRA=-standard-semantics -assume nostd_mod_proc_name -std03 -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -FCFLAGS_PIC=-fPIC -# Flags used to toggle the building of a dynamic (shared) library -FCFLAGS_SHARED=-shared -# Flags used for compiling a dynamically linked test executable; in some cases -# control of this is argument order dependent - for these cases the first -# variable will be inserted before the link commands and the second will be -# inserted afterwards -FCFLAGS_DYNAMIC=-dynamic -FCFLAGS_DYNAMIC_TRAIL=-Wl,-rpath=${LIBDIR_OUT}/lib -# Flags used for compiling a statically linked test executable (following the -# same rules as the dynamic equivalents - see above comment) -FCFLAGS_STATIC= -FCFLAGS_STATIC_TRAIL= - -# C -#-- -# Compiler command -CC=cc -# Precision flags (passed to all compilation commands) -CCFLAGS_PREC= -# Flag used to set OpenMP (passed to all compilation commands) -CCFLAGS_OPENMP=-qopenmp -# Flag used to unset OpenMP (passed to all compilation commands) -CCFLAGS_NOOPENMP=-diag-disable 3180 -# Any other flags (to be passed to all compilation commands) -CCFLAGS_EXTRA=-std=c99 -w3 -Werror-all -no-inline-max-size -# Flag used to set PIC (Position-independent-code; required by dynamic lib -# and so will only be passed to compile objects destined for the dynamic lib) -CCFLAGS_PIC=-fPIC - -# Archiver -#--------- -# Archiver command -AR=ar -rc - -# Set the name of this platform; this will be included as the name of the -# top-level directory in the build -PLATFORM=meto-xc40-ifort-icc - -# Proceed to include the rest of the common makefile -include Makefile diff --git a/pyproject.toml b/pyproject.toml new file mode 100644 index 0000000..302d7a3 --- /dev/null +++ b/pyproject.toml @@ -0,0 +1,39 @@ +# (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. + +[project] +name = "shumlib" +# dynamic = ["version"] +version = "26.1.0" +description = "Set of libraries used by the Met Office Unified Model (UM)" +authors = [ + {name = "Met Office", email = "enquiries@metoffice.gov.uk"}, +] +maintainers = [ + {name = "SSD Team", email = "umsysteam@metoffice.gov.uk"}, +] +licence = { file = "../LICENCE" } +homepage = "https://metoffice.github.com/shumlib" +repository = "https://github.com/MetOffice/shumlib" +keywords = ["SHUM", "library"] +classifiers = [ + "Development Status :: 5 - Production/Stable", + "Intended Audience :: UM Developers", + "License :: OSI Approved :: BSD-3-Clause License", + "Programming Language :: Fortran, C", + ] + +requires-python = ">=3.11" +dependencies = [ + "fortitude-lint == 0.7.5", + "cpplint == 2.0.2", + "sphinx == 8.2.3", + "sphinx-lint == 1.0.0", + "pydata-sphinx-theme == 0.16.1", + "sphinx-design == 0.6.1", + "sphinx-copybutton == 0.5.2", + "sphinx-lint == 1.0.0", + "sphinx-sitemap == 2.8.0", + "sphinxcontrib-svg2pdfconverter == 1.3.0" +] diff --git a/scripts/icm_install_shumlib.sh b/scripts/icm_install_shumlib.sh index 7c9b815..ac2a1d4 100755 --- a/scripts/icm_install_shumlib.sh +++ b/scripts/icm_install_shumlib.sh @@ -1,31 +1,31 @@ #!/bin/bash # *********************************COPYRIGHT************************************ -# (C) Crown copyright Met Office. All rights reserved. -# For further details please refer to the file LICENCE.txt -# which you should have received as part of this distribution. +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file LICENCE.txt +# which you should have received as part of this distribution. # *********************************COPYRIGHT************************************ -# -# This file is part of the UM Shared Library project. -# -# The UM Shared Library is free software: you can redistribute it -# and/or modify it under the terms of the Modified BSD License, as -# published by the Open Source Initiative. -# -# The UM Shared Library is distributed in the hope that it will be -# useful, but WITHOUT ANY WARRANTY; without even the implied warranty -# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# Modified BSD License for more details. -# -# You should have received a copy of the Modified BSD License -# along with the UM Shared Library. -# If not, see . +# +# This file is part of the UM Shared Library project. +# +# The UM Shared Library is free software: you can redistribute it +# and/or modify it under the terms of the Modified BSD License, as +# published by the Open Source Initiative. +# +# The UM Shared Library is distributed in the hope that it will be +# useful, but WITHOUT ANY WARRANTY; without even the implied warranty +# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# Modified BSD License for more details. +# +# You should have received a copy of the Modified BSD License +# along with the UM Shared Library. +# If not, see . #******************************************************************************* # # Script to assist with installing shumlib under the many platform/compiler # combinations available at the Met Office... # # USAGE: (Note - must be run from the toplevel Shumlib directory!) -# scripts/meto_install_shumlib.sh [xc40|x86] +# scripts/meto_install_shumlib.sh [xc40|x86] # # This script was used to install shumlib version 2018.06.1 # and is based on the families etc. from the UM at UM 11.1 @@ -33,7 +33,7 @@ set -eu -# Take the platform name as an argument +# Take the platform name as an argument # (purely so we can maintain one script rather than 2) PLATFORM=${1:-} if [ -z "${PLATFORM}" ] ; then @@ -53,7 +53,7 @@ fi # tasks to exclude certain libraries) LIB_DIRS=$(ls -d shum_* | xargs) -# Destination for the build (can be overidden, otherwise defaults to a +# Destination for the build (can be overidden, otherwise defaults to a # "build" directory in the working copy - like the Makefile would) BUILD_DESTINATION=${BUILD_DESTINATION:-$PWD/build} @@ -89,7 +89,7 @@ function build_openmp_onoff { if [ $PLATFORM == "xc40" ] ; then # Crayftn/CrayCC Haswell 8.6.4 (Current system default) - # - note that these versions of CCE don't work correctly with the + # - note that these versions of CCE don't work correctly with the # Fieldsfile, so we exclude them module list CONFIG=icm-xc40-crayftn-craycc @@ -97,8 +97,8 @@ if [ $PLATFORM == "xc40" ] ; then build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ -e "s/\bshum_fieldsfile\b//g" \ <<< $LIB_DIRS) - - # gfortran/gcc + + # gfortran/gcc module swap PrgEnv-cray/5.2.82 PrgEnv-gnu/5.2.82 module list CONFIG=icm-xc40-gfortran-gcc diff --git a/scripts/meto_install_shumlib.sh b/scripts/meto_install_shumlib.sh index a567cc0..77b1376 100755 --- a/scripts/meto_install_shumlib.sh +++ b/scripts/meto_install_shumlib.sh @@ -25,19 +25,23 @@ # combinations available at the Met Office... # # USAGE: (Note - must be run from the toplevel Shumlib directory!) -# scripts/meto_install_shumlib.sh [xc40|x86|ex1a] +# scripts/meto_install_shumlib.sh [azspice|ex1a] # -# This script was used to install shumlib version 2022.11.1 -# and was intended for use with the UM at UM 13.1 +# This script was used to install shumlib version 2025.10.1 +# and was intended for use with the UM at UM 14.0 # set -eu +RUN_SUCCESS=0 + # set up no IEEE list -NO_IEEE_LIST=${NO_IEEE_LIST:-"xc40_haswell_gnu_4.9.1 xc40_ivybridge_gnu_4.9.1 ex1a_gnu_12.1.0"} +NO_IEEE_LIST=${NO_IEEE_LIST:-"azspice_gnu_12.2"} # Ensure directory is correct -cd $(readlink -f $(dirname $0)/..) +CANONICAL_DIR=$(dirname "$0") +CANONICAL_DIR=$(readlink -f "$CANONICAL_DIR/..") +cd "$CANONICAL_DIR" # Take the platform name as an argument # (purely so we can maintain one script rather than 2) @@ -45,13 +49,13 @@ PLATFORM=${1:-} if [ -z "${PLATFORM}" ] ; then echo "Please provide platform or specific build as argument" - echo "e.g. x86, xc40, ex1a or grep this file for THIS to see the " + echo "e.g. azspice, ex1a or grep this file for THIS to see the " echo "other options for specific builds" exit 1 fi # Try and detect if the script is being run from the right place -if [ ! -f Makefile ] || ! `ls -d shum_* > /dev/null 2>&1` ; then +if [ ! -f Makefile ] || ! ls -d shum_* > /dev/null 2>&1 ; then echo "Cannot find expected files... Please note that this script " echo "must be run from toplevel Shumlib directory" exit 1 @@ -59,11 +63,11 @@ fi # Get the list of all possible libraries to build (this is used by some of the # tasks to exclude certain libraries) -LIB_DIRS=$(ls -d shum_* | xargs) +LIB_DIRS=$(find shum_* -maxdepth 0 -type d -print0 | xargs -0) # Destination for the build (can be overidden, otherwise defaults to a # "build" directory in the working copy - like the Makefile would) -BUILD_DESTINATION=${BUILD_DESTINATION:-$PWD/build} +BUILD_DESTINATION=${BUILD_DESTINATION:-$PWD/_build} # This list dictates which threading variants of Shumlib will be installed # (all versions defined will always be built + tested, but only those set @@ -83,19 +87,19 @@ function contains { function build_test_clean { local config=$1 shift - if [[ " $NO_IEEE_LIST " =~ " $THIS " ]] ; then + if [[ " $NO_IEEE_LIST " =~ [[:space:]]"$THIS"[[:space:]] ]] ; then export SHUM_HAS_IEEE_ARITHMETIC="false" else unset SHUM_HAS_IEEE_ARITHMETIC fi - echo make -f make/$config.mk clean-temp - make -f make/$config.mk clean-temp - echo make -f make/$config.mk $* - make -f make/$config.mk $* - echo make -f make/$config.mk test - make -f make/$config.mk test - echo make -f make/$config.mk clean-temp - make -f make/$config.mk clean-temp + echo "make -f make/$config.mk clean-temp" + make -f "make/$config.mk" clean-temp + echo "make -f make/$config.mk $*" + make -f "make/$config.mk" "$@" + echo "make -f make/$config.mk test" + make -f "make/$config.mk" test + echo "make -f make/$config.mk clean-temp" + make -f "make/$config.mk" clean-temp } # Function which executes the above function several times - once for each of @@ -109,21 +113,12 @@ function build_openmp_onoff { shift 2 # Copy source to temporary build directory and switch there TEMP_BUILD_DIR=${SHUM_TMPDIR:-$(mktemp -d)} - mkdir -p $TEMP_BUILD_DIR - cp -r * $TEMP_BUILD_DIR - cd $TEMP_BUILD_DIR + mkdir -p "$TEMP_BUILD_DIR" + cp -r ./* "$TEMP_BUILD_DIR" + cd "$TEMP_BUILD_DIR" echo "Build Dir is: $TEMP_BUILD_DIR" - # OpenMP - unset LIBDIR_OUT - if contains "openmp" "$INSTALL_LIBS" ; then - export LIBDIR_OUT=$dir/openmp - fi - export SHUM_OPENMP=true - export SHUM_USE_C_OPENMP_VIA_THREAD_UTILS=false - build_test_clean $config $* - # No-OpenMP unset LIBDIR_OUT if contains "no-openmp" "$INSTALL_LIBS" ; then @@ -131,7 +126,16 @@ function build_openmp_onoff { fi export SHUM_OPENMP=false export SHUM_USE_C_OPENMP_VIA_THREAD_UTILS=false - build_test_clean $config $* + build_test_clean "$config" "$@" + + # OpenMP + unset LIBDIR_OUT + if contains "openmp" "$INSTALL_LIBS" ; then + export LIBDIR_OUT=$dir/openmp + fi + export SHUM_OPENMP=true + export SHUM_USE_C_OPENMP_VIA_THREAD_UTILS=false + build_test_clean "$config" "$@" # Thread Utils + OpenMP unset LIBDIR_OUT @@ -140,7 +144,7 @@ function build_openmp_onoff { fi export SHUM_OPENMP=true export SHUM_USE_C_OPENMP_VIA_THREAD_UTILS=true - build_test_clean $config $* + build_test_clean "$config" "$@" # Thread Utils, No-OpenMP unset LIBDIR_OUT @@ -149,7 +153,7 @@ function build_openmp_onoff { fi export SHUM_OPENMP=false export SHUM_USE_C_OPENMP_VIA_THREAD_UTILS=true - build_test_clean $config $* + build_test_clean "$config" "$@" # Unset threading - not practically a useful install; more of a test # of the Makefiles; this checks to see what happens if the environment @@ -160,558 +164,102 @@ function build_openmp_onoff { fi unset SHUM_OPENMP unset SHUM_USE_C_OPENMP_VIA_THREAD_UTILS - build_test_clean $config $* + build_test_clean "$config" "$@" # Test if $SHUM_TMPDIR is unset. If it is not set, we are using the mktmp # directory, which must be cleaned up again. - if [ -z ${SHUM_TMPDIR+x} ]; then + if [ -z "${SHUM_TMPDIR+x}" ]; then # Tidy up the temporary directory - rm -rf $TEMP_BUILD_DIR + rm -rf "$TEMP_BUILD_DIR" fi } -# Intel/GCC (ifort 16) -THIS="x86_ifort_16.0_gcc" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - ( - source /etc/profile.d/metoffice.d/modules.sh || : - module purge - module load ifort/16.0_64 # From METO_LINUX family in rose-stem - unset SHUM_TMPDIR - CONFIG=meto-x86-ifort15+-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-ifort-16.0.1-gcc-4.4.7 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi +# AZ SPICE GNU 12.2 +THIS="azspice_gnu_12.2" +if [ "$PLATFORM" == "azspice" ] || [ "$PLATFORM" == $THIS ] ; then -THIS="x86_ifort_16.0_clang" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - # Intel/Clang (ifort 16 / clang 12.0.0) - ( - source /etc/profile.d/metoffice.d/modules.sh || : - module purge - module use /project/extrasoftware/modulefiles.rhel7 - module load ifort/16.0_64 # From METO_LINUX family in rose-stem - module unload libraries/gcc - module load gcc/8.1.0 - module load llvm/12.0.0 - unset SHUM_TMPDIR - CONFIG=meto-x86-ifort15+-clang - LIBDIR=$BUILD_DESTINATION/meto-x86-ifort-16.0.1-clang-12.0.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -THIS="x86_nag_6.2_gcc" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - # NagFor/GCC (nagfor 6.2.0) - ( - source /etc/profile.d/metoffice.d/modules.sh || : - module purge - module load nagfor/6.2.0_64 - unset SHUM_TMPDIR - CONFIG=meto-x86-nagfor-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-nagfor-6.2.0-gcc-4.4.7 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Portland/GCC (pgfortran 16.10) - Note that the "fieldsfile_class" -# lib doesn't work with portland, so we exclude it -THIS="x86_pgfortran_16.10_gcc" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - ( - source /etc/profile.d/metoffice.d/modules.sh || : - module purge - module load pgfortran/16.10_64 - unset SHUM_TMPDIR - CONFIG=meto-x86-portland-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-pgfortran-16.10.0-gcc-4.4.7 - build_openmp_onoff $CONFIG $LIBDIR $(sed "s/\bshum_fieldsfile_class\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Gfortran/GCC 6.1.0 -# Have to use Lfric module as default Gfortran is too old -THIS="x86_gnu_6.1.0" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - ( - module use /data/users/lfric/modules/modulefiles.rhel7 - module purge - module load environment/lfric/gnu/6.1.0 - unset SHUM_TMPDIR - CONFIG=meto-x86-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-gfortran-6.1.0-gcc-6.1.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Gfortran/GCC 9.2.0 -# Using jopa module -THIS="x86_gnu_9.2.0" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - ( - module use /home/h03/jopa/modulefiles - module purge - module load jedi/gcc/9.2.0 - unset SHUM_TMPDIR - CONFIG=meto-x86-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-gfortran-9.2.0-gcc-9.2.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Gfortran/GCC 9.3.0 -# Using jopa module -THIS="x86_gnu_9.3.0" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - ( - module use /home/h03/jopa/modulefiles - module purge - module load gnu-toolchain/gcc/9.3.0 - unset SHUM_TMPDIR - CONFIG=meto-x86-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-gfortran-9.3.0-gcc-9.3.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Gfortran/GCC 10.2.0 -# Using LFRic module -THIS="x86_gnu_10.2.0" -if [ $PLATFORM == "x86" ] || [ $PLATFORM == $THIS ] ; then - ( - module use /data/users/lfric/modules/modulefiles.rhel7 - module purge - module load environment/lfric/gnu/10.2.0 - unset SHUM_TMPDIR - CONFIG=meto-x86-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-x86-gfortran-10.2.0-gcc-10.2.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# GNU generic gfortran/gcc -THIS="x86_gnu_generic" -if [[ $PLATFORM == "x86" ]] || [[ $PLATFORM == $THIS ]] ; then - if [[ $(gcc -dumpversion) > 8 ]] ; then - ( - unset SHUM_TMPDIR - CONFIG=meto-x86-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/x86-gfortran-$(gfortran -dumpversion)-gcc-$(gcc -dumpversion) - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi - else - >&2 echo "SKIPPING $THIS as GCC version older than 8" + if [ -z "${SPACKDIR}" ] ; then + echo "Please set the SPACKDIR environment variable for loading" + echo "the relevant modules" + exit 1 fi -fi - - -# Crayftn/CrayCC Haswell 8.3.4 (Current system default) -# - note that these earlier versions of CCE don't work correctly with the -# Fieldsfile read/write libraries, so we exclude them -THIS="xc40_haswell_cray_8.3.4" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - - ( - module purge - module load PrgEnv-cray/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap cce/8.3.4 - module load craype-haswell - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-crayftn8.3.4+-craycc - LIBDIR=$BUILD_DESTINATION/meto-xc40-haswell-crayftn-8.3.4-craycc-8.3.4 - build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ - -e "s/\bshum_fieldsfile\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Crayftn/CrayCC Ivybridge 8.3.4 (Current system default) -# - note that these earlier versions of CCE don't work correctly with the -# Fieldsfile read/write libraries, so we exclude them -THIS="xc40_ivybridge_cray_8.3.4" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-cray/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap cce/8.3.4 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-crayftn8.3.4+-craycc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-crayftn-8.3.4-craycc-8.3.4 - build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ - -e "s/\bshum_fieldsfile\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi -# Crayftn/CrayCC Ivybridge 8.4.3 - note that these earlier versions of CCE don't -# work correctly with the Fieldsfile read/write libraries, so we exclude them -THIS="xc40_ivybridge_cray_8.4.3" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-cray/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap cce/8.4.3 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-crayftn8.4.0+-craycc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-crayftn-8.4.3-craycc-8.4.3 - build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ - -e "s/\bshum_fieldsfile\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Crayftn/CrayCC Haswell 8.5.8 -THIS="xc40_haswell_cray_8.5.8" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-cray/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap cce/8.5.8 - module load craype-haswell - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-crayftn8.4.0+-craycc - LIBDIR=$BUILD_DESTINATION/meto-xc40-haswell-crayftn-8.5.8-craycc-8.5.8 - build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ - -e "s/\bshum_fieldsfile\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Crayftn/CrayCC Ivybridge 8.5.8 -THIS="xc40_ivybridge_cray_8.5.8" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-cray/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap cce/8.5.8 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-crayftn8.4.0+-craycc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-crayftn-8.5.8-craycc-8.5.8 - build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ - -e "s/\bshum_fieldsfile\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Ifort/Icc Haswell 15.0 (Current system default) -THIS="xc40_haswell_intel_15.0" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-intel/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap intel/15.0.0.090 - module load craype-haswell - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-ifort-icc - LIBDIR=$BUILD_DESTINATION/meto-xc40-haswell-ifort-15.0.0-icc-15.0.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Ifort/Icc Ivybridge 15.0 (Current system default) -THIS="xc40_ivybridge_intel_15.0" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-intel/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap intel/15.0.0.090 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-ifort-icc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-ifort-15.0.0-icc-15.0.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Ifort/Icc Haswell 17.0 -THIS="xc40_haswell_intel_17.0" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-intel/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap intel/17.0.0.098 - module load craype-haswell - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-ifort-icc - LIBDIR=$BUILD_DESTINATION/meto-xc40-haswell-ifort-17.0.0-icc-17.0.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi - -# Ifort/Icc Ivybridge 17.0 -THIS="xc40_ivybridge_intel_17.0" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-intel/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.0.4 - module swap intel/17.0.0.098 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-ifort-icc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-ifort-17.0.0-icc-17.0.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi + module use $SPACKDIR/spack/modules/linux-rhel9-zen2 + module load gcc/12.2.0-gcc-12.2.0-elnqzkg + module load mpich/4.2.3-gcc-12.2.0-vqupwpn + unset SHUM_TMPDIR + CONFIG=meto-azspice-gfortran-gcc + LIBDIR=$BUILD_DESTINATION/azspice-gfortran-$(gfortran -dumpversion)-gcc-$(gcc -dumpversion) + build_openmp_onoff $CONFIG "$LIBDIR" all_libs + if [ $? -ne 0 ] ; then + >&2 echo "Error compiling for $THIS" + exit 1 + fi + RUN_SUCCESS=1 fi -# Gfortran/Gcc Haswell 4.9.1 (Current system default) -THIS="xc40_haswell_gnu_4.9.1" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-gnu/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.5.3 - module swap gcc/4.9.1 - module load craype-haswell - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-xc40-haswell-gfortran-4.9.1-gcc-4.9.1 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi +# Crayftn/CrayCC 15.0.0 +THIS="ex1a_cray_15.0.0" +if [ "$PLATFORM" == "ex1a" ] || [ "$PLATFORM" == $THIS ] ; then -# Gfortran/Gcc Ivybridge 4.9.1 (Current system default) -THIS="xc40_ivybridge_gnu_4.9.1" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-gnu/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.5.3 - module swap gcc/4.9.1 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries unset SHUM_TMPDIR - CONFIG=meto-xc40-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-gfortran-4.9.1-gcc-4.9.1 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 + # If it is not the case that $CYLC_TASK_WORK_PATH is unset, use it to + # define $SHUM_TMPDIR + if [ ! -z "${CYLC_TASK_WORK_PATH+x}" ]; then + export SHUM_TMPDIR=$CYLC_TASK_WORK_PATH/meto-ex1a-crayftn-15.0.0-craycc-15.0.0 fi -fi -# Gfortran/Gcc Haswell 6.3.0 -THIS="xc40_haswell_gnu_6.3.0" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then ( - module purge - module load PrgEnv-gnu/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.5.3 - module swap gcc/6.3.0 - module load craype-haswell - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-xc40-haswell-gfortran-6.3.0-gcc-6.3.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 - fi -fi + module switch PrgEnv-cray PrgEnv-cray/8.4.0 + module load cpe/23.05 + module swap cce cce/15.0.0 + module load craype-x86-milan -# Gfortran/Gcc Ivybridge 6.3.0 -THIS="xc40_ivybridge_gnu_6.3.0" -if [ $PLATFORM == "xc40" ] || [ $PLATFORM == $THIS ] ; then - ( - module purge - module load PrgEnv-gnu/5.2.82 - module load cdt/17.03 - module load cray-mpich/7.5.3 - module swap gcc/6.3.0 - module load craype-ivybridge - module load metoffice/tempdir - module load metoffice/userenv - module load craype-network-aries - unset SHUM_TMPDIR - CONFIG=meto-xc40-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-xc40-ivybridge-gfortran-6.3.0-gcc-6.3.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs + CONFIG=meto-ex1a-crayftn12.0.1+-craycc + LIBDIR=$BUILD_DESTINATION/meto-ex1a-crayftn-15.0.0-craycc-15.0.0 + read -ra TEST_LIBS < <(sed -e "s/\bshum_fieldsfile_class\b//g" \ + -e "s/\bshum_fieldsfile\b//g" \ + <<< "$LIB_DIRS") + build_openmp_onoff $CONFIG "$LIBDIR" "${TEST_LIBS[@]}" ) if [ $? -ne 0 ] ; then >&2 echo "Error compiling for $THIS" exit 1 fi + RUN_SUCCESS=1 fi -# Crayftn/CrayCC 15.0.0 -THIS="ex1a_cray_15.0.0" -if [ $PLATFORM == "ex1a" ] || [ $PLATFORM == $THIS ] ; then +# Gfortran 12.2.0 +THIS="ex1a_gnu_12.2.0" +if [ "$PLATFORM" == "ex1a" ] || [ "$PLATFORM" == $THIS ] ; then - ( - module switch PrgEnv-cray PrgEnv-cray/8.3.3 - module load cpe/22.11 unset SHUM_TMPDIR - CONFIG=meto-ex1a-crayftn12.0.1+-craycc - LIBDIR=$BUILD_DESTINATION/meto-ex1a-crayftn-15.0.0-craycc-15.0.0 # If it is not the case that $CYLC_TASK_WORK_PATH is unset, use it to # define $SHUM_TMPDIR - if [ ! -z ${CYLC_TASK_WORK_PATH+x} ]; then - export SHUM_TMPDIR=$CYLC_TASK_WORK_PATH/meto-ex1a-crayftn-15.0.0-craycc-15.0.0 - fi - build_openmp_onoff $CONFIG $LIBDIR $(sed -e "s/\bshum_fieldsfile_class\b//g" \ - -e "s/\bshum_fieldsfile\b//g" \ - <<< $LIB_DIRS) - ) - if [ $? -ne 0 ] ; then - >&2 echo "Error compiling for $THIS" - exit 1 + if [ ! -z "${CYLC_TASK_WORK_PATH+x}" ]; then + export SHUM_TMPDIR=$CYLC_TASK_WORK_PATH/meto-ex1a-gfortran-12.2.0-gcc-12.2.0 fi -fi - -# Gfortran 12.1.0 -THIS="ex1a_gnu_12.1.0" -if [ $PLATFORM == "ex1a" ] || [ $PLATFORM == $THIS ] ; then ( - module switch PrgEnv-cray PrgEnv-gnu/8.3.3 - module load cpe/22.11 - unset SHUM_TMPDIR + module switch PrgEnv-cray PrgEnv-gnu/8.4.0 + module load cpe/23.05 + module swap gcc gcc/12.2.0 + module load craype-x86-milan + CONFIG=meto-ex1a-gfortran-gcc - LIBDIR=$BUILD_DESTINATION/meto-ex1a-gfortran-12.1.0-gcc-12.1.0 - build_openmp_onoff $CONFIG $LIBDIR all_libs + LIBDIR=$BUILD_DESTINATION/meto-ex1a-gfortran-12.2.0-gcc-12.2.0 + build_openmp_onoff $CONFIG "$LIBDIR" all_libs ) if [ $? -ne 0 ] ; then >&2 echo "Error compiling for $THIS" exit 1 fi + RUN_SUCCESS=1 +fi + +if [[ "$RUN_SUCCESS" -eq 0 ]] ; then + echo "Did not succesfully run." | tee >(cat >&2) + echo "(Is '${PLATFORM}' a valid platform argument?)" | tee >(cat >&2) + exit 2 fi 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/src/Makefile b/shum_byteswap/src/Makefile index 925b229..c9901d7 100644 --- a/shum_byteswap/src/Makefile +++ b/shum_byteswap/src/Makefile @@ -42,6 +42,6 @@ libshum_byteswap.so: c_shum_byteswap_PIC.o f_shum_byteswap_PIC.o ${VERSION_OBJEC # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_byteswap/src/c_shum_byteswap.c b/shum_byteswap/src/c_shum_byteswap.c index 14da368..4f7de1b 100644 --- a/shum_byteswap/src/c_shum_byteswap.c +++ b/shum_byteswap/src/c_shum_byteswap.c @@ -32,6 +32,7 @@ #include "c_shum_byteswap.h" #include "c_shum_byteswap_opt.h" #include "c_shum_compile_diag_suspend.h" +#include "c_shum_compiler_select.h" #if defined(_OPENMP) && defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) #include "c_shum_thread_utils.h" @@ -51,14 +52,18 @@ #if defined(_OPENMP) && defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) #define INLINEQUAL #else +#if defined(SHUM_IS_GNU_COMPILER) +#define INLINEQUAL static inline __attribute__((always_inline)) +#else #define INLINEQUAL static inline #endif +#endif /* We need to suspend compiler diagnostics for the expansion of byteswap macros * on some systems, as they bring in reserved identifiers from system headers. */ -#if defined(__clang__) -#if __clang_major__ >= 13 +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#if SHUM_HAS_CLANG_EXTENSIONS >= 130000 #define SUSPEND_RES_IDNET SHUM_COMPILE_DIAG_SUSPEND(-Wreserved-identifier) #define RESUME_RES_IDENT SHUM_COMPILE_DIAG_RESUME #endif @@ -120,11 +125,13 @@ int64_t c_shum_byteswap(void *array, int64_t len, int64_t word_len, #endif #if defined(_OPENMP) && !defined(SHUM_USE_C_OPENMP_VIA_THREAD_UTILS) -#if defined(_CRAYC) +#if defined(SHUM_IS_CRAY_COMPILER) +#if (SHUM_IS_CRAY_COMPILER < 90200) #pragma _CRI inline_always c_shum_byteswap_par_swap64 #pragma _CRI inline_always c_shum_byteswap_par_swap32 #pragma _CRI inline_always c_shum_byteswap_par_swap16 #endif +#endif #endif if (word_len == 8) @@ -168,6 +175,10 @@ int64_t c_shum_byteswap(void *array, int64_t len, int64_t word_len, /* -------------------------------------------------------------------------- */ +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#pragma clang attribute push(__attribute__((always_inline)), apply_to = function) +#endif + INLINEQUAL void c_shum_byteswap_par_swap64(void **const array, const int64_t * const restrict imin, const int64_t * const restrict imax, @@ -192,8 +203,16 @@ INLINEQUAL void c_shum_byteswap_par_swap64(void **const array, } } +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#pragma clang attribute pop +#endif + /* -------------------------------------------------------------------------- */ +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#pragma clang attribute push(__attribute__((always_inline)), apply_to = function) +#endif + INLINEQUAL void c_shum_byteswap_par_swap32(void **const array, const int64_t *const restrict imin, const int64_t *const restrict imax, @@ -218,8 +237,16 @@ INLINEQUAL void c_shum_byteswap_par_swap32(void **const array, } } +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#pragma clang attribute pop +#endif + /* -------------------------------------------------------------------------- */ +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#pragma clang attribute push(__attribute__((always_inline)), apply_to = function) +#endif + INLINEQUAL void c_shum_byteswap_par_swap16(void **const array, const int64_t *const restrict imin, const int64_t *const restrict imax, @@ -244,6 +271,10 @@ INLINEQUAL void c_shum_byteswap_par_swap16(void **const array, } } +#if defined(SHUM_HAS_CLANG_EXTENSIONS) +#pragma clang attribute pop +#endif + /* -------------------------------------------------------------------------- */ endianness c_shum_get_machine_endianism(void) diff --git a/shum_byteswap/src/c_shum_byteswap.h b/shum_byteswap/src/c_shum_byteswap.h index 4ef1880..262c224 100644 --- a/shum_byteswap/src/c_shum_byteswap.h +++ b/shum_byteswap/src/c_shum_byteswap.h @@ -31,7 +31,7 @@ typedef enum ENDIANNESS { bigEndian, littleEndian, numEndians } endianness; -extern int64_t c_shum_byteswap(void *array, int64_t len, int64_t word_len, +extern int64_t c_shum_byteswap(void *array, int64_t len, int64_t word_len, char *message, int64_t message_len); extern endianness c_shum_get_machine_endianism(void); diff --git a/shum_byteswap/src/c_shum_byteswap_opt.h b/shum_byteswap/src/c_shum_byteswap_opt.h index 0db2dee..fad3e4a 100644 --- a/shum_byteswap/src/c_shum_byteswap_opt.h +++ b/shum_byteswap/src/c_shum_byteswap_opt.h @@ -50,9 +50,10 @@ * version 4.8 or later, we can use the the non-standard intrinsic * __builtin_bswap*() functions for all sizes of bswap. * - * iv) If we are using the Cray compiler (defines _CRAYC) with GNU extensions - * enabled (-hgnu): we can use GCC extensions, but not inline assembly. - * Therefore, for __GNUC__ support greater than version 4.3 but less than + * iv) If we are using the Cray compiler (defines SHUM_IS_CRAY_COMPILER) with + * GNU extensions enabled (defines SHUM_HAS_GNU_EXTENSIONS): we can use GCC + * extensions, but not inline assembly. Therefore, for + * SHUM_HAS_GNU_EXTENSIONS support greater than version 4.3 but less than * 6.1, fall-back to the non-standard intrinsic __builtin_bswap*() * functions, except for __builtin_bswap16, which isn't implemented, and * so therefore use a directly implemented macro for bswap_16. (Note, some @@ -74,45 +75,43 @@ * and so are out of sequence. A user choice (case vi) will still override * these defaults * - * vii) If we are usining a version of the Cray compiler (defines _CRAYC) with - * GNU extensions enabled (-hgnu) and has __GNUC__ greater than version - * 6.1, fall-back to the non-standard intrinsic __builtin_bswap*() - * functions for all data sizes. + * vii) If we are usining a version of the Cray compiler (defines + * SHUM_IS_CRAY_COMPILER) with GNU extensions enabled (defines + * SHUM_HAS_GNU_EXTENSIONS) with a version greater than 6.1, fall-back to + * the non-standard intrinsic __builtin_bswap*() functions for all data + * sizes. * * viii) If we are on a Mac OS X / Darwin system (defines __APPLE__) instead * use the non-standard header */ +#include "c_shum_compiler_select.h" + /*----------------*/ /* Control macros */ /*----------------*/ /* Feature test macros */ -#if (defined(__GNUC__) && __GNUC__ >= 2) -#define C_SHUM_BSWAP_HASGNU 1 -#else -#define C_SHUM_BSWAP_HASGNU 0 -#endif +#if defined(SHUM_HAS_GNU_EXTENSIONS) -#if (C_SHUM_BSWAP_HASGNU && ((__GNUC__ > 4) || \ - (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) -#define C_SHUM_BSWAP_HASGNU4_3 1 -#else -#define C_SHUM_BSWAP_HASGNU4_3 0 -#endif +#define C_SHUM_BSWAP_HASGNU6_1 (SHUM_HAS_GNU_EXTENSIONS >= 60100) -#if (C_SHUM_BSWAP_HASGNU && ((__GNUC__ > 4) || \ - (__GNUC__ == 4 && __GNUC_MINOR__ >= 8))) -#define C_SHUM_BSWAP_HASGNU4_8 1 -#else -#define C_SHUM_BSWAP_HASGNU4_8 0 -#endif +#define C_SHUM_BSWAP_HASGNU4_8 ((SHUM_HAS_GNU_EXTENSIONS >= 40800) \ + && (SHUM_HAS_GNU_EXTENSIONS < 60100)) + +#define C_SHUM_BSWAP_HASGNU4_3 ((SHUM_HAS_GNU_EXTENSIONS >= 40300) \ + && (SHUM_HAS_GNU_EXTENSIONS < 40800)) + +#define C_SHUM_BSWAP_HASGNU2_0 ((SHUM_HAS_GNU_EXTENSIONS >= 20000) \ + && (SHUM_HAS_GNU_EXTENSIONS < 40300)) -#if (C_SHUM_BSWAP_HASGNU && ((__GNUC__ > 6) || \ - (__GNUC__ == 6 && __GNUC_MINOR__ >= 1))) -#define C_SHUM_BSWAP_HASGNU6_1 1 #else + #define C_SHUM_BSWAP_HASGNU6_1 0 +#define C_SHUM_BSWAP_HASGNU4_8 0 +#define C_SHUM_BSWAP_HASGNU4_3 0 +#define C_SHUM_BSWAP_HASGNU2_0 0 + #endif /* ensure test macros are unset */ @@ -188,19 +187,19 @@ /* case viii) */ #define C_USE_BSWAP_OSBYTEORDER_H -#elif C_SHUM_BSWAP_HASGNU && !C_SHUM_BSWAP_HASGNU4_3 +#elif C_SHUM_BSWAP_HASGNU2_0 /* case i) */ #define C_USE_BSWAP_BYTESWAP_H -#elif C_SHUM_BSWAP_HASGNU6_1 && defined(_CRAYC) +#elif C_SHUM_BSWAP_HASGNU6_1 && defined(SHUM_IS_CRAY_COMPILER) /* case vii) */ #define C_USE_BSWAP_BUILTINS_64 #define C_USE_BSWAP_BUILTINS_32 #define C_USE_BSWAP_BUILTINS_16 -#elif C_SHUM_BSWAP_HASGNU4_3 && defined(_CRAYC) +#elif C_SHUM_BSWAP_HASGNU4_3 && defined(SHUM_IS_CRAY_COMPILER) /* case iv) */ #define C_USE_BSWAP_BUILTINS_64 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/src/f_shum_chemistry_constants_mod.f90 b/shum_constants/src/f_shum_chemistry_constants_mod.f90 index e49aa7b..52bec78 100644 --- a/shum_constants/src/f_shum_chemistry_constants_mod.f90 +++ b/shum_constants/src/f_shum_chemistry_constants_mod.f90 @@ -3,21 +3,21 @@ ! For further details please refer to the file COPYRIGHT.txt ! which you should have received as part of this distribution. ! *****************************COPYRIGHT******************************* -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . ! !******************************************************************************* ! @@ -56,7 +56,7 @@ MODULE f_shum_chemistry_constants_mod ! Density of SO4 particle (kg/m3) REAL(KIND=real64), PARAMETER :: shum_rho_so4_const = 1769.0_real64 -! Mean Free Path +! Mean Free Path ! Ref value (m) REAL(KIND=real64), PARAMETER :: shum_ref_mfp_const = 6.6e-8_real64 ! Ref temperature (K) diff --git a/shum_constants/src/f_shum_conversions_mod.f90 b/shum_constants/src/f_shum_conversions_mod.f90 index 3c016ab..9592720 100644 --- a/shum_constants/src/f_shum_conversions_mod.f90 +++ b/shum_constants/src/f_shum_conversions_mod.f90 @@ -64,22 +64,22 @@ MODULE f_shum_conversions_mod !------------------------------------------------------------------------------! !------------------------------------------------------------------------------! -! 64 Bit Conversion Paramters ! +! Primary Conversion Parameters ! !------------------------------------------------------------------------------! ! Number of seconds in one day - now rsec_per_day and isec_per_day ! which will replace magic number 86400 wherever possible REAL(KIND=real64), PARAMETER :: shum_rsec_per_day_const = 86400.0_real64 -INTEGER(KIND=int64), PARAMETER :: shum_isec_per_day_const = 86400_int64 +INTEGER(KIND=int32), PARAMETER :: shum_isec_per_day_const_32 = 86400_int32 REAL(KIND=real64), PARAMETER :: shum_rsec_per_hour_const = 3600.0_real64 -INTEGER(KIND=int64), PARAMETER :: shum_isec_per_hour_const = 3600_int64 +INTEGER(KIND=int32), PARAMETER :: shum_isec_per_hour_const_32 = 3600_int32 REAL(KIND=real64), PARAMETER :: shum_rsec_per_min_const = 60.0_real64 -INTEGER(KIND=int64), PARAMETER :: shum_isec_per_min_const = 60_int64 +INTEGER(KIND=int32), PARAMETER :: shum_isec_per_min_const_32 = 60_int32 REAL(KIND=real64), PARAMETER :: shum_rhour_per_day_const = 24.0_real64 -INTEGER(KIND=int64), PARAMETER :: shum_ihour_per_day_const = 24_int64 +INTEGER(KIND=int32), PARAMETER :: shum_ihour_per_day_const_32 = 24_int32 REAL(KIND=real64), PARAMETER :: & shum_rhour_per_sec_const = 1.0_real64/shum_rsec_per_hour_const, & @@ -107,32 +107,32 @@ MODULE f_shum_conversions_mod REAL(KIND=real64), PARAMETER :: shum_ft2m_const = 0.3048_real64 !------------------------------------------------------------------------------! -! 32 Bit Conversion Paramters (as above but in 32-bit types) ! +! Secondary Conversion Parameters (as above but in opposite precision) ! !------------------------------------------------------------------------------! REAL(KIND=real32), PARAMETER :: & shum_rsec_per_day_const_32 = REAL(shum_rsec_per_day_const,real32) -INTEGER(KIND=int32), PARAMETER :: & - shum_isec_per_day_const_32 = INT(shum_isec_per_day_const,int32) +INTEGER(KIND=int64), PARAMETER :: & + shum_isec_per_day_const = INT(shum_isec_per_day_const_32,int64) REAL(KIND=real32), PARAMETER :: & shum_rsec_per_hour_const_32 = REAL(shum_rsec_per_hour_const,real32) -INTEGER(KIND=int32), PARAMETER :: & - shum_isec_per_hour_const_32 = INT(shum_isec_per_hour_const,int32) +INTEGER(KIND=int64), PARAMETER :: & + shum_isec_per_hour_const = INT(shum_isec_per_hour_const_32,int64) REAL(KIND=real32), PARAMETER :: & shum_rsec_per_min_const_32 = REAL(shum_rsec_per_min_const,real32) -INTEGER(KIND=int32), PARAMETER :: & - shum_isec_per_min_const_32 = INT(shum_isec_per_min_const,int32) +INTEGER(KIND=int64), PARAMETER :: & + shum_isec_per_min_const = INT(shum_isec_per_min_const_32,int64) REAL(KIND=real32), PARAMETER :: & shum_rhour_per_day_const_32 = REAL(shum_rhour_per_day_const,real32) -INTEGER(KIND=int32), PARAMETER :: & - shum_ihour_per_day_const_32 = INT(shum_ihour_per_day_const,int32) +INTEGER(KIND=int64), PARAMETER :: & + shum_ihour_per_day_const = INT(shum_ihour_per_day_const_32,int64) REAL(KIND=real32), PARAMETER :: & shum_rhour_per_sec_const_32 = 1.0_real32/shum_rsec_per_hour_const_32 diff --git a/shum_constants/src/f_shum_planet_earth_constants_mod.f90 b/shum_constants/src/f_shum_planet_earth_constants_mod.f90 index e159295..6c59897 100644 --- a/shum_constants/src/f_shum_planet_earth_constants_mod.f90 +++ b/shum_constants/src/f_shum_planet_earth_constants_mod.f90 @@ -3,21 +3,21 @@ ! For further details please refer to the file COPYRIGHT.txt ! which you should have received as part of this distribution. ! *****************************COPYRIGHT******************************* -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . ! !******************************************************************************* ! diff --git a/shum_constants/src/f_shum_rel_mol_mass_mod.f90 b/shum_constants/src/f_shum_rel_mol_mass_mod.f90 index cecc8d0..b8ba0e6 100644 --- a/shum_constants/src/f_shum_rel_mol_mass_mod.f90 +++ b/shum_constants/src/f_shum_rel_mol_mass_mod.f90 @@ -3,21 +3,21 @@ ! For further details please refer to the file COPYRIGHT.txt ! which you should have received as part of this distribution. ! *****************************COPYRIGHT******************************* -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . ! !******************************************************************************* ! diff --git a/shum_constants/src/f_shum_water_constants_mod.f90 b/shum_constants/src/f_shum_water_constants_mod.f90 index 93dba94..9e116a9 100644 --- a/shum_constants/src/f_shum_water_constants_mod.f90 +++ b/shum_constants/src/f_shum_water_constants_mod.f90 @@ -3,21 +3,21 @@ ! For further details please refer to the file COPYRIGHT.txt ! which you should have received as part of this distribution. ! *****************************COPYRIGHT******************************* -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . ! !******************************************************************************* ! 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_constants/test/fruit_test_shum_constants.f90 b/shum_constants/test/fruit_test_shum_constants.f90 index 955b592..cb94b41 100644 --- a/shum_constants/test/fruit_test_shum_constants.f90 +++ b/shum_constants/test/fruit_test_shum_constants.f90 @@ -109,41 +109,83 @@ SUBROUTINE test_conversions_constant_prec_values REAL(KIND=real64), PARAMETER :: r64eps32 = REAL(EPSILON(0.0_real32),KIND=real64) LOGICAL(KIND=bool) :: l_is_equal +INTEGER(kind=int32) :: itemp32(2) ! Integer Comparisons CALL assert_equals(INT(shum_isec_per_day_const_32,KIND=int64), & - shum_isec_per_day_const, "shum_isec_per_day_const") + shum_isec_per_day_const, & + "shum_isec_per_day_const up-conversion") CALL assert_equals(INT(shum_isec_per_hour_const_32,KIND=int64), & - shum_isec_per_hour_const, "shum_isec_per_hour_const") + shum_isec_per_hour_const, & + "shum_isec_per_hour_const up-conversion") CALL assert_equals(INT(shum_isec_per_min_const_32,KIND=int64), & - shum_isec_per_min_const, "shum_isec_per_min_const") + shum_isec_per_min_const, & + "shum_isec_per_min_const up-conversion") CALL assert_equals(INT(shum_ihour_per_day_const_32,KIND=int64), & - shum_ihour_per_day_const, "shum_ihour_per_day_const") + shum_ihour_per_day_const, & + "shum_ihour_per_day_const up-conversion") -! Exactly representable Real comparisons +itemp32(1:2) = TRANSFER(shum_isec_per_day_const,itemp32) -CALL assert_equals(REAL(shum_rhour_per_sec_const_32,KIND=real64), & - shum_rhour_per_sec_const, r64eps32, & - "shum_rhour_per_sec_const") +CALL assert_equals(itemp32(1) + itemp32(2), & + shum_isec_per_day_const_32, & + "shum_isec_per_day_const down-conversion") -CALL assert_equals(REAL(shum_rsec_per_day_const,KIND=real32), & - shum_rsec_per_day_const_32, "shum_rsec_per_day_const_32") +itemp32(1:2) = TRANSFER(shum_isec_per_hour_const,itemp32) + +CALL assert_equals(itemp32(1) + itemp32(2), & + shum_isec_per_hour_const_32, & + "shum_isec_per_hour_const down-conversion") + +itemp32(1:2) = TRANSFER(shum_isec_per_min_const,itemp32) + +CALL assert_equals(itemp32(1) + itemp32(2), & + shum_isec_per_min_const_32, & + "shum_isec_per_min_const down-conversion") + +itemp32(1:2) = TRANSFER(shum_ihour_per_day_const,itemp32) + +CALL assert_equals(itemp32(1) + itemp32(2), & + shum_ihour_per_day_const_32, & + "shum_ihour_per_day_const") + +! Exactly representable Real comparisons + +CALL assert_equals(REAL(shum_rsec_per_day_const_32,KIND=real64), & + shum_rsec_per_day_const, "shum_rsec_per_day_const_32 up-conversion") CALL assert_equals(REAL(shum_rsec_per_hour_const_32,KIND=real64), & - shum_rsec_per_hour_const, "shum_rsec_per_hour_const") + shum_rsec_per_hour_const, "shum_rsec_per_hour_const up-conversion") CALL assert_equals(REAL(shum_rhour_per_day_const_32,KIND=real64), & - shum_rhour_per_day_const, "shum_rhour_per_day_const") + shum_rhour_per_day_const, "shum_rhour_per_day_const up-conversion") CALL assert_equals(REAL(shum_rsec_per_min_const_32,KIND=real64), & - shum_rsec_per_min_const, "shum_rhour_per_day_const") + shum_rsec_per_min_const, "shum_rhour_per_day_const up-conversion") + +CALL assert_equals(REAL(shum_rsec_per_day_const,KIND=real32), & + shum_rsec_per_day_const_32, "shum_rsec_per_day_const_32 down-conversion") + +CALL assert_equals(REAL(shum_rsec_per_hour_const,KIND=real32), & + shum_rsec_per_hour_const_32, "shum_rsec_per_hour_const down-conversion") + +CALL assert_equals(REAL(shum_rhour_per_day_const,KIND=real32), & + shum_rhour_per_day_const_32, "shum_rhour_per_day_const down-conversion") + +CALL assert_equals(REAL(shum_rsec_per_min_const,KIND=real32), & + shum_rsec_per_min_const_32, "shum_rhour_per_day_const down-conversion") ! Approximate Real comparisons +l_is_equal = equals(REAL(shum_rhour_per_sec_const_32,KIND=real64), & + shum_rhour_per_sec_const, r64eps32) + +CALL assert_true(l_is_equal, "shum_rhour_per_sec_const") + l_is_equal = equals(REAL(shum_pi_const_32,KIND=real64), & shum_pi_const, r64eps32) 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_data_conv/src/f_shum_data_conv.f90 b/shum_data_conv/src/f_shum_data_conv.f90 index 3f04cbf..aff7d4e 100644 --- a/shum_data_conv/src/f_shum_data_conv.f90 +++ b/shum_data_conv/src/f_shum_data_conv.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* ! This module contains the interfaces to call c code within fortran. ! @@ -74,7 +74,7 @@ MODULE f_shum_data_conv_mod INTEGER, PARAMETER :: int64 = C_INT64_T INTEGER, PARAMETER :: int32 = C_INT32_T INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT + INTEGER, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! ! Interfaces ! C Interfaces 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/Makefile b/shum_fieldsfile/src/Makefile index 77f5ed0..de838a0 100644 --- a/shum_fieldsfile/src/Makefile +++ b/shum_fieldsfile/src/Makefile @@ -62,6 +62,6 @@ libshum_fieldsfile.so: \ # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_fieldsfile/src/f_shum_fieldsfile.f90 b/shum_fieldsfile/src/f_shum_fieldsfile.f90 index 7d6d8e5..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 !------------------------------------------------------------------------------! @@ -606,11 +606,13 @@ FUNCTION f_shum_read_integer_constants( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(integer_constants) .AND. (SIZE(integer_constants) /= DIM)) THEN - DEALLOCATE(integer_constants, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed integer_constants" - RETURN +IF (ALLOCATED(integer_constants)) THEN + IF (SIZE(integer_constants) /= DIM) THEN + DEALLOCATE(integer_constants, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed integer_constants" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(integer_constants)) THEN @@ -679,11 +681,13 @@ FUNCTION f_shum_read_real_constants( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(real_constants) .AND. (SIZE(real_constants) /= DIM)) THEN - DEALLOCATE(real_constants, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed real_constants" - RETURN +IF (ALLOCATED(real_constants)) THEN + IF (SIZE(real_constants) /= DIM) THEN + DEALLOCATE(real_constants, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed real_constants" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(real_constants)) THEN @@ -755,13 +759,14 @@ FUNCTION f_shum_read_level_dependent_constants( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(level_dependent_constants) & - .AND. (SIZE(level_dependent_constants, 1) /= dim1) & - .AND. (SIZE(level_dependent_constants, 2) /= dim2)) THEN - DEALLOCATE(level_dependent_constants, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed level_dependent_constants" - RETURN +IF (ALLOCATED(level_dependent_constants)) THEN + IF ((SIZE(level_dependent_constants, 1) /= dim1) & + .AND. (SIZE(level_dependent_constants, 2) /= dim2)) THEN + DEALLOCATE(level_dependent_constants, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed level_dependent_constants" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(level_dependent_constants)) THEN @@ -836,13 +841,14 @@ FUNCTION f_shum_read_row_dependent_constants( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(row_dependent_constants) & - .AND. (SIZE(row_dependent_constants, 1) /= dim1) & - .AND. (SIZE(row_dependent_constants, 2) /= dim2)) THEN - DEALLOCATE(row_dependent_constants, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed row_dependent_constants" - RETURN +IF (ALLOCATED(row_dependent_constants)) THEN + IF ((SIZE(row_dependent_constants, 1) /= dim1) & + .AND. (SIZE(row_dependent_constants, 2) /= dim2)) THEN + DEALLOCATE(row_dependent_constants, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed row_dependent_constants" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(row_dependent_constants)) THEN @@ -916,13 +922,14 @@ FUNCTION f_shum_read_column_dependent_constants( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(column_dependent_constants) & - .AND. (SIZE(column_dependent_constants, 1) /= dim1) & - .AND. (SIZE(column_dependent_constants, 2) /= dim2)) THEN - DEALLOCATE(column_dependent_constants, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed column_dependent_constants" - RETURN +IF (ALLOCATED(column_dependent_constants)) THEN + IF ((SIZE(column_dependent_constants, 1) /= dim1) & + .AND. (SIZE(column_dependent_constants, 2) /= dim2)) THEN + DEALLOCATE(column_dependent_constants, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed column_dependent_constants" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(column_dependent_constants)) THEN @@ -997,13 +1004,14 @@ FUNCTION f_shum_read_additional_parameters( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(additional_parameters) & - .AND. (SIZE(additional_parameters, 1) /= dim1) & - .AND. (SIZE(additional_parameters, 2) /= dim2)) THEN - DEALLOCATE(additional_parameters, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed additional_parameters" - RETURN +IF (ALLOCATED(additional_parameters)) THEN + IF ((SIZE(additional_parameters, 1) /= dim1) & + .AND. (SIZE(additional_parameters, 2) /= dim2)) THEN + DEALLOCATE(additional_parameters, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed additional_parameters" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(additional_parameters)) THEN @@ -1075,11 +1083,13 @@ FUNCTION f_shum_read_extra_constants( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(extra_constants) .AND. (SIZE(extra_constants) /= DIM)) THEN - DEALLOCATE(extra_constants, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed extra_constants" - RETURN +IF (ALLOCATED(extra_constants)) THEN + IF (SIZE(extra_constants) /= DIM) THEN + DEALLOCATE(extra_constants, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed extra_constants" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(extra_constants)) THEN @@ -1148,11 +1158,13 @@ FUNCTION f_shum_read_temp_histfile(ff_id, temp_histfile, message) RESULT(STATUS) ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(temp_histfile) .AND. (SIZE(temp_histfile) /= DIM)) THEN - DEALLOCATE(temp_histfile, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed temp_histfile" - RETURN +IF (ALLOCATED(temp_histfile) ) THEN + IF (SIZE(temp_histfile) /= DIM) THEN + DEALLOCATE(temp_histfile, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed temp_histfile" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(temp_histfile)) THEN @@ -1236,11 +1248,13 @@ FUNCTION f_shum_read_compressed_index( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(compressed_index) .AND. (SIZE(compressed_index) /= DIM)) THEN - DEALLOCATE(compressed_index, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed compressed_index" - RETURN +IF (ALLOCATED(compressed_index)) THEN + IF (SIZE(compressed_index) /= DIM) THEN + DEALLOCATE(compressed_index, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed compressed_index" + RETURN + END IF END IF END IF IF (.NOT. ALLOCATED(compressed_index)) THEN @@ -1312,13 +1326,14 @@ FUNCTION f_shum_read_lookup(ff_id, lookup, message) RESULT(STATUS) ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(lookup) & - .AND. (SIZE(lookup, 1) /= dim1) & - .AND. (SIZE(lookup, 2) /= dim2)) THEN - DEALLOCATE(lookup, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed lookup array" - RETURN +IF (ALLOCATED(lookup)) THEN + IF ((SIZE(lookup, 1) /= dim1) & + .AND. (SIZE(lookup, 2) /= dim2)) THEN + DEALLOCATE(lookup, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed lookup array" + RETURN + END IF END IF END IF @@ -1519,11 +1534,13 @@ FUNCTION f_shum_read_field_data_real64( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(field_data) .AND. SIZE(field_data) /= len_data) THEN - DEALLOCATE(field_data, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed field_data array" - RETURN +IF (ALLOCATED(field_data)) THEN + IF (SIZE(field_data) /= len_data) THEN + DEALLOCATE(field_data, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed field_data array" + RETURN + END IF END IF END IF @@ -1638,11 +1655,13 @@ FUNCTION f_shum_read_field_data_int64( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(field_data) .AND. SIZE(field_data) /= len_data) THEN - DEALLOCATE(field_data, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed field_data array" - RETURN +IF (ALLOCATED(field_data)) THEN + IF (SIZE(field_data) /= len_data) THEN + DEALLOCATE(field_data, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed field_data array" + RETURN + END IF END IF END IF @@ -1760,11 +1779,13 @@ FUNCTION f_shum_read_field_data_real32( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(field_data) .AND. SIZE(field_data) /= len_data) THEN - DEALLOCATE(field_data, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed field_data array" - RETURN +IF (ALLOCATED(field_data)) THEN + IF (SIZE(field_data) /= len_data) THEN + DEALLOCATE(field_data, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed field_data array" + RETURN + END IF END IF END IF @@ -1889,11 +1910,13 @@ FUNCTION f_shum_read_field_data_int32( & ! If the output array is already allocated it must be deallocated first, ! unless it happens to be exactly the right size already -IF (ALLOCATED(field_data) .AND. SIZE(field_data) /= len_data) THEN - DEALLOCATE(field_data, STAT=STATUS) - IF (STATUS /= 0) THEN - message = "Unable to de-allocate passed field_data array" - RETURN +IF (ALLOCATED(field_data)) THEN + IF (SIZE(field_data) /= len_data) THEN + DEALLOCATE(field_data, STAT=STATUS) + IF (STATUS /= 0) THEN + message = "Unable to de-allocate passed field_data array" + RETURN + END IF END IF END IF @@ -1966,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(:) @@ -2021,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 @@ -2110,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) @@ -3036,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/src/f_shum_fixed_length_header_indices.f90 b/shum_fieldsfile/src/f_shum_fixed_length_header_indices.f90 index 4fce24c..3cd8db2 100644 --- a/shum_fieldsfile/src/f_shum_fixed_length_header_indices.f90 +++ b/shum_fieldsfile/src/f_shum_fixed_length_header_indices.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* ! Description: Indices for the fixed length header. ! @@ -26,7 +26,7 @@ MODULE f_shum_fixed_length_header_indices_mod USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE -IMPLICIT NONE +IMPLICIT NONE PUBLIC @@ -43,7 +43,7 @@ MODULE f_shum_fixed_length_header_indices_mod INTEGER, PRIVATE, PARAMETER :: int64 = C_INT64_T INTEGER, PRIVATE, PARAMETER :: int32 = C_INT32_T INTEGER, PRIVATE, PARAMETER :: real64 = C_DOUBLE - INTEGER, PRIVATE, PARAMETER :: real32 = C_FLOAT + INTEGER, PRIVATE, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! INTEGER(KIND=int64), PARAMETER :: data_set_format_version = 1 @@ -115,7 +115,7 @@ MODULE f_shum_fixed_length_header_indices_mod INTEGER(KIND=int64), PARAMETER :: lookup_start = 150 INTEGER(KIND=int64), PARAMETER :: lookup_dim1 = 151 INTEGER(KIND=int64), PARAMETER :: lookup_dim2 = 152 -INTEGER(KIND=int64), PARAMETER :: data_start = 160 +INTEGER(KIND=int64), PARAMETER :: data_start = 160 INTEGER(KIND=int64), PARAMETER :: data_dim = 161 !------------------------------------------------------------------------------! diff --git a/shum_fieldsfile/src/f_shum_lookup_indices.f90 b/shum_fieldsfile/src/f_shum_lookup_indices.f90 index 1e23185..6aca0bc 100644 --- a/shum_fieldsfile/src/f_shum_lookup_indices.f90 +++ b/shum_fieldsfile/src/f_shum_lookup_indices.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* ! Description: Indices for the lookup headers. ! @@ -26,7 +26,7 @@ MODULE f_shum_lookup_indices_mod USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE -IMPLICIT NONE +IMPLICIT NONE PRIVATE @@ -41,7 +41,7 @@ MODULE f_shum_lookup_indices_mod INTEGER, PARAMETER :: int64 = C_INT64_T INTEGER, PARAMETER :: int32 = C_INT32_T INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT + INTEGER, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! INTEGER(KIND=int64), PARAMETER, PUBLIC :: lbyr = 1 diff --git a/shum_fieldsfile/src/f_shum_stashmaster.f90 b/shum_fieldsfile/src/f_shum_stashmaster.f90 index 3829be4..7d7adc9 100644 --- a/shum_fieldsfile/src/f_shum_stashmaster.f90 +++ b/shum_fieldsfile/src/f_shum_stashmaster.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* ! Description: Methods for reading the UM STASHmaster. ! @@ -26,7 +26,7 @@ MODULE f_shum_stashmaster_mod USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_DOUBLE, C_FLOAT, C_INT8_T -IMPLICIT NONE +IMPLICIT NONE PRIVATE @@ -45,7 +45,7 @@ MODULE f_shum_stashmaster_mod INTEGER, PARAMETER :: int32 = C_INT32_T INTEGER, PARAMETER :: int8 = C_INT8_T INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT + INTEGER, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! ! This type stores the records defined by the stashmaster for a single @@ -83,7 +83,7 @@ MODULE f_shum_stashmaster_mod INTEGER(KIND=int64) :: cfff END TYPE shum_STASHmaster_record -! This type provides a pointer to the above point - used to enable the +! This type provides a pointer to the above point - used to enable the ! STASHmaster to be an array of pointers (with elements that have no matching ! STASH entry being left unassociated) TYPE shum_STASHmaster @@ -100,7 +100,7 @@ FUNCTION f_shum_add_new_stash_record( & datat, dumpp, packing_codes, rotate, ppfc, user, lbvc, blev, tlev, rblevv, & cfll, cfff, message) RESULT(status) -IMPLICIT NONE +IMPLICIT NONE TYPE(shum_STASHmaster), INTENT(INOUT) :: STASHmaster(99999) INTEGER(KIND=int64), INTENT(IN) :: model, section, item, space, point, & @@ -172,7 +172,7 @@ END FUNCTION f_shum_add_new_stash_record FUNCTION f_shum_read_stashmaster(stashmaster_path, stashmaster, message) & RESULT(status) -IMPLICIT NONE +IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: stashmaster_path TYPE(shum_STASHmaster), INTENT(INOUT) :: STASHmaster(99999) @@ -218,8 +218,8 @@ FUNCTION f_shum_read_stashmaster(stashmaster_path, stashmaster, message) & IF (record_start == '1|') THEN ! Back-up to re-read the record properly BACKSPACE file_unit - - ! Record line 1 + + ! Record line 1 READ(file_unit, "(2X,3(I5,2X),A36)", IOSTAT=status, IOMSG=message) & model, section, item, name IF (status /= 0) THEN 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/Makefile b/shum_fieldsfile_class/src/Makefile index 516c3bf..58ee70a 100644 --- a/shum_fieldsfile_class/src/Makefile +++ b/shum_fieldsfile_class/src/Makefile @@ -50,6 +50,6 @@ libshum_fieldsfile_class.so: \ # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_fieldsfile_class/src/f_shum_ff_status.f90 b/shum_fieldsfile_class/src/f_shum_ff_status.f90 index 31689fc..2eddb9f 100644 --- a/shum_fieldsfile_class/src/f_shum_ff_status.f90 +++ b/shum_fieldsfile_class/src/f_shum_ff_status.f90 @@ -96,7 +96,7 @@ FUNCTION eq_status_first_64(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int64), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode == int1) THEN eq = .TRUE. ELSE @@ -112,7 +112,7 @@ FUNCTION eq_status_second_64(int1, obj) RESULT(eq) INTEGER(KIND=int64), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode == int1) THEN eq = .TRUE. ELSE @@ -128,7 +128,7 @@ FUNCTION eq_status_first_32(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int32), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode == int1) THEN eq = .TRUE. ELSE @@ -144,7 +144,7 @@ FUNCTION eq_status_second_32(int1, obj) RESULT(eq) INTEGER(KIND=int32), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode == int1) THEN eq = .TRUE. ELSE @@ -159,7 +159,7 @@ FUNCTION eq_status_both(obj1, obj2) RESULT(eq) IMPLICIT NONE CLASS(shum_ff_status_type), INTENT(IN) :: obj1, obj2 LOGICAL :: eq - + IF (obj1%icode == obj2%icode) THEN eq = .TRUE. ELSE @@ -175,7 +175,7 @@ FUNCTION gt_status_first_64(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int64), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode > int1) THEN eq = .TRUE. ELSE @@ -191,7 +191,7 @@ FUNCTION gt_status_second_64(int1, obj) RESULT(eq) INTEGER(KIND=int64), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode > int1) THEN eq = .TRUE. ELSE @@ -207,7 +207,7 @@ FUNCTION gt_status_first_32(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int32), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode > int1) THEN eq = .TRUE. ELSE @@ -223,7 +223,7 @@ FUNCTION gt_status_second_32(int1, obj) RESULT(eq) INTEGER(KIND=int32), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode > int1) THEN eq = .TRUE. ELSE @@ -238,7 +238,7 @@ FUNCTION gt_status_both(obj1, obj2) RESULT(eq) IMPLICIT NONE CLASS(shum_ff_status_type), INTENT(IN) :: obj1, obj2 LOGICAL :: eq - + IF (obj1%icode > obj2%icode) THEN eq = .TRUE. ELSE @@ -254,7 +254,7 @@ FUNCTION lt_status_first_64(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int64), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode < int1) THEN eq = .TRUE. ELSE @@ -270,7 +270,7 @@ FUNCTION lt_status_second_64(int1, obj) RESULT(eq) INTEGER(KIND=int64), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode < int1) THEN eq = .TRUE. ELSE @@ -286,7 +286,7 @@ FUNCTION lt_status_first_32(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int32), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode < int1) THEN eq = .TRUE. ELSE @@ -302,7 +302,7 @@ FUNCTION lt_status_second_32(int1, obj) RESULT(eq) INTEGER(KIND=int32), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode < int1) THEN eq = .TRUE. ELSE @@ -317,7 +317,7 @@ FUNCTION lt_status_both(obj1, obj2) RESULT(eq) IMPLICIT NONE CLASS(shum_ff_status_type), INTENT(IN) :: obj1, obj2 LOGICAL :: eq - + IF (obj1%icode < obj2%icode) THEN eq = .TRUE. ELSE @@ -333,7 +333,7 @@ FUNCTION ge_status_first_64(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int64), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode >= int1) THEN eq = .TRUE. ELSE @@ -349,7 +349,7 @@ FUNCTION ge_status_second_64(int1, obj) RESULT(eq) INTEGER(KIND=int64), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode >= int1) THEN eq = .TRUE. ELSE @@ -365,7 +365,7 @@ FUNCTION ge_status_first_32(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int32), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode >= int1) THEN eq = .TRUE. ELSE @@ -381,7 +381,7 @@ FUNCTION ge_status_second_32(int1, obj) RESULT(eq) INTEGER(KIND=int32), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode >= int1) THEN eq = .TRUE. ELSE @@ -396,7 +396,7 @@ FUNCTION ge_status_both(obj1, obj2) RESULT(eq) IMPLICIT NONE CLASS(shum_ff_status_type), INTENT(IN) :: obj1, obj2 LOGICAL :: eq - + IF (obj1%icode >= obj2%icode) THEN eq = .TRUE. ELSE @@ -412,7 +412,7 @@ FUNCTION le_status_first_64(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int64), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode <= int1) THEN eq = .TRUE. ELSE @@ -428,7 +428,7 @@ FUNCTION le_status_second_64(int1, obj) RESULT(eq) INTEGER(KIND=int64), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode <= int1) THEN eq = .TRUE. ELSE @@ -444,7 +444,7 @@ FUNCTION le_status_first_32(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int32), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode <= int1) THEN eq = .TRUE. ELSE @@ -460,7 +460,7 @@ FUNCTION le_status_second_32(int1, obj) RESULT(eq) INTEGER(KIND=int32), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode <= int1) THEN eq = .TRUE. ELSE @@ -475,7 +475,7 @@ FUNCTION le_status_both(obj1, obj2) RESULT(eq) IMPLICIT NONE CLASS(shum_ff_status_type), INTENT(IN) :: obj1, obj2 LOGICAL :: eq - + IF (obj1%icode <= obj2%icode) THEN eq = .TRUE. ELSE @@ -491,7 +491,7 @@ FUNCTION ne_status_first_64(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int64), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode /= int1) THEN eq = .TRUE. ELSE @@ -507,7 +507,7 @@ FUNCTION ne_status_second_64(int1, obj) RESULT(eq) INTEGER(KIND=int64), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode /= int1) THEN eq = .TRUE. ELSE @@ -523,7 +523,7 @@ FUNCTION ne_status_first_32(obj, int1) RESULT(eq) CLASS(shum_ff_status_type), INTENT(IN) :: obj INTEGER(KIND=int32), INTENT(IN) :: int1 LOGICAL :: eq - + IF (obj%icode /= int1) THEN eq = .TRUE. ELSE @@ -539,7 +539,7 @@ FUNCTION ne_status_second_32(int1, obj) RESULT(eq) INTEGER(KIND=int32), INTENT(IN) :: int1 CLASS(shum_ff_status_type), INTENT(IN) :: obj LOGICAL :: eq - + IF (obj%icode /= int1) THEN eq = .TRUE. ELSE @@ -554,7 +554,7 @@ FUNCTION ne_status_both(obj1, obj2) RESULT(eq) IMPLICIT NONE CLASS(shum_ff_status_type), INTENT(IN) :: obj1, obj2 LOGICAL :: eq - + IF (obj1%icode /= obj2%icode) THEN eq = .TRUE. ELSE diff --git a/shum_fieldsfile_class/src/f_shum_field.f90 b/shum_fieldsfile_class/src/f_shum_field.f90 index 68bff7a..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. & @@ -298,7 +299,7 @@ FUNCTION get_real_lookup_by_index(self, num_index, value_to_get) RESULT(status) status%icode = 1_int64 WRITE(status%message,'(A,I0,A)') 'Real lookup index ',num_index, & ' out of range' - ELSE + ELSE ! SHUMlib stores parameters containing the index in the 64-word lookup ! However, here we've split it into it's integer and real components, so we ! deduct the length of the integer lookup to find the position in the real @@ -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 6b0f1ef..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,13 +2564,11 @@ 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 -s_thf = SIZE(temp_histfile) - IF (ALLOCATED(self%temp_histfile)) THEN s_thf = SIZE(self%temp_histfile) @@ -2596,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 @@ -2656,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 @@ -2736,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 @@ -2764,9 +2766,9 @@ FUNCTION find_field_indices_in_file(self, found_field_indices, & ! field via the file handle. For example: ! STATUS = um_file%read_field(found_field_indices(1_int64)) ! STATUS = um_file%get_field(found_field_indices(1_int64), local_field) - ! where found_field_indices is a list on indices matching the criteria and + ! where found_field_indices is a list on indices matching the criteria and ! local_field is a field of type shum_field_type. In this case the field - ! corresponding to the first index of found_field_indices is retrieved. + ! corresponding to the first index of found_field_indices is retrieved. ! An optional argument "max_returned_fields" can be set to limit the number of ! indices returned by this function. ! Note that FCTIME is a REAL argument which is calculated manually, and @@ -2783,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 @@ -2810,7 +2812,7 @@ FUNCTION find_field_indices_in_file(self, found_field_indices, & num_matching = 0 matching_fields = um_imdi -! Loop over fields to find potential matches +! Loop over fields to find potential matches DO i_field = 1, self%num_fields STATUS = self%get_field(i_field, current_field) IF (STATUS%icode /= shumlib_success) THEN @@ -2867,7 +2869,7 @@ FUNCTION find_field_indices_in_file(self, found_field_indices, & END IF END IF - ! All criteria match - add field index to the list + ! All criteria match - add field index to the list num_matching = num_matching + 1 matching_fields(num_matching) = i_field END DO @@ -2932,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 @@ -3034,8 +3036,8 @@ END FUNCTION find_fields_in_file FUNCTION find_forecast_time(self, found_fctime, stashcode) RESULT(STATUS) - ! This function takes a stashcode as input and returns a list of all the times - ! associated with that stashcode. + ! This function takes a stashcode as input and returns a list of all the times + ! associated with that stashcode. IMPLICIT NONE @@ -3044,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 @@ -3077,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) @@ -3092,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 @@ -3207,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/src/Makefile b/shum_horizontal_field_interp/src/Makefile index c9d76b9..e1238a6 100644 --- a/shum_horizontal_field_interp/src/Makefile +++ b/shum_horizontal_field_interp/src/Makefile @@ -40,5 +40,5 @@ libshum_horizontal_field_interp.so: \ # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_horizontal_field_interp/src/f_shum_horizontal_field_interp.f90 b/shum_horizontal_field_interp/src/f_shum_horizontal_field_interp.f90 index 6c5597c..0acb01b 100644 --- a/shum_horizontal_field_interp/src/f_shum_horizontal_field_interp.f90 +++ b/shum_horizontal_field_interp/src/f_shum_horizontal_field_interp.f90 @@ -233,11 +233,10 @@ END SUBROUTINE f_shum_horizontal_field_bi_lin_interp_calc ! target point. Two indices are needed to cater for east-west ! (lambda direction) cyclic boundaries when the source data is ! global. If a target point falls outside the domain of the source -! data, one sided differencing is used. The source latitude -! coordinates must be supplied in decreasing order. The source -! long- itude coordinates must be supplied in increasing order, -! starting at any value, but not wrapping round. The target -! points may be specified in any order. +! data, one sided differencing is used. The source latitude and +! longitude coordinates must be supplied in increasing order. The +! source longitude coordinates may start at any value, but not +! wrapping round. The target points may be specified in any order. ! ! Vector Machines : The original versions of this code had sections designed ! for improved performance on vector machines controlled by @@ -605,7 +604,9 @@ SUBROUTINE f_shum_calc_weights & ! If we only have 1 row then we need to make sure we can cope. b = ABS(phi_srce(iy(i))-phi_srce(MIN(iy(i)+1,points_phi_srce))) IF (b /= 0.0_shum_real64) THEN - b = MAX(phi_targ(i)-phi_srce(iy(i)),0.0_shum_real64)/b + ! If (phi_targ - phi_srce)/b is outside [0, 1] range then cap to prevent + ! extrapolation + b = MIN(MAX(phi_targ(i)-phi_srce(iy(i)),0.0_shum_real64)/b,1.0_shum_real64) ELSE b = 0.0_shum_real64 END IF 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/src/Makefile b/shum_kinds/src/Makefile new file mode 100644 index 0000000..ad2c2bd --- /dev/null +++ b/shum_kinds/src/Makefile @@ -0,0 +1,49 @@ +# Makefile for library; builds both a static (.a) and dynamic (.so) version +# for maximum flexibility. The required files are copied to the final directory +#------------------------------------------------------------------------------ +LIBTARGETS= \ + ${LIBDIR_OUT}/lib/libshum_kinds.so \ + ${LIBDIR_OUT}/lib/libshum_kinds.a + +${LIBTARGETS}: libshum_kinds.so libshum_kinds.a + cp $^ ${LIBDIR_OUT}/lib + cp *.h *.mod ${LIBDIR_OUT}/include + cp ${COMMON_DIR}/shumlib_version.h ${LIBDIR_OUT}/include + +# Include precision bomb and version reporting information +#------------------------------------------------------------------------------- +VERSION_LIBNAME=shum_kinds +include ${COMMON_DIR}/Makefile-version + +# Static library - uses archiver to create library +#------------------------------------------------------------------------------- +f_shum_kinds.o: f_shum_kinds.f90 + ${FC} ${FCFLAGS} -c -I${LIBDIR_OUT}/include $< + +libshum_kinds.a: \ + f_shum_kinds.o \ + ${VERSION_OBJECTS} + ${AR} $@ $^ + +# Dynamic library - uses compiler to create shared library - the object files +# are suffixed to keep them separate to the above (since the dynamic library +# required position-independent-code flags whilst the static version does not) +#------------------------------------------------------------------------------- +f_shum_kinds_PIC.o: f_shum_kinds.f90 + ${FC} ${FCFLAGS} ${FCFLAGS_PIC} -c -I${LIBDIR_OUT}/include $< -o $@ + +libshum_kinds.so: \ + f_shum_kinds_PIC.o \ + ${VERSION_OBJECTS_PIC} + ${FC} ${FCFLAGS_SHARED} ${FCFLAGS} ${FCFLAGS_PIC} $^ -o $@ + +# Cleanup +#------------------------------------------------------------------------------- +.PHONY: clean +clean: + rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} + +# Preprocess targets +#-------------------------------------------------------------------------------- +%.f90: %.F90 + ${FPP} ${FPPFLAGS} $< -o $@ diff --git a/shum_kinds/src/f_shum_kinds.F90 b/shum_kinds/src/f_shum_kinds.F90 new file mode 100644 index 0000000..e30ef8c --- /dev/null +++ b/shum_kinds/src/f_shum_kinds.F90 @@ -0,0 +1,215 @@ +! *****************************COPYRIGHT******************************* +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT******************************* +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . +! +!******************************************************************************* +! +! Description : Module to define kinds used in Shumlib +! +MODULE f_shum_kinds_mod + +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: & + LOGICAL_KINDS, REAL_KINDS, INTEGER_KINDS, REAL32, REAL64 + +USE, INTRINSIC :: ISO_C_BINDING, ONLY: & + C_BOOL, c_int64_t, c_int32_t, c_int8_t + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: & + shum_logical64, & + shum_logical32, & + shum_logical8, & + shum_lkinds, & + shum_real64, & + shum_real32, & + shum_rkinds, & + shum_int64, & + shum_int32, & + shum_int8, & + shum_ikinds + +!------------------------------------------------------------------------------! +! LOGICAL KINDS ! +!------------------------------------------------------------------------------! + +#if defined(FORCE_LOGICALS) + +#if !defined(FORCE_LOGICAL_64) +#define FORCE_LOGICAL_64 8 +#endif + +#if !defined(FORCE_LOGICAL_32) +#define FORCE_LOGICAL_32 4 +#endif + +#if !defined(FORCE_LOGICAL_8) +#define FORCE_LOGICAL_8 1 +#endif + +INTEGER, PARAMETER :: shum_logical64 = FORCE_LOGICAL_64 +INTEGER, PARAMETER :: shum_logical32 = FORCE_LOGICAL_32 +INTEGER, PARAMETER :: shum_logical8 = FORCE_LOGICAL_8 + +INTEGER, PARAMETER :: & + s_lks = SIZE(LOGICAL_KINDS) + +INTEGER, PARAMETER :: & + shum_lkinds(s_lks) = LOGICAL_KINDS(1:s_lks) + +#else + +! Available Logical Kinds + +! The method to determine Logical Kinds is somewhat convoluted in order to be +! compatible with multiple compilers. +! +! We will create an array of storage sizes based on the LOGICAL_KINDS array. +! We will then manually test if the size of each element matches out size +! requirement. By fixing the size at 10 elements, then abstracting the array +! indices, we can cope with differing numbers of logical kinds. (If a particular +! array index is too large, it is re-mapped to the first element, which is +! guaranteed to exist.) The assumption has been made that 10 elements is large +! enough to always hold all elements of LOGICAL_KINDS. However, if a system is +! encountered that requires more elements, this method is easy to extend. +! +! The manual method is verbose, but has no performance impact, as all values are +! calculated at compile time. + +INTEGER, PARAMETER :: & + s_lks = MERGE( SIZE(LOGICAL_KINDS), 10, (SIZE(LOGICAL_KINDS) < 10) ) + +INTEGER, PARAMETER :: & + shum_lkinds(s_lks) = LOGICAL_KINDS(1:s_lks) + +! Index Parameters for Logical Kind selection + +INTEGER, PARAMETER :: & + l_idx_1 = 1, & + l_idx_2 = MERGE( 2, 1, 2<=s_lks ), & + l_idx_3 = MERGE( 3, 1, 3<=s_lks ), & + l_idx_4 = MERGE( 4, 1, 4<=s_lks ), & + l_idx_5 = MERGE( 5, 1, 5<=s_lks ), & + l_idx_6 = MERGE( 6, 1, 6<=s_lks ), & + l_idx_7 = MERGE( 7, 1, 7<=s_lks ), & + l_idx_8 = MERGE( 8, 1, 8<=s_lks ), & + l_idx_9 = MERGE( 9, 1, 9<=s_lks ), & + l_idx_10 = MERGE( 10, 1, 10<=s_lks ) + +INTEGER, PARAMETER :: & + l_idxk_1 = LOGICAL_KINDS(l_idx_1), & + l_idxk_2 = LOGICAL_KINDS(l_idx_2), & + l_idxk_3 = LOGICAL_KINDS(l_idx_3), & + l_idxk_4 = LOGICAL_KINDS(l_idx_4), & + l_idxk_5 = LOGICAL_KINDS(l_idx_5), & + l_idxk_6 = LOGICAL_KINDS(l_idx_6), & + l_idxk_7 = LOGICAL_KINDS(l_idx_7), & + l_idxk_8 = LOGICAL_KINDS(l_idx_8), & + l_idxk_9 = LOGICAL_KINDS(l_idx_9), & + l_idxk_10 = LOGICAL_KINDS(l_idx_10) + +! Temporary Array of storage sizes + +INTEGER, PARAMETER :: & + lkinds_ss_tmp(10) = [ & + STORAGE_SIZE(.TRUE._l_idxk_1), & + STORAGE_SIZE(.TRUE._l_idxk_2), & + STORAGE_SIZE(.TRUE._l_idxk_3), & + STORAGE_SIZE(.TRUE._l_idxk_4), & + STORAGE_SIZE(.TRUE._l_idxk_5), & + STORAGE_SIZE(.TRUE._l_idxk_6), & + STORAGE_SIZE(.TRUE._l_idxk_7), & + STORAGE_SIZE(.TRUE._l_idxk_8), & + STORAGE_SIZE(.TRUE._l_idxk_9), & + STORAGE_SIZE(.TRUE._l_idxk_10) & + ] + +INTEGER, PARAMETER :: & + lk_idx_l64_1 = 1, & + lk_idx_l64_2 = MERGE( 2, lk_idx_l64_1, lkinds_ss_tmp(2) == 64 ), & + lk_idx_l64_3 = MERGE( 3, lk_idx_l64_2, lkinds_ss_tmp(3) == 64 ), & + lk_idx_l64_4 = MERGE( 4, lk_idx_l64_3, lkinds_ss_tmp(4) == 64 ), & + lk_idx_l64_5 = MERGE( 5, lk_idx_l64_4, lkinds_ss_tmp(5) == 64 ), & + lk_idx_l64_6 = MERGE( 6, lk_idx_l64_5, lkinds_ss_tmp(6) == 64 ), & + lk_idx_l64_7 = MERGE( 7, lk_idx_l64_6, lkinds_ss_tmp(7) == 64 ), & + lk_idx_l64_8 = MERGE( 8, lk_idx_l64_7, lkinds_ss_tmp(8) == 64 ), & + lk_idx_l64_9 = MERGE( 9, lk_idx_l64_8, lkinds_ss_tmp(9) == 64 ), & + lk_idx_l64_10 = MERGE( 10, lk_idx_l64_9, lkinds_ss_tmp(10) == 64 ) + + +INTEGER, PARAMETER :: & + lk_idx_l32_1 = 1, & + lk_idx_l32_2 = MERGE( 2, lk_idx_l32_1, lkinds_ss_tmp(2) == 32 ), & + lk_idx_l32_3 = MERGE( 3, lk_idx_l32_2, lkinds_ss_tmp(3) == 32 ), & + lk_idx_l32_4 = MERGE( 4, lk_idx_l32_3, lkinds_ss_tmp(4) == 32 ), & + lk_idx_l32_5 = MERGE( 5, lk_idx_l32_4, lkinds_ss_tmp(5) == 32 ), & + lk_idx_l32_6 = MERGE( 6, lk_idx_l32_5, lkinds_ss_tmp(6) == 32 ), & + lk_idx_l32_7 = MERGE( 7, lk_idx_l32_6, lkinds_ss_tmp(7) == 32 ), & + lk_idx_l32_8 = MERGE( 8, lk_idx_l32_7, lkinds_ss_tmp(8) == 32 ), & + lk_idx_l32_9 = MERGE( 9, lk_idx_l32_8, lkinds_ss_tmp(9) == 32 ), & + lk_idx_l32_10 = MERGE( 10, lk_idx_l32_9, lkinds_ss_tmp(10) == 32 ) + +! Logical Kind selection indices + +INTEGER, PARAMETER :: lk_idx_l64 = lk_idx_l64_10 +INTEGER, PARAMETER :: lk_idx_l32 = lk_idx_l32_10 + +! Logical Kind selection + +INTEGER, PARAMETER :: shum_logical64 = LOGICAL_KINDS(lk_idx_l64) +INTEGER, PARAMETER :: shum_logical32 = LOGICAL_KINDS(lk_idx_l32) +INTEGER, PARAMETER :: shum_logical8 = C_BOOL + +#endif + +!------------------------------------------------------------------------------! +! REAL KINDS ! +!------------------------------------------------------------------------------! + +! Real Kind selection + +INTEGER, PARAMETER :: shum_real64 = REAL64 +INTEGER, PARAMETER :: shum_real32 = REAL32 + +INTEGER, PARAMETER :: & + s_rks = SIZE(REAL_KINDS) + +INTEGER, PARAMETER :: & + shum_rkinds(s_rks) = REAL_KINDS(1:s_rks) + +!------------------------------------------------------------------------------! +! INTEGER KINDS ! +!------------------------------------------------------------------------------! + +! Integer Kind selection + +INTEGER, PARAMETER :: shum_int64 = c_int64_t +INTEGER, PARAMETER :: shum_int32 = c_int32_t +INTEGER, PARAMETER :: shum_int8 = c_int8_t + +INTEGER, PARAMETER :: & + s_iks = SIZE(INTEGER_KINDS) + +INTEGER, PARAMETER :: & + shum_ikinds(s_iks) = INTEGER_KINDS(1:s_iks) + +END MODULE f_shum_kinds_mod 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/Makefile b/shum_kinds/test/Makefile new file mode 100644 index 0000000..3340711 --- /dev/null +++ b/shum_kinds/test/Makefile @@ -0,0 +1,24 @@ +# Makefile for FRUIT testing modules; builds the object files suitable for +# inclusion in either a static (.a) or dynamic (.so) test executable, to be +# picked up by a later make task +#------------------------------------------------------------------------------- +.PHONY: test +test: fruit_test_shum_kinds.o fruit_test_shum_kinds_PIC.o + +# Static version +#------------------------------------------------------------------------------- +fruit_test_shum_kinds.o: fruit_test_shum_kinds.f90 ${LIBDIR_OUT}/lib/libshum_kinds.a + ${FC} -c ${FCFLAGS_STATIC} ${FCFLAGS} $< \ + -I${LIBDIR_OUT}/include -o $@ ${FCFLAGS_STATIC_TRAIL} + +# Dynamic version +#------------------------------------------------------------------------------- +fruit_test_shum_kinds_PIC.o: fruit_test_shum_kinds.f90 ${LIBDIR_OUT}/lib/libshum_kinds.so + ${FC} -c ${FCFLAGS_DYNAMIC} ${FCFLAGS} ${FCFLAGS_PIC} $< \ + -I${LIBDIR_OUT}/include -o $@ ${FCFLAGS_DYNAMIC_TRAIL} + +# Cleanup +#------------------------------------------------------------------------------- +.PHONY: clean +clean: + rm -f *.o *.mod diff --git a/shum_kinds/test/fruit_test_shum_kinds.f90 b/shum_kinds/test/fruit_test_shum_kinds.f90 new file mode 100644 index 0000000..0790928 --- /dev/null +++ b/shum_kinds/test/fruit_test_shum_kinds.f90 @@ -0,0 +1,119 @@ +! *********************************COPYRIGHT************************************ +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. +! *********************************COPYRIGHT************************************ +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . +!******************************************************************************* +MODULE fruit_test_shum_kinds_mod + +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 + + +USE f_shum_kinds_mod, ONLY: & + shum_logical64, shum_logical32, shum_logical8, & + shum_lkinds, & + shum_real64, shum_real32, & + shum_rkinds, & + shum_int64, shum_int32, shum_int8, & + shum_ikinds + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: fruit_test_shum_kinds + +!------------------------------------------------------------------------------! +! We're going to use the types from the ISO_C_BINDING module, since although ! +! the REALs aren't 100% guaranteed to correspond to the sizes we want to ! +! enforce, they should be good enough on the majority of systems. ! +! ! +! Additional protection for the case that FLOAT/DOUBLE do not conform to the ! +! sizes we expect is provided via the "precision_bomb" macro-file ! +!------------------------------------------------------------------------------! +INTEGER, PARAMETER :: INT64 = C_INT64_T +INTEGER, PARAMETER :: INT32 = C_INT32_T +INTEGER, PARAMETER :: REAL64 = C_DOUBLE +INTEGER, PARAMETER :: bool = C_BOOL +!------------------------------------------------------------------------------! + +CONTAINS + +SUBROUTINE fruit_test_shum_kinds + +USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT, ERROR_UNIT +USE f_shum_kinds_version_mod, ONLY: get_shum_kinds_version + +IMPLICIT NONE + +INTEGER(KIND=INT64) :: version + +! Note: we don't have a test case for the version checking because we don't +! want the testing to include further hardcoded version numbers to test +! against. Since the version module is simple and hardcoded anyway it's +! sufficient to make sure it is callable; but let's print the version for info. +version = get_shum_kinds_version() + +WRITE(OUTPUT_UNIT, "()") +WRITE(OUTPUT_UNIT, "(A,I0)") & + "Testing shum_kinds at Shumlib version: ", version + +CALL run_test_case( & + test_shum_kinds, "kinds") + +END SUBROUTINE fruit_test_shum_kinds + +!------------------------------------------------------------------------------! + +SUBROUTINE test_shum_kinds + + +IMPLICIT NONE + +CALL assert_equals(STORAGE_SIZE(.TRUE._shum_logical64), & + 64, "shum_logical64 storage size is wrong" ) + + +CALL assert_equals(STORAGE_SIZE(.TRUE._shum_logical32), & + 32, "shum_logical32 storage size is wrong" ) + +CALL assert_equals(STORAGE_SIZE(.TRUE._shum_logical8), & + 8, "shum_logical8 storage size is wrong" ) + +CALL assert_equals(STORAGE_SIZE(1.0_shum_real64), & + 64, "shum_real64 storage size is wrong" ) + +CALL assert_equals(STORAGE_SIZE(1.0_shum_real32), & + 32, "shum_real32 storage size is wrong" ) + +CALL assert_equals(STORAGE_SIZE(1_shum_int64), & + 64, "shum_int64 storage size is wrong" ) + +CALL assert_equals(STORAGE_SIZE(1_shum_int32), & + 32, "shum_int32 storage size is wrong" ) + +CALL assert_equals(STORAGE_SIZE(1_shum_int8), & + 8, "shum_int8 storage size is wrong" ) + +END SUBROUTINE test_shum_kinds + +!------------------------------------------------------------------------------! + +END MODULE fruit_test_shum_kinds_mod 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/Makefile b/shum_latlon_eq_grids/src/Makefile index 9b25fbd..ccbb058 100644 --- a/shum_latlon_eq_grids/src/Makefile +++ b/shum_latlon_eq_grids/src/Makefile @@ -38,5 +38,5 @@ libshum_latlon_eq_grids.so: f_shum_latlon_eq_grids_PIC.o \ # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} 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 5a6375e..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 @@ -1,30 +1,30 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* 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 +IMPLICIT NONE PRIVATE @@ -41,7 +41,7 @@ MODULE fruit_test_shum_latlon_eq_grids_mod INTEGER, PARAMETER :: int64 = C_INT64_T INTEGER, PARAMETER :: int32 = C_INT32_T INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT + INTEGER, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! ! The number of points in the individual test arrays @@ -110,12 +110,12 @@ SUBROUTINE fruit_test_shum_latlon_eq_grids END SUBROUTINE fruit_test_shum_latlon_eq_grids -! Functions used to provide sample arrays of lat/long data - the goal here +! Functions used to provide sample arrays of lat/long data - the goal here ! isn't for a numerical workout but easy to identify and work with arrays. ! The range from -90 to 90 lat and 1 to 360 long is spread across 10 values. !------------------------------------------------------------------------------! SUBROUTINE sample_starting_data_64(latitude, longitude) -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real64), INTENT(OUT) :: latitude(n) REAL(KIND=real64), INTENT(OUT) :: longitude(n) @@ -130,8 +130,8 @@ END SUBROUTINE sample_starting_data_64 !------------------------------------------------------------------------------! -SUBROUTINE sample_starting_data_32(latitude, longitude) -IMPLICIT NONE +SUBROUTINE sample_starting_data_32(latitude, longitude) +IMPLICIT NONE REAL(KIND=real32), INTENT(OUT) :: latitude(n) REAL(KIND=real32), INTENT(OUT) :: longitude(n) @@ -154,7 +154,7 @@ END SUBROUTINE sample_starting_data_32 SUBROUTINE sample_rotated_data_64 & (case_index, pole_lat, pole_lon, latitude_eq, longitude_eq) -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), INTENT(IN ) :: case_index REAL(KIND=real64), INTENT(OUT) :: pole_lat REAL(KIND=real64), INTENT(OUT) :: pole_lon @@ -229,7 +229,7 @@ SUBROUTINE sample_rotated_data_64 & 12.4979706108037_real64, & -1.93508314394315_real64, & 18.0000000000000_real64 ] - + longitude_eq(:) = [ 179.999999146226_real64, & 169.992216056674_real64, & 154.328820636016_real64, & @@ -279,7 +279,7 @@ SUBROUTINE sample_rotated_data_64 & -73.0882699868836_real64, & -40.7803149924612_real64, & -54.0000000000000_real64 ] - + longitude_eq(:) = [ 180.000001909096_real64, & 189.231457280872_real64, & 238.213796851124_real64, & @@ -326,7 +326,7 @@ END SUBROUTINE sample_rotated_data_64 SUBROUTINE sample_rotated_data_32 & (case_index, pole_lat, pole_lon, latitude_eq, longitude_eq) -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), INTENT(IN ) :: case_index REAL(KIND=real32), INTENT(OUT) :: pole_lat REAL(KIND=real32), INTENT(OUT) :: pole_lon @@ -360,7 +360,7 @@ END SUBROUTINE sample_rotated_data_32 SUBROUTINE sample_rotated_wind_data_64 & (case_index, pole_lat, pole_lon, longitude_eq, u_ll, v_ll) -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), INTENT(IN ) :: case_index REAL(KIND=real64), INTENT(OUT) :: pole_lat @@ -371,7 +371,7 @@ SUBROUTINE sample_rotated_wind_data_64 & REAL(KIND=real64) :: latitude_eq_dummy(n) -! We're sharing data with the test cases from the non-vector rotation tests, +! We're sharing data with the test cases from the non-vector rotation tests, ! so to avoid duplication retrieve the pole co-ordinates and longitudes ! directly from there (the latitudes aren't needed however) CALL sample_rotated_data( & @@ -436,7 +436,7 @@ SUBROUTINE sample_rotated_wind_data_64 & 3.06913674758749_real64, & 30.2050787224513_real64, & 136.731456986939_real64 ] - + v_ll(:) = [ 16.2231918521525_real64, & 11.6707878263360_real64, & 6.45115237043830_real64, & @@ -525,7 +525,7 @@ END SUBROUTINE sample_rotated_wind_data_64 SUBROUTINE sample_rotated_wind_data_32 & (case_index, pole_lat, pole_lon, longitude_eq, u_ll, v_ll) -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), INTENT(IN ) :: case_index REAL(KIND=real32), INTENT(OUT) :: pole_lat REAL(KIND=real32), INTENT(OUT) :: pole_lon @@ -568,8 +568,8 @@ SUBROUTINE sample_wind_data_64(lambda, u_eq, v_eq) REAL(KIND=real64) :: phi_dummy(n) -! We're sharing data with the test cases from the non-vector rotation tests, -! so to avoid duplication retrieve the starting longitudes directly from +! We're sharing data with the test cases from the non-vector rotation tests, +! so to avoid duplication retrieve the starting longitudes directly from ! there (the latitudes aren't needed however) CALL sample_starting_data(phi_dummy, lambda) @@ -586,7 +586,7 @@ END SUBROUTINE sample_wind_data_64 !------------------------------------------------------------------------------! SUBROUTINE sample_wind_data_32(lambda, u_eq, v_eq) -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real32), INTENT(OUT) :: lambda(n) REAL(KIND=real32), INTENT(OUT) :: u_eq(n) REAL(KIND=real32), INTENT(OUT) :: v_eq(n) @@ -613,7 +613,7 @@ SUBROUTINE test_ll_to_eq_arg64 USE f_shum_latlon_eq_grids_mod, ONLY: f_shum_latlon_to_eq -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real64) :: longitude(n) REAL(KIND=real64) :: latitude(n) @@ -634,7 +634,7 @@ SUBROUTINE test_ll_to_eq_arg64 ! Retrieve the set of lat/lon points to be tested CALL sample_starting_data(latitude, longitude) -! The above points will be tested using a variety of target grids, the +! The above points will be tested using a variety of target grids, the ! pole co-ordinates of these and the expected values after rotation are ! returned by a call to "sample_rotated_data" with the case number, i DO i = 1,cases @@ -666,7 +666,7 @@ SUBROUTINE test_ll_to_eq_arg32 USE f_shum_latlon_eq_grids_mod, ONLY: f_shum_latlon_to_eq -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real32) :: longitude(n) REAL(KIND=real32) :: latitude(n) @@ -687,7 +687,7 @@ SUBROUTINE test_ll_to_eq_arg32 ! Retrieve the set of lat/lon points to be tested CALL sample_starting_data(latitude, longitude) -! The above points will be tested using a variety of target grids, the +! The above points will be tested using a variety of target grids, the ! pole co-ordinates of these and the expected values after rotation are ! returned by a call to "sample_rotated_data" with the case number, i DO i = 1,cases @@ -719,7 +719,7 @@ SUBROUTINE test_eq_to_ll_arg64 USE f_shum_latlon_eq_grids_mod, ONLY: f_shum_eq_to_latlon -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real64) :: phi_pole REAL(KIND=real64) :: phi_eq(n) @@ -741,11 +741,11 @@ SUBROUTINE test_eq_to_ll_arg64 CALL sample_starting_data(phi_exp, lambda_exp) ! Now go through the sample cases un-rotating the data and comparing to the -! original data above +! original data above DO i = 1,cases CALL sample_rotated_data(i, phi_pole, lambda_pole, phi_eq, lambda_eq) - + status = f_shum_eq_to_latlon( & phi_eq, lambda_eq, latitude, longitude, phi_pole, lambda_pole, message) @@ -769,9 +769,9 @@ END SUBROUTINE test_eq_to_ll_arg64 SUBROUTINE test_eq_to_ll_arg32 -USE f_shum_latlon_eq_grids_mod, ONLY: f_shum_eq_to_latlon +USE f_shum_latlon_eq_grids_mod, ONLY: f_shum_eq_to_latlon -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real32) :: phi_pole REAL(KIND=real32) :: phi_eq(n) @@ -793,11 +793,11 @@ SUBROUTINE test_eq_to_ll_arg32 CALL sample_starting_data(phi_exp, lambda_exp) ! Now go through the sample cases un-rotating the data and comparing to the -! original data above +! original data above DO i = 1,cases CALL sample_rotated_data(i, phi_pole, lambda_pole, phi_eq, lambda_eq) - + status = f_shum_eq_to_latlon( & phi_eq, lambda_eq, latitude, longitude, phi_pole, lambda_pole, message) @@ -807,7 +807,7 @@ SUBROUTINE test_eq_to_ll_arg32 "Unrotating eq arrays to ll returned non-zero exit status"//case_info// & " Message: "//TRIM(message)) - CALL assert_equals(phi_exp, latitude, n, test_tol_32, & + CALL assert_equals(phi_exp, latitude, n, test_tol_32, & "Unrotated phi array does not agree with expected result"//case_info) CALL assert_equals(lambda_exp, longitude, n, test_tol_32, & 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/Makefile b/shum_number_tools/test/Makefile index 4109d9c..b13daa7 100644 --- a/shum_number_tools/test/Makefile +++ b/shum_number_tools/test/Makefile @@ -12,9 +12,9 @@ fruit_test_shum_number_tools.o: fruit_test_shum_number_tools.f90 ${LIBDIR_OUT}/l ${FC} -c ${FCFLAGS_STATIC} ${FCFLAGS} $< \ -I${LIBDIR_OUT}/include -o $@ ${FCFLAGS_STATIC_TRAIL} -c_fruit_test_shum_number_tools.o: c_fruit_test_shum_number_tools.c ${LIBDIR_OUT}/lib/libshum_number_tools.a +c_fruit_test_shum_number_tools.o: c_fruit_test_shum_number_tools.c ${LIBDIR_OUT}/lib/libshum_number_tools.a ${COMMON_DIR}/c_shum_compiler_select.h ${CC} -c ${CCFLAGS_STATIC} ${CCFLAGS} $< \ - -I${LIBDIR_OUT}/include -o $@ ${CCFLAGS_STATIC_TRAIL} + -I${LIBDIR_OUT}/include -I${COMMON_DIR} -o $@ ${CCFLAGS_STATIC_TRAIL} # Dynamic version @@ -23,9 +23,9 @@ fruit_test_shum_number_tools_PIC.o: fruit_test_shum_number_tools.f90 ${LIBDIR_OU ${FC} -c ${FCFLAGS_DYNAMIC} ${FCFLAGS} ${FCFLAGS_PIC} $< \ -I${LIBDIR_OUT}/include -o $@ ${FCFLAGS_DYNAMIC_TRAIL} -c_fruit_test_shum_number_tools_PIC.o: c_fruit_test_shum_number_tools.c ${LIBDIR_OUT}/lib/libshum_number_tools.so +c_fruit_test_shum_number_tools_PIC.o: c_fruit_test_shum_number_tools.c ${LIBDIR_OUT}/lib/libshum_number_tools.so ${COMMON_DIR}/c_shum_compiler_select.h ${CC} -c ${CCFLAGS_DYNAMIC} ${CCFLAGS} ${CCFLAGS_PIC} $< \ - -I${LIBDIR_OUT}/include -o $@ ${CCFLAGS_DYNAMIC_TRAIL} + -I${LIBDIR_OUT}/include -I${COMMON_DIR} -o $@ ${CCFLAGS_DYNAMIC_TRAIL} # Cleanup #------------------------------------------------------------------------------- diff --git a/shum_number_tools/test/c_fruit_test_shum_number_tools.c b/shum_number_tools/test/c_fruit_test_shum_number_tools.c index 2e992b6..6d68c5f 100644 --- a/shum_number_tools/test/c_fruit_test_shum_number_tools.c +++ b/shum_number_tools/test/c_fruit_test_shum_number_tools.c @@ -30,6 +30,7 @@ #include #endif #include "c_fruit_test_shum_number_tools.h" +#include "c_shum_compiler_select.h" /******************************************************************************/ /* prototypes */ @@ -69,7 +70,7 @@ double c_test_generate_dnan(void) void c_test_generate_fdenormal(float *denormal_float) { -#if !defined(__GNUC__) || defined(__clang__) +#if !defined(SHUM_IS_GNU_COMPILER) #if defined(__STDC_IEC_559__) /* tell the compiler we will modify the floating point environment */ #pragma STDC FENV_ACCESS ON @@ -137,7 +138,7 @@ if (hwdaz) void c_test_generate_ddenormal(double *denomal_double) { -#if !defined(__GNUC__) || defined(__clang__) +#if !defined(SHUM_IS_GNU_COMPILER) #if defined(__STDC_IEC_559__) /* tell the compiler we will modify the floating point environment */ #pragma STDC FENV_ACCESS ON 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/src/Makefile b/shum_spiral_search/src/Makefile index 4875921..fc28cab 100644 --- a/shum_spiral_search/src/Makefile +++ b/shum_spiral_search/src/Makefile @@ -48,5 +48,5 @@ libshum_spiral_search.so: \ # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_spiral_search/src/c_shum_spiral_search.f90 b/shum_spiral_search/src/c_shum_spiral_search.f90 index c34a12c..ab8386a 100644 --- a/shum_spiral_search/src/c_shum_spiral_search.f90 +++ b/shum_spiral_search/src/c_shum_spiral_search.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* MODULE c_shum_spiral_search_mod @@ -28,7 +28,7 @@ MODULE c_shum_spiral_search_mod USE, INTRINSIC :: iso_c_binding, ONLY: & C_INT64_T, C_INT32_T, C_CHAR, C_FLOAT, C_DOUBLE, C_BOOL, C_LOC, C_F_POINTER -IMPLICIT NONE +IMPLICIT NONE ! Note - this module (intentionally) has nothing set to PUBLIC - this is because ! it shouldn't ever be accessed from Fortran and only exists to provide the @@ -56,7 +56,7 @@ FUNCTION c_shum_spiral_search_algorithm( & INTEGER(KIND=C_INT64_T), INTENT(IN) :: points_phi INTEGER(KIND=C_INT64_T), INTENT(IN) :: points_lambda LOGICAL(KIND=C_BOOL), INTENT(IN) :: lsm(points_lambda*points_phi) -INTEGER(KIND=C_INT64_T), INTENT(IN) :: no_point_unres +INTEGER(KIND=C_INT64_T), INTENT(IN) :: no_point_unres INTEGER(KIND=C_INT64_T), INTENT(IN) :: index_unres(no_point_unres) REAL(KIND=C_DOUBLE), INTENT(IN) :: lats(points_phi) REAL(KIND=C_DOUBLE), INTENT(IN) :: lons(points_lambda) @@ -87,7 +87,7 @@ FUNCTION c_shum_spiral_search_algorithm( & dist_step, cyclic_domain, & unres_mask, indices_ptr, planet_radius, message) -! If something went wrong allow the calling program to catch the non-zero +! If something went wrong allow the calling program to catch the non-zero ! exit code and error message then act accordingly IF (status /= 0) THEN cmessage = f_shum_f2c_string(TRIM(message)) diff --git a/shum_spiral_search/src/f_shum_spiral_search.f90 b/shum_spiral_search/src/f_shum_spiral_search.f90 index 9c9c396..00aa679 100644 --- a/shum_spiral_search/src/f_shum_spiral_search.f90 +++ b/shum_spiral_search/src/f_shum_spiral_search.f90 @@ -48,15 +48,15 @@ MODULE f_shum_spiral_search_mod ! Additional protection for the case that FLOAT/DOUBLE do not conform to the ! ! sizes we expect is provided via the "precision_bomb" macro-file ! !------------------------------------------------------------------------------! - INTEGER, PARAMETER :: int64 = C_INT64_T - INTEGER, PARAMETER :: int32 = C_INT32_T - INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT - INTEGER, PARAMETER :: bool = C_BOOL +INTEGER, PARAMETER :: INT64 = C_INT64_T +INTEGER, PARAMETER :: INT32 = C_INT32_T +INTEGER, PARAMETER :: REAL64 = C_DOUBLE +INTEGER, PARAMETER :: REAL32 = C_FLOAT +INTEGER, PARAMETER :: bool = C_BOOL !------------------------------------------------------------------------------! -REAL(KIND=real64), PARAMETER :: rMDI = -32768.0_real64*32768.0_real64 -REAL(KIND=real32), PARAMETER :: rMDI_32b = -32768.0_real32*32768.0_real32 +REAL(KIND=REAL64), PARAMETER :: rMDI = -32768.0_real64*32768.0_real64 +REAL(KIND=REAL32), PARAMETER :: rMDI_32b = -32768.0_real32*32768.0_real32 INTERFACE f_shum_spiral_search_algorithm MODULE PROCEDURE & @@ -99,76 +99,76 @@ FUNCTION f_shum_spiral_arg64 & is_land_field, constrained, constrained_max_dist, & dist_step, cyclic_domain, unres_mask, & indices, planet_radius, & - cmessage) RESULT(status) + cmessage) RESULT(istat) IMPLICIT NONE ! Number of rows in grid -INTEGER(KIND=int64), INTENT(IN) :: points_phi +INTEGER(KIND=INT64), INTENT(IN) :: points_phi ! Number of columns in grid -INTEGER(KIND=int64), INTENT(IN) :: points_lambda +INTEGER(KIND=INT64), INTENT(IN) :: points_lambda ! Land sea mask LOGICAL(KIND=bool), INTENT(IN) :: lsm(points_lambda*points_phi) ! Number of unresolved points -INTEGER(KIND=int64), INTENT(IN) :: no_point_unres +INTEGER(KIND=INT64), INTENT(IN) :: no_point_unres ! Index to unresolved pts -INTEGER(KIND=int64), INTENT(IN) :: index_unres(no_point_unres) +INTEGER(KIND=INT64), INTENT(IN) :: index_unres(no_point_unres) ! Latitudes -REAL(KIND=real64), INTENT(IN) :: lats(points_phi) +REAL(KIND=REAL64), INTENT(IN) :: lats(points_phi) ! Longitudes -REAL(KIND=real64), INTENT(IN) :: lons(points_lambda) +REAL(KIND=REAL64), INTENT(IN) :: lons(points_lambda) ! False for sea, True for land field LOGICAL(KIND=bool), INTENT(IN) :: is_land_field ! True to apply constraint distance LOGICAL(KIND=bool), INTENT(IN) :: constrained ! Contraint distance (m) -REAL(KIND=real64), INTENT(IN) :: constrained_max_dist +REAL(KIND=REAL64), INTENT(IN) :: constrained_max_dist ! Step size modifier for search -REAL(KIND=real64), INTENT(IN) :: dist_step +REAL(KIND=REAL64), INTENT(IN) :: dist_step ! True if covering complete lat circle LOGICAL(KIND=bool), INTENT(IN) :: cyclic_domain ! False for a point that is resolved, ! True for an unresolved point LOGICAL(KIND=bool), INTENT(IN) :: unres_mask(points_lambda*points_phi) ! Indices to resolved pts -INTEGER(KIND=int64), INTENT(OUT) :: indices(no_point_unres) +INTEGER(KIND=INT64), INTENT(OUT) :: indices(no_point_unres) ! Radius of planet (in m) -REAL(KIND=real64), INTENT(IN) :: planet_radius +REAL(KIND=REAL64), INTENT(IN) :: planet_radius ! Error message -CHARACTER(LEN=*), INTENT(INOUT) :: cmessage +CHARACTER(LEN=*), INTENT(IN OUT) :: cmessage ! Return status -INTEGER(KIND=int64) :: status +INTEGER(KIND=INT64) :: istat ! LOCAL VARIABLES -INTEGER(KIND=int64) :: i,j,k,l ! Loop counters -INTEGER(KIND=int64) :: north ! Number of points to search north -INTEGER(KIND=int64) :: south ! Number of points to search south -INTEGER(KIND=int64) :: east ! Number of points to search east -INTEGER(KIND=int64) :: west ! Number of points to search west -INTEGER(KIND=int64) :: unres_i ! Index for i for unres -INTEGER(KIND=int64) :: unres_j ! Index for j for unres -INTEGER(KIND=int64) :: curr_i_valid_min ! Posn of valid min distance in E-W dir -INTEGER(KIND=int64) :: curr_j_valid_min ! Posn of valid min distance in S-N dir -INTEGER(KIND=int64) :: curr_i_invalid_min ! Posn of invalid min dist in E-W dir -INTEGER(KIND=int64) :: curr_j_invalid_min ! Posn of invalid min dist in S-N dir +INTEGER(KIND=INT64) :: i,j,k,l ! Loop counters +INTEGER(KIND=INT64) :: north ! Number of points to search north +INTEGER(KIND=INT64) :: south ! Number of points to search south +INTEGER(KIND=INT64) :: east ! Number of points to search east +INTEGER(KIND=INT64) :: west ! Number of points to search west +INTEGER(KIND=INT64) :: unres_i ! Index for i for unres +INTEGER(KIND=INT64) :: unres_j ! Index for j for unres +INTEGER(KIND=INT64) :: curr_i_valid_min ! Posn of valid min distance in E-W dir +INTEGER(KIND=INT64) :: curr_j_valid_min ! Posn of valid min distance in S-N dir +INTEGER(KIND=INT64) :: curr_i_invalid_min ! Posn of invalid min dist in E-W dir +INTEGER(KIND=INT64) :: curr_j_invalid_min ! Posn of invalid min dist in S-N dir LOGICAL :: found ! resolved point fitting critirea has been found LOGICAL :: allsametype ! no resolved points of same type in lsm LOGICAL(KIND=bool) :: tmp_lsm(points_lambda*points_phi) ! temp land sea mask -REAL(KIND=real64) :: search_dist ! distance to search -REAL(KIND=real64) :: step ! step size to loop over -REAL(KIND=real64) :: tempdist ! temporary distance -REAL(KIND=real64) :: min_loc_spc ! minimum of the local spacings -REAL(KIND=real64) :: max_dist ! maximum distance to search -REAL(KIND=real64) :: distance(points_lambda) ! Vector of calculation. -REAL(KIND=real64) :: curr_dist_valid_min ! Current distance to valid point -REAL(KIND=real64) :: curr_dist_invalid_min ! Current distance to invalid point +REAL(KIND=REAL64) :: search_dist ! distance to search +REAL(KIND=REAL64) :: step ! step size to loop over +REAL(KIND=REAL64) :: tempdist ! temporary distance +REAL(KIND=REAL64) :: min_loc_spc ! minimum of the local spacings +REAL(KIND=REAL64) :: max_dist ! maximum distance to search +REAL(KIND=REAL64) :: distance(points_lambda) ! Vector of calculation. +REAL(KIND=REAL64) :: curr_dist_valid_min ! Current distance to valid point +REAL(KIND=REAL64) :: curr_dist_invalid_min ! Current distance to invalid point LOGICAL(KIND=bool) :: is_the_same(SIZE(tmp_lsm,1)) ! End of header ! Initialise -status = 0 +istat = 0 indices(:) = -1 cmessage = ' ' IF (constrained) THEN @@ -182,10 +182,10 @@ FUNCTION f_shum_spiral_arg64 & ! Test to see if all resolved points are of the opposite type tmp_lsm=lsm -tmp_lsm(index_unres(1:no_point_unres))=.NOT. is_land_field +tmp_lsm(index_unres(1:no_point_unres))= .NOT. is_land_field WHERE (tmp_lsm .EQV. is_land_field) is_the_same = .TRUE. -ELSEWHERE +ELSE WHERE is_the_same = .FALSE. END WHERE @@ -206,23 +206,23 @@ FUNCTION f_shum_spiral_arg64 & min_loc_spc=99999999_int64 IF (unres_j > 1) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j-1_int64), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j-1_int64), & lons(unres_i), planet_radius)) END IF IF (unres_j < points_phi) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j+1_int64), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j+1_int64), & lons(unres_i), planet_radius)) END IF IF (unres_i > 1) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & lons(unres_i-1_int64), planet_radius)) END IF IF (unres_i < points_lambda) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & lons(unres_i+1_int64), planet_radius)) END IF @@ -234,9 +234,9 @@ FUNCTION f_shum_spiral_arg64 & search_dist = max_dist END IF -! Assume if we don't find a valid min the value is at planet_radius*pi+1. + ! Assume if we don't find a valid min the value is at planet_radius*pi+1. curr_dist_valid_min = (planet_radius*shum_pi_const)+1.0_real64 -! We want nearest one so we dont want to limit search to max_dist. + ! We want nearest one so we dont want to limit search to max_dist. curr_dist_invalid_min = rMDI found=.FALSE. @@ -258,8 +258,8 @@ FUNCTION f_shum_spiral_arg64 & ! Find how many points can go south and be inside search_dist DO j = 1, unres_j-1 - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j-j),lons(unres_i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j-j),lons(unres_i), & planet_radius) IF (tempdist > search_dist) THEN south=j-1_int64 @@ -268,8 +268,8 @@ FUNCTION f_shum_spiral_arg64 & END DO ! Find how many points can go north and be inside search_dist DO j = 1, points_phi-unres_j - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j+j),lons(unres_i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j+j),lons(unres_i), & planet_radius) IF (tempdist > search_dist) THEN north=j-1_int64 @@ -278,8 +278,8 @@ FUNCTION f_shum_spiral_arg64 & END DO ! Find how many points can go west and be inside search_dist DO i = 1, unres_i-1 - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j),lons(unres_i-i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j),lons(unres_i-i), & planet_radius) IF (tempdist > search_dist) THEN west=i-1_int64 @@ -288,8 +288,8 @@ FUNCTION f_shum_spiral_arg64 & END DO ! Find how many points can go east and be inside search_dist DO i = 1, points_lambda-unres_i - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j),lons(unres_i+i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j),lons(unres_i+i), & planet_radius) IF (tempdist > search_dist) THEN east=i-1_int64 @@ -312,7 +312,7 @@ FUNCTION f_shum_spiral_arg64 & END IF END IF - IF (south == -1_int64 .OR. north == -1_int64 .OR. & + IF (south == -1_int64 .OR. north == -1_int64 .OR. & west == -1_int64 .OR. east == -1_int64) THEN ! have hit an edge of a cyclic domain so will have to do the whole domain ! Want to avoid doing the whole domain as much as possible @@ -322,8 +322,15 @@ FUNCTION f_shum_spiral_arg64 & ! Check to see if it is a resolved point IF (.NOT. unres_mask(l)) THEN ! Calculate distance from point - distance(i) = calc_distance(lats(unres_j), lons(unres_i), & + distance(i) = calc_distance(lats(unres_j), lons(unres_i), & lats(j), lons(i), planet_radius) + END IF + END DO + + DO i = 1, points_lambda + l = i+(j - 1_int64)*points_lambda + ! Check to see if it is a resolved point + IF (.NOT. unres_mask(l)) THEN ! Same type of point. IF (lsm(l) .EQV. is_land_field) THEN ! If current distance is less than any previous min store it. @@ -333,7 +340,7 @@ FUNCTION f_shum_spiral_arg64 & curr_j_valid_min = j END IF ELSE IF (constrained .OR. allsametype) THEN - IF (distance(i) < curr_dist_invalid_min .OR. & + IF (distance(i) < curr_dist_invalid_min .OR. & curr_dist_invalid_min == rMDI) THEN curr_dist_invalid_min = distance(i) curr_i_invalid_min=i @@ -344,33 +351,33 @@ FUNCTION f_shum_spiral_arg64 & END DO END DO -! Set the unresolved data to something sensible if possible. Need to keep this -! independent due to we dont want it to interact with future searches. + ! Set the unresolved data to something sensible if possible. Need to keep this + ! independent due to we dont want it to interact with future searches. IF (curr_dist_valid_min <= max_dist) THEN indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int64)*points_lambda - ELSE IF (allsametype .AND. & - curr_dist_invalid_min /= rMDI .AND. & + ELSE IF (allsametype .AND. & + curr_dist_invalid_min /= rMDI .AND. & curr_dist_invalid_min > max_dist) THEN - cmessage = 'There are no resolved points of this type, setting ' & + cmessage = 'There are no resolved points of this type, setting ' & // 'to closest resolved point' - status = -5 + istat = -5 indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int64)*points_lambda - ELSE IF (curr_dist_invalid_min /= rMDI .AND. & + ELSE IF (curr_dist_invalid_min /= rMDI .AND. & curr_dist_invalid_min <= max_dist) THEN indices(k) = curr_i_invalid_min+(curr_j_invalid_min - 1_int64)*points_lambda - ELSE IF (curr_dist_invalid_min /= rMDI .AND. & + ELSE IF (curr_dist_invalid_min /= rMDI .AND. & curr_dist_invalid_min > max_dist) THEN ! Though hit the maximum search distance there has not been a ! resolved point of either type found, therefore use the closest ! resolved point of the same type which will be greater than max_dist - cmessage = 'Despite being constrained there were no resolved points ' & - // 'of any type within the limit, will just use closest resolved ' & + cmessage = 'Despite being constrained there were no resolved points ' & + // 'of any type within the limit, will just use closest resolved ' & // 'point of the same type' - status = -10 + istat = -10 indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int64)*points_lambda ELSE cmessage = 'A point has been left as still unresolved' - status = 47 + istat = 47 END IF found=.TRUE. @@ -383,10 +390,17 @@ FUNCTION f_shum_spiral_arg64 & ! Check to see if it is a resolved point IF (.NOT. unres_mask(l)) THEN ! Calculate distance from point - distance(i) = calc_distance(lats(unres_j),lons(unres_i), & + distance(i) = calc_distance(lats(unres_j),lons(unres_i), & lats(j),lons(i), planet_radius) + END IF + END DO + + DO i = unres_i-west, unres_i+east + l = i+(j - 1_int64)*points_lambda + ! Check to see if it is a resolved point + IF (.NOT. unres_mask(l)) THEN ! Same type of point and distance less than maximum distance. - IF ((lsm(l) .EQV. is_land_field) .AND. & + IF ((lsm(l) .EQV. is_land_field) .AND. & (distance(i) < search_dist)) THEN ! If current distance is less than any previous min store it. IF (distance(i) < curr_dist_valid_min) THEN @@ -395,9 +409,9 @@ FUNCTION f_shum_spiral_arg64 & curr_j_valid_min = j END IF ELSE IF (constrained .OR. allsametype) THEN - ! have to add this in as if it isn't constrained don't want it - ! storing an invalid value - IF (distance(i) < curr_dist_invalid_min .OR. & + ! have to add this in as if it isn't constrained don't want it + ! storing an invalid value + IF (distance(i) < curr_dist_invalid_min .OR. & curr_dist_invalid_min == rMDI) THEN curr_dist_invalid_min = distance(i) curr_i_invalid_min=i @@ -408,16 +422,16 @@ FUNCTION f_shum_spiral_arg64 & END DO END DO - ! Set unresolved data to something sensible if possible. Need to keep this - ! independent as we don't want it to interact with future searches. + ! Set unresolved data to something sensible if possible. Need to keep this + ! independent as we don't want it to interact with future searches. IF (curr_dist_valid_min < search_dist) THEN indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int64)*points_lambda found=.TRUE. END IF IF (allsametype .AND. curr_dist_invalid_min < search_dist) THEN - cmessage = 'There are no resolved points of this type, setting ' & + cmessage = 'There are no resolved points of this type, setting ' & // 'to closest resolved point' - status = -5 + istat = -5 indices(k)=curr_i_invalid_min+(curr_j_invalid_min - 1_int64)*points_lambda found=.TRUE. END IF @@ -426,15 +440,15 @@ FUNCTION f_shum_spiral_arg64 & search_dist=search_dist+step ELSE IF (search_dist < max_dist) THEN search_dist=max_dist - ELSE IF (constrained .AND. & + ELSE IF (constrained .AND. & curr_dist_invalid_min == rMDI) THEN ! Though hit the maximum search distance there has not been a ! resolved point of either type found, therefore increase ! max_dist by step - cmessage = 'Despite being constrained there were no resolved ' & - // 'points of any type within the limit, will just use closest ' & + cmessage = 'Despite being constrained there were no resolved ' & + // 'points of any type within the limit, will just use closest ' & // 'resolved point of the same type' - status = -20 + istat = -20 max_dist=planet_radius*shum_pi_const curr_dist_valid_min=max_dist search_dist=search_dist+step @@ -447,15 +461,15 @@ FUNCTION f_shum_spiral_arg64 & search_dist=search_dist+step ELSE IF (search_dist < max_dist) THEN search_dist=max_dist - ELSE IF (constrained .AND. & + ELSE IF (constrained .AND. & curr_dist_invalid_min == rMDI) THEN ! Though hit the maximum search distance there has not been a ! resolved point of either type found, therefore increase ! max_dist by step - cmessage = 'Despite being constrained there were no resolved ' & - // 'points of any type within the limit, will just use closest ' & + cmessage = 'Despite being constrained there were no resolved ' & + // 'points of any type within the limit, will just use closest ' & // 'resolved point of the same type' - status = -30 + istat = -30 max_dist=planet_radius*shum_pi_const curr_dist_valid_min=max_dist search_dist=search_dist+step @@ -470,7 +484,7 @@ FUNCTION f_shum_spiral_arg64 & indices(k) = curr_i_invalid_min+(curr_j_invalid_min - 1)*points_lambda ELSE cmessage = 'A point has been left as still unresolved' - status = 47 + istat = 47 END IF END IF END DO @@ -484,76 +498,76 @@ FUNCTION f_shum_spiral_arg32 & is_land_field, constrained, constrained_max_dist, & dist_step, cyclic_domain, unres_mask, & indices, planet_radius, & - cmessage) RESULT(status) + cmessage) RESULT(istat) IMPLICIT NONE ! Number of rows in grid -INTEGER(KIND=int32), INTENT(IN) :: points_phi +INTEGER(KIND=INT32), INTENT(IN) :: points_phi ! Number of columns in grid -INTEGER(KIND=int32), INTENT(IN) :: points_lambda +INTEGER(KIND=INT32), INTENT(IN) :: points_lambda ! Land sea mask LOGICAL(KIND=bool), INTENT(IN) :: lsm(points_lambda*points_phi) ! Number of unresolved points -INTEGER(KIND=int32), INTENT(IN) :: no_point_unres +INTEGER(KIND=INT32), INTENT(IN) :: no_point_unres ! Index to unresolved pts -INTEGER(KIND=int32), INTENT(IN) :: index_unres(no_point_unres) +INTEGER(KIND=INT32), INTENT(IN) :: index_unres(no_point_unres) ! Latitudes -REAL(KIND=real32), INTENT(IN) :: lats(points_phi) +REAL(KIND=REAL32), INTENT(IN) :: lats(points_phi) ! Longitudes -REAL(KIND=real32), INTENT(IN) :: lons(points_lambda) +REAL(KIND=REAL32), INTENT(IN) :: lons(points_lambda) ! False for sea, True for land field LOGICAL(KIND=bool), INTENT(IN) :: is_land_field ! True to apply constraint distance LOGICAL(KIND=bool), INTENT(IN) :: constrained ! Contraint distance (m) -REAL(KIND=real32), INTENT(IN) :: constrained_max_dist +REAL(KIND=REAL32), INTENT(IN) :: constrained_max_dist ! Step size modifier for search -REAL(KIND=real32), INTENT(IN) :: dist_step +REAL(KIND=REAL32), INTENT(IN) :: dist_step ! True if covering complete lat circle LOGICAL(KIND=bool), INTENT(IN) :: cyclic_domain ! False for a point that is resolved, ! True for an unresolved point LOGICAL(KIND=bool), INTENT(IN) :: unres_mask(points_lambda*points_phi) ! Index to resolved pts -INTEGER(KIND=int32), INTENT(OUT) :: indices(no_point_unres) +INTEGER(KIND=INT32), INTENT(OUT) :: indices(no_point_unres) ! Radius of planet -REAL(KIND=real32), INTENT(IN) :: planet_radius +REAL(KIND=REAL32), INTENT(IN) :: planet_radius ! Error message -CHARACTER(LEN=*), INTENT(INOUT) :: cmessage +CHARACTER(LEN=*), INTENT(IN OUT) :: cmessage ! Return status -INTEGER(KIND=int32) :: status +INTEGER(KIND=INT32) :: istat ! LOCAL VARIABLES -INTEGER(KIND=int32) :: i,j,k,l ! Loop counters -INTEGER(KIND=int32) :: north ! Number of points to search north -INTEGER(KIND=int32) :: south ! Number of points to search south -INTEGER(KIND=int32) :: east ! Number of points to search east -INTEGER(KIND=int32) :: west ! Number of points to search west -INTEGER(KIND=int32) :: unres_i ! Index for i for unres -INTEGER(KIND=int32) :: unres_j ! Index for j for unres -INTEGER(KIND=int32) :: curr_i_valid_min ! Posn of valid min distance in E-W dir -INTEGER(KIND=int32) :: curr_j_valid_min ! Posn of valid min distance in S-N dir -INTEGER(KIND=int32) :: curr_i_invalid_min ! Posn of invalid min dist in E-W dir -INTEGER(KIND=int32) :: curr_j_invalid_min ! Posn of invalid min dist in S-N dir +INTEGER(KIND=INT32) :: i,j,k,l ! Loop counters +INTEGER(KIND=INT32) :: north ! Number of points to search north +INTEGER(KIND=INT32) :: south ! Number of points to search south +INTEGER(KIND=INT32) :: east ! Number of points to search east +INTEGER(KIND=INT32) :: west ! Number of points to search west +INTEGER(KIND=INT32) :: unres_i ! Index for i for unres +INTEGER(KIND=INT32) :: unres_j ! Index for j for unres +INTEGER(KIND=INT32) :: curr_i_valid_min ! Posn of valid min distance in E-W dir +INTEGER(KIND=INT32) :: curr_j_valid_min ! Posn of valid min distance in S-N dir +INTEGER(KIND=INT32) :: curr_i_invalid_min ! Posn of invalid min dist in E-W dir +INTEGER(KIND=INT32) :: curr_j_invalid_min ! Posn of invalid min dist in S-N dir LOGICAL :: found ! resolved point fitting critirea has been found LOGICAL :: allsametype ! no resolved points of same type in lsm LOGICAL(KIND=bool) :: tmp_lsm(points_lambda*points_phi) ! temp land sea mask -REAL(KIND=real32) :: search_dist ! distance to search -REAL(KIND=real32) :: step ! step size to loop over -REAL(KIND=real32) :: tempdist ! temporary distance -REAL(KIND=real32) :: min_loc_spc ! minimum of the local spacings -REAL(KIND=real32) :: max_dist ! maximum distance to search -REAL(KIND=real32) :: distance(points_lambda) ! Vector of calculation. -REAL(KIND=real32) :: curr_dist_valid_min ! Current distance to valid point -REAL(KIND=real32) :: curr_dist_invalid_min ! Current distance to invalid point +REAL(KIND=REAL32) :: search_dist ! distance to search +REAL(KIND=REAL32) :: step ! step size to loop over +REAL(KIND=REAL32) :: tempdist ! temporary distance +REAL(KIND=REAL32) :: min_loc_spc ! minimum of the local spacings +REAL(KIND=REAL32) :: max_dist ! maximum distance to search +REAL(KIND=REAL32) :: distance(points_lambda) ! Vector of calculation. +REAL(KIND=REAL32) :: curr_dist_valid_min ! Current distance to valid point +REAL(KIND=REAL32) :: curr_dist_invalid_min ! Current distance to invalid point LOGICAL(KIND=bool) :: is_the_same(SIZE(tmp_lsm,1)) ! End of header ! Initialise -status = 0 +istat = 0 indices(:) = -1 cmessage = ' ' IF (constrained) THEN @@ -567,10 +581,10 @@ FUNCTION f_shum_spiral_arg32 & ! Test to see if all resolved points are of the opposite type tmp_lsm=lsm -tmp_lsm(index_unres)=.NOT. is_land_field +tmp_lsm(index_unres)= .NOT. is_land_field WHERE (tmp_lsm .EQV. is_land_field) is_the_same = .TRUE. -ELSEWHERE +ELSE WHERE is_the_same = .FALSE. END WHERE @@ -591,23 +605,23 @@ FUNCTION f_shum_spiral_arg32 & min_loc_spc=99999999.0_real32 IF (unres_j > 1) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j-1_int32), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j-1_int32), & lons(unres_i), planet_radius)) END IF IF (unres_j < points_phi) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j+1_int32), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j+1_int32), & lons(unres_i), planet_radius)) END IF IF (unres_i > 1) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & lons(unres_i-1_int32), planet_radius)) END IF IF (unres_i < points_lambda) THEN - min_loc_spc=MIN(min_loc_spc,& - calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & + min_loc_spc=MIN(min_loc_spc, & + calc_distance(lats(unres_j), lons(unres_i), lats(unres_j), & lons(unres_i+1_int32), planet_radius)) END IF @@ -619,9 +633,9 @@ FUNCTION f_shum_spiral_arg32 & search_dist = max_dist END IF -! Assume if we don't find a valid min the value is at planet_radius*pi+1. + ! Assume if we don't find a valid min the value is at planet_radius*pi+1. curr_dist_valid_min = (planet_radius*shum_pi_const_32)+1.0_real32 -! We want nearest one so we dont want to limit search to max_dist. + ! We want nearest one so we dont want to limit search to max_dist. curr_dist_invalid_min = rMDI_32b found=.FALSE. @@ -643,8 +657,8 @@ FUNCTION f_shum_spiral_arg32 & ! Find how many points can go south and be inside search_dist DO j = 1, unres_j-1_int32 - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j-j),lons(unres_i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j-j),lons(unres_i), & planet_radius) IF (tempdist > search_dist) THEN south=j-1_int32 @@ -653,8 +667,8 @@ FUNCTION f_shum_spiral_arg32 & END DO ! Find how many points can go north and be inside search_dist DO j = 1, points_phi-unres_j - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j+j),lons(unres_i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j+j),lons(unres_i), & planet_radius) IF (tempdist > search_dist) THEN north=j-1_int32 @@ -663,8 +677,8 @@ FUNCTION f_shum_spiral_arg32 & END DO ! Find how many points can go west and be inside search_dist DO i = 1, unres_i-1_int32 - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j),lons(unres_i-i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j),lons(unres_i-i), & planet_radius) IF (tempdist > search_dist) THEN west=i-1_int32 @@ -673,8 +687,8 @@ FUNCTION f_shum_spiral_arg32 & END DO ! Find how many points can go east and be inside search_dist DO i = 1, points_lambda-unres_i - tempdist=calc_distance(lats(unres_j),lons(unres_i), & - lats(unres_j),lons(unres_i+i), & + tempdist=calc_distance(lats(unres_j),lons(unres_i), & + lats(unres_j),lons(unres_i+i), & planet_radius) IF (tempdist > search_dist) THEN east=i-1_int32 @@ -697,7 +711,7 @@ FUNCTION f_shum_spiral_arg32 & END IF END IF - IF (south == -1_int32 .OR. north == -1_int32 .OR. & + IF (south == -1_int32 .OR. north == -1_int32 .OR. & west == -1_int32 .OR. east == -1_int32) THEN ! have hit an edge of a cyclic domain so will have to do the whole domain ! Want to avoid doing the whole domain as much as possible @@ -707,8 +721,15 @@ FUNCTION f_shum_spiral_arg32 & ! Check to see if it is a resolved point IF (.NOT. unres_mask(l)) THEN ! Calculate distance from point - distance(i) = calc_distance(lats(unres_j), lons(unres_i), & + distance(i) = calc_distance(lats(unres_j), lons(unres_i), & lats(j), lons(i), planet_radius) + END IF + END DO + + DO i = 1, points_lambda + l = i+(j - 1_int32)*points_lambda + ! Check to see if it is a resolved point + IF (.NOT. unres_mask(l)) THEN ! Same type of point. IF (lsm(l) .EQV. is_land_field) THEN ! If current distance is less than any previous min store it. @@ -718,7 +739,7 @@ FUNCTION f_shum_spiral_arg32 & curr_j_valid_min = j END IF ELSE IF (constrained .OR. allsametype) THEN - IF (distance(i) < curr_dist_invalid_min .OR. & + IF (distance(i) < curr_dist_invalid_min .OR. & curr_dist_invalid_min == rMDI_32b) THEN curr_dist_invalid_min = distance(i) curr_i_invalid_min=i @@ -729,33 +750,33 @@ FUNCTION f_shum_spiral_arg32 & END DO END DO -! Set the unresolved data to something sensible if possible. Need to keep this -! independent due to we dont want it to interact with future searches. + ! Set the unresolved data to something sensible if possible. Need to keep this + ! independent due to we dont want it to interact with future searches. IF (curr_dist_valid_min <= max_dist) THEN indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int32)*points_lambda - ELSE IF (allsametype .AND. & - curr_dist_invalid_min /= rMDI_32b .AND. & + ELSE IF (allsametype .AND. & + curr_dist_invalid_min /= rMDI_32b .AND. & curr_dist_invalid_min > max_dist) THEN - cmessage = 'There are no resolved points of this type, setting ' & + cmessage = 'There are no resolved points of this type, setting ' & // 'to closest resolved point' - status = -5 + istat = -5 indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int32)*points_lambda - ELSE IF (curr_dist_invalid_min /= rMDI_32b .AND. & + ELSE IF (curr_dist_invalid_min /= rMDI_32b .AND. & curr_dist_invalid_min <= max_dist) THEN indices(k) = curr_i_invalid_min+(curr_j_invalid_min - 1_int32)*points_lambda - ELSE IF (curr_dist_invalid_min /= rMDI_32b .AND. & + ELSE IF (curr_dist_invalid_min /= rMDI_32b .AND. & curr_dist_invalid_min > max_dist) THEN ! Though hit the maximum search distance there has not been a ! resolved point of either type found, therefore use the closest ! resolved point of the same type which will be greater than max_dist - cmessage = 'Despite being constrained there were no resolved points ' & - // 'of any type within the limit, will just use closest resolved ' & + cmessage = 'Despite being constrained there were no resolved points ' & + // 'of any type within the limit, will just use closest resolved ' & // 'point of the same type' - status = -10 + istat = -10 indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int32)*points_lambda ELSE cmessage = 'A point has been left as still unresolved' - status = 47 + istat = 47 END IF found=.TRUE. @@ -768,10 +789,17 @@ FUNCTION f_shum_spiral_arg32 & ! Check to see if it is a resolved point IF (.NOT. unres_mask(l)) THEN ! Calculate distance from point - distance(i) = calc_distance(lats(unres_j),lons(unres_i), & + distance(i) = calc_distance(lats(unres_j),lons(unres_i), & lats(j),lons(i), planet_radius) + END IF + END DO + + DO i = unres_i-west, unres_i+east + l = i+(j - 1_int32)*points_lambda + ! Check to see if it is a resolved point + IF (.NOT. unres_mask(l)) THEN ! Same type of point and distance less than maximum distance. - IF ((lsm(l) .EQV. is_land_field) .AND. & + IF ((lsm(l) .EQV. is_land_field) .AND. & (distance(i) < search_dist)) THEN ! If current distance is less than any previous min store it. IF (distance(i) < curr_dist_valid_min) THEN @@ -780,9 +808,9 @@ FUNCTION f_shum_spiral_arg32 & curr_j_valid_min = j END IF ELSE IF (constrained .OR. allsametype) THEN - ! have to add this in as if it isn't constrained don't want it - ! storing an invalid value - IF (distance(i) < curr_dist_invalid_min .OR. & + ! have to add this in as if it isn't constrained don't want it + ! storing an invalid value + IF (distance(i) < curr_dist_invalid_min .OR. & curr_dist_invalid_min == rMDI_32b) THEN curr_dist_invalid_min = distance(i) curr_i_invalid_min=i @@ -793,16 +821,16 @@ FUNCTION f_shum_spiral_arg32 & END DO END DO - ! Set unresolved data to something sensible if possible. Need to keep this - ! independent as we don't want it to interact with future searches. + ! Set unresolved data to something sensible if possible. Need to keep this + ! independent as we don't want it to interact with future searches. IF (curr_dist_valid_min < search_dist) THEN indices(k) = curr_i_valid_min+(curr_j_valid_min - 1_int32)*points_lambda found=.TRUE. END IF IF (allsametype .AND. curr_dist_invalid_min < search_dist) THEN - cmessage = 'There are no resolved points of this type, setting ' & + cmessage = 'There are no resolved points of this type, setting ' & // 'to closest resolved point' - status = -5 + istat = -5 indices(k)=curr_i_invalid_min+(curr_j_invalid_min - 1_int32)*points_lambda found=.TRUE. END IF @@ -811,15 +839,15 @@ FUNCTION f_shum_spiral_arg32 & search_dist=search_dist+step ELSE IF (search_dist < max_dist) THEN search_dist=max_dist - ELSE IF (constrained .AND. & + ELSE IF (constrained .AND. & curr_dist_invalid_min == rMDI_32b) THEN ! Though hit the maximum search distance there has not been a ! resolved point of either type found, therefore increase ! max_dist by step - cmessage = 'Despite being constrained there were no resolved ' & - // 'points of any type within the limit, will just use closest ' & + cmessage = 'Despite being constrained there were no resolved ' & + // 'points of any type within the limit, will just use closest ' & // 'resolved point of the same type' - status = -20 + istat = -20 max_dist=planet_radius*shum_pi_const_32 curr_dist_valid_min=max_dist search_dist=search_dist+step @@ -832,15 +860,15 @@ FUNCTION f_shum_spiral_arg32 & search_dist=search_dist+step ELSE IF (search_dist < max_dist) THEN search_dist=max_dist - ELSE IF (constrained .AND. & + ELSE IF (constrained .AND. & curr_dist_invalid_min == rMDI_32b) THEN ! Though hit the maximum search distance there has not been a ! resolved point of either type found, therefore increase ! max_dist by step - cmessage = 'Despite being constrained there were no resolved ' & - // 'points of any type within the limit, will just use closest ' & + cmessage = 'Despite being constrained there were no resolved ' & + // 'points of any type within the limit, will just use closest ' & // 'resolved point of the same type' - status = -30 + istat = -30 max_dist=planet_radius*shum_pi_const_32 curr_dist_valid_min=max_dist search_dist=search_dist+step @@ -855,7 +883,7 @@ FUNCTION f_shum_spiral_arg32 & indices(k) = curr_i_invalid_min+(curr_j_invalid_min - 1_int32)*points_lambda ELSE cmessage = 'A point has been left as still unresolved' - status = 47 + istat = 47 END IF END IF END DO @@ -867,13 +895,13 @@ FUNCTION calc_distance_arg64(lat0, lon0, lat1, lon1, planet_radius) IMPLICIT NONE -REAL(KIND=real64) :: calc_distance_arg64 -REAL(KIND=real64), INTENT(IN) :: lat0, lon0, lat1, lon1, planet_radius +REAL(KIND=REAL64) :: calc_distance_arg64 +REAL(KIND=REAL64), INTENT(IN) :: lat0, lon0, lat1, lon1, planet_radius -REAL(KIND=real64) :: dlat_rad -REAL(KIND=real64) :: dlon_rad -REAL(KIND=real64) :: lat0_rad -REAL(KIND=real64) :: lat1_rad +REAL(KIND=REAL64) :: dlat_rad +REAL(KIND=REAL64) :: dlon_rad +REAL(KIND=REAL64) :: lat0_rad +REAL(KIND=REAL64) :: lat1_rad lat0_rad = lat0*shum_pi_over_180_const lat1_rad = lat1*shum_pi_over_180_const @@ -881,8 +909,8 @@ FUNCTION calc_distance_arg64(lat0, lon0, lat1, lon1, planet_radius) dlon_rad = (lon1-lon0)*shum_pi_over_180_const ! Use the Haversine formula. -calc_distance_arg64 = 2.0_real64*planet_radius* & - ASIN(SQRT(SIN(0.5_real64*dlat_rad)**2_int64 + & +calc_distance_arg64 = 2.0_real64*planet_radius* & + ASIN(SQRT(SIN(0.5_real64*dlat_rad)**2_int64 + & COS(lat0_rad)*COS(lat1_rad)*SIN(0.5_real64*dlon_rad)**2_int64)) END FUNCTION calc_distance_arg64 @@ -891,13 +919,13 @@ FUNCTION calc_distance_arg32(lat0, lon0, lat1, lon1, planet_radius) IMPLICIT NONE -REAL(KIND=real32) :: calc_distance_arg32 -REAL(KIND=real32), INTENT(IN) :: lat0, lon0, lat1, lon1, planet_radius +REAL(KIND=REAL32) :: calc_distance_arg32 +REAL(KIND=REAL32), INTENT(IN) :: lat0, lon0, lat1, lon1, planet_radius -REAL(KIND=real32) :: dlat_rad -REAL(KIND=real32) :: dlon_rad -REAL(KIND=real32) :: lat0_rad -REAL(KIND=real32) :: lat1_rad +REAL(KIND=REAL32) :: dlat_rad +REAL(KIND=REAL32) :: dlon_rad +REAL(KIND=REAL32) :: lat0_rad +REAL(KIND=REAL32) :: lat1_rad lat0_rad = lat0*shum_pi_over_180_const_32 lat1_rad = lat1*shum_pi_over_180_const_32 @@ -905,8 +933,8 @@ FUNCTION calc_distance_arg32(lat0, lon0, lat1, lon1, planet_radius) dlon_rad = (lon1-lon0)*shum_pi_over_180_const_32 ! Use the Haversine formula. -calc_distance_arg32 = 2.0_real32*planet_radius* & - ASIN(SQRT(SIN(0.5_real32*dlat_rad)**2_int32 + & +calc_distance_arg32 = 2.0_real32*planet_radius* & + ASIN(SQRT(SIN(0.5_real32*dlat_rad)**2_int32 + & COS(lat0_rad)*COS(lat1_rad)*SIN(0.5_real32*dlon_rad)**2_int32)) END FUNCTION calc_distance_arg32 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/Makefile b/shum_string_conv/src/Makefile index 8b8f18e..d5f596a 100644 --- a/shum_string_conv/src/Makefile +++ b/shum_string_conv/src/Makefile @@ -36,5 +36,5 @@ libshum_string_conv.so: f_shum_string_conv_PIC.o ${VERSION_OBJECTS_PIC} # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_string_conv/src/f_shum_string_conv.f90 b/shum_string_conv/src/f_shum_string_conv.f90 index ed66ba5..85b1710 100644 --- a/shum_string_conv/src/f_shum_string_conv.f90 +++ b/shum_string_conv/src/f_shum_string_conv.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* ! This module contains the interfaces for interoperability of c and ! fortran characters/strings @@ -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/src/Makefile b/shum_thread_utils/src/Makefile index a53c9e5..63c42f5 100644 --- a/shum_thread_utils/src/Makefile +++ b/shum_thread_utils/src/Makefile @@ -39,6 +39,6 @@ libshum_thread_utils.so: f_shum_thread_utils_PIC.o ${VERSION_OBJECTS_PIC} # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_thread_utils/src/c_shum_thread_utils.h b/shum_thread_utils/src/c_shum_thread_utils.h index 622a778..7895186 100644 --- a/shum_thread_utils/src/c_shum_thread_utils.h +++ b/shum_thread_utils/src/c_shum_thread_utils.h @@ -60,4 +60,6 @@ extern void f_shum_startOMPparallelfor (void **, extern int64_t f_shum_LockQueue (int64_t *); +extern int64_t f_shum_barrier (void); + #endif diff --git a/shum_thread_utils/src/f_shum_thread_utils.f90 b/shum_thread_utils/src/f_shum_thread_utils.f90 index 0ff1689..1a97bcc 100644 --- a/shum_thread_utils/src/f_shum_thread_utils.f90 +++ b/shum_thread_utils/src/f_shum_thread_utils.f90 @@ -558,5 +558,22 @@ END SUBROUTINE startOMPparallelfor !------------------------------------------------------------------------------! -END MODULE f_shum_thread_utils_mod +! barrier() sets up an OpenMP barrier. Returns 1 if the barrier was used. + +FUNCTION barrier() & + BIND(c,NAME="f_shum_barrier") & + RESULT(r) + +IMPLICIT NONE + +INTEGER(KIND=c_int64_t) :: r +r = 0 +!$ r = 1 +!$OMP BARRIER + +END FUNCTION barrier + +!------------------------------------------------------------------------------! + +END MODULE f_shum_thread_utils_mod 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/c_fruit_test_shum_thread_utils.c b/shum_thread_utils/test/c_fruit_test_shum_thread_utils.c index 87505d1..2e19faa 100644 --- a/shum_thread_utils/test/c_fruit_test_shum_thread_utils.c +++ b/shum_thread_utils/test/c_fruit_test_shum_thread_utils.c @@ -20,6 +20,10 @@ /* If not, see . */ /******************************************************************************/ +#if !defined(_POSIX_C_SOURCE) +#define _POSIX_C_SOURCE 200112L +#endif + #include #include #include @@ -27,6 +31,7 @@ #include #include #include +#include #include "c_shum_thread_utils.h" #include "c_fruit_test_shum_thread_utils.h" @@ -1069,6 +1074,60 @@ void c_test_threadflush(bool *test_ret, volatile int64_t *shared1) /******************************************************************************/ +void c_test_barrier(bool *test_ret, int64_t *shared1) +{ + int64_t tid = f_shum_threadID(); + + struct timespec sleep_one = { 1, 0 }; + + const int64_t inpar = f_shum_inPar(); + + *test_ret = (inpar==f_shum_barrier()); + + if (tid==0) + { + shared1[0] = 1; + } + else + { + while (nanosleep(&sleep_one, NULL)) + { + /* repeat until we sleep uninterupted */ + } + } + + *test_ret &= (inpar==f_shum_barrier()); + + *test_ret &= (shared1[0] + shared1[1] + shared1[2] == 1); + + *test_ret &= (inpar==f_shum_barrier()); + + shared1[tid] = 2; + + if (tid!=0) + { + while (nanosleep(&sleep_one, NULL)) + { + /* repeat until we sleep uninterupted */ + } + } + + if (tid==2) + { + while (nanosleep(&sleep_one, NULL)) + { + /* repeat until we sleep uninterupted */ + } + } + + *test_ret &= (inpar==f_shum_barrier()); + + *test_ret &= (shared1[0] + shared1[1] + shared1[2] == 2*f_shum_numThreads()); + +} + +/******************************************************************************/ + void c_test_startOMPparallel(bool *test_ret, int64_t *threads) { dispatch_pack pack; diff --git a/shum_thread_utils/test/c_fruit_test_shum_thread_utils.h b/shum_thread_utils/test/c_fruit_test_shum_thread_utils.h index d6d59c3..9328544 100644 --- a/shum_thread_utils/test/c_fruit_test_shum_thread_utils.h +++ b/shum_thread_utils/test/c_fruit_test_shum_thread_utils.h @@ -57,6 +57,7 @@ extern void c_test_create_single_lock (bool *, int64_t *); extern void c_test_inpar (bool *, int64_t *); extern void c_test_threadid (bool *, int64_t *); extern void c_test_threadflush (bool *, volatile int64_t *); +extern void c_test_barrier (bool *, int64_t *); extern void c_test_numthreads (bool *, int64_t *); extern void c_test_startOMPparallel (bool *, int64_t *); extern void c_test_startOMPparallelfor (bool *, 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 8d011ee..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 @@ -476,6 +476,20 @@ SUBROUTINE c_test_create_single_lock(test_ret, lock) & END SUBROUTINE c_test_create_single_lock +!-------------! + + SUBROUTINE c_test_barrier(test_ret,shared1) & + BIND(c, name="c_test_barrier") + + IMPORT :: C_BOOL, C_INT64_T + + IMPLICIT NONE + + LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret + INTEGER(KIND=C_INT64_T), INTENT(INOUT) :: shared1(3) + + END SUBROUTINE c_test_barrier + !-------------! END INTERFACE @@ -549,6 +563,7 @@ SUBROUTINE fruit_test_shum_thread_utils ! OpenMP functions CALL run_test_case(test_flush, "test_flush") +CALL run_test_case(test_barrier, "test_barrier") END SUBROUTINE fruit_test_shum_thread_utils @@ -1064,6 +1079,42 @@ END SUBROUTINE test_flush !------------------------------------------------------------------------------! +SUBROUTINE test_barrier + +IMPLICIT NONE + +! This test has been explicitly designed to work with three threads. +! Modifying this number without adjusting the test will cause errors. +INTEGER, PARAMETER :: max_threads = 3 + +LOGICAL(KIND=C_BOOL) :: test_ret, test_ret_arr(max_threads) +INTEGER(KIND=C_INT64_T) :: shared1(max_threads), tid + +CALL set_case_name("test_threadbarrier") + +shared1 = 0 +test_ret = .FALSE. +test_ret_arr = .FALSE. +tid = 1 + +!$ CALL omp_set_num_threads(max_threads) +!$OMP PARALLEL DEFAULT(NONE) SHARED(shared1,test_ret_arr) & +!$OMP PRIVATE(tid) + +!$ tid = omp_get_thread_num() + 1 +CALL c_test_barrier(test_ret_arr(tid),shared1) + +!$OMP END PARALLEL + +test_ret = test_ret_arr(1) +!$ test_ret = ALL(test_ret_arr) + +CALL assert_true(test_ret, "Barrier test fails!") + +END SUBROUTINE test_barrier + +!------------------------------------------------------------------------------! + SUBROUTINE test_numthreads IMPLICIT NONE 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/Makefile b/shum_wgdos_packing/src/Makefile index 8cff410..b1d905c 100644 --- a/shum_wgdos_packing/src/Makefile +++ b/shum_wgdos_packing/src/Makefile @@ -48,5 +48,5 @@ libshum_wgdos_packing.so: \ # Cleanup #------------------------------------------------------------------------------- .PHONY: clean -clean: +clean: rm -f *.o *.mod *.so *.a ${VERSION_CLEAN} diff --git a/shum_wgdos_packing/src/c_shum_wgdos_packing.f90 b/shum_wgdos_packing/src/c_shum_wgdos_packing.f90 index 9278690..ea14394 100644 --- a/shum_wgdos_packing/src/c_shum_wgdos_packing.f90 +++ b/shum_wgdos_packing/src/c_shum_wgdos_packing.f90 @@ -1,23 +1,23 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* MODULE c_shum_wgdos_packing_mod @@ -29,7 +29,7 @@ MODULE c_shum_wgdos_packing_mod USE, INTRINSIC :: iso_c_binding, ONLY: & C_F_POINTER, C_LOC, C_INT64_T, C_INT32_T, C_CHAR, C_FLOAT, C_DOUBLE, C_PTR -IMPLICIT NONE +IMPLICIT NONE ! Note - this module (intentionally) has nothing set to PUBLIC - this is because ! it shouldn't ever be accessed from Fortran and only exists to provide the @@ -48,7 +48,7 @@ MODULE c_shum_wgdos_packing_mod INTEGER, PARAMETER :: int64 = C_INT64_T INTEGER, PARAMETER :: int32 = C_INT32_T INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT + INTEGER, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! CONTAINS @@ -123,7 +123,7 @@ FUNCTION c_shum_wgdos_pack(field, cols, rows, acc, rmdi, comp_field, len_comp, & num_words, message) NULLIFY(field2d) -! If something went wrong allow the calling program to catch the non-zero +! If something went wrong allow the calling program to catch the non-zero ! exit code and error message then act accordingly IF (status /= 0) THEN cmessage = f_shum_f2c_string(TRIM(message)) @@ -165,7 +165,7 @@ FUNCTION c_shum_wgdos_unpack(comp_field, len_comp, cols, rows, rmdi, & status = f_shum_wgdos_unpack(comp_field, rmdi, field2d, message) NULLIFY(field2d) -! If something went wrong allow the calling program to catch the non-zero +! If something went wrong allow the calling program to catch the non-zero ! exit code and error message then act accordingly IF (status /= 0) THEN cmessage = f_shum_f2c_string(TRIM(message)) diff --git a/shum_wgdos_packing/src/c_shum_wgdos_packing.h b/shum_wgdos_packing/src/c_shum_wgdos_packing.h index 27ae064..f9c3028 100644 --- a/shum_wgdos_packing/src/c_shum_wgdos_packing.h +++ b/shum_wgdos_packing/src/c_shum_wgdos_packing.h @@ -34,24 +34,24 @@ extern int64_t c_shum_read_wgdos_header( int64_t *message_len); extern int64_t c_shum_wgdos_pack( - double *field, - int64_t *cols, - int64_t *rows, - int64_t *accuracy, - double *rmdi, - int32_t *comp_field, - int64_t *len_comp, - int64_t *num_words, + double *field, + int64_t *cols, + int64_t *rows, + int64_t *accuracy, + double *rmdi, + int32_t *comp_field, + int64_t *len_comp, + int64_t *num_words, char *err_msg, int64_t *message_len); extern int64_t c_shum_wgdos_unpack( - int32_t *comp_field, - int64_t *len_comp, - int64_t *cols, - int64_t *rows, - double *rmdi, - double *field, + int32_t *comp_field, + int64_t *len_comp, + int64_t *cols, + int64_t *rows, + double *rmdi, + double *field, char *err_msg, int64_t *message_len); 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 0b37dd8..b7a5e23 100644 --- a/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 +++ b/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 @@ -1,35 +1,35 @@ ! *********************************COPYRIGHT************************************ -! (C) Crown copyright Met Office. All rights reserved. -! For further details please refer to the file LICENCE.txt -! which you should have received as part of this distribution. +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file LICENCE.txt +! which you should have received as part of this distribution. ! *********************************COPYRIGHT************************************ -! -! This file is part of the UM Shared Library project. -! -! The UM Shared Library is free software: you can redistribute it -! and/or modify it under the terms of the Modified BSD License, as -! published by the Open Source Initiative. -! -! The UM Shared Library is distributed in the hope that it will be -! useful, but WITHOUT ANY WARRANTY; without even the implied warranty -! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! Modified BSD License for more details. -! -! You should have received a copy of the Modified BSD License -! along with the UM Shared Library. -! If not, see . +! +! This file is part of the UM Shared Library project. +! +! The UM Shared Library is free software: you can redistribute it +! and/or modify it under the terms of the Modified BSD License, as +! published by the Open Source Initiative. +! +! The UM Shared Library is distributed in the hope that it will be +! useful, but WITHOUT ANY WARRANTY; without even the implied warranty +! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! Modified BSD License for more details. +! +! You should have received a copy of the Modified BSD License +! along with the UM Shared Library. +! If not, see . !******************************************************************************* MODULE fruit_test_shum_wgdos_packing_mod -USE fruit -USE, INTRINSIC :: ISO_C_BINDING, ONLY: & +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 ! Define a mask used to manipulate values later USE f_shum_ztables_mod, ONLY: & mask16 => z0000FFFF -IMPLICIT NONE +IMPLICIT NONE PRIVATE @@ -46,7 +46,7 @@ MODULE fruit_test_shum_wgdos_packing_mod INTEGER, PARAMETER :: int64 = C_INT64_T INTEGER, PARAMETER :: int32 = C_INT32_T INTEGER, PARAMETER :: real64 = C_DOUBLE - INTEGER, PARAMETER :: real32 = C_FLOAT + INTEGER, PARAMETER :: real32 = C_FLOAT !------------------------------------------------------------------------------! INTERFACE sample_starting_data @@ -64,13 +64,13 @@ SUBROUTINE fruit_test_shum_wgdos_packing USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT USE f_shum_wgdos_packing_version_mod, ONLY: get_shum_wgdos_packing_version -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64) :: version ! Note: we don't have a test case for the version checking because we don't ! want the testing to include further hardcoded version numbers to test -! against. Since the version module is simple and hardcoded anyway it's +! against. Since the version module is simple and hardcoded anyway it's ! sufficient to make sure it is callable; but let's print the version for info. version = get_shum_wgdos_packing_version() @@ -131,14 +131,14 @@ SUBROUTINE fruit_test_shum_wgdos_packing END SUBROUTINE fruit_test_shum_wgdos_packing -! Functions used to return sample dataset of unpacked data - the goal here +! Functions used to return sample dataset of unpacked data - the goal here ! isn't for a numerical workout but rather an easy to identify and work with ! array - a simple range from 1 - 30 split across 6 rows. This data can be ! returned as either 1d or 2d data to handle both types of interface. !------------------------------------------------------------------------------! -SUBROUTINE sample_starting_data_2d(sample) -IMPLICIT NONE +SUBROUTINE sample_starting_data_2d(sample) +IMPLICIT NONE REAL(KIND=real64), INTENT(OUT) :: sample(5, 6) sample(:,1) = [ 1.0, 2.0, 3.0, 4.0, 5.0 ] sample(:,2) = [ 6.0, 7.0, 8.0, 9.0, 10.0 ] @@ -149,7 +149,7 @@ SUBROUTINE sample_starting_data_2d(sample) END SUBROUTINE sample_starting_data_2d SUBROUTINE sample_starting_data_1d(sample) -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real64), INTENT(OUT) :: sample(30) sample(1:5) = [ 1.0, 2.0, 3.0, 4.0, 5.0 ] sample(6:10) = [ 6.0, 7.0, 8.0, 9.0, 10.0 ] @@ -166,8 +166,8 @@ END SUBROUTINE sample_starting_data_1d ! multiple of 2; again this is simple easy to test against and visualise. !------------------------------------------------------------------------------! -SUBROUTINE sample_unpacked_data_2d(sample) -IMPLICIT NONE +SUBROUTINE sample_unpacked_data_2d(sample) +IMPLICIT NONE REAL(KIND=real64), INTENT(OUT) :: sample(5, 6) sample(:,1) = [ 2.0, 2.0, 4.0, 4.0, 6.0 ] sample(:,2) = [ 6.0, 8.0, 8.0, 10.0, 10.0 ] @@ -178,7 +178,7 @@ SUBROUTINE sample_unpacked_data_2d(sample) END SUBROUTINE sample_unpacked_data_2d SUBROUTINE sample_unpacked_data_1d(sample) -IMPLICIT NONE +IMPLICIT NONE REAL(KIND=real64), INTENT(OUT) :: sample(30) sample(1:5) = [ 2.0, 2.0, 4.0, 4.0, 6.0 ] sample(6:10) = [ 6.0, 8.0, 8.0, 10.0, 10.0 ] @@ -190,16 +190,16 @@ END SUBROUTINE sample_unpacked_data_1d ! Function which returns the intermediate stage between the two pairs of sample ! data above - this array is less intuitive since the data is compressed, but -! some header values can be observed (particularly the array length in the +! some header values can be observed (particularly the array length in the ! first element and the accuracy of the packing in the second). !------------------------------------------------------------------------------! SUBROUTINE sample_packed_data(sample) -IMPLICIT NONE +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 @@ -239,7 +239,7 @@ SUBROUTINE test_pack_simple_field_1d_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -256,7 +256,9 @@ SUBROUTINE test_pack_simple_field_1d_arg64 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -274,6 +276,9 @@ SUBROUTINE test_pack_simple_field_1d_arg64 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_1d_arg64 !------------------------------------------------------------------------------! @@ -282,7 +287,7 @@ SUBROUTINE test_pack_simple_field_1d_alloc_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -299,7 +304,9 @@ SUBROUTINE test_pack_simple_field_1d_alloc_arg64 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -317,6 +324,9 @@ SUBROUTINE test_pack_simple_field_1d_alloc_arg64 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_1d_alloc_arg64 !------------------------------------------------------------------------------! @@ -325,7 +335,7 @@ SUBROUTINE test_pack_simple_field_2d_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -342,7 +352,9 @@ SUBROUTINE test_pack_simple_field_2d_arg64 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -360,6 +372,9 @@ SUBROUTINE test_pack_simple_field_2d_arg64 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_2d_arg64 !------------------------------------------------------------------------------! @@ -368,7 +383,7 @@ SUBROUTINE test_pack_simple_field_2d_alloc_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -385,7 +400,9 @@ SUBROUTINE test_pack_simple_field_2d_alloc_arg64 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -402,6 +419,9 @@ SUBROUTINE test_pack_simple_field_2d_alloc_arg64 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_2d_alloc_arg64 !------------------------------------------------------------------------------! @@ -410,7 +430,7 @@ SUBROUTINE test_pack_simple_field_1d_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -427,7 +447,9 @@ SUBROUTINE test_pack_simple_field_1d_arg32 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -445,6 +467,9 @@ SUBROUTINE test_pack_simple_field_1d_arg32 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_1d_arg32 !------------------------------------------------------------------------------! @@ -453,7 +478,7 @@ SUBROUTINE test_pack_simple_field_1d_alloc_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -470,7 +495,9 @@ SUBROUTINE test_pack_simple_field_1d_alloc_arg32 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -488,6 +515,9 @@ SUBROUTINE test_pack_simple_field_1d_alloc_arg32 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_1d_alloc_arg32 !------------------------------------------------------------------------------! @@ -496,7 +526,7 @@ SUBROUTINE test_pack_simple_field_2d_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -513,7 +543,9 @@ SUBROUTINE test_pack_simple_field_2d_arg32 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -531,6 +563,9 @@ SUBROUTINE test_pack_simple_field_2d_arg32 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_2d_arg32 !------------------------------------------------------------------------------! @@ -539,7 +574,7 @@ SUBROUTINE test_pack_simple_field_2d_alloc_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -556,7 +591,9 @@ SUBROUTINE test_pack_simple_field_2d_alloc_arg32 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -573,6 +610,9 @@ SUBROUTINE test_pack_simple_field_2d_alloc_arg32 CALL assert_equals(expected_data, packed_data, len_packed, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_pack_simple_field_2d_alloc_arg32 !------------------------------------------------------------------------------! @@ -581,7 +621,7 @@ SUBROUTINE test_unpack_simple_field_1d_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -597,6 +637,8 @@ SUBROUTINE test_unpack_simple_field_1d_arg64 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack(packed_data, mdi, unpacked_data, len1_unpacked, & @@ -610,6 +652,9 @@ SUBROUTINE test_unpack_simple_field_1d_arg64 CALL assert_equals(expected_data, unpacked_data, len1_unpacked, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_unpack_simple_field_1d_arg64 !------------------------------------------------------------------------------! @@ -618,7 +663,7 @@ SUBROUTINE test_unpack_simple_field_2d_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -634,6 +679,8 @@ SUBROUTINE test_unpack_simple_field_2d_arg64 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack(packed_data, mdi, unpacked_data, message) @@ -647,6 +694,9 @@ SUBROUTINE test_unpack_simple_field_2d_arg64 len1_unpacked, len2_unpacked, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_unpack_simple_field_2d_arg64 !------------------------------------------------------------------------------! @@ -655,7 +705,7 @@ SUBROUTINE test_unpack_simple_field_1d_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -671,6 +721,8 @@ SUBROUTINE test_unpack_simple_field_1d_arg32 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack( & @@ -685,6 +737,9 @@ SUBROUTINE test_unpack_simple_field_1d_arg32 CALL assert_equals(expected_data, unpacked_data, INT(len1_unpacked), & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_unpack_simple_field_1d_arg32 !------------------------------------------------------------------------------! @@ -693,7 +748,7 @@ SUBROUTINE test_unpack_simple_field_2d_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -709,6 +764,8 @@ SUBROUTINE test_unpack_simple_field_2d_arg32 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack(packed_data, mdi, unpacked_data, message) @@ -722,6 +779,9 @@ SUBROUTINE test_unpack_simple_field_2d_arg32 expected_data, unpacked_data, len1_unpacked, len2_unpacked, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_unpack_simple_field_2d_arg32 !------------------------------------------------------------------------------! @@ -730,7 +790,7 @@ SUBROUTINE test_packing_field_with_zeros USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack, f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -749,6 +809,8 @@ SUBROUTINE test_packing_field_with_zeros REAL(KIND=real64) :: mdi CHARACTER(LEN=500) :: message +WRITE(message,'(A)') "Return message never set" + ! Row starting with zeros unpacked_data(:,1) = [ 0.0, 0.0, 3.0, 4.0, 5.0 ] ! Row ending with zeros @@ -760,7 +822,7 @@ SUBROUTINE test_packing_field_with_zeros ! Rows with random grouped zeros unpacked_data(:,5) = [ 0.0, 22.0, 0.0, 0.0, 25.0 ] unpacked_data(:,6) = [ 26.0, 0.0, 28.0, 29.0, 0.0 ] - + accuracy = 1 mdi = -99.0 @@ -770,12 +832,15 @@ SUBROUTINE test_packing_field_with_zeros CALL assert_equals(0_int64, status, & "Packing of array returned non-zero exit status") -! Define the expected 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 stream of bits (which might not necessary map correctly -! onto 32-bit ints) This isn't a problem in general usage because the -! packed arrays are merely passed around, but here we need to set the values -! explicitly, so having a full 64-bit int array is more permissive and avoids +CALL assert_equals("Return message never set", TRIM(message), & + "Error message (1) issued different than expected") + +! Define the expected 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 stream of bits (which might not necessary map correctly +! onto 32-bit ints) This isn't a problem in general usage because the +! packed arrays are merely passed around, but here we need to set the values +! explicitly, so having a full 64-bit int array is more permissive and avoids ! compile errors expected_packed_data64 = [ & 4294967320_int64, & @@ -822,6 +887,9 @@ SUBROUTINE test_packing_field_with_zeros len1_unpacked, len2_unpacked, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message (2) issued different than expected") + END SUBROUTINE test_packing_field_with_zeros !------------------------------------------------------------------------------! @@ -830,7 +898,7 @@ SUBROUTINE test_packing_field_with_mdi USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack, f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -849,6 +917,8 @@ SUBROUTINE test_packing_field_with_mdi REAL(KIND=real64) :: mdi CHARACTER(LEN=500) :: message +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -863,19 +933,22 @@ SUBROUTINE test_packing_field_with_mdi ! Rows with random grouped mdi unpacked_data(:,5) = [ -99.0, 22.0, -99.0, -99.0, 25.0 ] unpacked_data(:,6) = [ 26.0, -99.0, 28.0, 29.0, -99.0 ] - + status = f_shum_wgdos_pack(unpacked_data, accuracy, mdi, packed_data, & num_words, message) CALL assert_equals(0_int64, status, & "Packing of array returned non-zero exit status") -! Define the expected 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 stream of bits (which might not necessary map correctly -! onto 32-bit ints) This isn't a problem in general usage because the -! packed arrays are merely passed around, but here we need to set the values -! explicitly, so having a full 64-bit int array is more permissive and avoids +CALL assert_equals("Return message never set", TRIM(message), & + "Error message (1) issued different than expected") + +! Define the expected 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 stream of bits (which might not necessary map correctly +! onto 32-bit ints) This isn't a problem in general usage because the +! packed arrays are merely passed around, but here we need to set the values +! explicitly, so having a full 64-bit int array is more permissive and avoids ! compile errors expected_packed_data64 = [ & 4294967322_int64, & @@ -923,6 +996,9 @@ SUBROUTINE test_packing_field_with_mdi len1_unpacked, len2_unpacked, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message (2) issued different than expected") + END SUBROUTINE test_packing_field_with_mdi !------------------------------------------------------------------------------! @@ -931,7 +1007,7 @@ SUBROUTINE test_packing_field_with_zeros_and_mdi USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack, f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -950,6 +1026,8 @@ SUBROUTINE test_packing_field_with_zeros_and_mdi REAL(KIND=real64) :: mdi CHARACTER(LEN=500) :: message +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -965,19 +1043,22 @@ SUBROUTINE test_packing_field_with_zeros_and_mdi unpacked_data(:,5) = [ 0.0, 0.0, 0.0, 0.0, 0.0 ] ! Row with neither zero nor mdi unpacked_data(:,6) = [ 26.0, 27.0, 28.0, 29.0, 30.0 ] - + status = f_shum_wgdos_pack(unpacked_data, accuracy, mdi, packed_data, & num_words, message) CALL assert_equals(0_int64, status, & "Packing of array returned non-zero exit status") -! Define the expected 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 stream of bits (which might not necessary map correctly -! onto 32-bit ints) This isn't a problem in general usage because the -! packed arrays are merely passed around, but here we need to set the values -! explicitly, so having a full 64-bit int array is more permissive and avoids +CALL assert_equals("Return message never set", TRIM(message), & + "Error message (1) issued different than expected") + +! Define the expected 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 stream of bits (which might not necessary map correctly +! onto 32-bit ints) This isn't a problem in general usage because the +! packed arrays are merely passed around, but here we need to set the values +! explicitly, so having a full 64-bit int array is more permissive and avoids ! compile errors expected_packed_data64 = [ & 4294967318_int64, & @@ -1022,6 +1103,9 @@ SUBROUTINE test_packing_field_with_zeros_and_mdi len1_unpacked, len2_unpacked, & "Packed array does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message (2) issued different than expected") + END SUBROUTINE test_packing_field_with_zeros_and_mdi !------------------------------------------------------------------------------! @@ -1030,7 +1114,7 @@ SUBROUTINE test_read_simple_header_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_read_wgdos_header -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len_packed = 21 @@ -1045,6 +1129,8 @@ SUBROUTINE test_read_simple_header_arg64 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + status = f_shum_read_wgdos_header(packed_data, words, accuracy, cols, rows, & message) @@ -1063,6 +1149,9 @@ SUBROUTINE test_read_simple_header_arg64 CALL assert_equals(5_int64, cols, & "Packed array column count does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_read_simple_header_arg64 !------------------------------------------------------------------------------! @@ -1071,7 +1160,7 @@ SUBROUTINE test_read_simple_header_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_read_wgdos_header -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len_packed = 21 @@ -1086,6 +1175,8 @@ SUBROUTINE test_read_simple_header_arg32 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + status = f_shum_read_wgdos_header(packed_data, words, accuracy, cols, rows, & message) @@ -1104,6 +1195,9 @@ SUBROUTINE test_read_simple_header_arg32 CALL assert_equals(5_int32, cols, & "Packed array column count does not agree with expected result") +CALL assert_equals("Return message never set", TRIM(message), & + "Error message issued different than expected") + END SUBROUTINE test_read_simple_header_arg32 !------------------------------------------------------------------------------! @@ -1112,7 +1206,7 @@ SUBROUTINE test_fail_packing_accuracy USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -1127,7 +1221,9 @@ SUBROUTINE test_fail_packing_accuracy CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + unpacked_data(3,3) = 999999999999999.9_real64 accuracy = 1 @@ -1139,8 +1235,7 @@ SUBROUTINE test_fail_packing_accuracy CALL assert_equals(2_int64, status, & "Packing of array with unpackable value returned unexpected exit status") - -CALL assert_equals("Unable to WGDOS pack to this accuracy", TRIM(message), & +CALL assert_equals("Unable to WGDOS pack to this accuracy", TRIM(message), & "Error message issued different than expected") END SUBROUTINE test_fail_packing_accuracy @@ -1151,7 +1246,7 @@ SUBROUTINE test_fail_packing_return_array_size USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -1167,7 +1262,9 @@ SUBROUTINE test_fail_packing_return_array_size CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -1189,7 +1286,7 @@ SUBROUTINE test_fail_pack_stride_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -1205,7 +1302,9 @@ SUBROUTINE test_fail_pack_stride_arg64 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -1226,7 +1325,7 @@ SUBROUTINE test_fail_pack_stride_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_pack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -1242,7 +1341,9 @@ SUBROUTINE test_fail_pack_stride_arg32 CHARACTER(LEN=500) :: message CALL sample_starting_data(unpacked_data) - + +WRITE(message,'(A)') "Return message never set" + accuracy = 1 mdi = -99.0 @@ -1263,7 +1364,7 @@ SUBROUTINE test_fail_unpack_stride_arg64 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -1278,6 +1379,8 @@ SUBROUTINE test_fail_unpack_stride_arg64 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack(packed_data, mdi, unpacked_data, & @@ -1297,7 +1400,7 @@ SUBROUTINE test_fail_unpack_stride_arg32 USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int32), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int32), PARAMETER :: len2_unpacked = 6 @@ -1312,6 +1415,8 @@ SUBROUTINE test_fail_unpack_stride_arg32 CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack(packed_data, mdi, unpacked_data, & @@ -1331,7 +1436,7 @@ SUBROUTINE test_fail_unpack_too_many_elements USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 1 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 1 @@ -1346,6 +1451,8 @@ SUBROUTINE test_fail_unpack_too_many_elements CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + mdi = -99.0 status = f_shum_wgdos_unpack(packed_data(1:4), mdi, unpacked_data, message) @@ -1367,7 +1474,7 @@ SUBROUTINE test_fail_unpack_inconsistent USE f_shum_wgdos_packing_mod, ONLY: f_shum_wgdos_unpack -IMPLICIT NONE +IMPLICIT NONE INTEGER(KIND=int64), PARAMETER :: len1_unpacked = 5 INTEGER(KIND=int64), PARAMETER :: len2_unpacked = 6 @@ -1387,16 +1494,18 @@ SUBROUTINE test_fail_unpack_inconsistent CALL sample_packed_data(packed_data) +WRITE(message,'(A)') "Return message never set" + ! The consistency check is making sure the total size of data stored in each ! of the packed rows once added together doesn't exceed the total size to be ! unpacked... so we want to increase the first row-size value to cause the ! check to fail -! However, the sample array used here is a fairly simple case; each row is +! However, the sample array used here is a fairly simple case; each row is ! actually packed into a single value - so the row size increase has to be ! by a specific amount to work correctly (3 points) -! Now split the first row-header's 2nd word into two 16-bit words - the +! Now split the first row-header's 2nd word into two 16-bit words - the ! second of these is the word-count for the row bad_word_p1 = ISHFT(packed_data(5), -16_int32) bad_word_p2 = IAND(packed_data(5), mask16)