diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 0fb84aa9..00000000 --- a/.travis.yml +++ /dev/null @@ -1,100 +0,0 @@ -#====================================================================== -# Project settings -#====================================================================== -# Only build master. -branches: - only: - - master - - develop - -language: fortran - -#====================================================================== -# Environment -#====================================================================== - -# Code is Fortran. While docs need doxygen and graphviz to build -addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - cmake - - gcc-6 - - gfortran-6 - - g++-6 - - doxygen - - graphviz - - lcov - -#====================================================================== -# Build Matrix -#====================================================================== -matrix: - include: - - os: linux - compiler: gcc - sudo: false - dist: trusty - - os: osx - compiler: gcc - osx_image: xcode9.4 - -#====================================================================== -# Building -#====================================================================== -before_install: - - | - if [[ "$TRAVIS_OS_NAME" == "osx" ]] ; then - brew install gcc@7 || true; - brew link --overwrite gcc@7; - fi - - | - if [[ "$TRAVIS_OS_NAME" == "linux" ]] ; then - pip install --user cpp-coveralls - fi - -before_script: - - | - if [[ "$TRAVIS_OS_NAME" == "osx" ]] ; then - export CC="clang" FC="gfortran-7" CXX="clang++" ; - fi - - | - if [[ "$TRAVIS_OS_NAME" == "linux" ]] ; then - export CC="gcc-6" FC="gfortran-6" CXX="g++-6" ; - fi -# - export CC="gcc-6" FC="gfortran-6" CXX="g++-6" ; - -script: - - mkdir build && cd build && cmake .. && make - - | - if [[ "$TRAVIS_OS_NAME" == "linux" ]] ; then - export LD_LIBRARY_PATH=${PWD}/schemes/check/src/check-build - make test - fi - - | - if [[ "$TRAVIS_OS_NAME" == "osx" ]] ; then - export DYLD_LIBRARY_PATH=${PWD}/schemes/check/src/check-build - ctest - fi - - | - if [[ "$TRAVIS_OS_NAME" == "linux" ]] ; then - make clean - alias gcov="/usr/bin/gcov-6" - cmake -DCMAKE_BUILD_TYPE=Coverage .. && make coverage - fi - -after_success: - - | - if [[ "$TRAVIS_OS_NAME" == "linux" ]] ; then - bash <(curl -s https://codecov.io/bash) - fi - -#====================================================================== -# Notifications -#====================================================================== -notifications: - email: - recipients: dom.heinzeller@noaa.gov - on_success: change - on_failure: always diff --git a/CMakeLists.txt b/CMakeLists.txt index 073c0efe..45b02dbc 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -17,17 +17,10 @@ if(POLICY CMP0042) cmake_policy(SET CMP0042 NEW) endif(POLICY CMP0042) -#Setting this policy was required when building with the SCM. Without it, the -# STATIC cmake variable was getting cleared, making this CMakeLists.txt -# assume a dynamic build. -if(POLICY CMP0077) - cmake_policy(SET CMP0077 NEW) -endif(POLICY CMP0077) - #------------------------------------------------------------------------------ # Set package definitions set(PACKAGE "ccpp-framework") -set(AUTHORS "Dom Heinzeller" "Timothy Brown" "David Gill") +set(AUTHORS "Dom Heinzeller" "Grant Firl" "Laurie Carson") string(TIMESTAMP YEAR "%Y") #------------------------------------------------------------------------------ @@ -35,13 +28,6 @@ string(TIMESTAMP YEAR "%Y") # Set the CMake module path list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") -#------------------------------------------------------------------------------ -# Static or dynamic CCPP, default is dynamic; standalone build can only be dynamic -option(STATIC "Build a static CCPP" OFF) -if (PROJECT STREQUAL "Unknown" AND STATIC) - message(FATAL_ERROR "ccpp-framework standalone build can only be dynamic") -endif(PROJECT STREQUAL "Unknown" AND STATIC) - #------------------------------------------------------------------------------ # Set OpenMP flags for C/C++/Fortran if (OPENMP) @@ -88,12 +74,8 @@ if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "PGI") endif() #------------------------------------------------------------------------------ -# By default we want a shared library (unless a static build is requested) -if(STATIC) - option(BUILD_SHARED_LIBS "Build a static library" OFF) -else(STATIC) - option(BUILD_SHARED_LIBS "Build a shared library" ON) -endif(STATIC) +# Request a static build +option(BUILD_SHARED_LIBS "Build a static library" OFF) #------------------------------------------------------------------------------ # Enable code coverage @@ -112,8 +94,6 @@ enable_testing() add_subdirectory(src) # Documentation add_subdirectory(doc) -# All schemes -add_subdirectory(schemes) #------------------------------------------------------------------------------ # Configure and enable packaging diff --git a/schemes/CMakeLists.txt b/schemes/CMakeLists.txt deleted file mode 100644 index 6f8899b1..00000000 --- a/schemes/CMakeLists.txt +++ /dev/null @@ -1,30 +0,0 @@ -# Set default project to unknown -if(NOT PROJECT) - message(STATUS "Setting CCPP project to 'unknown' as none was specified.") - set(PROJECT "Unknown") -endif (NOT PROJECT) - -#------------------------------------------------------------------------------ -# Include the external test project only in standalone builds (project not set) -#------------------------------------------------------------------------------ -if (PROJECT STREQUAL "Unknown") - include(ExternalProject) - - #---------------------------------------------------------------------------- - # The checker scheme - ExternalProject_Add( - check - DEPENDS ccpp - SOURCE_DIR "${CMAKE_CURRENT_SOURCE_DIR}/check" - PREFIX "check" - DOWNLOAD_COMMAND "" - UPDATE_COMMAND "" - INSTALL_COMMAND "" - CMAKE_ARGS -DCCPP_INCLUDE_DIRS=${CCPP_INCLUDE_DIRS} - -DCCPP_LIB_DIRS=${CCPP_LIB_DIRS} - -DPROJECT=${PROJECT} - -DCMAKE_Fortran_FLAGS=${CMAKE_Fortran_FLAGS} - -DCMAKE_SHARED_LIBRARY_CREATE_Fortran_FLAGS=${CMAKE_SHARED_LIBRARY_CREATE_Fortran_FLAGS} - -DCMAKE_BUILD_TYPE=${CMAKE_BUILD_TYPE} - ) -endif (PROJECT STREQUAL "Unknown") \ No newline at end of file diff --git a/schemes/check/CMakeLists.txt b/schemes/check/CMakeLists.txt deleted file mode 100644 index abdbec42..00000000 --- a/schemes/check/CMakeLists.txt +++ /dev/null @@ -1,99 +0,0 @@ -# Set default project to unknown -if(NOT PROJECT) - message(STATUS "Setting CCPP project to 'unknown' as none was specified.") - set(PROJECT "Unknown") -endif (NOT PROJECT) - -# Use rpaths on MacOSX -set(CMAKE_MACOSX_RPATH 1) - -#------------------------------------------------------------------------------ -cmake_minimum_required(VERSION 2.8.11) - -if(POLICY CMP0048) - cmake_policy(SET CMP0048 NEW) - project(check VERSION 0.0.1) -else(POLICY CMP0048) - project(check) - set(PROJECT_VERSION 0.0.1) - set(PROJECT_VERSION_MAJOR 0) - set(PROJECT_VERSION_MINOR 0) - set(PROJECT_VERSION_PATCH 1) -endif(POLICY CMP0048) - -#------------------------------------------------------------------------------ -set(PACKAGE "check") -set(AUTHORS "Timothy Brown" "Dom Heinzeller") -string(TIMESTAMP YEAR "%Y") - -#------------------------------------------------------------------------------ -# Enable Fortran -enable_language(Fortran) - -#------------------------------------------------------------------------------ -# CMake Modules -# Set the CMake module path -list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/../../cmake") - -#------------------------------------------------------------------------------ -# By default we want a shared library -option(BUILD_SHARED_LIBS "Build a shared library" ON) - -#------------------------------------------------------------------------------ -# Add the CCPP include/module directory and libraries, currently depends on build -# see FV3_current_trunk/ccpp/CMakeLists.txt on how to set CCPP_INCLUDE_DIRS etc. -if (PROJECT STREQUAL "CCPP-FV3") - # Add the CCPP include/module directory - set(CCPP_INCLUDE_DIRS "" CACHE FILEPATH "Path to ccpp includes") - set_property(DIRECTORY PROPERTY INCLUDE_DIRECTORIES ${CCPP_INCLUDE_DIRS}) - # Add the CCPP library - set(CCPP_LIB_DIRS "" CACHE FILEPATH "Path to ccpp library") - link_directories(${CCPP_LIB_DIRS}) - list(APPEND LIBS "ccpp") -else (PROJECT STREQUAL "CCPP-SCM") - # Add the CCPP include/module directory - INCLUDE_DIRECTORIES("${CMAKE_CURRENT_BINARY_DIR}/../../../../src") - # Add the CCPP library - LINK_DIRECTORIES("${CMAKE_CURRENT_BINARY_DIR}/../../../../src") - list(APPEND LIBS "ccpp") -endif (PROJECT STREQUAL "CCPP-FV3") - -#------------------------------------------------------------------------------ -# Set the sources -set(SOURCES - check_test.f90 - check_noop.f90 -) - -#------------------------------------------------------------------------------ -# Add the auto-generated caps -set (CCPP_MKCAP "${CMAKE_CURRENT_SOURCE_DIR}/../../scripts/ccpp_prebuild.py") -add_custom_command( - OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/test_cap.F90 - DEPENDS ${CCPP_MKCAP} - COMMAND ${CCPP_MKCAP} --config=${CMAKE_CURRENT_SOURCE_DIR}/ccpp_prebuild_config.py --debug -) -list(APPEND SOURCES ${CMAKE_CURRENT_BINARY_DIR}/test_cap.F90) - -#------------------------------------------------------------------------------ -# The Fortran compiler/linker flag inserted by cmake to create shared libraries -# with the Intel compiler is deprecated (-i_dynamic), correct here. -# CMAKE_Fortran_COMPILER_ID = {"Intel", "PGI", "GNU", "Clang", "MSVC", ...} -if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "Intel") - string(REPLACE "-i_dynamic" "-shared-intel" - CMAKE_SHARED_LIBRARY_CREATE_Fortran_FLAGS - "${CMAKE_SHARED_LIBRARY_CREATE_Fortran_FLAGS}") - string(REPLACE "-i_dynamic" "-shared-intel" - CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS - "${CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS}") -endif() - -# Guard for undefined/empty CMAKE_Fortran_FLAGS -set(CMAKE_Fortran_FLAGS " ${CMAKE_Fortran_FLAGS}") - -add_library(check ${SOURCES}) -target_link_libraries(check LINK_PUBLIC ${LIBS}) -set_target_properties(check PROPERTIES VERSION ${PROJECT_VERSION} - SOVERSION ${PROJECT_VERSION_MAJOR} - COMPILE_FLAGS ${CMAKE_Fortran_FLAGS} - LINK_FLAGS ${CMAKE_Fortran_FLAGS}) diff --git a/schemes/check/ccpp_prebuild_config.py b/schemes/check/ccpp_prebuild_config.py deleted file mode 100755 index 651afd50..00000000 --- a/schemes/check/ccpp_prebuild_config.py +++ /dev/null @@ -1,97 +0,0 @@ -#!/usr/bin/env python - -# CCPP prebuild config for unit tests - - -############################################################################### -# Definitions # -############################################################################### - -HOST_MODEL_IDENTIFIER = 'TEST' - -# Add all files with metadata tables on the host model side, -# relative to basedir = top-level directory of host model -VARIABLE_DEFINITION_FILES = [ - '../../../../../src/tests/test_check.f90', - ] - -# Add all physics scheme dependencies relative to basedir - note that these are all violations -# of the CCPP requirement to not use any external modules except Fortran standard modules! -SCHEME_FILES_DEPENDENCIES = [ - ] - -# Add all physics scheme files relative to basedir -SCHEME_FILES = { - # Relative path to source (from where ccpp_prebuild.py is called) : [ list of physics sets in which scheme may be called ]; - # current restrictions are that each scheme can only belong to one physics set, and all schemes within one group in the - # suite definition file have to belong to the same physics set - '../../../../../schemes/check/check_test.f90' : [ 'test' ], - } - -# Default build dir, relative to current working directory, -# if not specified as command-line argument -DEFAULT_BUILD_DIR = '.' - -# Auto-generated makefile/cmakefile snippets that contain all type definitions -TYPEDEFS_MAKEFILE = 'CCPP_TYPEDEFS.mk' -TYPEDEFS_CMAKEFILE = 'CCPP_TYPEDEFS.cmake' -TYPEDEFS_SOURCEFILE = 'CCPP_TYPEDEFS.sh' - -# Auto-generated makefile/cmakefile snippets that contain all schemes -SCHEMES_MAKEFILE = 'CCPP_SCHEMES.mk' -SCHEMES_CMAKEFILE = 'CCPP_SCHEMES.cmake' -SCHEMES_SOURCEFILE = 'CCPP_SCHEMES.sh' - -# CCPP host cap in which to insert the ccpp_field_add statements; -# determines the directory to place ccpp_{modules,fields}.inc -TARGET_FILES = [ - '../../../../../src/tests/test_check.f90', - ] - -# Auto-generated makefile/cmakefile snippets that contain all caps -CAPS_MAKEFILE = 'CCPP_CAPS.mk' -CAPS_CMAKEFILE = 'CCPP_CAPS.cmake' -CAPS_SOURCEFILE = 'CCPP_CAPS.sh' - -# Directory where to put all auto-generated physics caps -CAPS_DIR = '.' - -# Directory where the suite definition files are stored -SUITES_DIR = '../../../../../src/tests' - -# Optional arguments - only required for schemes that use -# optional arguments. ccpp_prebuild.py will throw an exception -# if it encounters a scheme subroutine with optional arguments -# if no entry is made here. Possible values are: 'all', 'none', -# or a list of standard_names: [ 'var1', 'var3' ]. -OPTIONAL_ARGUMENTS = { - 'test' : { - 'test_run' : [ 'surface_skin_temperature' ], - }, - #'subroutine_name_1' : 'all', - #'subroutine_name_2' : 'none', - #'subroutine_name_2' : [ 'var1', 'var3'], - } - -# Names of Fortran include files in the host model cap (do not change); -# both files will be written to the directory of each target file -MODULE_INCLUDE_FILE = 'ccpp_modules_{set}.inc' -FIELDS_INCLUDE_FILE = 'ccpp_fields_{set}.inc' - -# Directory where to write static API to -STATIC_API_DIR = '.' -STATIC_API_SRCFILE = './CCPP_STATIC_API.sh' - -# HTML document containing the model-defined CCPP variables -HTML_VARTABLE_FILE = 'CCPP_VARIABLES_FV3.html' - -# LaTeX document containing the provided vs requested CCPP variables -LATEX_VARTABLE_FILE = 'CCPP_VARIABLES_FV3.tex' - - -############################################################################### -# Template code to generate include files # -############################################################################### - -# Name of the CCPP data structure in the host model cap -CCPP_DATA_STRUCTURE = 'cdata' diff --git a/schemes/check/check_noop.f90 b/schemes/check/check_noop.f90 deleted file mode 100644 index ab8d17d0..00000000 --- a/schemes/check/check_noop.f90 +++ /dev/null @@ -1,72 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief A NO-OP physics modules. -!! -! -module check_noop - - use, intrinsic :: iso_c_binding, & - only: c_f_pointer, c_ptr - use :: ccpp_types, & - only: ccpp_t - use :: ccpp_fields, & - only: ccpp_field_get - implicit none - - private - public :: noop_init_cap, noop_run_cap, noop_finalize_cap - - contains - - subroutine noop_init_cap(ptr) bind(c) - implicit none - type(c_ptr), intent(inout) :: ptr - - type(ccpp_t), pointer :: cdata - - call c_f_pointer(ptr, cdata) - - print *, 'In noop_init_cap' - print *, cdata%suite%groups(1)%subcycles(1)%schemes(1)%name - - end subroutine noop_init_cap - - subroutine noop_run_cap(ptr) bind(c) - implicit none - type(c_ptr), intent(inout) :: ptr - - type(ccpp_t), pointer :: cdata - - call c_f_pointer(ptr, cdata) - - print *, 'In noop_run_cap' - print *, cdata%suite%groups(1)%subcycles(1)%schemes(1)%name - - end subroutine noop_run_cap - - subroutine noop_finalize_cap(ptr) bind(c) - implicit none - type(c_ptr), intent(inout) :: ptr - - type(ccpp_t), pointer :: cdata - - call c_f_pointer(ptr, cdata) - - print *, 'In noop_finalize_cap' - print *, cdata%suite%groups(1)%subcycles(1)%schemes(1)%name - - end subroutine noop_finalize_cap - -end module check_noop diff --git a/schemes/check/check_test.f90 b/schemes/check/check_test.f90 deleted file mode 100644 index ffa04f3f..00000000 --- a/schemes/check/check_test.f90 +++ /dev/null @@ -1,65 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief A checking physics modules. -!! -! -module test - - implicit none - - private - public :: test_init, test_run, test_finalize - - contains - - subroutine test_init() - end subroutine test_init - - subroutine test_finalize() - end subroutine test_finalize - -!! \section arg_table_test_run -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-------------------------------------------|------------------------------------------|---------|------|-----------|----------|--------|----------| -!! | gravity | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | | in | F | -!! | u | x_wind | zonal wind | m s-1 | 2 | real | | inout | F | -!! | v | y_wind | meridional wind | m s-1 | 2 | real | | inout | F | -!! | tsfc | surface_skin_temperature | surface skin temperature | K | 1 | real | | in | T | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! - subroutine test_run(gravity, u, v, tsfc, errflg, errmsg) - implicit none - real, intent(inout) :: gravity - real, intent(inout) :: u(:,:) - real, intent(inout) :: v(:,:) - real, intent(in) :: tsfc(:) - integer, intent(out) :: errflg - character(len=*), intent(out) :: errmsg - - errflg = 0 - errmsg = '' - - print *, 'In physics test_run' - print *, 'gravity: ', gravity - print *, 'tsfc: ', tsfc - print *, 'updating u to be 10m/s' - u = 10.0 - print *, 'updating v to be -10m/s' - v = -10.0 - - end subroutine test_run - -end module test diff --git a/schemes/check/nan.f90 b/schemes/check/nan.f90 deleted file mode 100644 index 166239b8..00000000 --- a/schemes/check/nan.f90 +++ /dev/null @@ -1,61 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief A physics module to check for NaNs. -!! -! -module check_nans - - use, intrinsic :: iso_c_binding, & - only: c_f_pointer, c_ptr - use :: ccpp_types, & - only: ccpp_t - use :: ccpp_fields, & - only: ccpp_field_get - implicit none - - private - public :: nans_cap - - contains - - subroutine nans_cap(ptr) bind(c) - implicit none - type(c_ptr), intent(inout) :: ptr - - type(ccpp_t), pointer :: cdata - real, pointer :: v(:,:,:) - integer :: i - integer :: ierr - - call c_f_pointer(ptr, cdata) - - call ccpp_field_get(cdata, 'northward_wind', v, ierr) - - call nans_run(gravity, u, v, surf_t) - - end subroutine nans_cap - - subroutine nans_run(gravity, u, v, surf_t) - implicit none - real, pointer, intent(inout) :: gravity - real, pointer, intent(inout) :: surf_t(:) - real, pointer, intent(inout) :: u(:,:,:) - real, pointer, intent(inout) :: v(:,:,:) - - print *, 'In physics check nans run' - - end subroutine nans_run - -end module check_test diff --git a/schemes/check/scheme.xml b/schemes/check/scheme.xml deleted file mode 100644 index 8ae52e7d..00000000 --- a/schemes/check/scheme.xml +++ /dev/null @@ -1,35 +0,0 @@ - - - - - - gravity - m s-2 - gravity - 0 - real - - - surface_temperature - K - surf_t - 1 - real - - - eastward_wind - m s-1 - u - 3 - real - - - northward_wind - m s-1 - v - 3 - real - - - - diff --git a/scripts/ccpp_prebuild.py b/scripts/ccpp_prebuild.py index 01dbaf42..abe81c6a 100755 --- a/scripts/ccpp_prebuild.py +++ b/scripts/ccpp_prebuild.py @@ -17,7 +17,7 @@ from common import STANDARD_VARIABLE_TYPES, STANDARD_INTEGER_TYPE, CCPP_TYPE from common import split_var_name_and_array_reference from metadata_parser import merge_dictionaries, parse_scheme_tables, parse_variable_tables -from mkcap import Cap, CapsMakefile, CapsCMakefile, CapsSourcefile, \ +from mkcap import CapsMakefile, CapsCMakefile, CapsSourcefile, \ SchemesMakefile, SchemesCMakefile, SchemesSourcefile, \ TypedefsMakefile, TypedefsCMakefile, TypedefsSourcefile from mkdoc import metadata_to_html, metadata_to_latex @@ -31,8 +31,7 @@ parser.add_argument('--config', action='store', help='path to CCPP prebuild configuration file', required=True) parser.add_argument('--clean', action='store_true', help='remove files created by this script, then exit', default=False) parser.add_argument('--debug', action='store_true', help='enable debugging output', default=False) -parser.add_argument('--static', action='store_true', help='enable a static build for a given suite definition file', default=False) -parser.add_argument('--suites', action='store', help='suite definition files to use (comma-separated, for static build only, without path)', default='') +parser.add_argument('--suites', action='store', help='suite definition files to use (comma-separated, without path)', default='') parser.add_argument('--builddir', action='store', help='relative path to CCPP build directory', required=False, default=None) # BASEDIR is the current directory where this script is executed @@ -49,13 +48,12 @@ def parse_arguments(): configfile = args.config clean = args.clean debug = args.debug - static = args.static - if static and not args.suites: + if not args.suites: parser.print_help() sys.exit(-1) sdfs = [ 'suite_{0}.xml'.format(x) for x in args.suites.split(',')] builddir = args.builddir - return (success, configfile, clean, debug, static, sdfs, builddir) + return (success, configfile, clean, debug, sdfs, builddir) def import_config(configfile, builddir): """Import the configuration from a given configuration file""" @@ -103,7 +101,7 @@ def import_config(configfile, builddir): config['host_model'] = ccpp_prebuild_config.HOST_MODEL_IDENTIFIER config['html_vartable_file'] = ccpp_prebuild_config.HTML_VARTABLE_FILE.format(build_dir=builddir) config['latex_vartable_file'] = ccpp_prebuild_config.LATEX_VARTABLE_FILE.format(build_dir=builddir) - # For static build: location of static API file, and shell script to source + # Location of static API file, and shell script to source config['static_api_dir'] = ccpp_prebuild_config.STATIC_API_DIR.format(build_dir=builddir) config['static_api_srcfile'] = ccpp_prebuild_config.STATIC_API_SRCFILE.format(build_dir=builddir) # Template code in host-model dependent CCPP prebuild config script @@ -136,7 +134,7 @@ def setup_logging(debug): logging.info('Logging level set to INFO') return success -def clean_files(config, static): +def clean_files(config): """Clean files created by ccpp_prebuild.py""" success = True logging.info('Performing clean ....') @@ -153,24 +151,17 @@ def clean_files(config, static): config['caps_sourcefile'], config['html_vartable_file'], config['latex_vartable_file'], + os.path.join(config['caps_dir'], 'ccpp_*_cap.F90'), + os.path.join(config['static_api_dir'], '{api}.F90'.format(api=CCPP_STATIC_API_MODULE)), + config['static_api_srcfile'], ] - if static: - files_to_remove.append(os.path.join(config['caps_dir'], 'ccpp_*_cap.F90')) - files_to_remove.append(os.path.join(config['static_api_dir'], '{api}.F90'.format(api=CCPP_STATIC_API_MODULE))) - files_to_remove.append(config['static_api_srcfile']) - else: - files_to_remove.append(os.path.join(config['caps_dir'], '*_cap.F90')) - for target_file in config['target_files']: - target_file_path = os.path.split(target_file)[0] - files_to_remove.append(os.path.join(target_file_path, config['module_include_file'].format(set='*'))) - files_to_remove.append(os.path.join(target_file_path, config['fields_include_file'].format(set='*'))) # Not very pythonic, but the easiest way w/o importing another Python module cmd = 'rm -vf {0}'.format(' '.join(files_to_remove)) execute(cmd) return success def parse_suites(suites_dir, sdfs): - """Parse suite definition files for static build""" + """Parse suite definition files for prebuild""" logging.info('Parsing suite definition files ...') suites = [] for sdf in sdfs: @@ -408,7 +399,7 @@ def check_optional_arguments(metadata, arguments, optional_arguments): # Remove this var instance from list of var instances for this var_name metadata[var_name].remove(var) # Remove var_name from list of calling arguments for that subroutine - # (unless that module has been filtered out for the static build) + # (unless that module has been filtered out because none of the suites uses it) if module_name in arguments.keys(): arguments[module_name][scheme_name][subroutine_name].remove(var_name) elif optional_arguments[module_name][subroutine_name] == 'all': @@ -509,105 +500,6 @@ def compare_metadata(metadata_define, metadata_request, pset_request, psets_merg modules[pset] = sorted(list(set(modules[pset]))) return (success, modules, metadata) -def create_module_use_statements(modules, pset): - """Create Fortran module use statements to be included in the host cap.""" - logging.info('Generating module use statements for physics set {0} ...'.format(pset)) - success = True - module_use_statements = '' - cnt = 1 - for module in modules: - module_use_statements += 'use {0}\n'.format(module) - cnt += 1 - logging.info('Generated module use statements for {0} module(s)'.format(cnt)) - return (success, module_use_statements) - -def create_ccpp_field_add_statements(metadata, pset, ccpp_data_structure): - """Create Fortran code to add host model variables to the cdata - structure. The metadata container may contain multiple entries - of a variable with the same standard_name, but for different - "callers" (i.e. subroutines using it) with identical or - different local_name. We only need to add it once to - the add_field statement, since the target (i.e. the - original variable defined by the model) is the same.""" - logging.info('Generating ccpp_field_add statements for physics set {0} ...'.format(pset)) - success = True - ccpp_field_add_statements = '' - cnt = 0 - # Record the index for each variable added to cdata via ccpp_add_field() - ccpp_field_map = {} - # Important - adding the variables sorted is key to using hard-coded - # indices for faster retrieval of variables from cdata via ccpp_field_get - for var_name in sorted(metadata.keys()): - # Skip CCPP internal variables, these are treated differently - if var_name in CCPP_INTERNAL_VARIABLES.keys(): - continue - # Add variable with var_name = standard_name once - logging.debug('Generating ccpp_field_add statement for variable {0}'.format(var_name)) - var = metadata[var_name][0] - # Use print add with specified index number and register the index in ccpp_field_map; - # note: Python counters run from 0 to X, Fortran counters from 1 to X+1 - ccpp_field_add_statements += var.print_add(ccpp_data_structure, cnt+1) - ccpp_field_map[var_name] = cnt+1 - cnt += 1 - logging.info('Generated ccpp_field_add statements for {0} variable(s)'.format(cnt)) - return (success, ccpp_field_add_statements, ccpp_field_map) - -def generate_include_files(module_use_statements, ccpp_field_add_statements, - target_files, module_include_file, fields_include_file): - """Generate include files for modules and field-add statements for host model cap.""" - logging.info('Generating include files for host model caps {0} ...'.format(', '.join(target_files))) - success = True - target_dirs = [] - for target_file in target_files: - target_dirs.append(os.path.split(target_file)[0]) - target_dirs = sorted(list(set(target_dirs))) - for target_dir in target_dirs: - # module use statements - includefile = os.path.join(target_dir, module_include_file) - logging.info('Generated module-use include file {0}'.format(includefile)) - with open(includefile, "w") as f: - f.write(module_use_statements) - # ccpp_field_add statements - includefile = os.path.join(target_dir, fields_include_file) - logging.info('Generated fields-add include file {0}'.format(includefile)) - with open(includefile, "w") as f: - f.write(ccpp_field_add_statements) - return success - -def generate_scheme_caps(metadata_define, metadata_request, arguments, pset_schemes, ccpp_field_maps, caps_dir): - """Generate scheme caps for all schemes parsed.""" - success = True - # Change to caps directory - os.chdir(caps_dir) - # List of filenames of scheme caps - scheme_caps = [] - for module_name in arguments.keys(): - for scheme_name in arguments[module_name].keys(): - for subroutine_name in arguments[module_name][scheme_name].keys(): - # Skip subroutines without argument table or with empty argument table - if not arguments[module_name][scheme_name][subroutine_name]: - continue - # Create cap - cap = Cap() - cap.filename = "{0}_cap.F90".format(scheme_name) - scheme_caps.append(cap.filename) - # Parse all subroutines and their arguments to generate the cap - capdata = collections.OrderedDict() - for subroutine_name in arguments[module_name][scheme_name].keys(): - capdata[subroutine_name] = [] - for var_name in arguments[module_name][scheme_name][subroutine_name]: - container = encode_container(module_name, scheme_name, subroutine_name) - for var in metadata_request[var_name]: - if var.container == container: - capdata[subroutine_name].append(var) - break - # Write cap using the unique physics set for the scheme - pset = pset_schemes[scheme_name][0] - cap.write(module_name, capdata, ccpp_field_maps[pset], metadata_define) - # - os.chdir(BASEDIR) - return (success, scheme_caps) - def generate_suite_and_group_caps(suites, metadata_request, metadata_define, arguments, caps_dir): """Generate for the suite and for all groups parsed.""" logging.info("Generating suite and group caps ...") @@ -627,7 +519,7 @@ def generate_suite_and_group_caps(suites, metadata_request, metadata_define, arg return (success, suite_and_group_caps) def generate_static_api(suites, static_api_dir): - """Generate API for static build for a given suite""" + """Generate static API for given suite(s)""" success = True # Change to caps directory, create if necessary if not os.path.isdir(static_api_dir): @@ -785,7 +677,7 @@ def generate_caps_makefile(caps, caps_makefile, caps_cmakefile, caps_sourcefile, def main(): """Main routine that handles the CCPP prebuild for different host models.""" # Parse command line arguments - (success, configfile, clean, debug, static, sdfs, builddir) = parse_arguments() + (success, configfile, clean, debug, sdfs, builddir) = parse_arguments() if not success: raise Exception('Call to parse_arguments failed.') @@ -799,15 +691,14 @@ def main(): # Perform clean if requested, then exit if clean: - success = clean_files(config, static) + success = clean_files(config) logging.info('CCPP prebuild clean completed successfully, exiting.') sys.exit(0) - # Parse suite definition files for static build - if static: - (success, suites) = parse_suites(config['suites_dir'], sdfs) - if not success: - raise Exception('Parsing suite definition files failed.') + # Parse suite definition files for prebuild + (success, suites) = parse_suites(config['suites_dir'], sdfs) + if not success: + raise Exception('Parsing suite definition files failed.') # Check that each scheme only belongs to one set of physics # this is required for using the optimized version of ccpp_field_get @@ -831,12 +722,11 @@ def main(): if not success: raise Exception('Call to collect_physics_subroutines failed.') - # Filter metadata/pset/arguments for static build - remove whatever is not included in suite definition file - if static: - (success, metadata_request, pset_request, arguments_request) = filter_metadata(metadata_request, pset_request, - arguments_request, suites) - if not success: - raise Exception('Call to filter_metadata failed.') + # Filter metadata/pset/arguments - remove whatever is not included in suite definition files + (success, metadata_request, pset_request, arguments_request) = filter_metadata(metadata_request, pset_request, + arguments_request, suites) + if not success: + raise Exception('Call to filter_metadata failed.') # Process optional arguments based on configuration in above dictionary optional_arguments (success, metadata_request, arguments_request) = check_optional_arguments(metadata_request,arguments_request, @@ -857,34 +747,6 @@ def main(): if not success: raise Exception('Call to compare_metadata failed.') - if not static: - # Dictionary of indices of variables in the cdata structure, per pset - ccpp_field_maps = {} - for pset in psets_merged: - # Create module use statements to inject into the host model cap - (success, module_use_statements) = create_module_use_statements(modules[pset], pset) - if not success: - raise Exception('Call to create_module_use_statements failed.') - - # Only process variables that fall into this pset - metadata_filtered = { key : value for (key, value) in metadata.items() if pset in pset_request[key] } - - # Create ccpp_fiels_add statements to inject into the host model cap; - # this returns a ccpp_field_map that contains indices of variables in - # the cdata structure for the given pset - (success, ccpp_field_add_statements, ccpp_field_map) = create_ccpp_field_add_statements(metadata_filtered, - pset, config['ccpp_data_structure']) - if not success: - raise Exception('Call to create_ccpp_field_add_statements failed.') - ccpp_field_maps[pset] = ccpp_field_map - - # Generate include files for module_use_statements and ccpp_field_add_statements - success = generate_include_files(module_use_statements, ccpp_field_add_statements, config['target_files'], - config['module_include_file'].format(set=pset), - config['fields_include_file'].format(set=pset)) - if not success: - raise Exception('Call to generate_include_files failed.') - # Add Fortran module files of typedefs to makefile/cmakefile/shell script success = generate_typedefs_makefile(metadata_define, config['typedefs_makefile'], config['typedefs_cmakefile'], config['typedefs_sourcefile']) @@ -898,32 +760,23 @@ def main(): if not success: raise Exception('Call to generate_schemes_makefile failed.') - if static: - # Static build: generate caps for entire suite and groups in the specified suite; generate API - (success, suite_and_group_caps) = generate_suite_and_group_caps(suites, metadata_request, metadata_define, - arguments_request, config['caps_dir']) - if not success: - raise Exception('Call to generate_suite_and_group_caps failed.') + # Static build: generate caps for entire suite and groups in the specified suite; generate API + (success, suite_and_group_caps) = generate_suite_and_group_caps(suites, metadata_request, metadata_define, + arguments_request, config['caps_dir']) + if not success: + raise Exception('Call to generate_suite_and_group_caps failed.') - (success, api) = generate_static_api(suites, config['static_api_dir']) - if not success: - raise Exception('Call to generate_static_api failed.') + (success, api) = generate_static_api(suites, config['static_api_dir']) + if not success: + raise Exception('Call to generate_static_api failed.') - success = api.write_sourcefile(config['static_api_srcfile']) - if not success: - raise Exception("Writing API sourcefile {sourcefile} failed".format(sourcefile=config['static_api_srcfile'])) - else: - # Generate scheme caps for each individual scheme - (success, scheme_caps) = generate_scheme_caps(metadata_define, metadata_request, arguments_request, - pset_schemes, ccpp_field_maps, config['caps_dir']) - if not success: - raise Exception('Call to generate_scheme_caps failed.') + success = api.write_sourcefile(config['static_api_srcfile']) + if not success: + raise Exception("Writing API sourcefile {sourcefile} failed".format(sourcefile=config['static_api_srcfile'])) # Add filenames of caps to makefile/cmakefile/shell script - if static: - all_caps = suite_and_group_caps - else: - all_caps = scheme_caps + all_caps = suite_and_group_caps + success = generate_caps_makefile(all_caps, config['caps_makefile'], config['caps_cmakefile'], config['caps_sourcefile'], config['caps_dir']) if not success: diff --git a/scripts/common.py b/scripts/common.py index afedbe33..520e6c8c 100755 --- a/scripts/common.py +++ b/scripts/common.py @@ -69,23 +69,6 @@ def execute(cmd, abort = True): logging.error(message) return (status, stdout.rstrip('\n'), stderr.rstrip('\n')) -def indent(elem, level=0): - """Subroutine for writing "pretty" XML; copied from - http://effbot.org/zone/element-lib.htm#prettyprint""" - i = "\n" + level*" " - if len(elem): - if not elem.text or not elem.text.strip(): - elem.text = i + " " - if not elem.tail or not elem.tail.strip(): - elem.tail = i - for elem in elem: - indent(elem, level+1) - if not elem.tail or not elem.tail.strip(): - elem.tail = i - else: - if level and (not elem.tail or not elem.tail.strip()): - elem.tail = i - def split_var_name_and_array_reference(var_name): """Split an expression like foo(:,a,1:ddt%ngas) into components foo and (:,a,1:ddt%ngas).""" diff --git a/scripts/convert_metadata.py b/scripts/convert_metadata.py deleted file mode 100755 index 34082f77..00000000 --- a/scripts/convert_metadata.py +++ /dev/null @@ -1,718 +0,0 @@ -#!/usr/bin/env python - -# Python library imports -import sys -import os.path -import re -from collections import OrderedDict -import logging -# CCPP framework imports -from parse_tools import FORTRAN_ID, init_log, set_log_level -from fortran_tools import parse_fortran_file -from common import split_var_name_and_array_reference - -yes_re = re.compile(r"(?i)^\s*yes\s*$") -module_re = re.compile(r"(?i)\s*module\s+"+(FORTRAN_ID)+r"\s*.*$") -end_module_re = re.compile(r"(?i)\s*end\s*module\s+"+(FORTRAN_ID)+r"\s*.*$") -type_re = re.compile(r"(?i)\s*type\s+"+(FORTRAN_ID)+r"\s*.*$") -end_type_re = re.compile(r"(?i)\s*end\s*type\s+"+(FORTRAN_ID)+r"\s*.*$") -required_attrs = ['standard_name', 'units', 'dimensions', 'type'] -warning = True -__not_found__ = 'XX_NotFound_XX' - -# Configured models -MODELS = ['FV3'] - -######################################################################## - -def next_line(lines, max_line, cindex=-1): - nindex = cindex + 1 - if nindex > max_line: - return None, -1 - else: - return lines[nindex].rstrip('\n'), nindex - -######################################################################## - -def parse_module_line(line, mod_name): - match = module_re.match(line) - if match is not None: - mod_name = match.group(1) - else: - match = end_module_re.match(line) - if match is not None: - mod_name = None - # End if - # End if - return mod_name - -######################################################################## - -class MetadataEntry(OrderedDict): - - def __init__(self, local_name): - self._name = local_name - super(MetadataEntry, self).__init__() - - @property - def local_name(self): - return self._name - - def write(self, mdfile): - mdfile.write('[{}]\n'.format(self.local_name)) - for key in self.keys(): - mdfile.write(" {} = {}\n".format(key, self[key])) - # End for - -######################################################################## - -class MetadataTable(OrderedDict): - - def __init__(self, table_name, mod_name): - self._name = table_name - if (mod_name is not None) and (mod_name.lower() == table_name.lower()): - self._type = 'module' - elif table_name.split('_')[-1].lower() == 'type': - self._type = 'ddt' - else: - self._type = 'scheme' - # End if - super(MetadataTable, self).__init__() - - @property - def name(self): - return self._name - - @property - def type(self): - return self._type - - def has(self, varname): - hasvar = False - vartest = varname.lower() - for name in self.keys(): - if vartest == name.lower(): - hasvar = True - break - # End if - # End for - return hasvar - - def get(self, varname): - var = None - vartest = varname.lower() - for name in self.keys(): - if vartest == name.lower(): - var = self[name] - break - # End if - # End for - return var - - def write(self, mdfile): - mdfile.write('[ccpp-arg-table]\n') - mdfile.write(' name = {}\n'.format(self._name)) - mdfile.write(' type = {}\n'.format(self._type)) - for key in self.keys(): - self[key].write(mdfile) - -######################################################################## - -def convert_file(filename_in, filename_out, metadata_filename_out, model, logger=None): - """Convert a file's old metadata to the new format - Note that only the bare minimum error checking is done. - """ - if logger: - logger.info("Converting file {} ...".format(filename_in)) - else: - print "Converting file {} ...".format(filename_in) - current_module = None - # First, suck in the old file - do_convert = True - if not os.path.exists(filename_in): - raise IOError("convert_file: file, '{}', does not exist".format(filename_in)) - # End if - if os.path.exists(filename_out): - raise IOError("convert_file: file, '{}', already exists".format(filename_out)) - # End if - - # Lookup table local_name -> standard_name with data from ccpp_types.F90 - standard_names = { - 'cdata%blk_no' : 'ccpp_block_number', - 'cdata%thrd_no' : 'ccpp_thread_number', - 'cdata%errflg' : 'ccpp_error_flag', - 'cdata%errmsg' : 'ccpp_error_message', - 'cdata%loop_cnt': 'ccpp_loop_counter', - } - # Lookup table local_name -> dimensions - dimensions = {} - - # Read all lines of the file at once - with open(filename_in, 'r') as file: - fin_lines = file.readlines() - for index in xrange(len(fin_lines)): - fin_lines[index] = fin_lines[index].rstrip('\n') - # First loop through file to build dictionary with local names versus standard names - # and to record array dimensions from allocate statements - words = fin_lines[index].split('|') - if len(words)>=11: - # Create a dictionary with local names versus standard names in file - if words[0].strip() == '!!' and not words[1].strip() == 'local_name' and not words[2].strip() == 'standard_name' \ - and not "---" in words[1].strip() and not "---" in words[2].strip() : - local_name = words[1].strip().lower() - standard_name = words[2].strip() - if not standard_name: - continue - # No duplicates allowed - if local_name in standard_names.keys(): - raise Exception("Multiple definitions of local name {}".format(local_name)) - standard_names[local_name] = standard_name - elif 'allocate' in fin_lines[index]: - # Find all allocate statements to identify the correct dimensions - line_stripped = fin_lines[index].replace(' ','') - if 'allocate(' in line_stripped: - var_and_dims = line_stripped[line_stripped.find("allocate(")+9:line_stripped.rfind(")")] - # Variable to allocate, replace code with text used in metadata - var = var_and_dims[:var_and_dims.find("(")].lower() - # - # Begin model and file-dependent substitutions - if model == 'FV3': - if "GFS_typedefs" in filename_in: - var = var.replace("model%","gfs_control%") - var = var.replace("interstitial%","gfs_interstitial(cdata%thrd_no)%") - elif "CCPP_typedefs" in filename_in: - var = var.replace("interstitial%","ccpp_interstitial%") - # End model and file-dependent substitutions - # - # Dimensions to use, replace code with text used in metadata - dims = var_and_dims[var_and_dims.find("(")+1:var_and_dims.rfind(")")].split(',') - dims = [dim.lower() for dim in dims] - # - # Begin model and file-dependent substitutions - if model == 'FV3': - if "GFS_typedefs" in filename_in: - dims = [dim.replace("model%","gfs_control%") for dim in dims] - dims = [dim.replace("interstitial%","gfs_interstitial(cdata%thrd_no)%") for dim in dims] - elif "CCPP_typedefs" in filename_in: - dims = [dim.replace("interstitial%","ccpp_interstitial%") for dim in dims] - # Special handling of certain variables with multiple allocation lines in GFS_typedefs.F90 / CCPP_typedefs.F90 - if var == 'Diag%dq3dt'.lower(): - dims = ['im', 'gfs_control%levs', 'oz_coeff+5'] - elif var == 'ccpp_interstitial%cappa'.lower(): - dims = ['isd:ied', 'jsd:jed', '1:npzcappa'] - elif var in dimensions.keys() and not dims == dimensions[var]: - raise Exception("Multiple, conflicting allocations of variable with local name {}: {} vs {}".format( - var, dimensions[var], dims)) - # End model and file-dependent substitutions - else: - if var in dimensions.keys() and not dims == dimensions[var]: - raise Exception("Multiple, conflicting allocations of variable with local name {}: {} vs {}".format( - var, dimensions[var], dims)) - dimensions[var] = dims - # End if - # End if - # End if - # End for - # End with - - # Begin model and file-dependent substitutions - if model == 'FV3': - # Replace local dimensions in GFS_typedefs.F90, CCPP_typedefs.F90 and CCPP_data.F90 with correct standard names - for key in dimensions.keys(): - for i in xrange(len(dimensions[key])): - dim = dimensions[key][i] - if dim == 'im': - dimensions[key][i] = 'horizontal_dimension' - elif dim == 'interstitial%nvdiff': - dimensions[key][i] = 'number_of_vertical_diffusion_tracers' - elif dim == 'interstitial%nn': - dimensions[key][i] = 'number_of_tracers_for_convective_transport' - elif dim == 'gfs_control%levr+1': - dimensions[key][i] = 'number_of_vertical_layers_for_radiation_calculations_plus_one' - elif dim == 'gfs_control%levs+1': - dimensions[key][i] = 'vertical_dimension_plus_one' - elif dim == 'gfs_control%levs-1': - dimensions[key][i] = 'vertical_dimension_minus_one' - elif dim == 'gfs_control%levr+ltp': - dimensions[key][i] = 'adjusted_vertical_layer_dimension_for_radiation' - elif dim == 'gfs_control%levr+1+ltp': - dimensions[key][i] = 'adjusted_vertical_level_dimension_for_radiation' - elif dim in [ '-2:4', '4', '-2:0', '1:4', '6', '2', '3', '5', '7' ]: - continue - elif dim == 'levh2o': - dimensions[key][i] = 'vertical_dimension_of_h2o_forcing_data' - elif dim == 'h2o_coeff': - dimensions[key][i] = 'number_of_coefficients_in_h2o_forcing_data' - elif dim == 'levozp': - dimensions[key][i] = 'vertical_dimension_of_ozone_forcing_data' - elif dim == 'oz_coeff': - dimensions[key][i] = 'number_of_coefficients_in_ozone_forcing_data' - elif dim == 'oz_coeff+5': - dimensions[key][i] = 'number_of_coefficients_in_ozone_forcing_data_plus_five' - elif dim == '1:gfs_control%nblks': - dimensions[key][i] = 'number_of_blocks' - elif dim == 'ntrcaer': - dimensions[key][i] = 'number_of_aerosol_tracers_MG' - elif dim == 'nspc1': - dimensions[key][i] = 'number_of_species_for_aerosol_optical_depth' - elif dim == 'nbdlw': - dimensions[key][i] = 'number_of_aerosol_bands_for_longwave_radiation' - elif dim == 'nbdsw': - dimensions[key][i] = 'number_of_aerosol_bands_for_shortwave_radiation' - elif dim == 'nf_aelw': - dimensions[key][i] = 'number_of_aerosol_output_fields_for_longwave_radiation' - elif dim == 'nf_aesw': - dimensions[key][i] = 'number_of_aerosol_output_fields_for_shortwave_radiation' - elif dim == 'is:ie': - dimensions[key][i] = 'starting_x_direction_index:ending_x_direction_index' - elif dim == 'isd:ied': - dimensions[key][i] = 'starting_x_direction_index_domain:ending_x_direction_index_domain' - elif dim == 'js:je': - dimensions[key][i] = 'starting_y_direction_index:ending_y_direction_index' - elif dim == 'jsd:jed': - dimensions[key][i] = 'starting_y_direction_index_domain:ending_y_direction_index_domain' - elif dim == '1:npz': - dimensions[key][i] = '1:vertical_dimension_for_fast_physics' - elif dim == '1:npzcappa': - dimensions[key][i] = '1:vertical_dimension_for_cappa_at_Lagrangian_surface' - elif dim == '0:ccpp_interstitial%ngas': - dimensions[key][i] = '0:number_of_gases_for_multi_gases_physics' - elif dim in [ 'gfs_control%nfxr', - 'gfs_control%ntot2d', - 'gfs_control%ntot3d', - 'nf_clds', - '1:size(bk)', - 'nf_vgas', - '1:size(ak)', - 'nf_albd', - 'n', - ]: - dimensions[key][i] = dim + "_XX_SubstituteWithStandardName_XX" - elif not dim in standard_names.keys(): - raise Exception("Dimension {} not defined".format(dim)) - else: - dimensions[key][i] = standard_names[dim] - # End if - # End for - # End for - # End model and file-dependent substitutions - - max_line = len(fin_lines) - 1 - mdconfig = list() - in_preamble = True - in_type = False - ddt_references = {} - with open(filename_out, 'w') as file: - line, lindex = next_line(fin_lines, max_line) - while line is not None: - # Check for a module line - current_module = parse_module_line(line, current_module) - # Maintain a status of being in a DDT definition - if (not in_type) and type_re.match(line): - in_type = True - elif in_type and end_type_re.match(line): - in_type = False - # End if - # Check for end of preamble - if (not in_type) and (line.lstrip()[0:8].lower() == 'contains'): - in_preamble = False - # End if - - # Check for beginning of new table - words = line.split() - # This is case sensitive - if len(words) > 2 and words[0] in ['!!', '!>'] and '\section' in words[1] and 'arg_table_' in words[2]: - # We have a new table, parse the header - table_name = words[2].replace('arg_table_','') -##XXgoldyXX: Uncomment this after conversion is over -# logger.info('Found old metadata table, {}, on line {}'.format(table_name, lindex+1)) - # The header line is not modified - file.write(line+"\n") - # Create the table start section - mdtable = MetadataTable(table_name, current_module) - mdconfig.append(mdtable) - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - words = line.split('|') - header_locs = {} - dim_names = [__not_found__]*15 - # Do not work on a blank table - if len(words) > 1: - # Write an include line for the metadata table - file.write('!! \htmlinclude {}.html\n'.format(table_name)) - # - table_header = [x.strip() for x in words[1:-1]] - for ind in xrange(len(table_header)): - header_locs[table_header[ind]] = ind - # End for - # Find the local_name index (exception if not found) - local_name_ind = header_locs['local_name'] - # Find the standard_name index (exception if not found) - standard_name_ind = header_locs['standard_name'] - # The table header line is not output - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - # Parse the entries - while len(words) > 1: - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - words = line.split('|') - if len(words) <= 1: - # End of table, just write and continue - file.write(line+'\n') - continue - # End if - entries = [x.strip() for x in words[1:-1]] - # Okay, one check - if len(entries) != len(header_locs): - raise ValueError("Malformed table entry") - # End if - # First output the local name - local_name = entries[local_name_ind] - # Then check the local name, skip variables without a standard_name - standard_name = entries[standard_name_ind] - if not standard_name: - if logger is None: - raise ValueError("{} does not have a standard name in {}".format(local_name, table_name)) - else: - logger.debug("{} does not have a standard name in {}".format(local_name, table_name)) - continue - else: - # Standard names cannot have dashes or periods - standard_name = standard_name.replace('-', '_').replace('.', '_') - # Create var_name: strip old-style DDT references from local_name and try to substitute array indices - var_name = local_name - if "(" in var_name: - if "%" in var_name and var_name.rfind("%") > var_name.rfind(")"): - if mdtable.type == 'ddt': - ddt_reference = var_name[:var_name.rfind('%')] - var_name = var_name[var_name.rfind('%')+1:] - else: - (actual_var_name, array_reference) = split_var_name_and_array_reference(var_name) - if mdtable.type == 'ddt': - ddt_reference = actual_var_name[:actual_var_name.rfind('%')] - actual_var_name = actual_var_name[actual_var_name.rfind('%')+1:] - for index in array_reference.lstrip("(").rstrip(")").split(","): - # Keep literals and colons, substitute variables - match = re.match(r"[0-9]+|:", index) - if match: - continue - else: - if index.lower() in standard_names.keys(): - array_reference = array_reference.replace(index, standard_names[index.lower()]) - else: - array_reference = array_reference.replace(index, index + "_XX_SubstituteWithStandardName_XX") - # End if - # End if - # End for - var_name = actual_var_name + array_reference - # End if - elif "%" in var_name: - if mdtable.type == 'ddt': - ddt_reference = var_name[:var_name.rfind('%')] - var_name = var_name[var_name.rfind('%')+1:] - else: - ddt_reference = '' - # End if - # - if mdtable.type == 'module': - ddt_reference = '' - if not current_module in ddt_references.keys(): - ddt_references[current_module] = {} - if not table_name in ddt_references[current_module].keys(): - ddt_references[current_module][table_name] = ddt_reference - elif not ddt_references[current_module][table_name] == ddt_reference: - raise Exception("Conflicting DDT references in table {}: {} vs {}".format( - table_name, ddt_references[current_module][table_name], ddt_reference)) - # - mdobj = MetadataEntry(var_name) - mdtable[var_name] = mdobj - # Now, create the rest of the entries - for ind in xrange(len(entries)): - attr_name = table_header[ind] - entry = entries[ind] - if attr_name == 'local_name': - # Already handled this - continue - elif attr_name == 'rank': - attr_name = 'dimensions' - rank = int(entry) - if rank>0: - # Search for key in dimensions dictionary - if local_name.lower() in dimensions.keys(): - dim_key = local_name.lower() - # Begin model and file-dependent substitutions - elif model == 'FV3': - if local_name.replace("GFS_Data(cdata%blk_no)%","").lower() in dimensions.keys(): - dim_key = local_name.replace("GFS_Data(cdata%blk_no)%","").lower() - elif local_name.replace("GFS_Data(cdata%blk_no)%Intdiag%","Diag%").lower() in dimensions.keys(): - dim_key = local_name.replace("GFS_Data(cdata%blk_no)%Intdiag%","Diag%").lower() - elif local_name.replace("GFS_Interstitial(cdata%thrd_no)%","Interstitial%").lower() in dimensions.keys(): - dim_key = local_name.replace("GFS_Interstitial(cdata%thrd_no)%","Interstitial%").lower() - elif local_name.replace("CCPP_Interstitial%","Interstitial%").lower() in dimensions.keys(): - dim_key = local_name.replace("CCPP_Interstitial%","Interstitial%").lower() - else: - dim_key = None - # End model and file-dependent substitution - else: - dim_key = None - - # Begin model and file-dependent substitutions - if model == 'FV3': - if dim_key and 'n_XX_SubstituteWithStandardName_XX' in dimensions[dim_key]: - if local_name in [ 'GFS_Data(cdata%blk_no)%Intdiag%sedim', - 'GFS_Data(cdata%blk_no)%Intdiag%drydep', - 'GFS_Data(cdata%blk_no)%Intdiag%wetdpl', - 'GFS_Data(cdata%blk_no)%Intdiag%wetdpc' ]: - entry = '(horizonal_dimension,number_of_chemical_tracers_for_diagnostics)' - elif local_name == 'GFS_Data(cdata%blk_no)%Intdiag%duem': - entry = '(horizonal_dimension,number_of_dust_bins_for_diagnostics)' - elif local_name == 'GFS_Data(cdata%blk_no)%Intdiag%ssem': - entry = '(horizonal_dimension,number_of_seasalt_bins_for_diagnostics)' - else: - raise Exception("No entry defined for variable {} with dimensions {}".format( - local_name, dimensions[dim_key])) - elif dim_key: - if not rank == len(dimensions[dim_key]): - raise Exception("ERROR, mismatch of variable rank and dimensions for variable {}".format(local_name)) - entry = '(' + ','.join(dimensions[dim_key]) + ')' - # Special handling for slices of arrays that do not have an entry in the dimensions dictionary - elif local_name.endswith('(:,1)') and ('at_lowest_model_layer' in standard_name or \ - 'at_lowest_model_interface' in standard_name): - entry = '(horizontal_dimension)' - elif 'GFS_Data(cdata%blk_no)%Tbd%phy_f2d(:,' in local_name and rank==1: - entry = '(horizontal_dimension)' - elif 'GFS_Data(cdata%blk_no)%Tbd%phy_f3d(:,:' in local_name and rank==2: - entry = '(horizontal_dimension,vertical_dimension)' - elif 'GFS_Data(cdata%blk_no)%Statein%qgrs(:,:,GFS_Control' in local_name or \ - 'GFS_Data(cdata%blk_no)%Stateout%gq0(:,:,GFS_Control' in local_name or \ - 'GFS_Interstitial(cdata%thrd_no)%save_q(:,:,GFS_Control' in local_name: - entry = '(horizontal_dimension,vertical_dimension)' - elif 'GFS_Data(cdata%blk_no)%Statein%qgrs(:,1,GFS_Control' in local_name or \ - 'GFS_Data(cdata%blk_no)%Stateout%gq0(:,1,GFS_Control' in local_name: - entry = '(horizontal_dimension)' - elif ("Intdiag%du3dt" in local_name or \ - "Intdiag%dv3dt" in local_name or \ - "Intdiag%dt3dt" in local_name or \ - "Intdiag%dq3dt" in local_name) and rank==2: - entry = '(horizontal_dimension,vertical_dimension)' - elif ("GFS_Interstitial(cdata%thrd_no)%clouds(:,:" in local_name or \ - "GFS_Interstitial(cdata%thrd_no)%clw(:,:" in local_name) and rank==2: - entry = '(horizontal_dimension,vertical_dimension)' - elif "GFS_Interstitial(cdata%thrd_no)%dqdt(:,:,GFS_Control" in local_name: - entry = '(horizontal_dimension,vertical_dimension)' - elif local_name == "GFS_Control%input_nml_file": - entry = '(number_of_lines_of_namelist_filename_for_internal_file_reads)' - elif local_name == 'GFS_Control%blksz': - entry = '(number_of_blocks)' - elif local_name in [ 'GFS_Control%idat', - 'GFS_Control%jdat', - ]: - entry = '(8)' - elif local_name == 'GFS_Control%idate': - entry = '(4)' - elif local_name in [ 'GFS_Control%psautco', - 'GFS_Control%prautco', - 'GFS_Control%wminco', - 'GFS_Control%mg_ts_auto_ice', - 'GFS_Control%mg_qcmin', - 'GFS_Control%flgmin', - 'GFS_Control%cgwf', - 'GFS_Control%ccwf', - 'GFS_Control%cdmbgwd', - 'GFS_Control%ctei_rm', - 'GFS_Control%dlqf', - 'GFS_Control%psauras', - 'GFS_Control%prauras', - 'GFS_Control%wminras', - ]: - entry = '(2)' - elif local_name in [ 'GFS_Control%cs_parm' ]: - entry = '(10)' - elif local_name in [ 'GFS_Control%crtrh' ]: - entry = '(3)' - elif local_name in [ 'GFS_Control%pertz0', - 'GFS_Control%pertzt', - 'GFS_Control%pertshc', - 'GFS_Control%pertlai', - 'GFS_Control%pertalb', - 'GFS_Control%pertvegf', - ]: - entry = '(5)' - elif 'GFS_Interstitial(cdata%thrd_no)%faerlw(:,:,:' in local_name and rank==3: - entry = '(horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation,number_of_aerosol_bands_for_longwave_radiation)' - elif 'GFS_Interstitial(cdata%thrd_no)%faersw(:,:,:' in local_name and rank==3: - entry = '(horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation,number_of_aerosol_bands_for_shortwave_radiation)' - elif 'GFS_Interstitial(cdata%thrd_no)%gasvmr(:,:' in local_name and rank==2: - entry = '(horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation)' - elif 'GFS_Interstitial(cdata%thrd_no)%sfcalb(:,' in local_name and rank==1: - entry = '(horizontal_dimension)' - elif local_name in [ - 'CCPP_interstitial%delp', - 'CCPP_interstitial%pt', - 'CCPP_interstitial%qv', - 'CCPP_interstitial%ql', - 'CCPP_interstitial%qi', - 'CCPP_interstitial%qr', - 'CCPP_interstitial%qs', - 'CCPP_interstitial%qg', - 'CCPP_interstitial%qc', - ]: - entry = '(starting_x_direction_index_domain:ending_x_direction_index_domain,starting_y_direction_index_domain:ending_y_direction_index_domain,1:vertical_dimension_for_fast_physics)' - elif local_name in [ - 'CCPP_interstitial%delz', - ]: - entry = '(starting_x_direction_index_domain:ending_x_direction_index_domain,starting_y_direction_index_domain:ending_y_direction_index_domain,1:vertical_dimension_for_thickness_at_Lagrangian_surface)' - elif local_name in [ - 'CCPP_interstitial%area', - 'CCPP_interstitial%phis', - ]: - entry = '(starting_x_direction_index_domain:ending_x_direction_index_domain,starting_y_direction_index_domain:ending_y_direction_index_domain)' - elif local_name in [ - 'CCPP_interstitial%peln', - ]: - entry = '(starting_x_direction_index:ending_x_direction_index,1:vertical_dimension_for_fast_physics_plus_one,starting_y_direction_index:ending_y_direction_index)' - elif local_name in [ - 'CCPP_interstitial%pkz', - ]: - entry = '(starting_x_direction_index:ending_x_direction_index,starting_y_direction_index:ending_y_direction_index,1:vertical_dimension_for_fast_physics)' - elif local_name in [ - 'CCPP_interstitial%qvi', - ]: - entry = '(starting_x_direction_index_domain:ending_x_direction_index_domain,starting_y_direction_index_domain:ending_y_direction_index_domain,1:vertical_dimension_for_fast_physics,1:number_of_gases_for_multi_gases_physics)' - elif local_name in [ - 'CCPP_interstitial%q_con', - ]: - entry = '(starting_x_direction_index_domain:ending_x_direction_index_domain,starting_y_direction_index_domain:ending_y_direction_index_domain,1:vertical_dimension_for_condensed_water_at_Lagrangian_surface)' - elif "CCPP_data" in filename_in and standard_name == 'GFS_data_type_instance_all_blocks': - entry = '(ccpp_block_number)' - elif "CCPP_data" in filename_in and standard_name == 'GFS_interstitial_type_instance_all_threads': - entry = '(ccpp_thread_number)' - else: - entry = '(' + ','.join(dim_names[0:rank]) + ')' - # End model and file-dependent substitutions - else: - if dim_key: - if not rank == len(dimensions[dim_key]): - raise Exception("ERROR, mismatch of variable rank and dimensions for variable {}".format(local_name)) - entry = '(' + ','.join(dimensions[dim_key]) + ')' - else: - entry = '(' + ','.join(dim_names[0:rank]) + ')' - # rank == 0 - else: - entry = '(' + ','.join(dim_names[0:rank]) + ')' - # End if - elif attr_name == 'standard_name': - # Parsing done earlier - entries[ind] = standard_name - entry = standard_name - elif attr_name == 'intent': - # Don't write intent attribute for variable/type definitions - if in_preamble: - entry = '' - elif entry.lower() == 'none': - if logger is None: - raise ValueError("{} has intent = none in {}".format(var_name, table_name)) - else: - logger.warning("{} has intent = none in {}".format(var_name, table_name)) - elif attr_name == 'optional': - # Don't write optional attribute for variable/type definitions - if in_preamble: - entry = '' - elif not entry in ['F', 'T']: - if logger is None: - raise ValueError("{} has optional = {} in {}".format(var_name, entry, table_name)) - else: - logger.warning("{} has optional = {} in {}".format(var_name, entry, table_name)) - # End if - # End if - # No else needed - # End if - # Add attribute - if (len(entry) > 0) or (attr_name in required_attrs): - mdobj[attr_name] = entry - # End if - # End for (done with entry) - # End while (done with table) - else: - # Just write the line (should be a table ending) - if line.strip() != '!!': - raise ValueError("All tables must end with !! line") - # End if - file.write(line+'\n') - # End if (blank table) - else: - # Not a table, just write and continue - file.write(line+'\n') - # End if - # Always load a new line - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - # End while - # End with (file) - - # Write out finalized metadata file - with open(metadata_filename_out, 'w') as mdfile: - spacer = "" - # First pass: write type definitions, - # second pass: write module table - for count in xrange(2): - for table in mdconfig: - if (count == 0 and not table.type == 'ddt') or \ - (count == 1 and table.type == 'ddt'): - continue - if len(spacer) > 0: - mdfile.write(spacer) - # End if - table.write(mdfile) - spacer = '\n'+72*'#'+'\n' - # End for - # End for - # End with (mdfile) - - if ddt_references: - message = """Add the following statement to the CCPP prebuild config (add to existing entry): -TYPEDEFS_NEW_METADATA = { -""" - for module_name in ddt_references.keys(): - message += " '{module_name}' : {{\n".format(module_name=module_name) - for table_name in ddt_references[module_name].keys(): - message += " '{table_name}' : '{ddt_reference}',\n".format(table_name=table_name, - ddt_reference=ddt_references[module_name][table_name]) - message += " },\n" - message += " }\n" - if logger is not None: - logger.info(message) - else: - print message - -######################################################################## - -def usage(cmd): - print("Usage:") - print("{} ".format(cmd)) - print("") - print(" can be one of '{}'".format(MODELS)) - print("") - print("Translate the metadata in into a new file") - raise Exception - -######################################################################## - -if __name__ == "__main__": - # Process the files passed in - num_args = len(sys.argv) - if not num_args == 4: - usage(sys.argv[0]) - else: - ## Init this now so that all Exceptions can be trapped - logger = init_log('ccpp_capgen') - set_log_level(logger, logging.INFO) - ## To cause convert_metadata to stop when an error condition is found - ## (no metadata file), uncomment out the next line. - #logger = None - tbase = os.path.basename(sys.argv[2]) - tdir = os.path.dirname(sys.argv[2]) - if not sys.argv[3] in MODELS: - usage(sys.argv[0]) - mdfilename = "{}.meta".format('.'.join(tbase.split('.')[:-1])) - dest_mdfile = os.path.join(tdir, mdfilename) - convert_file(sys.argv[1], sys.argv[2], dest_mdfile, sys.argv[3], logger) - # End if -# End if diff --git a/scripts/convert_metadata_schemes_using_typedef_dims.py b/scripts/convert_metadata_schemes_using_typedef_dims.py deleted file mode 100755 index 2100c3df..00000000 --- a/scripts/convert_metadata_schemes_using_typedef_dims.py +++ /dev/null @@ -1,394 +0,0 @@ -#!/usr/bin/env python - -# Python library imports -import sys -import os.path -import re -from collections import OrderedDict -import logging -# CCPP framework imports -from parse_tools import FORTRAN_ID, init_log, set_log_level -from fortran_tools import parse_fortran_file -from metadata_table import MetadataHeader -from common import split_var_name_and_array_reference - -yes_re = re.compile(r"(?i)^\s*yes\s*$") -module_re = re.compile(r"(?i)\s*module\s+"+(FORTRAN_ID)+r"\s*.*$") -end_module_re = re.compile(r"(?i)\s*end\s*module\s+"+(FORTRAN_ID)+r"\s*.*$") -type_re = re.compile(r"(?i)\s*type\s+"+(FORTRAN_ID)+r"\s*.*$") -end_type_re = re.compile(r"(?i)\s*end\s*type\s+"+(FORTRAN_ID)+r"\s*.*$") -required_attrs = ['standard_name', 'units', 'dimensions', 'type'] -warning = True -__not_found__ = 'XX_NotFound_XX' - -# Configured models -#MODELS = ['FV3'] - -METADATA_TYPEDEFS = { - 'FV3' : [ - 'ccpp/physics/physics/machine.meta', - 'ccpp/physics/physics/radsw_param.meta', - 'ccpp/physics/physics/radlw_param.meta', - 'FV3/gfsphysics/CCPP_layer/CCPP_typedefs.meta', - 'FV3/gfsphysics/CCPP_layer/CCPP_data.meta', - 'FV3/gfsphysics/GFS_layer/GFS_typedefs.meta', - ], - } - -######################################################################## - -def parse_metadata_tables_typedefs(model): - # Lookup table local_name -> dimensions - dimensions = { - 'ccpp_error_flag' : [], - 'ccpp_error_message' : [], - 'ccpp_loop_counter' : [], - 'ccpp_block_number' : [], - 'ccpp_thread_number' : [], - 'ccpp_t' : [], - } - for filename in METADATA_TYPEDEFS[model]: - metadata_headers = MetadataHeader.parse_metadata_file(filename) - for metadata_header in metadata_headers: - for var in metadata_header.variable_list(): - standard_name = var.get_prop_value('standard_name') - if standard_name in dimensions.keys(): - raise ValueError("Duplicate standard name {} in type/variable definition metadata tables".format(standard_name)) - dimensions[standard_name] = var.get_prop_value('dimensions') - # - # Add missing variables (not used by FV3) - dimensions['lw_heating_rate_spectral'] = [ 'horizontal_dimension', 'adjusted_vertical_layer_dimension_for_radiation', 'number_of_aerosol_bands_for_longwave_radiation' ] - dimensions['lw_fluxes'] = ['horizontal_dimension', 'adjusted_vertical_level_dimension_for_radiation'] - dimensions['cloud_optical_depth'] = [ 'horizontal_dimension', 'adjusted_vertical_layer_dimension_for_radiation' ] - # - dimensions['sw_heating_rate_spectral'] = [ 'horizontal_dimension', 'adjusted_vertical_layer_dimension_for_radiation', 'number_of_aerosol_bands_for_shortwave_radiation' ] - dimensions['sw_fluxes'] = ['horizontal_dimension', 'adjusted_vertical_level_dimension_for_radiation'] - dimensions['cloud_single_scattering_albedo'] = [ 'horizontal_dimension', 'adjusted_vertical_layer_dimension_for_radiation' ] - dimensions['cloud_asymmetry_parameter'] = [ 'horizontal_dimension', 'adjusted_vertical_layer_dimension_for_radiation' ] - # - dimensions['specified_kinematic_surface_upward_sensible_heat_flux'] = [ 'horizontal_dimension' ] - dimensions['specified_kinematic_surface_upward_latent_heat_flux'] = [ 'horizontal_dimension' ] - dimensions['vonKarman_constant'] = [] - # - return dimensions - -######################################################################## - -def next_line(lines, max_line, cindex=-1): - nindex = cindex + 1 - if nindex > max_line: - return None, -1 - else: - return lines[nindex].rstrip('\n'), nindex - -######################################################################## - -def parse_module_line(line, mod_name): - match = module_re.match(line) - if match is not None: - mod_name = match.group(1) - else: - match = end_module_re.match(line) - if match is not None: - mod_name = None - # End if - # End if - return mod_name - -######################################################################## - -class MetadataEntry(OrderedDict): - - def __init__(self, local_name): - self._name = local_name - super(MetadataEntry, self).__init__() - - @property - def local_name(self): - return self._name - - def write(self, mdfile): - mdfile.write('[{}]\n'.format(self.local_name)) - for key in self.keys(): - mdfile.write(" {} = {}\n".format(key, self[key])) - # End for - -######################################################################## - -class MetadataTable(OrderedDict): - - def __init__(self, table_name, mod_name): - self._name = table_name - if (mod_name is not None) and (mod_name.lower() == table_name.lower()): - self._type = 'module' - elif table_name.split('_')[-1].lower() == 'type': - self._type = 'ddt' - else: - self._type = 'scheme' - # End if - super(MetadataTable, self).__init__() - - @property - def name(self): - return self._name - - @property - def type(self): - return self._type - - def has(self, varname): - hasvar = False - vartest = varname.lower() - for name in self.keys(): - if vartest == name.lower(): - hasvar = True - break - # End if - # End for - return hasvar - - def get(self, varname): - var = None - vartest = varname.lower() - for name in self.keys(): - if vartest == name.lower(): - var = self[name] - break - # End if - # End for - return var - - def write(self, mdfile): - mdfile.write('[ccpp-arg-table]\n') - mdfile.write(' name = {}\n'.format(self._name)) - mdfile.write(' type = {}\n'.format(self._type)) - for key in self.keys(): - self[key].write(mdfile) - -######################################################################## - -def convert_file(filename_in, filename_out, metadata_filename_out, typedef_dimensions, logger=None): - """Convert a file's old metadata to the new format - Note that only the bare minimum error checking is done. - """ - if logger: - logger.info("Converting file {} ...".format(filename_in)) - else: - print "Converting file {} ...".format(filename_in) - current_module = None - # First, suck in the old file - do_convert = True - if not os.path.exists(filename_in): - raise IOError("convert_file: file, '{}', does not exist".format(filename_in)) - # End if - if os.path.exists(filename_out): - raise IOError("convert_file: file, '{}', already exists".format(filename_out)) - # End if - - # Read all lines of the file at once - with open(filename_in, 'r') as file: - fin_lines = file.readlines() - for index in xrange(len(fin_lines)): - fin_lines[index] = fin_lines[index].rstrip('\n') - # End for - # End with - - max_line = len(fin_lines) - 1 - mdconfig = list() - in_preamble = True - in_type = False - with open(filename_out, 'w') as file: - line, lindex = next_line(fin_lines, max_line) - while line is not None: - # Check for a module line - current_module = parse_module_line(line, current_module) - # Maintain a status of being in a DDT definition - if (not in_type) and type_re.match(line): - in_type = True - elif in_type and end_type_re.match(line): - in_type = False - # End if - # Check for end of preamble - if (not in_type) and (line.lstrip()[0:8].lower() == 'contains'): - in_preamble = False - # End if - - # Check for beginning of new table - words = line.split() - # This is case sensitive - if len(words) > 2 and words[0] in ['!!', '!>'] and '\section' in words[1] and 'arg_table_' in words[2]: - # We have a new table, parse the header - table_name = words[2].replace('arg_table_','') -##XXgoldyXX: Uncomment this after conversion is over -# logger.info('Found old metadata table, {}, on line {}'.format(table_name, lindex+1)) - # The header line is not modified - file.write(line+"\n") - # Create the table start section - mdtable = MetadataTable(table_name, current_module) - mdconfig.append(mdtable) - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - words = line.split('|') - header_locs = {} - dim_names = [__not_found__]*15 - # Do not work on a blank table - if len(words) > 1: - # Write an include line for the metadata table - file.write('!! \htmlinclude {}.html\n'.format(table_name)) - # - table_header = [x.strip() for x in words[1:-1]] - for ind in xrange(len(table_header)): - header_locs[table_header[ind]] = ind - # End for - # Find the local_name index (exception if not found) - local_name_ind = header_locs['local_name'] - # Find the standard_name index (exception if not found) - standard_name_ind = header_locs['standard_name'] - # The table header line is not output - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - # Parse the entries - while len(words) > 1: - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - words = line.split('|') - if len(words) <= 1: - # End of table, just write and continue - file.write(line+'\n') - continue - # End if - entries = [x.strip() for x in words[1:-1]] - # Okay, one check - if len(entries) != len(header_locs): - raise ValueError("Malformed table entry") - # End if - # First output the local name - local_name = entries[local_name_ind] - # Then check the local name, skip variables without a standard_name - standard_name = entries[standard_name_ind] - if not standard_name: - raise ValueError("{} does not have a standard name in {}".format(local_name, table_name)) - # Standard names cannot have dashes or periods - standard_name = standard_name.replace('-', '_').replace('.', '_') - # Create var_name: strip old-style DDT references from local_name and try to substitute array indices - var_name = local_name - # - mdobj = MetadataEntry(var_name) - mdtable[var_name] = mdobj - # Now, create the rest of the entries - for ind in xrange(len(entries)): - attr_name = table_header[ind] - entry = entries[ind] - if attr_name == 'local_name': - # Already handled this - continue - elif attr_name == 'rank': - attr_name = 'dimensions' - rank = int(entry) - # Search for standard_name key in typedef_dimensions dictionary - if not standard_name in typedef_dimensions.keys(): - raise ValueError("{} does not have an entry in the in typedef_dimensions dictionary".format(standard_name)) - if not rank == len(typedef_dimensions[standard_name]): - raise ValueError("Rank of {} in {} does not match with dimension information in typedef_dimensions".format( - standard_name, table_name)) - entry = '(' + ','.join(typedef_dimensions[standard_name]) + ')' - elif attr_name == 'standard_name': - # Parsing done earlier - entries[ind] = standard_name - entry = standard_name - elif attr_name == 'intent': - # Don't write intent attribute for variable/type definitions - if in_preamble: - entry = '' - elif entry.lower() == 'none': - if logger is None: - raise ValueError("{} has intent = none in {}".format(var_name, table_name)) - else: - logger.error("{} has intent = none in {}".format(var_name, table_name)) - elif attr_name == 'optional': - # Don't write optional attribute for variable/type definitions - if in_preamble: - entry = '' - elif not entry in ['F', 'T']: - if logger is None: - raise ValueError("{} has optional = {} in {}".format(var_name, entry, table_name)) - else: - logger.error("{} has optional = {} in {}".format(var_name, entry, table_name)) - # End if - # End if - # No else needed - # End if - # Add attribute - if (len(entry) > 0) or (attr_name in required_attrs): - mdobj[attr_name] = entry - # End if - # End for (done with entry) - # End while (done with table) - else: - # Just write the line (should be a table ending) - if line.strip() != '!!': - raise ValueError("All tables must end with !! line") - # End if - file.write(line+'\n') - # End if (blank table) - else: - # Not a table, just write and continue - file.write(line+'\n') - # End if - # Always load a new line - line, lindex = next_line(fin_lines, max_line, cindex=lindex) - # End while - # End with (file) - - # Write out finalized metadata file - with open(metadata_filename_out, 'w') as mdfile: - spacer = "" - # First pass: write type definitions, - # second pass: write module table - for count in xrange(2): - for table in mdconfig: - if (count == 0 and not table.type == 'ddt') or \ - (count == 1 and table.type == 'ddt'): - continue - if len(spacer) > 0: - mdfile.write(spacer) - # End if - table.write(mdfile) - spacer = '\n'+72*'#'+'\n' - # End for - # End for - # End with (mdfile) - -######################################################################## - -def usage(cmd): - print("Usage:") - print("{} ".format(cmd)) - print("") - print(" can be one of '{}'".format(METADATA_TYPEDEFS.keys())) - print("") - print("Translate the metadata in into a new file") - raise Exception - -######################################################################## - -if __name__ == "__main__": - # Process the files passed in - num_args = len(sys.argv) - if not num_args == 4: - usage(sys.argv[0]) - else: - ## Init this now so that all Exceptions can be trapped - logger = init_log('ccpp_capgen') - set_log_level(logger, logging.INFO) - ## To cause convert_metadata to stop when an error condition is found - ## (no metadata file), uncomment out the next line. - #logger = None - tbase = os.path.basename(sys.argv[2]) - tdir = os.path.dirname(sys.argv[2]) - if not sys.argv[3] in METADATA_TYPEDEFS.keys(): - usage(sys.argv[0]) - mdfilename = "{}.meta".format('.'.join(tbase.split('.')[:-1])) - dest_mdfile = os.path.join(tdir, mdfilename) - typedef_dimensions = parse_metadata_tables_typedefs(sys.argv[3]) - - convert_file(sys.argv[1], sys.argv[2], dest_mdfile, typedef_dimensions, logger) - # End if -# End if diff --git a/scripts/metadata_parser.py b/scripts/metadata_parser.py index f4104195..4cf0f772 100755 --- a/scripts/metadata_parser.py +++ b/scripts/metadata_parser.py @@ -5,7 +5,7 @@ import subprocess from xml.etree import ElementTree as ET -from common import indent, encode_container +from common import encode_container from mkcap import Var import sys, os @@ -13,37 +13,8 @@ from parse_fortran import Ftype_type_decl from metadata_table import MetadataHeader -# The argument tables for schemes and variable definitions should have the following format: -# !! \section arg_table_SubroutineName (e.g. SubroutineName = SchemeName_run) OR \section arg_table_DerivedTypeName OR \section arg_table_ModuleName -# !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -# !! |----------------|-------------------------------------------------------|------------------------------------------|---------|------|-----------|-----------|--------|----------| -# !! | im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | -# !! | ix | horizontal_dimension | horizontal dimension | index | 0 | integer | | in | F | -# !! | ... | ... | | | | | | | | -# !! | errmsg | error_message | error message for error handling in CCPP | none | 0 | character | | out | F | -# !! | ierr | error_flag | error flag for error handling in CCPP | none | 0 | integer | | out | F | -# !! -# Notes on the input format: -# - if the argument table starts a new doxygen section, it should start with !> \section instead of !! \section -# - the "\section arg_table_{SubroutineName,DerivedTypeName,ModuleName}" command denotes the start of the table -# - SubroutineName must match the name of the subroutine that the argument table describes -# - DerivedTypeName must match the name of the derived type that the argument table describes -# - ModuleName must match the name of the module whose variables the argument table describes -# - the table must be placed immediately before the subroutine / derived data type, -# or immediately before the module variables (but within the module structure) -# - each line of the table must begin with the doxygen-delimiter '!!' -# - table headers are the first row, the second row must have the |---|-----| format -# - after the last row of the table, there must be a blank doxygen line (only '!!') to denote the end of the table -# - for variable type definitions and module variables, the intent and optional columns must be set to 'none' and 'F' -# - each argument table (and its subroutine) must accept the following two arguments for error handling: -# - character(len=512), intent(out) :: errmsg -# - errmsg must be initialized as '' and contains the error message in case an error occurs -# - integer, intent(out) :: ierr -# - ierr must be initialized as 0 and set to >1 in case of errors -# Output: This routine converts the argument tables for all subroutines / typedefs / module variables into an XML file -# suitable to be used with mkcap.py (which generates the fortran code for the scheme cap) -# - the script generates a separate file for each module within the given files - +# Output: This routine converts the argument tables for all subroutines / typedefs / kind / module variables +# into dictionaries suitable to be used with ccpp_prebuild.py (which generates the fortran code for the caps) # Items in this dictionary are used for checking valid entries in metadata tables. For columsn with no keys/keys # commented out, no check is performed. This is the case for 'type' and 'kind' right now, since models use their diff --git a/scripts/mkcap.py b/scripts/mkcap.py index aa9388d0..6eb38ccb 100755 --- a/scripts/mkcap.py +++ b/scripts/mkcap.py @@ -211,22 +211,6 @@ def print_module_use(self): str = 'use {module}, only: {varname}'.format(module=module,varname=self.local_name) return str - def print_def_pointer(self): - '''Print the definition line for the variable, using pointers''' - if self.type in STANDARD_VARIABLE_TYPES: - if self.kind: - str = "{s.type}({s._kind}), pointer :: {s.local_name}{s.rank}" - else: - str = "{s.type}, pointer :: {s.local_name}{s.rank}" - else: - if self.kind: - error_message = "Generating variable definition statements for derived types with" + \ - " kind attributes not implemented; variable: {0}".format(self.standard_name) - raise Exception(error_message) - else: - str = "type({s.type}), pointer :: {s.local_name}{s.rank}" - return str.format(s=self) - def print_def_intent(self): '''Print the definition line for the variable, using intent.''' if self.type in STANDARD_VARIABLE_TYPES: @@ -268,116 +252,6 @@ def print_def_local(self): str = "type({s.type}) :: {s.local_name}" return str.format(s=self) - def print_get(self, index=0): - '''Print the data retrieval line for the variable. Depends on the type and of variable. - If index (= location of variable in cdata structure) is supplied, pass to Fortran call.''' - if index==0: - index_string = '' - else: - index_string = ', index={index}'.format(index=index) - if self.type in STANDARD_VARIABLE_TYPES and self.rank == '': - str=''' - call ccpp_field_get(cdata, '{s.standard_name}', {s.local_name}, ierr=ierr, kind=ckind{index_string}) -#ifdef DEBUG - if (ierr /= 0) then - call ccpp_error('Unable to retrieve {s.standard_name} from CCPP data structure') - return - end if - if (kind({s.local_name}).ne.ckind) then - call ccpp_error('Kind mismatch for variable {s.standard_name}') - ierr = 1 - return - end if -#endif - ''' - elif self.type in STANDARD_VARIABLE_TYPES: - str=''' - call ccpp_field_get(cdata, '{s.standard_name}', {s.local_name}, ierr=ierr, dims=cdims, kind=ckind{index_string}) -#ifdef DEBUG - if (ierr /= 0) then - call ccpp_error('Unable to retrieve {s.standard_name} from CCPP data structure') - return - end if - if (kind({s.local_name}).ne.ckind) then - call ccpp_error('Kind mismatch for variable {s.standard_name}') - ierr = 1 - return - end if -#endif - deallocate(cdims) - ''' - # Derived-type variables, scalar - elif self.rank == '': - str=''' - call ccpp_field_get(cdata, '{s.standard_name}', cptr, ierr=ierr, kind=ckind{index_string}) -#ifdef DEBUG - if (ierr /= 0) then - call ccpp_error('Unable to retrieve {s.standard_name} from CCPP data structure') - return - end if - if (ckind.ne.CCPP_GENERIC_KIND) then - call ccpp_error('Kind mismatch for variable {s.standard_name}') - ierr = 1 - return - end if -#endif - call c_f_pointer(cptr, {s.local_name})''' - # Derived-type variables, array - else: - str=''' - call ccpp_field_get(cdata, '{s.standard_name}', cptr, ierr=ierr, dims=cdims, kind=ckind{index_string}) -#ifdef DEBUG - if (ierr /= 0) then - call ccpp_error('Unable to retrieve {s.standard_name} from CCPP data structure') - return - end if - if (ckind.ne.CCPP_GENERIC_KIND) then - call ccpp_error('Kind mismatch for variable {s.standard_name}') - ierr = 1 - return - end if -#endif - call c_f_pointer(cptr, {s.local_name}, cdims) - deallocate(cdims) - ''' - return str.format(s=self, index_string=index_string) - - def print_add(self, ccpp_data_structure, index=0): - '''Print the data addition line for the variable. Depends on the type of variable. - Since the name of the ccpp data structure is not known, this needs to be filled later. - In case of errors a message is printed to screen; using 'return' statements as above - for ccpp_field_get is not possible, since the ccpp_field_add statements may be placed - inside OpenMP parallel regions. - If index (= location of variable in cdata structure) is supplied, pass to Fortran call.''' - # Index string to test that index generated by CCPP prebuild matches - # the actual index in the cdata lookup table - if index==0: - index_string = '' - else: - index_string = ', index={index}'.format(index=index) - # Standard-type variables, scalar and array - if self.type in STANDARD_VARIABLE_TYPES: - str=''' - call ccpp_field_add({ccpp_data_structure}, '{s.standard_name}', {s.target}, ierr=ierr, units='{s.units}'{index_string}) - if (ierr /= 0) then - call ccpp_error('Unable to add field "{s.standard_name}" to CCPP data structure') - end if''' - # Derived-type variables, scalar - elif self.rank == '': - str=''' - call ccpp_field_add({ccpp_data_structure}, '{s.standard_name}', '', c_loc({s.target}), ierr=ierr{index_string}) - if (ierr /= 0) then - call ccpp_error('Unable to add field "{s.standard_name}" to CCPP data structure') - end if''' - # Derived-type variables, array - else: - str=''' - call ccpp_field_add({ccpp_data_structure}, '{s.standard_name}', '', c_loc({s.target}), rank=size(shape({s.target})), dims=shape({s.target}), ierr=ierr{index_string}) - if (ierr /= 0) then - call ccpp_error('Unable to add field "{s.standard_name}" to CCPP data structure') - end if''' - return str.format(ccpp_data_structure=ccpp_data_structure, s=self, index_string=index_string) - def print_debug(self): '''Print the data retrieval line for the variable.''' str='''Contents of {s} (* = mandatory for compatibility): @@ -409,225 +283,6 @@ def from_table(cls, columns, data): var.optional = data[columns.index('optional')] return var - def to_xml(self, element): - element.set('name', self._standard_name) - sub_element = ET.SubElement(element, 'standard_name') - sub_element.text = self._standard_name - sub_element = ET.SubElement(element, 'long_name') - sub_element.text = self._long_name - sub_element = ET.SubElement(element, 'units') - sub_element.text = self._units - sub_element = ET.SubElement(element, 'local_name') - sub_element.text = self._local_name - sub_element = ET.SubElement(element, 'type') - sub_element.text = self._type - sub_element = ET.SubElement(element, 'rank') - sub_element.text = self._rank - sub_element = ET.SubElement(element, 'intent') - sub_element.text = self._intent - sub_element = ET.SubElement(element, 'optional') - sub_element.text = self._optional - sub_element = ET.SubElement(element, 'container') - sub_element.text = self._container - return element - -############################################################################### -class Cap(object): - - header=''' -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief Auto-generated cap module for the {module} scheme -!! -! -module {module}_cap - - use, intrinsic :: iso_c_binding, & - only: c_f_pointer, c_ptr, c_int32_t - use :: ccpp_types, & - only: ccpp_t, CCPP_GENERIC_KIND - use :: ccpp_fields, & - only: ccpp_field_get - use :: ccpp_errors, & - only: ccpp_error, ccpp_debug - use :: {module}, & - only: {subroutines} - ! Other modules required, e.g. type definitions - {module_use} - - implicit none - - private - public :: {subroutine_caps} - - contains - -''' - - sub=''' - function {subroutine}_cap(ptr) bind(c) result(ierr) - - integer(c_int32_t) :: ierr - type(c_ptr), intent(inout) :: ptr - - type(ccpp_t), pointer :: cdata - type(c_ptr) :: cptr - integer, allocatable :: cdims(:) - integer :: ckind -{var_defs} - - ierr = 0 - - call c_f_pointer(ptr, cdata) - -{var_gets} - -{actions_before} - - call {subroutine}({args}) - {ierr_assign} - -{actions_after} - - end function {subroutine}_cap -''' - - def __init__(self, **kwargs): - self._filename = 'sys.stdout' - for key, value in kwargs.items(): - setattr(self, "_"+key, value) - - def write(self, module, data, ccpp_field_map, metadata_define): - if (self.filename is not sys.stdout): - filepath = os.path.split(self.filename)[0] - if filepath and not os.path.isdir(filepath): - os.makedirs(filepath) - f = open(self.filename, 'w') - else: - f = sys.stdout - - subs = ','.join(["{0}".format(s) for s in data.keys()]) - sub_caps = ','.join(["{0}_cap".format(s) for s in data.keys()]) - - # Import variable type definitions for all subroutines (init, run, finalize) - module_use = [] - local_kind_and_type_vars = [] - for sub in data.keys(): - for var in data[sub]: - if var.type in STANDARD_VARIABLE_TYPES and var.kind and not var.type == STANDARD_CHARACTER_TYPE: - kind_var_standard_name = var.kind - if not kind_var_standard_name in local_kind_and_type_vars: - if not kind_var_standard_name in metadata_define.keys(): - raise Exception("Kind {kind} not defined by host model".format(kind=kind_var_standard_name)) - kind_var = metadata_define[kind_var_standard_name][0] - module_use.append(kind_var.print_module_use()) - local_kind_and_type_vars.append(kind_var_standard_name) - elif not var.type in STANDARD_VARIABLE_TYPES: - type_var_standard_name = var.type - if not type_var_standard_name in local_kind_and_type_vars: - if not type_var_standard_name in metadata_define.keys(): - raise Exception("Type {type} not defined by host model".format(type=type_var_standard_name)) - type_var = metadata_define[type_var_standard_name][0] - module_use.append(type_var.print_module_use()) - local_kind_and_type_vars.append(type_var_standard_name) - del local_kind_and_type_vars - - f.write(Cap.header.format(module = module, - module_use = '\n '.join(module_use), - subroutines = subs, - subroutine_caps = sub_caps)) - - for sub in data.keys(): - # Treat CCPP internal variables differently: do not retrieve - # via ccpp_field_get, use them directly via cdata%... - # (configured in common.py, needs to match what is is ccpp_types.F90) - var_defs = "\n".join([" "*8 + x.print_def_pointer() for x in data[sub] if x.standard_name not in CCPP_INTERNAL_VARIABLES.keys()]) - # Use lookup index in cdata from build time for faster retrieval - var_gets = "\n".join([x.print_get(ccpp_field_map[x.standard_name]) for x in data[sub]if x.standard_name not in CCPP_INTERNAL_VARIABLES.keys()]) - # Generate unit conversion statements on input and output. Special handling for - # unit conversions for intent(in) variables, these don't require defining a - # temporary variable, instead just pass the conversion function as argument - actions_before = '' - actions_after = '' - tmpvar_cnt = 0 - tmpvars = {} - for x in data[sub]: - if x.actions['out']: - tmpvar_cnt += 1 - tmpvar = copy.deepcopy(x) - tmpvar.local_name = 'tmpvar{0}'.format(tmpvar_cnt) - var_defs += '\n' + " "*8 + tmpvar.print_def_local() - if x.rank: - actions_before += ' allocate({t}, source={x})\n'.format(t=tmpvar.local_name, x=x.local_name) - if x.actions['in']: - actions_before += ' {t} = {c}\n'.format(t=tmpvar.local_name, - c=x.actions['in'].format(var=x.local_name, - kind='_' + x.kind if x.kind else '')) - actions_after += ' {x} = {c}\n'.format(x=x.local_name, - c=x.actions['out'].format(var=tmpvar.local_name, - kind='_' + x.kind if x.kind else '')) - if x.rank: - actions_after += ' deallocate({t})\n'.format(t=tmpvar.local_name) - tmpvars[x.local_name] = tmpvar.local_name - # Split args so that lines don't exceed 260 characters (for PGI) - args = '' - length = 0 - for x in data[sub]: - if x.standard_name in CCPP_INTERNAL_VARIABLES.keys(): - arg = "{0}={1},".format(x.local_name, CCPP_INTERNAL_VARIABLES[x.standard_name]) - elif x.local_name in tmpvars.keys(): - arg = "{0}={1},".format(x.local_name, tmpvars[x.local_name]) - elif x.actions['in'] and not x.actions['out']: - action = x.actions['in'].format(var=x.local_name, kind='_' + x.kind if x.kind else '') - arg = '{0}={1},'.format(x.local_name, action) - else: - arg = "{0}={0},".format(x.local_name) - args += arg - length += len(arg) - if length > 70 and not x == data[sub][-1]: - args += ' &\n ' - length = 0 - args = args.rstrip(',') - # If CCPP_ERROR_FLAG_VARIABLE is present, assign to ierr - ierr_assign = '' - for x in data[sub]: - if x.standard_name == CCPP_ERROR_FLAG_VARIABLE: - ierr_assign = 'ierr={0}'.format(CCPP_INTERNAL_VARIABLES[CCPP_ERROR_FLAG_VARIABLE]) - break - # Write to scheme cap - f.write(Cap.sub.format(subroutine=sub, - var_defs=var_defs, - var_gets=var_gets, - actions_before=actions_before.rstrip('\n'), - args=args, - ierr_assign=ierr_assign, - actions_after=actions_after.rstrip('\n'))) - f.write("end module {module}_cap\n".format(module = module)) - - if (f is not sys.stdout): - f.close() - - @property - def filename(self): - '''Get the filename of write the output to.''' - return self._filename - - @filename.setter - def filename(self, value): - self._filename = value - class CapsMakefile(object): header=''' diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 2ca7447f..57944670 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -6,39 +6,10 @@ endif (NOT PROJECT) #------------------------------------------------------------------------------ # Set the sources -if(STATIC) - set(SOURCES_C) - set(SOURCES_F90 - ccpp_types.F90 - ccpp_errors.F90 - ccpp.F90 - ccpp_api.F90 - ) -else(STATIC) - set(SOURCES_C - ccpp_dl.h - ccpp_dl.c - ccpp_fields_idx.h - ccpp_fields_idx.c - ccpp_utils.h - ccpp_utils.c - ccpp_xml.h - ccpp_xml.c - ) - set(SOURCES_F90 - ccpp.F90 - ccpp_dl.F90 - ccpp_errors.F90 - ccpp_fcall.F90 - ccpp_fields.F90 - ccpp_strings.F90 - ccpp_scheme.F90 - ccpp_suite.F90 - ccpp_types.F90 - ccpp_xml.F90 - ccpp_api.F90 - ) -endif(STATIC) +set(SOURCES_F90 + ccpp_types.F90 + ccpp_api.F90 +) # Generate list of Fortran modules from defined sources foreach(source_f90 ${SOURCES_F90}) @@ -46,47 +17,11 @@ foreach(source_f90 ${SOURCES_F90}) list(APPEND MODULES_F90 ${CMAKE_CURRENT_BINARY_DIR}/${module_f90}) endforeach() -#------------------------------------------------------------------------------ -# Find/set libXML2 -if(LIBXML2_LIB_DIR AND LIBXML2_INCLUDE_DIR) - include_directories(${LIBXML2_INCLUDE_DIR}) - if (STATIC) - list(APPEND LIBS "${LIBXML2_LIB_DIR}/libxml2.a") - else (STATIC) - if(APPLE) - list(APPEND LIBS "${LIBXML2_LIB_DIR}/libxml2.dylib") - elseif(UNIX) - list(APPEND LIBS "${LIBXML2_LIB_DIR}/libxml2.so") - else (APPLE) - message (FATAL_ERROR "Unsupported platform, only Linux and MacOSX are supported at this time.") - endif(APPLE) - endif (STATIC) -else(LIBXML2_LIB_DIR AND LIBXML2_INCLUDE_DIR) - find_package(LibXml2 REQUIRED) - if(LIBXML2_FOUND) - include_directories(${LIBXML2_INCLUDE_DIR}) - list(APPEND LIBS ${LIBXML2_LIBRARIES}) - endif(LIBXML2_FOUND) -endif(LIBXML2_LIB_DIR AND LIBXML2_INCLUDE_DIR) - #------------------------------------------------------------------------------ # CMake Modules # Set the CMake module path list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/../cmake") -#------------------------------------------------------------------------------ -# The Fortran compiler/linker flag inserted by cmake to create shared libraries -# with the Intel compiler is deprecated (-i_dynamic), correct here. -# CMAKE_Fortran_COMPILER_ID = {"Intel", "PGI", "GNU", "Clang", "MSVC", ...} -if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "Intel") - string(REPLACE "-i_dynamic" "-shared-intel" - CMAKE_SHARED_LIBRARY_CREATE_Fortran_FLAGS - "${CMAKE_SHARED_LIBRARY_CREATE_Fortran_FLAGS}") - string(REPLACE "-i_dynamic" "-shared-intel" - CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS - "${CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS}") -endif() - #------------------------------------------------------------------------------ # Set a default build type if none was specified if(NOT CMAKE_BUILD_TYPE AND NOT CMAKE_CONFIGURATION_TYPES) @@ -121,21 +56,9 @@ set(${PACKAGE}_LIB_DIRS "${CMAKE_CURRENT_BINARY_DIR}" CACHE FILEPATH "${PACKAGE} library directories") -#------------------------------------------------------------------------------ -# Add the tests (designed for DYNAMIC build only) -if(STATIC) - message(STATUS "Skipping tests, defined for dynamic build only") -else(STATIC) - add_subdirectory(tests) -endif(STATIC) - #------------------------------------------------------------------------------ # Define the executable and what to link -if(STATIC) - add_library(ccpp STATIC ${SOURCES_C} ${SOURCES_F90}) -else(STATIC) - add_library(ccpp SHARED ${SOURCES_C} ${SOURCES_F90}) -endif(STATIC) +add_library(ccpp STATIC ${SOURCES_F90}) target_link_libraries(ccpp LINK_PUBLIC ${LIBS} ${CMAKE_DL_LIBS}) set_target_properties(ccpp PROPERTIES VERSION ${PROJECT_VERSION} SOVERSION ${PROJECT_VERSION_MAJOR} @@ -144,12 +67,6 @@ set_target_properties(ccpp PROPERTIES VERSION ${PROJECT_VERSION} #------------------------------------------------------------------------------ # Installation # - -# Find all the C headers and Fortran modules -file(GLOB HEADERS_C - "${CMAKE_CURRENT_SOURCE_DIR}/ccpp*.h" -) - if (PROJECT STREQUAL "CCPP-FV3") target_include_directories(ccpp PUBLIC $ @@ -176,12 +93,9 @@ install(EXPORT ccpp-targets DESTINATION lib/cmake ) +# Define where to install the Fortran modules if (PROJECT STREQUAL "CCPP-FV3") - # Define where to install the C headers and Fortran modules - install(FILES ${HEADERS_C} DESTINATION include) install(FILES ${MODULES_F90} DESTINATION include) else (PROJECT STREQUAL "CCPP-SCM") - # Define where to install the C headers and Fortran modules - install(FILES ${HEADERS_C} DESTINATION include/${PROJECT_NAME}) install(FILES ${MODULES_F90} DESTINATION include/${PROJECT_NAME}) endif (PROJECT STREQUAL "CCPP-FV3") diff --git a/src/ccpp.F90 b/src/ccpp.F90 deleted file mode 100644 index 6bef125a..00000000 --- a/src/ccpp.F90 +++ /dev/null @@ -1,180 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief The CCPP library main entry and exit points. -!! -! -module ccpp - -#ifdef STATIC - use :: ccpp_types, & - only: ccpp_t -#else - use, intrinsic :: iso_c_binding, & - only: c_ptr - use :: ccpp_types, & - only: ccpp_t, ccpp_suite_t - use :: ccpp_suite, & - only: ccpp_suite_init, ccpp_suite_finalize - use :: ccpp_fields, & - only: ccpp_fields_init, ccpp_fields_finalize -#endif - use :: ccpp_errors, & - only: ccpp_error, ccpp_debug - - implicit none - - private - - public :: ccpp_init, & - ccpp_finalize, & - ccpp_initialized - - contains - - !> - !! CCPP initialization subroutine. - !! - !! @param[in] suitename The suite name to use/load - !! @param[in,out] cdata The ccpp_t type data. - !! @param[ out] ierr Integer error flag. - !! @param[in] cdata_target An optional cdata instance to cope the suite from - !! @param[in] is_filename Switch to interpret suitename as filename/filepath - !! (for dynamic build only, default value .false.) - ! - subroutine ccpp_init(suitename, cdata, ierr, cdata_target, is_filename) - character(len=*), intent(in) :: suitename - type(ccpp_t), target, intent(inout) :: cdata - integer, intent( out) :: ierr - type(ccpp_t), target, intent(in), optional :: cdata_target - logical, intent(in), optional :: is_filename - ! Local variables - logical :: is_filename_local - character(len=256) :: filename_local - - ierr = 0 - - call ccpp_debug('Called ccpp_init') - -#ifndef STATIC - if (present(is_filename)) then - is_filename_local = is_filename - else - is_filename_local = .false. - end if - - if (is_filename_local) then - if (len(trim(suitename))>len(filename_local)) then - call ccpp_error('Length of suitename=filename exceeds length of local filename variable') - ierr = 1 - return - end if - filename_local = trim(suitename) - else - if (len('./suite_' // trim(suitename) // '.xml')>len(filename_local)) then - call ccpp_error('Length of suitename + 12 exceeds length of local filename variable') - ierr = 1 - return - end if - filename_local = './suite_' // trim(suitename) // '.xml' - end if - - if (present(cdata_target)) then - ! Copy the suite from the target cdata instance - cdata%suite => cdata_target%suite - cdata%suite_iscopy = .True. - else - ! Initialize the suite from the file - cdata%suite => cdata%suite_target - cdata%suite_iscopy = .False. - call ccpp_suite_init(filename_local, cdata%suite, ierr) - if (ierr /= 0) then - call ccpp_error('In initializing the CCPP suite') - return - end if - end if - - ! Initialize the fields - call ccpp_fields_init(cdata, ierr) - if (ierr /= 0) then - call ccpp_error('In initializing the CCPP fields') - return - end if -#endif - - ! Set flag indicating initialization state of cdata - cdata%initialized = .true. - - end subroutine ccpp_init - - !> - !! CCPP finalization subroutine. - !! - !! @param[in,out] cdata The ccpp_t type data. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_finalize(cdata, ierr) - type(ccpp_t), target, intent(inout) :: cdata - integer, intent( out) :: ierr - - ierr = 0 - - call ccpp_debug('Called ccpp_finalize') - -#ifndef STATIC - if (cdata%suite_iscopy) then - nullify(cdata%suite) - cdata%suite_iscopy = .False. - return - end if - - ! Finalize the suite - call ccpp_suite_finalize(cdata%suite, ierr) - if (ierr /= 0) then - call ccpp_error('In finalizing the CCPP suite') - return - end if - - ! Finalize the fields - call ccpp_fields_finalize(cdata, ierr) - if (ierr /= 0) then - call ccpp_error('In finalizing the CCPP fields') - return - end if - - nullify(cdata%suite) -#endif - - ! Set flag indicating initialization state of cdata - cdata%initialized = .false. - - end subroutine ccpp_finalize - - !> - !! CCPP test initialization routine - !! - !! @param[in] cdata The ccpp_t type data - !! @return initialized .true. or .false. - ! - function ccpp_initialized(cdata) result(initialized) - type(ccpp_t), target, intent(in) :: cdata - logical :: initialized - - call ccpp_debug('Called ccpp_initialized') - - initialized = cdata%initialized - - end function ccpp_initialized - -end module ccpp diff --git a/src/ccpp_api.F90 b/src/ccpp_api.F90 index 9fafddc7..bbaa2fd5 100644 --- a/src/ccpp_api.F90 +++ b/src/ccpp_api.F90 @@ -18,35 +18,10 @@ ! module ccpp_api - use ccpp_types, only: CCPP_STR_LEN, & - ccpp_t - use ccpp_errors, only: ccpp_error, & - ccpp_debug - use ccpp, only: ccpp_init, & - ccpp_finalize, & - ccpp_initialized -#ifndef STATIC - use ccpp_fcall, only: ccpp_physics_init, & - ccpp_physics_run, & - ccpp_physics_finalize - use ccpp_fields, only: ccpp_field_add, & - ccpp_field_get -#endif + use ccpp_types, only: ccpp_t implicit none - public :: CCPP_STR_LEN, & - ccpp_t, & - ccpp_error, & - ccpp_debug, & - ccpp_init, & - ccpp_finalize -#ifndef STATIC - public :: ccpp_physics_init, & - ccpp_physics_run, & - ccpp_physics_finalize, & - ccpp_field_add, & - ccpp_initialized -#endif + public :: ccpp_t end module ccpp_api diff --git a/src/ccpp_dl.F90 b/src/ccpp_dl.F90 deleted file mode 100644 index a81f7bae..00000000 --- a/src/ccpp_dl.F90 +++ /dev/null @@ -1,53 +0,0 @@ -!> -!! @brief The function pointer module. -!! -!! @details The routines for calling the specified functions. -!! This module contains no subroutines or functions it -!! only provies an interface to the C counterparts. -! -module ccpp_dl - - use, intrinsic :: iso_c_binding, & - only: c_int32_t, c_char, c_ptr - - implicit none - - private - public :: ccpp_dl_open, & - ccpp_dl_close, & - ccpp_dl_call - - interface - integer(c_int32_t) & - function ccpp_dl_open & - (name, library, version, fhdl, lhdl) & - bind(c, name='ccpp_dl_open') - import :: c_char, c_int32_t, c_ptr - character(kind=c_char), dimension(*) :: name - character(kind=c_char), dimension(*) :: library - character(kind=c_char), dimension(*) :: version - type(c_ptr) :: fhdl - type(c_ptr) :: lhdl - end function ccpp_dl_open - - integer(c_int32_t) & - function ccpp_dl_close & - (lhdl) & - bind(c, name='ccpp_dl_close') - import :: c_int32_t, c_ptr - type(c_ptr) :: lhdl - end function ccpp_dl_close - - integer(c_int32_t) & - function ccpp_dl_call & - (shdl, cdata) & - bind(c, name='ccpp_dl_call') - import :: c_int32_t, c_ptr - type(c_ptr) :: shdl - type(c_ptr) :: cdata - end function ccpp_dl_call - end interface - - contains - -end module ccpp_dl diff --git a/src/ccpp_dl.c b/src/ccpp_dl.c deleted file mode 100644 index f670d41a..00000000 --- a/src/ccpp_dl.c +++ /dev/null @@ -1,181 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * @file ccpp_dl.c - * - * Routines for the function/subroutine calls using dynamic loaded shared - * objects. - * - * @ingroup CCPP - * @{ - **/ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#include "ccpp_dl.h" - -/** Shared library prefix and suffix for different platforms **/ -static const char prefix[] = "lib"; -#if __APPLE__ -static const char suffix[] = ".dylib"; -#elif __unix__ -static const char suffix[] = ".so"; -#endif - -/** - * Function call initialization routine. - * - * This dlopen()'s the library specified and tries to - * obtain a handle to the function/scheme cap. - * - * @param[in] scheme The scheme name to call. - * @param[in] lib The library continaing the physics scheme. - * @param[in] ver The library version number. - * @param[out] fhdl The scheme function pointer handle. - * @param[out] lhdl The library handle. - * @retval 0 If it was sucessful - * @retval 1 If there was an error - **/ -int -ccpp_dl_open(const char *scheme, const char *lib, const char *ver, - void **fhdl, void **lhdl) -{ - int i = 0; - int n = 0; - const char cap[] = "_cap"; - const char *l = NULL; - char *library = NULL; - char *scheme_cap = NULL; - char *error = NULL; - struct stat sbuf = {0}; - - /* Did we get an actual library file? */ - if (stat(lib, &sbuf) == 0) { - l = lib; - } else { - /* Generate the library name with the platform suffix */ - n = (strlen(prefix) + strlen(lib) + strlen(suffix) - + strlen(ver) +2) *sizeof(char); - library = malloc(n); - memset(library, 0, n); - if (strcmp(ver, "") != 0) { -#ifdef __APPLE__ - snprintf(library, n, "%s%s.%s%s", prefix, lib, - ver, suffix); -#elif defined(__linux__) || defined(__unix__) - snprintf(library, n, "%s%s%s.%s", prefix, lib, - suffix, ver); -#else - warnx("CCPP library name not configured for this operating system"); - return(EXIT_FAILURE); -#endif - } else { - snprintf(library, n, "%s%s%s", prefix, lib, suffix); - } - l = library; - } - - /* Generate the scheme cap function name */ - n = (strlen(scheme) +strlen(cap) +1)*sizeof(char); - scheme_cap = malloc(n); - memset(scheme_cap, 0, n); - - n = strlen(scheme); - for (i=0; i < n; ++i) { - scheme_cap[i] = tolower(scheme[i]); - } - - strncat(scheme_cap, cap, n); - - /* Open a handle to the library */ - *lhdl = dlopen(l, RTLD_NOW); - if (!*lhdl) { - warnx("%s", dlerror()); - return(EXIT_FAILURE); - } - - dlerror(); - *(void **)fhdl = dlsym(*lhdl, scheme_cap); - if ((error = dlerror()) != NULL) { - warnx("%s", error); - return(EXIT_FAILURE); - } - - /* Free the library filename */ - if (library) { - free(library); - library = NULL; - } - - /* Free the scheme cap function name */ - if (scheme_cap) { - free(scheme_cap); - scheme_cap = NULL; - } - - return(EXIT_SUCCESS); -} - -/** - * Function call library closing routine. - * - * @param[in] lhdl The library handle. - * @retval 0 If it was sucessful - * @retval 1 If there was an error - **/ -int -ccpp_dl_close(void **lhdl) -{ - char *error = NULL; - - dlerror(); - dlclose(*lhdl); - if ((error = dlerror()) != NULL) { - warnx("%s", error); - return(EXIT_FAILURE); - } - - return(EXIT_SUCCESS); -} - -/** - * The function cap calling routine. - * - * @param[in] f_ptr The scheme function pointer to call. - * @param[in] data The opaque ccpp_t data type to pass. - * @retval 0 If it was sucessful - * @retval !=0 If there was an error - **/ -int -ccpp_dl_call(void **f_ptr, void **data) -{ - int (*fun)(void **) = NULL; - - *(int **)(&fun) = *f_ptr; - - return(fun(data)); -} - -/** - * @} - **/ diff --git a/src/ccpp_dl.h b/src/ccpp_dl.h deleted file mode 100644 index 0657188c..00000000 --- a/src/ccpp_dl.h +++ /dev/null @@ -1,34 +0,0 @@ -/** - * @file ccpp_dl.h - * - * The function pointer routines using dynamic loaded shared objects. - * - * @ingroup CCPP - * @{ - **/ -#ifndef CCPP_DL_H -#define CCPP_DL_H - -#ifdef __cplusplus -extern "C" -{ -#endif - -/** Function libaray and cap function initialization routine. **/ -int ccpp_dl_open(const char *, const char *, const char *, void **, void **); - -/** Function library closing/unloading routine. **/ -int ccpp_dl_close(void **); - -/** Function pointer physics cap function call. **/ -int ccpp_dl_call(void **, void **); - -#ifdef __cplusplus -} /* extern "C" */ -#endif - -#endif /* CCPP_DL_H */ - -/** - * @} - **/ diff --git a/src/ccpp_errors.F90 b/src/ccpp_errors.F90 deleted file mode 100644 index 9a3fee02..00000000 --- a/src/ccpp_errors.F90 +++ /dev/null @@ -1,128 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief Error/Warning reporting module. -!! -!! @details Subroutines for reporting warnings. -! -module ccpp_errors - - use, intrinsic :: iso_fortran_env, & - only: error_unit, output_unit - - implicit none - - private - public :: ccpp_error, & - ccpp_warn, & - ccpp_info, & - ccpp_debug, & - ccpp_if_error, & - ccpp_if_warn - - contains - - !> - !! Fatal error reporting. - !! - !! Write an error message to error_unit/stderr. - !! - !! @param[in] message The error message to write. - ! - subroutine ccpp_error(message) - character(len=*), intent(in) :: message - - write(error_unit, *) 'ERROR: ', trim(message) - end subroutine ccpp_error - - !> - !! Non-fatal warning reporting. - !! - !! Write an warning message to error_unit/stderr. - !! - !! @param[in] message The warning message to write. - ! - subroutine ccpp_warn(message) - character(len=*), intent(in) :: message - - write(error_unit, *) 'WARN: ', trim(message) - end subroutine ccpp_warn - - !> - !! Reporting on info level - !! - !! Write an info message to output_unit/stdout. - !! - !! @param[in] message The info message to write. - ! - subroutine ccpp_info(message) - character(len=*), intent(in) :: message - - write(output_unit, *) 'INFO: ', trim(message) - end subroutine ccpp_info - - !> - !! Reporting on debug level - !! - !! Write a debug message to output_unit/stdout. - !! - !! @param[in] message The debug message to write. - ! - subroutine ccpp_debug(message) - character(len=*), intent(in) :: message - -#ifdef DEBUG - write(output_unit, *) 'DEBUG: ', trim(message) -#endif - end subroutine ccpp_debug - - !> - !! Fatal error checking and reporting. - !! - !! Check to see if ierr is non-zero. If it is - !! write an error message to error_unit/stderr. - !! - !! @param[in] ierr The exit code. - !! @param[in] message The error message to write. - ! - subroutine ccpp_if_error(ierr, message) - integer, intent(in) :: ierr - character(len=*), intent(in) :: message - - if (ierr /= 0) then - write(error_unit, *) 'ERROR: ', trim(message) - end if - - end subroutine ccpp_if_error - - !> - !! Non-fatal warning checking and reporting. - !! - !! Check to see if ierr is non-zero. If it is - !! write an warning message to error_unit/stderr. - !! - !! @param[in] ierr The exit code. - !! @param[in] message The warning message to write. - ! - subroutine ccpp_if_warn(ierr, message) - integer, intent(in) :: ierr - character(len=*), intent(in) :: message - - if (ierr /= 0) then - write(error_unit, *) 'WARN: ', trim(message) - end if - - end subroutine ccpp_if_warn - -end module ccpp_errors diff --git a/src/ccpp_fcall.F90 b/src/ccpp_fcall.F90 deleted file mode 100644 index 62c5318f..00000000 --- a/src/ccpp_fcall.F90 +++ /dev/null @@ -1,472 +0,0 @@ -!> -!! @brief The CCPP function call module. -!! -!! @details The CCPP routines for calling the specified -!! physics group/subcyce/scheme. -! -module ccpp_fcall - - use, intrinsic :: iso_c_binding, & - only: c_int32_t, c_char, c_ptr, c_loc, c_funptr - use :: ccpp_types, & - only: ccpp_t, ccpp_suite_t, ccpp_group_t, & - ccpp_subcycle_t, ccpp_scheme_t, & - CCPP_STAGES, CCPP_DEFAULT_STAGE, & - CCPP_DEFAULT_LOOP_CNT - use :: ccpp_errors, & - only: ccpp_error, ccpp_debug - use :: ccpp_strings, & - only: ccpp_cstr - use :: ccpp_dl, & - only: ccpp_dl_call - - implicit none - - private - public :: ccpp_physics_init, ccpp_physics_run, ccpp_physics_finalize - - contains - - !! - !! Public CCPP physics init/run/finalize routines - !! - - !> - !! Single entry point for initializing ccpp physics. - !! - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_physics_init(cdata, group_name, scheme_name, ierr) - - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), optional, intent(in) :: group_name - character(len=*), optional, intent(in) :: scheme_name - integer, intent(out) :: ierr - - ! Local variables - type(ccpp_group_t) , pointer :: group - type(ccpp_scheme_t), pointer :: scheme - - ierr = 0 - call ccpp_debug('Called ccpp_physics_init') - - if (present(group_name) .and. present(scheme_name)) then - call ccpp_error('Logic error in ccpp_physics_init: group_name and scheme_name are mutually exclusive') - ierr = 1 - return - end if - - if (present(group_name)) then - ! Find the group to initialize from the suite - group => ccpp_find_group(cdata%suite, group_name, ierr=ierr) - if (ierr/=0) return - call ccpp_run_group(group, cdata, stage='init', ierr=ierr) - else if (present(scheme_name)) then - ! Find the scheme to initialize from the suite - scheme => ccpp_find_scheme(cdata%suite, scheme_name, ierr=ierr) - if (ierr/=0) return - call ccpp_run_scheme(scheme, cdata, stage='init', ierr=ierr) - else - ! Run the suite init scheme before the individual init schemes - if (allocated(cdata%suite%init%name)) then - scheme => cdata%suite%init - call ccpp_run_scheme(scheme, cdata, stage='init', ierr=ierr) - end if - ! Initialize all schemes - call ccpp_run_suite(cdata%suite, cdata, stage='init', ierr=ierr) - end if - - end subroutine ccpp_physics_init - - !> - !! Single entry point for running ccpp physics. - !! Optional arguments specify whether to run one - !! group or an individual scheme of the suite. - !! If no optional arguments are provided, the - !! entire suite attached to cdata is run. - !! group and scheme are mutually exclusive. - !! - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[in ] group The group of physics to run (optional) - !! @param[in ] scheme The name of a single scheme to run (optional) - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_physics_run(cdata, group_name, scheme_name, ierr) - - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), optional, intent(in) :: group_name - character(len=*), optional, intent(in) :: scheme_name - integer, intent(out) :: ierr - - ! Local variables - type(ccpp_suite_t) , pointer :: suite - type(ccpp_group_t) , pointer :: group - type(ccpp_scheme_t) , pointer :: scheme - - ierr = 0 - call ccpp_debug('Called ccpp_physics_run') - - ! Consistency checks - if (present(group_name) .and. present(scheme_name)) then - call ccpp_error('Logic error in ccpp_physics_run: group_name and scheme_name are mutually exclusive') - ierr = 1 - return - end if - - suite => cdata%suite - - if (present(group_name)) then - ! Find the group to run from the suite - group => ccpp_find_group(suite, group_name, ierr=ierr) - if (ierr/=0) return - call ccpp_run_group(group, cdata, ierr=ierr) - else if (present(scheme_name)) then - ! Find the scheme to run from the suite - scheme => ccpp_find_scheme(suite, scheme_name, ierr=ierr) - if (ierr/=0) return - call ccpp_run_scheme(scheme, cdata, ierr=ierr) - else - ! If none of the optional arguments is present, run the entire suite - call ccpp_run_suite(suite, cdata, ierr=ierr) - end if - - end subroutine ccpp_physics_run - - !> - !! Single entry point for finalizing ccpp physics. - !! - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_physics_finalize(cdata, group_name, scheme_name, ierr) - - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), optional, intent(in) :: group_name - character(len=*), optional, intent(in) :: scheme_name - integer, intent(out) :: ierr - - ! Local variables - type(ccpp_group_t) , pointer :: group - type(ccpp_scheme_t), pointer :: scheme - - ierr = 0 - call ccpp_debug('Called ccpp_physics_finalize') - - if (present(group_name) .and. present(scheme_name)) then - call ccpp_error('Logic error in ccpp_physics_finalize: group_name and scheme_name are mutually exclusive') - ierr = 1 - return - end if - - if (present(group_name)) then - ! Find the group to finalize from the suite - group => ccpp_find_group(cdata%suite, group_name, ierr=ierr) - if (ierr/=0) return - call ccpp_run_group(group, cdata, stage='finalize', ierr=ierr) - else if (present(scheme_name)) then - ! Find the scheme to finalize from the suite - scheme => ccpp_find_scheme(cdata%suite, scheme_name, ierr=ierr) - if (ierr/=0) return - call ccpp_run_scheme(scheme, cdata, stage='finalize', ierr=ierr) - else - ! Finalize all schemes - call ccpp_run_suite(cdata%suite, cdata, stage='finalize', ierr=ierr) - ! Run the suite finalize scheme after the individual finalize schemes - if (allocated(cdata%suite%finalize%name)) then - scheme => cdata%suite%finalize - call ccpp_run_scheme(scheme, cdata, stage='finalize', ierr=ierr) - end if - end if - - end subroutine ccpp_physics_finalize - - !! - !! Private/internal routines for running suites, groups, subcycles and schemes *DH - !! - - !> - !! The run subroutine for a suite. This will call - !! the all groups within a suite. - !! - !! @param[in ] suite The suite to run - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[in ] stage The stage for which to run the suite - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_run_suite(suite, cdata, stage, ierr) - - type(ccpp_suite_t), intent(inout) :: suite - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), intent(in), optional :: stage - integer, intent( out) :: ierr - - integer :: i - - ierr = 0 - - call ccpp_debug('Called ccpp_run_suite for stage ' // trim(stage)) - - do i=1,suite%groups_max - call ccpp_run_group(suite%groups(i), cdata, stage=stage, ierr=ierr) - if (ierr /= 0) then - return - end if - end do - - end subroutine ccpp_run_suite - - !> - !! The find subroutine for a group. This will return - !! the group that matches group_name and ierr=0, - !! or ierr=1 if no such group is found. - !! - !! @param[in ] suite The suite in which to find the group - !! @param[in ] group_name The name of the group to run - !! @param[ out] ierr Integer error flag - ! - function ccpp_find_group(suite, group_name, ierr) result(group) - - type(ccpp_suite_t), target, intent(in ) :: suite - character(len=*), intent(in ) :: group_name - integer, intent( out) :: ierr - type(ccpp_group_t), pointer :: group - - integer :: i - - call ccpp_debug('Called ccpp_find_group') - - ierr = 0 - do i=1, suite%groups_max - if (trim(suite%groups(i)%name) .eq. trim(group_name)) then - call ccpp_debug('Group ' // trim(group_name) // ' found in suite') - group => suite%groups(i) - return - end if - end do - - call ccpp_error('Group ' // trim(group_name) // ' not found in suite') - ierr = 1 - - end function ccpp_find_group - - !> - !! The run subroutine for a group. This will call - !! the all subcycles within a group. - !! - !! @param[in ] group The group to run - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[in ] stage The stage for which to run the group - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_run_group(group, cdata, stage, ierr) - - type(ccpp_group_t), intent(inout) :: group - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), intent(in), optional :: stage - integer, intent( out) :: ierr - - integer :: i - - ierr = 0 - - call ccpp_debug('Called ccpp_run_group for stage ' // trim(stage)) - - do i=1,group%subcycles_max - call ccpp_run_subcycle(group%subcycles(i), cdata, stage=stage, ierr=ierr) - if (ierr /= 0) then - return - end if - end do - - end subroutine ccpp_run_group - - !> - !! The run subroutine for a subcycle. This will call - !! the all schemes within a subcycle. It will also - !! loop if the loop attribut is greater than 1. - !! - !! @param[in ] subcycle The subcycle to run - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[in ] stage The stage for which to run the subcycle - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_run_subcycle(subcycle, cdata, stage, ierr) - - type(ccpp_subcycle_t), intent(inout) :: subcycle - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), intent(in), optional :: stage - integer, intent( out) :: ierr - - integer :: j - - ierr = 0 - - call ccpp_debug('Called ccpp_run_subcycle for stage ' // trim(stage)) - - associate(i=>cdata%loop_cnt) - do i=1,subcycle%loops_max - do j=1,subcycle%schemes_max - call ccpp_run_scheme(subcycle%schemes(j), cdata, stage=stage, ierr=ierr) - if (ierr /= 0) then - return - end if - end do - end do - end associate - - cdata%loop_cnt = CCPP_DEFAULT_LOOP_CNT - - end subroutine ccpp_run_subcycle - - !> - !! The find subroutine for a scheme. This will return - !! the scheme that matches scheme_name and ierr==0, - !! or ierr==1 if no such scheme is found. - !! - !! @param[in ] suite The suite in which to find the scheme - !! @param[in ] scheme_name The name of the scheme to run - !! @param[ out] ierr Integer error flag - ! - function ccpp_find_scheme(suite, scheme_name, ierr) result(scheme) - - type(ccpp_suite_t), target, intent(in ) :: suite - character(len=*), intent(in ) :: scheme_name - integer, intent( out) :: ierr - type(ccpp_scheme_t), pointer :: scheme - - integer :: i, j, k - - call ccpp_debug('Called ccpp_find_scheme') - - ierr = 0 - do i=1, suite%groups_max - do j=1, suite%groups(i)%subcycles_max - do k=1, suite%groups(i)%subcycles(j)%schemes_max - if (trim(suite%groups(i)%subcycles(j)%schemes(k)%name) .eq. trim(scheme_name)) then - call ccpp_debug('Scheme ' // trim(scheme_name) // ' found in suite') - scheme => suite%groups(i)%subcycles(j)%schemes(k) - return - end if - end do - end do - end do - - call ccpp_error('Scheme ' // trim(scheme_name) // ' not found in suite') - ierr = 1 - - end function ccpp_find_scheme - - !> - !! The run subroutine for a scheme. This will call - !! the single scheme specified. - !! - !! @param[in ] scheme The scheme to run - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[in ] stage The stage for which to run the scheme - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_run_scheme(scheme, cdata, stage, ierr) - - type(ccpp_scheme_t), intent(inout) :: scheme - type(ccpp_t), target, intent(inout) :: cdata - character(len=*), intent(in), optional :: stage - integer, intent( out) :: ierr - - character(:), allocatable :: stage_local - character(:), allocatable :: function_name - integer :: l - - ierr = 0 - - if (present(stage)) then - stage_local = trim(stage) - else - stage_local = trim(CCPP_DEFAULT_STAGE) - end if - - call ccpp_debug('Called ccpp_run_scheme for ' // trim(scheme%name) & - //' in stage ' // trim(stage_local)) - - if (trim(stage_local) == 'init' .and. scheme%initialized) then - call ccpp_debug('Scheme ' // trim(scheme%name) // ' already initialized, skip.') - return - else if (trim(stage_local) == 'finalize' .and. .not.scheme%initialized) then - call ccpp_debug('Scheme ' // trim(scheme%name) // ' not initialized, skip.') - return - ! Check for default run stage that scheme is initialized - else if (trim(stage_local) == trim(CCPP_DEFAULT_STAGE) .and. .not.scheme%initialized) then - call ccpp_error('Error in ccpp_run_scheme, stage ' // trim(stage_local) // & - ': ' // trim(scheme%name) // ' not initialized.') - ierr = 1 - return - end if - - function_name = trim(scheme%get_function_name(stage_local)) - - do l=1,scheme%functions_max - associate (f=>scheme%functions(l)) - if (trim(function_name) == trim(f%name)) then - ierr = ccpp_dl_call(f%function_hdl, c_loc(cdata)) - if (ierr /= 0) then - call ccpp_error('A problem occured calling '// trim(f%name) & - //' of scheme ' // trim(scheme%name) & - //' in stage ' // trim(stage_local)) - else if (trim(stage_local) == 'init') then - scheme%initialized = .true. - else if (trim(stage_local) == 'finalize') then - scheme%initialized = .false. - end if - ! Return after calling the scheme, with or without error - return - end if - end associate - end do - - ! If we reach this point, the required function was not found - ierr = 1 - do l=1,size(CCPP_STAGES) - if (trim(stage_local) == trim(CCPP_STAGES(l))) then - ! Stage is valid --> problem with the scheme - call ccpp_error('Function ' // trim(function_name) & - //' of scheme ' // trim(scheme%name) & - //' for stage ' // trim(stage_local) & - //' not found in suite') - return - end if - end do - ! Stage is invalid - call ccpp_error('Invalid stage ' // trim(stage_local) & - //' requested in ccpp_run_scheme') - - end subroutine ccpp_run_scheme - -#if 0 - ! DH 20180504 - keep for future use - !> - !! The run subroutine for a function pointer. This - !! will call the single function specified. - !! - !! @param[in ] scheme The scheme to run - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_run_fptr(fptr, cdata, ierr) - - type(c_ptr), intent(in ) :: fptr - type(ccpp_t), target, intent(inout) :: cdata - integer, intent( out) :: ierr - - ierr = 0 - - call ccpp_debug('Called ccpp_run_fptr') - - ierr = ccpp_dl_call(fptr, c_loc(cdata)) - if (ierr /= 0) then - call ccpp_error('A problem occured calling function pointer') - end if - - end subroutine ccpp_run_fptr -#endif - -end module ccpp_fcall diff --git a/src/ccpp_fields.F90 b/src/ccpp_fields.F90 deleted file mode 100644 index 76f12663..00000000 --- a/src/ccpp_fields.F90 +++ /dev/null @@ -1,2151 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief Physics fields module. -!! -!! Routines and functions to interact with physics fields. -!! Most of the work is carried out in C (ccpp_field_idx.c). -!! The IPD contains an array of C pointers to all the -!! fields passed around. This array needs an index so -!! one can field the requested field. -!! -!! Example usage in the atmosphere driver cap. -!! @code{.f90} -!! -!! ! Add a field, for example the eastward_wind. -!! call ccpp_field_add(ipd_data, 'eastward_wind', & -!! u, ierr, 'm s-1') -!! if (ierr /= 0) then -!! call exit(ierr) -!! end if -!! -!! @endcode -!! -!! Example usage in a physics scheme cap. -!! @code{.f90} -!! -!! ! Extract a field, for example the eastward_wind. -!! call ccpp_field_get(ipd_data, 'eastward_wind', u, ierr) -!! if (ierr /= 0) then -!! call exit(ierr) -!! end if -!! -!! @endcode -! -module ccpp_fields - - use, intrinsic :: iso_fortran_env, & - only: INT8, INT16, INT32, INT64, & - REAL32, REAL64, REAL128 - use, intrinsic :: iso_c_binding, & - only: c_f_pointer, c_loc, c_ptr, c_int32_t, c_char - use :: ccpp_types, & - only: ccpp_t, ccpp_field_t, CCPP_GENERIC_KIND - use :: ccpp_strings, & - only: ccpp_cstr - use :: ccpp_errors, & - only: ccpp_debug, ccpp_info, ccpp_warn, ccpp_error - - implicit none - - private - public :: ccpp_fields_init, & - ccpp_fields_finalize, & - ccpp_fields_find, & - ccpp_field_add, & - ccpp_field_get - - ! DH* TODO can use new Fortran syntax? - ! type(*), dimension(..), intent(in) :: a - ! for arrays of any type, any rank? *DH - - !> - !! Module precedence for adding a field. - ! - interface ccpp_field_add - module procedure & - ccpp_field_add_i32_0, & - ccpp_field_add_i32_1, & - ccpp_field_add_i32_2, & - ccpp_field_add_i32_3, & - ccpp_field_add_i32_4, & - ccpp_field_add_i32_5, & - ccpp_field_add_i32_6, & - ccpp_field_add_i32_7, & - - ccpp_field_add_i64_0, & - ccpp_field_add_i64_1, & - ccpp_field_add_i64_2, & - ccpp_field_add_i64_3, & - ccpp_field_add_i64_4, & - ccpp_field_add_i64_5, & - ccpp_field_add_i64_6, & - ccpp_field_add_i64_7, & - - ccpp_field_add_r32_0, & - ccpp_field_add_r32_1, & - ccpp_field_add_r32_2, & - ccpp_field_add_r32_3, & - ccpp_field_add_r32_4, & - ccpp_field_add_r32_5, & - ccpp_field_add_r32_6, & - ccpp_field_add_r32_7, & - - ccpp_field_add_r64_0, & - ccpp_field_add_r64_1, & - ccpp_field_add_r64_2, & - ccpp_field_add_r64_3, & - ccpp_field_add_r64_4, & - ccpp_field_add_r64_5, & - ccpp_field_add_r64_6, & - ccpp_field_add_r64_7, & - - ccpp_field_add_l_0, & - ccpp_field_add_l_1, & - ccpp_field_add_l_2, & - ccpp_field_add_l_3, & - ccpp_field_add_l_4, & - ccpp_field_add_l_5, & - ccpp_field_add_l_6, & - ccpp_field_add_l_7, & - - ccpp_field_add_c_0, & - ccpp_field_add_c_1, & - - ccpp_field_add_ptr - end interface ccpp_field_add - - !> - !! Module precedence for getting a field. - ! - interface ccpp_field_get - module procedure & - ccpp_field_get_i32_0, & - ccpp_field_get_i32_1, & - ccpp_field_get_i32_2, & - ccpp_field_get_i32_3, & - ccpp_field_get_i32_4, & - ccpp_field_get_i32_5, & - ccpp_field_get_i32_6, & - ccpp_field_get_i32_7, & - - ccpp_field_get_i64_0, & - ccpp_field_get_i64_1, & - ccpp_field_get_i64_2, & - ccpp_field_get_i64_3, & - ccpp_field_get_i64_4, & - ccpp_field_get_i64_5, & - ccpp_field_get_i64_6, & - ccpp_field_get_i64_7, & - - ccpp_field_get_r32_0, & - ccpp_field_get_r32_1, & - ccpp_field_get_r32_2, & - ccpp_field_get_r32_3, & - ccpp_field_get_r32_4, & - ccpp_field_get_r32_5, & - ccpp_field_get_r32_6, & - ccpp_field_get_r32_7, & - - ccpp_field_get_r64_0, & - ccpp_field_get_r64_1, & - ccpp_field_get_r64_2, & - ccpp_field_get_r64_3, & - ccpp_field_get_r64_4, & - ccpp_field_get_r64_5, & - ccpp_field_get_r64_6, & - ccpp_field_get_r64_7, & - - ccpp_field_get_l_0, & - ccpp_field_get_l_1, & - ccpp_field_get_l_2, & - ccpp_field_get_l_3, & - ccpp_field_get_l_4, & - ccpp_field_get_l_5, & - ccpp_field_get_l_6, & - ccpp_field_get_l_7, & - - ccpp_field_get_c_0, & - ccpp_field_get_c_1, & - - ccpp_field_get_ptr - end interface ccpp_field_get - - !> - !! Interface to all the C field index functions. - ! - interface - integer(c_int32_t) & - function ccpp_field_idx_init & - (idx) & - bind(c, name='ccpp_field_idx_init') - import :: c_int32_t, c_ptr - type(c_ptr) :: idx - end function ccpp_field_idx_init - - integer(c_int32_t) & - function ccpp_field_idx_finalize & - (idx) & - bind(c, name='ccpp_field_idx_finalize') - import :: c_int32_t, c_ptr - type(c_ptr) :: idx - end function ccpp_field_idx_finalize - - integer(c_int32_t) & - function ccpp_field_idx_add & - (name, idx) & - bind(c, name='ccpp_field_idx_add') - import :: c_int32_t, c_char, c_ptr - character(kind=c_char), dimension(*) :: name - type(c_ptr) :: idx - end function ccpp_field_idx_add - - integer(c_int32_t) & - function ccpp_field_idx_find & - (name, idx) & - bind(c, name='ccpp_field_idx_find') - import :: c_char, c_int32_t, c_ptr - character(kind=c_char), dimension(*) :: name - type(c_ptr) :: idx - end function ccpp_field_idx_find - - integer(c_int32_t) & - function ccpp_field_idx_max & - (idx) & - bind(c, name='ccpp_field_idx_max') - import :: c_int32_t, c_ptr - type(c_ptr) :: idx - end function ccpp_field_idx_max - - end interface - - contains - - !> - !! CCPP fields initialization subroutine. - !! - !! @param[in,out] cdata The ccpp_t type data. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_fields_init(cdata, ierr) - type(ccpp_t), target, intent(inout) :: cdata - integer, intent( out) :: ierr - - integer :: fields_max - - ierr = 0 - - ierr = ccpp_field_idx_init(cdata%fields_idx) - if (ierr /= 0) then - call ccpp_warn('Unable to initalize cdata field index') - return - end if - - fields_max = ccpp_field_idx_max(cdata%fields_idx) - - allocate(cdata%fields(fields_max), stat=ierr) - if (ierr /= 0) then - call ccpp_warn('Unable to allocate cdata fields') - return - end if - - ! Add CCPP-internal fields to data structure, harcoded - - end subroutine ccpp_fields_init - - !> - !! CCPP fields finalization subroutine. - !! - !! @param[in,out] cdata The ccpp_t type data. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_fields_finalize(cdata, ierr) - type(ccpp_t), intent(inout) :: cdata - integer, intent( out) :: ierr - - ierr = 0 - - if (allocated(cdata%fields)) then - deallocate(cdata%fields) - end if - - ierr = ccpp_field_idx_finalize(cdata%fields_idx) - if (ierr /= 0) then - call ccpp_warn('Unable to clean up cdata field index') - return - end if - - end subroutine ccpp_fields_finalize - - !> - !! CCPP fields addition subroutine. - !! - !! @param[in,out] cdata The ccpp_t type data. - !! @param[in ] standard_name The standard name for the data. - !! @param[in ] units The SI units for the data. - !! @param[in ] ptr A C pointer to the data. - !! @param[in ] rank Optional rank of the data. - !! @param[in ] dims Optional dimensions of the data. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_field_add_ptr(cdata, standard_name, units, ptr, & - rank, dims, kind, index, ierr) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - character(len=*), intent(in) :: units - type(c_ptr), intent(in) :: ptr - integer, optional, intent(in) :: rank - integer, dimension(:), optional, intent(in) :: dims - integer, optional, intent(in) :: kind - integer, optional, intent(in) :: index - integer, optional, intent( out) :: ierr - - integer :: i - integer :: ierr_local - integer :: old_fields_max - integer :: new_fields_max - type(ccpp_field_t), allocatable, dimension(:) :: tmp - - call ccpp_debug('Called ccpp_field_add_ptr for field ' // trim(standard_name)) - - ierr_local = 0 - - ! Get the current/old fields max - old_fields_max = ccpp_field_idx_max(cdata%fields_idx) - - ! Add ourselves to the index and get our array position - i = ccpp_field_idx_add(ccpp_cstr(standard_name), cdata%fields_idx) - if (i .lt. 1) then - call ccpp_warn('Unable to add field index: '//trim(standard_name)) - return - end if - - ! If optional index is specified, make sure it matches the return value - ! from ccpp_field_idx_add; if not, issue warning but allow to proceed - if (present(index)) then - if (index/=i) then - call ccpp_warn('Supplied index for adding variable ' // trim(standard_name) // & - ' does not match return value from ccpp_field_idx_add') - end if - end if - - ! Get the new fields max - new_fields_max = ccpp_field_idx_max(cdata%fields_idx) - - if (old_fields_max .lt. new_fields_max) then - allocate(tmp(new_fields_max), stat=ierr_local) - if (ierr_local /= 0) then - call ccpp_warn('Unable to grow cdata fields array') - if (present(ierr)) ierr=ierr_local - return - end if - tmp(1:size(cdata%fields)) = cdata%fields - call move_alloc(tmp, cdata%fields) - end if - - cdata%fields(i)%standard_name = standard_name - cdata%fields(i)%units = units - cdata%fields(i)%ptr = ptr - - if (present(rank)) then - cdata%fields(i)%rank = rank - else - cdata%fields(i)%rank = 0 - end if - - if (present(dims)) then - allocate(cdata%fields(i)%dims(rank), stat=ierr_local) - if (ierr_local /= 0) then - call ccpp_warn('Unable to allocate cdata fields dims') - if (present(ierr)) ierr=ierr_local - return - end if - cdata%fields(i)%dims = dims - end if - - if (present(kind)) then - cdata%fields(i)%kind = kind - else - cdata%fields(i)%kind = CCPP_GENERIC_KIND - end if - - if (present(ierr)) ierr=ierr_local - - end subroutine ccpp_field_add_ptr - - !> - !! CCPP fields retrieval subroutine. - !! - !! @param[in,out] cdata The ccpp_t type data. - !! @param[in ] standard_name The standard name for the data. - !! @param[ out] ptr A C pointer to the data. - !! @param[ out] ierr Integer error flag. - !! @param[ out] units Optional the SI units for the data. - !! @param[ out] rank Optional rank of the data. - !! @param[ out] dims Optional dimensions of the data. - ! - subroutine ccpp_field_get_ptr(cdata, standard_name, ptr, ierr, & - units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - type(c_ptr), intent( out) :: ptr - integer, optional, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - integer :: ierr_local - - call ccpp_debug('Called ccpp_field_get_ptr for field ' // trim(standard_name)) - - ierr_local = 0 - - if (present(index)) then - if (index<=size(cdata%fields)) then - if (trim(standard_name)==trim(cdata%fields(index)%standard_name)) then - idx = index - call ccpp_debug('Found requested field ' // trim(standard_name) // ' at supplied index') - else - idx = ccpp_fields_find(cdata, standard_name, ierr_local) - call ccpp_warn('Could not find requested field ' // trim(standard_name) // & - ' at supplied index, falling back to standard search') - end if - else - idx = ccpp_fields_find(cdata, standard_name, ierr_local) - call ccpp_warn('Supplied index for requested field ' // trim(standard_name) // & - ' out of range, falling back to standard search') - end if - else - ! Lookup the standard name in the index - idx = ccpp_fields_find(cdata, standard_name, ierr_local) - call ccpp_info('No index supplied for requested field ' // trim(standard_name) // ', falling back to standard search') - end if - if (ierr_local /= 0) then - call ccpp_warn('Unable to find requested field ' // trim(standard_name)) - if (present(ierr)) ierr=ierr_local - return - end if - - ptr = cdata%fields(idx)%ptr - - if (present(units)) then - units = cdata%fields(idx)%units - end if - - if (present(rank)) then - rank = cdata%fields(idx)%rank - end if - - if (present(dims)) then - if (allocated(dims)) then - deallocate(dims) - end if - allocate(dims(cdata%fields(idx)%rank), stat=ierr_local) - if (ierr_local /= 0) then - call ccpp_warn('Unable to allocate cdata fields dims') - if (present(ierr)) ierr=ierr_local - return - end if - dims = cdata%fields(idx)%dims - end if - - if (present(kind)) then - kind = cdata%fields(idx)%kind - end if - - if (present(ierr)) ierr=ierr_local - - end subroutine ccpp_field_get_ptr - - - !> - !! CCPP find a fields location/array index by standard name. - !! - !! @param[in,out] cdata The ccpp_t type data. - !! @param[in ] standard_name The standard name for the data. - !! @param[ out] ierr Integer error flag. - ! - function ccpp_fields_find(cdata, standard_name, ierr) result(location) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer, intent( out) :: ierr - - integer :: location - - location = ccpp_field_idx_find(ccpp_cstr(standard_name), & - cdata%fields_idx) - if (location <= 0) then - ierr = 1 - end if - - end function ccpp_fields_find - - ! TODO: Subroutine to iterate over all fields. - - - !------------------------------------------------------------------! - !> - !! Single precision (32-bit) integer field addition subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_add_i32_0(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_0 - - subroutine ccpp_field_add_i32_1(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_1 - - subroutine ccpp_field_add_i32_2(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_2 - - subroutine ccpp_field_add_i32_3(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_3 - - subroutine ccpp_field_add_i32_4(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_4 - - subroutine ccpp_field_add_i32_5(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_5 - - subroutine ccpp_field_add_i32_6(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_6 - - subroutine ccpp_field_add_i32_7(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), target, intent(in) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i32_7 - - !------------------------------------------------------------------! - !> - !! Double precision (64-bit) integer field addition subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_add_i64_0(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_0 - - subroutine ccpp_field_add_i64_1(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_1 - - subroutine ccpp_field_add_i64_2(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_2 - - subroutine ccpp_field_add_i64_3(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_3 - - subroutine ccpp_field_add_i64_4(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_4 - - subroutine ccpp_field_add_i64_5(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_5 - - subroutine ccpp_field_add_i64_6(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_6 - - subroutine ccpp_field_add_i64_7(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), target, intent(in) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_i64_7 - - !------------------------------------------------------------------! - !> - !! Single precision (32-bit) real field addition subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_add_r32_0(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_0 - - subroutine ccpp_field_add_r32_1(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_1 - - subroutine ccpp_field_add_r32_2(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_2 - - subroutine ccpp_field_add_r32_3(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_3 - - subroutine ccpp_field_add_r32_4(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_4 - - subroutine ccpp_field_add_r32_5(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_5 - - subroutine ccpp_field_add_r32_6(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_6 - - subroutine ccpp_field_add_r32_7(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), target, intent(in) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r32_7 - - !------------------------------------------------------------------! - !> - !! Double precision (64-bit) real field addition subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_add_r64_0(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_0 - - subroutine ccpp_field_add_r64_1(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_1 - - subroutine ccpp_field_add_r64_2(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_2 - - subroutine ccpp_field_add_r64_3(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_3 - - subroutine ccpp_field_add_r64_4(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_4 - - subroutine ccpp_field_add_r64_5(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_5 - - subroutine ccpp_field_add_r64_6(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_6 - - subroutine ccpp_field_add_r64_7(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), target, intent(in) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_r64_7 - - !------------------------------------------------------------------! - !> - !! Logical field addition subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_add_l_0(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_0 - - subroutine ccpp_field_add_l_1(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_1 - - subroutine ccpp_field_add_l_2(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_2 - - subroutine ccpp_field_add_l_3(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_3 - - subroutine ccpp_field_add_l_4(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_4 - - subroutine ccpp_field_add_l_5(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_5 - - subroutine ccpp_field_add_l_6(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_6 - - subroutine ccpp_field_add_l_7(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - logical, target, intent(in) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_l_7 - - !------------------------------------------------------------------! - !> - !! Character field addition subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_add_c_0(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - character(len=*), target, intent(in) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_c_0 - - subroutine ccpp_field_add_c_1(cdata, standard_name, ptr, ierr, units, index) - type(ccpp_t), intent(inout) :: cdata - character(len=*), intent(in) :: standard_name - character(len=*), target, intent(in) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent(in) :: units - integer, optional, intent(in) :: index - - ierr = 0 - call ccpp_field_add_ptr(cdata, standard_name, units, & - c_loc(ptr), size(shape(ptr)), shape(ptr), kind=kind(ptr), index=index, ierr=ierr) - - end subroutine ccpp_field_add_c_1 - - !------------------------------------------------------------------! - !> - !! Single precision (32-bit) integer field retrieval subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_get_i32_0(cdata, standard_name, ptr, ierr, units, rank, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr) - - end subroutine ccpp_field_get_i32_0 - - subroutine ccpp_field_get_i32_1(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_1 - - subroutine ccpp_field_get_i32_2(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_2 - - subroutine ccpp_field_get_i32_3(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_3 - - subroutine ccpp_field_get_i32_4(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_4 - - subroutine ccpp_field_get_i32_5(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_5 - - subroutine ccpp_field_get_i32_6(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_6 - - subroutine ccpp_field_get_i32_7(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT32), pointer, intent( out) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i32_7 - - !------------------------------------------------------------------! - !> - !! Double precision (64-bit) integer field retrieval subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_get_i64_0(cdata, standard_name, ptr, ierr, units, rank, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr) - - end subroutine ccpp_field_get_i64_0 - - subroutine ccpp_field_get_i64_1(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_1 - - subroutine ccpp_field_get_i64_2(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_2 - - subroutine ccpp_field_get_i64_3(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_3 - - subroutine ccpp_field_get_i64_4(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_4 - - subroutine ccpp_field_get_i64_5(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_5 - - subroutine ccpp_field_get_i64_6(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_6 - - subroutine ccpp_field_get_i64_7(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - integer(kind=INT64), pointer, intent( out) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_i64_7 - - !------------------------------------------------------------------! - !> - !! Single precision (32-bit) real field retrieval subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_get_r32_0(cdata, standard_name, ptr, ierr, units, rank, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr) - - end subroutine ccpp_field_get_r32_0 - - subroutine ccpp_field_get_r32_1(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_1 - - subroutine ccpp_field_get_r32_2(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_2 - - subroutine ccpp_field_get_r32_3(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_3 - - subroutine ccpp_field_get_r32_4(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_4 - - subroutine ccpp_field_get_r32_5(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_5 - - subroutine ccpp_field_get_r32_6(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_6 - - subroutine ccpp_field_get_r32_7(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL32), pointer, intent( out) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r32_7 - - !------------------------------------------------------------------! - !> - !! Double precision (64-bit) real field retrieval subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_get_r64_0(cdata, standard_name, ptr, ierr, units, rank, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr) - - end subroutine ccpp_field_get_r64_0 - - subroutine ccpp_field_get_r64_1(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_1 - - subroutine ccpp_field_get_r64_2(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_2 - - subroutine ccpp_field_get_r64_3(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_3 - - subroutine ccpp_field_get_r64_4(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_4 - - subroutine ccpp_field_get_r64_5(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_5 - - subroutine ccpp_field_get_r64_6(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_6 - - subroutine ccpp_field_get_r64_7(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - real(kind=REAL64), pointer, intent( out) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_r64_7 - - !------------------------------------------------------------------! - !> - !! Logical field retrieval subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_get_l_0(cdata, standard_name, ptr, ierr, units, rank, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr) - - end subroutine ccpp_field_get_l_0 - - subroutine ccpp_field_get_l_1(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_1 - - subroutine ccpp_field_get_l_2(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_2 - - subroutine ccpp_field_get_l_3(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_3 - - subroutine ccpp_field_get_l_4(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_4 - - subroutine ccpp_field_get_l_5(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_5 - - subroutine ccpp_field_get_l_6(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_6 - - subroutine ccpp_field_get_l_7(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - logical, pointer, intent( out) :: ptr(:,:,:,:,:,:,:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_l_7 - - !------------------------------------------------------------------! - !> - !! Character field retrieval subroutines. - ! - !------------------------------------------------------------------! - subroutine ccpp_field_get_c_0(cdata, standard_name, ptr, ierr, units, rank, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - character(len=*), pointer, intent( out) :: ptr - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr) - - end subroutine ccpp_field_get_c_0 - - subroutine ccpp_field_get_c_1(cdata, standard_name, ptr, ierr, units, rank, dims, kind, index) - type(ccpp_t), intent(in) :: cdata - character(len=*), intent(in) :: standard_name - character(len=*), pointer, intent( out) :: ptr(:) - integer, intent( out) :: ierr - character(len=*), optional, intent( out) :: units - integer, optional, intent( out) :: rank - integer, allocatable, optional, intent( out) :: dims(:) - integer, optional, intent( out) :: kind - integer, optional, intent(in) :: index - - integer :: idx - type(c_ptr) :: cptr - - ierr = 0 - call ccpp_field_get_ptr(cdata, standard_name, cptr, ierr=ierr, & - units=units, rank=rank, dims=dims, kind=kind, index=index) - - if (ierr /=0) return - - call c_f_pointer(cptr, ptr, dims) - - end subroutine ccpp_field_get_c_1 - - !------------------------------------------------------------------! - -end module ccpp_fields diff --git a/src/ccpp_fields_idx.c b/src/ccpp_fields_idx.c deleted file mode 100644 index add0d50b..00000000 --- a/src/ccpp_fields_idx.c +++ /dev/null @@ -1,285 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * @file ccpp_fields_idx.c - * - * @brief Routines and functions to generate and lookup fields/variables - * needed for the physics routines. - * - * @details The fields are stored in an array of C pointers within the - * ccpp_t type. There is also an index array in this type. - * We poppulate this index array with the standard name of - * each variable in the fields array. We use a binary search - * on the sorted index array to retreive the array index for - * the field witin the fields array. - * - * TODO - * - Test the sort and lookup times for qsort() and bsearch(). - * - Implement this as a hash-map instead. - * - * @ingroup Physics - * @{ - **/ - -#include -#include -#include -#include -#include -#include - -#include "ccpp_fields_idx.h" - -/** - * Comparison function. - * - * Compares the name of two index elements using strcmp(). - * It returns an integer less than, equal to, or greater than - * zero if the name in f1 is found, respectively, to be less - * than, to match, or be greater than the name in f2. - * - * @param[in] f1 The first field. - * @param[in] f2 The second field. - **/ -static int -cmp(const void *f1, const void *f2) -{ - struct ccpp_field *f_1; - struct ccpp_field *f_2; - f_1 = *(struct ccpp_field * const *) f1; - f_2 = *(struct ccpp_field * const *) f2; - return strcmp(f_1->name, f_2->name); -} - -/** - * Initialization routine. - * - * Allocates an array for the field indices. - * - * @param[in,out] index The index array. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_field_idx_init(void **index) -{ - struct ccpp_field_idx *f_index; - f_index = NULL; - - *index = (struct ccpp_field_idx *)malloc(sizeof(struct ccpp_field_idx)); - if (*index == NULL) { - warnx("Unable to allocate field index"); - return(EXIT_FAILURE); - } - - f_index = (struct ccpp_field_idx *)(*index); - - f_index->sorted = 0; - f_index->n = 0; - f_index->max = CCPP_FIELD_IDX_MAX; - f_index->fields = malloc(CCPP_FIELD_IDX_MAX * sizeof(struct ccpp_field *)); - - return(EXIT_SUCCESS); -} - -/** - * Finalization routine. - * - * Deallocates the field indices array. - * - * @param[in] index The index array. - * @retval 0 If it was sucessful. - **/ -int -ccpp_field_idx_finalize(void **index) -{ - int i; - - struct ccpp_field_idx *f_index; - - f_index = (struct ccpp_field_idx *)(*index); - - for (i = 0; i < f_index->n; ++i) { - if (f_index->fields[i]->name) { - free(f_index->fields[i]->name); - f_index->fields[i]->name = NULL; - } - free(f_index->fields[i]); - f_index->fields[i] = NULL; - } - free(f_index->fields); - f_index->fields = NULL; - - free(f_index); - f_index = NULL; - - return(EXIT_SUCCESS); -} - -/** - * Add/Insert a field into the index. - * - * @param[in] name The name to add to the index array. - * @param[in,out] index The index array. - * @retval > 0 The index location. - * @retval -1 If there was an error. - **/ -int -ccpp_field_idx_add(const char *name, void **index) -{ - struct ccpp_field_idx *f_index; - int n; - size_t len; - f_index = (struct ccpp_field_idx *)(*index); - n = 0; - len = 0; - - n = f_index->n; - if (n == f_index->max) { - if (ccpp_field_idx_grow(index)) { - warnx("Unable to grow field index array"); - return(-1); - } - } - f_index->fields[n] = malloc(sizeof(struct ccpp_field)); - - len = strlen(name); - - f_index->fields[n]->name = malloc((len + 1) * sizeof(char)); - - strncpy(f_index->fields[n]->name, name, len * sizeof(char)); - f_index->fields[n]->name[len] = '\0'; - f_index->fields[n]->n = n+1; - f_index->sorted = 0; - f_index->n++; - - return(n+1); -} - - -/** - * Find the index number of a field. - * - * @param[in] name The field name to find the index array. - * @param[in,out] index The index array. - * @retval > 0 The position in the index array of the requested field. - * @retval -1 If there was an error. - **/ -int -ccpp_field_idx_find(const char *name, void **index) -{ - int n; - struct ccpp_field *key; - struct ccpp_field **res; - struct ccpp_field_idx *f_index; - n = 0; - key = NULL; - res = NULL; - f_index = (struct ccpp_field_idx *)(*index); - - if (f_index->sorted == 0) { - ccpp_field_idx_sort(index); - } - - key = malloc(sizeof(struct ccpp_field)); - n = strlen(name); - key->name = malloc((n+1) * sizeof(char)); - strncpy(key->name, name, n); - key->name[n] = '\0'; - - res = bsearch(&key, f_index->fields, f_index->n, - sizeof(struct ccpp_field *), cmp); - if (*res == NULL) { - warnx("Unable to find in index: %s", name); - return(-1); - } - - free(key->name); - free(key); - - return((*res)->n); -} - -/** - * Sort the index by calling qsort() and using cmp() as the - * comparison function. - * - * @param[in,out] index The index array. - * @retval 0 If there was no error. - **/ -static int -ccpp_field_idx_sort(void **index) -{ - struct ccpp_field_idx *f_index; - f_index = (struct ccpp_field_idx *)(*index); - - qsort(f_index->fields, f_index->n, sizeof(struct ccpp_field *), cmp); - f_index->sorted = 1; - - return(EXIT_SUCCESS); -} - -/** - * Grow the index field array. - * - * @param[in,out] index The index array. - * @retval 0 If there was no error. - **/ -static int -ccpp_field_idx_grow(void **index) -{ - // Warn user that field index array needs to grow - warnx("Growing field index array"); - - struct ccpp_field_idx *f_index; - struct ccpp_field **new; - int new_max; - f_index = (struct ccpp_field_idx *)(*index); - new = NULL; - new_max = 0; - - new_max = f_index->max * CCPP_FIELD_IDX_GROW; - - new = realloc(f_index->fields, new_max * sizeof(struct ccpp_field *)); - if (new == NULL) { - warnx("Unable to expand the field index array"); - return(EXIT_FAILURE); - } - f_index->fields = new; - f_index->max = new_max; - - return(EXIT_SUCCESS); -} - -/** - * Get the maximum number of fields the index array can hold. - * - * @param[in,out] index The index array. - * @retval >= 0 The maximum number of fields. - **/ -int -ccpp_field_idx_max(void **index) -{ - struct ccpp_field_idx *f_index; - f_index = (struct ccpp_field_idx *)(*index); - - assert(f_index->max > 0); - - return(f_index->max); - -} - -/** - * @} - **/ diff --git a/src/ccpp_fields_idx.h b/src/ccpp_fields_idx.h deleted file mode 100644 index 053fe9c2..00000000 --- a/src/ccpp_fields_idx.h +++ /dev/null @@ -1,80 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * @file ccpp_fields_idx.h - * - * Routines and functions to generate and lookup - * fields/variables needed for the physics routines. - * - * @ingroup Physics - * @{ - **/ -#ifndef CCPP_FIELD_IDX_H -#define CCPP_FIELD_IDX_H - -#ifdef __cplusplus -extern "C" -{ -#endif - - -#define CCPP_FIELD_IDX_MAX 1500 -#define CCPP_FIELD_IDX_GROW 2 - - -struct ccpp_field { - int n; /**< Location within nodes array **/ - char *name; /**< Name of the field **/ -}; - -struct ccpp_field_idx { - int sorted; /**< Sorted flag. 0=unsorted, 1=sorted **/ - int n; /**< Current number of used nodes **/ - int max; /**< Maximum nodes allocated **/ - struct ccpp_field **fields; /**< Array of fields **/ -}; - - -/** CCPP field index initialization routine. **/ -int ccpp_field_idx_init(void **); - -/** CCPP field index finalization routine. **/ -int ccpp_field_idx_finalize(void **); - -/** CCPP field index add/insert a field. **/ -int ccpp_field_idx_add(const char *, void **); - -/** CCPP field index find a field location. **/ -int ccpp_field_idx_find(const char *, void **); - -/** CCPP field index sorting routine. **/ -static int ccpp_field_idx_sort(void **); - -/** CCPP field index array extension. **/ -static int ccpp_field_idx_grow(void **); - -/** CCPP field index maximum number of fields. **/ -int ccpp_field_idx_max(void **); - - -#ifdef __cplusplus -} /* extern "C" */ -#endif - -#endif /* CCPP_FIELD_IDX_H */ - - -/** - * @} - **/ diff --git a/src/ccpp_scheme.F90 b/src/ccpp_scheme.F90 deleted file mode 100644 index 0306f129..00000000 --- a/src/ccpp_scheme.F90 +++ /dev/null @@ -1,159 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief Physics scheme infrastructure module. -! -module ccpp_scheme - - use :: ccpp_types, & - only: ccpp_scheme_t, CCPP_STAGES - use :: ccpp_errors, & - only: ccpp_error, ccpp_debug - use :: ccpp_strings, & - only: ccpp_cstr - use :: ccpp_dl, & - only: ccpp_dl_open, ccpp_dl_close - - implicit none - - private - public :: ccpp_scheme_init, & - ccpp_scheme_finalize, & - ccpp_scheme_load, & - ccpp_scheme_unload - - contains - - !> - !! Scheme initialization subroutine. - !! - !! @param[in,out] scheme The ccpp_scheme_t type to initalize - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_scheme_init(scheme, ierr) - - type(ccpp_scheme_t), intent(inout) :: scheme - integer , intent( out) :: ierr - - integer :: i - - call ccpp_debug('Called ccpp_scheme_init') - - ierr = 0 - - scheme%functions_max = size(CCPP_STAGES) - - allocate(scheme%functions(1:scheme%functions_max)) - do i=1,scheme%functions_max - scheme%functions(i)%name = trim(scheme%get_function_name(trim(CCPP_STAGES(i)))) - end do - - end subroutine ccpp_scheme_init - - !> - !! Scheme finalization subroutine. - !! - !! @param[in,out] scheme The ccpp_scheme_t type to finalize - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_scheme_finalize(scheme, ierr) - - type(ccpp_scheme_t), intent(inout) :: scheme - integer , intent( out) :: ierr - - integer :: i - - call ccpp_debug('Called ccpp_scheme_finalize') - - ierr = 0 - - if (.not.(allocated(scheme%functions))) return - - do i=1,scheme%functions_max - if (allocated(scheme%functions(i)%name)) & - deallocate(scheme%functions(i)%name) - end do - - deallocate(scheme%functions) - - end subroutine ccpp_scheme_finalize - - !> - !! Scheme loading subroutine. - !! - !! @param[in,out] scheme The ccpp_scheme_t type to load - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_scheme_load(scheme, ierr) - - type(ccpp_scheme_t), intent(inout) :: scheme - integer , intent( out) :: ierr - - integer :: i - - call ccpp_debug('Called ccpp_scheme_load') - - ierr = 0 - - do i=1, scheme%functions_max - associate (f => scheme%functions(i)) - call ccpp_debug('Loading ' // trim(f%name) & - // ' from ' // trim(scheme%library)) - ierr = ccpp_dl_open(ccpp_cstr(f%name), & - ccpp_cstr(scheme%library), & - ccpp_cstr(scheme%version), & - f%function_hdl, & - f%library_hdl) - if (ierr /= 0) then - call ccpp_error('A problem occured loading ' & - // trim(f%name) // ' from ' & - // trim(scheme%library)) - return - end if - end associate - end do - - end subroutine ccpp_scheme_load - - !> - !! Scheme unloading subroutine. - !! - !! @param[in,out] scheme The ccpp_scheme_t type to unload - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_scheme_unload(scheme, ierr) - - type(ccpp_scheme_t), intent(inout) :: scheme - integer , intent( out) :: ierr - - integer :: i - - call ccpp_debug('Called ccpp_scheme_unload') - - ierr = 0 - - do i=1, scheme%functions_max - associate (f => scheme%functions(i)) - ierr = ccpp_dl_close(f%library_hdl) - if (ierr /= 0) then - call ccpp_error('A problem occured closing ' & - // trim(scheme%library)) - return - end if - end associate - end do - - end subroutine ccpp_scheme_unload - -end module ccpp_scheme diff --git a/src/ccpp_strings.F90 b/src/ccpp_strings.F90 deleted file mode 100644 index 3e2e0ecd..00000000 --- a/src/ccpp_strings.F90 +++ /dev/null @@ -1,101 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief String routines module. -!! -!! @details A module continaing subroutines and functions to -!! manipulate strings. -! -module ccpp_strings - - use, intrinsic :: iso_c_binding, & - only: c_char, c_null_char, c_size_t, & - c_f_pointer, c_ptr - use :: ccpp_errors, & - only: ccpp_error - - implicit none - - private - public :: ccpp_fstr, & - ccpp_cstr, & - ccpp_free - - interface - integer(c_size_t) & - function strlen(s) & - bind(c, name='strlen') - import :: c_size_t, c_ptr - type(c_ptr), value, intent(in) :: s - end function strlen - - subroutine ccpp_free(s) & - bind(c, name='free') - import :: c_ptr - type(c_ptr), value, intent(in) :: s - end subroutine ccpp_free - end interface - - contains - - !> - !! ccpp_fstr converts an array of characters into a string. - !! - !! This function is needed to pass C char arrays to Fortran. - !! - !! @param[in] str1 The character array. - !! @returns str2 The fortran string. - ! - function ccpp_fstr(str1) result(str2) - type(c_ptr), intent(in) :: str1 - character(len=:), allocatable :: str2 - - integer :: ierr - integer :: i ! Temporary loop indexer - integer :: n ! Length of the str1 - character(kind=c_char), pointer :: cstr(:) - - n = strlen(str1) - - call c_f_pointer(str1, cstr, [strlen(str1)]) - - allocate(character(n) :: str2, stat=ierr) - if (ierr /= 0) then - call ccpp_error('Unable to allocate a string') - return - end if - - i = 1 - do i=1,n - str2(i:i) = cstr(i) - enddo - - end function ccpp_fstr - - !> - !! ccpp_cstr converts a string to a trimmed null terminated string. - !! - !! This function is needed to pass Fortran strings to C. - !! - !! @param[in] str1 The fortran string. - !! @returns str2 The trimmed, null terminated string. - ! - function ccpp_cstr(str1) result(str2) - character(len=*) :: str1 - character(len=:), allocatable :: str2 - - str2 = trim(str1)//c_null_char - end function ccpp_cstr - -end module ccpp_strings diff --git a/src/ccpp_suite.F90 b/src/ccpp_suite.F90 deleted file mode 100644 index 637e9de4..00000000 --- a/src/ccpp_suite.F90 +++ /dev/null @@ -1,438 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief Physics suite infrastructure module. -! -module ccpp_suite - - use, intrinsic :: iso_c_binding, & - only: c_ptr, c_null_ptr - use :: ccpp_types, & - only: ccpp_suite_t - use :: ccpp_errors, & - only: ccpp_error, ccpp_info, ccpp_debug - use :: ccpp_strings, & - only: ccpp_cstr - use :: ccpp_xml - use :: ccpp_scheme, & - only: ccpp_scheme_init, ccpp_scheme_finalize, & - ccpp_scheme_load, ccpp_scheme_unload - - implicit none - - private - public :: ccpp_suite_init, & - ccpp_suite_finalize, & - ccpp_suite_load, & - ccpp_suite_unload - - contains - - !> - !! Suite initialization subroutine. - !! - !! @param[in] filename The file name of the XML scheme file to load. - !! @param[in,out] suite The ccpp_suite_t type to initalize from - !! the scheme XML file. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_suite_init(filename, suite, ierr) - - implicit none - - character(len=*), intent(in) :: filename - type(ccpp_suite_t), intent(inout) :: suite - integer, intent( out) :: ierr - - integer :: i - integer :: j - integer :: k - integer :: l - type(c_ptr) :: xml - type(c_ptr) :: root - type(c_ptr) :: group - type(c_ptr) :: subcycle - type(c_ptr) :: scheme - type(c_ptr), target :: tmp - character(len=*), parameter :: err_msg = & - 'Please validate the suite xml file: ' - - ierr = 0 - tmp = c_null_ptr - - call ccpp_debug('Called ccpp_suite_init') - - ! Load the xml document. - ierr = ccpp_xml_load(ccpp_cstr(filename), xml, root) - if (ierr /= 0) then - call ccpp_error('Unable to load suite from: ' // trim(filename)) - return - end if - - ! Parse the suite element - call ccpp_xml_parse(root, suite, ierr) - if (ierr /= 0) then - call ccpp_error(err_msg // trim(filename)) - return - end if - - call ccpp_info('Parsing suite ' //trim(suite%name)) - ! Find the init subroutine - call ccpp_xml_ele_find(root, ccpp_cstr(CCPP_XML_ELE_INIT), tmp, ierr) - if (ierr == 0) then - ! Get the init subroutine name - call ccpp_xml_parse(tmp, suite%library, suite%version, & - suite%init, ierr) - if (ierr /= 0) then - call ccpp_error('Unable to load initialization subroutine') - call ccpp_error(err_msg // trim(filename)) - return - end if - ! Do not allow empty init constructs < - if (trim(suite%init%name) == '') then - call ccpp_error('CCPP does not allow empty ' & - // ' XML elements; remove if not used') - ierr = 1 - return - end if - ! Initialize the scheme - call ccpp_scheme_init(suite%init, ierr) - end if - - ! Find the finalize subroutine - call ccpp_xml_ele_find(root, ccpp_cstr(CCPP_XML_ELE_FINALIZE), & - tmp, ierr) - if (ierr == 0) then - ! Get the finalize subroutine name - call ccpp_xml_parse(tmp, suite%library, suite%version, & - suite%finalize, ierr) - if (ierr /= 0) then - call ccpp_error('Unable to load finalization subroutine') - call ccpp_error(err_msg // trim(filename)) - return - end if - ! Do not allow empty init constructs < - if (trim(suite%finalize%name) == '') then - call ccpp_error('CCPP does not allow empty ' & - // 'XML elements; remove if not used') - ierr = 1 - return - end if - ! Initialize the scheme - call ccpp_scheme_init(suite%finalize, ierr) - if (ierr /= 0) return - end if - - ! Find the first group - call ccpp_xml_ele_find(root, CCPP_XML_ELE_GROUP, group, ierr) - if (ierr /= 0) then - call ccpp_error('Unable to find first group') - call ccpp_error(err_msg // trim(filename)) - return - end if - - ! Loop over all groups - do i=1, suite%groups_max - - ! Parse the group - call ccpp_xml_parse(group, suite%groups_max, suite%groups(i), ierr) - if (ierr /= 0) then - call ccpp_error(err_msg // trim(filename)) - return - end if - - ! Find the first subcycle - call ccpp_xml_ele_find(group, CCPP_XML_ELE_SUBCYCLE, subcycle, ierr) - if (ierr /= 0) then - call ccpp_error('Unable to locate element: ' & - // CCPP_XML_ELE_SUBCYCLE) - call ccpp_error(err_msg // trim(filename)) - return - end if - - ! Loop over all subcycles - do j=1, suite%groups(i)%subcycles_max - - ! Parse the subcycle - call ccpp_xml_parse(subcycle, & - suite%groups(i)%subcycles_max, & - suite%groups(i)%subcycles(j), & - ierr) - if (ierr /= 0) then - call ccpp_error(err_msg // trim(filename)) - return - end if - - ! Find the first scheme - call ccpp_xml_ele_find(subcycle, CCPP_XML_ELE_SCHEME, & - scheme, ierr) - - ! Loop over all scheme - do k=1, suite%groups(i)%subcycles(j)%schemes_max - ! Parse the scheme - call ccpp_xml_parse(scheme, suite%library, suite%version, & - suite%groups(i)%subcycles(j)%schemes(k), & - ierr) - - ! Initialize the scheme - call ccpp_scheme_init(suite%groups(i)%subcycles(j)%schemes(k), ierr) - if (ierr /= 0) return - - ! Find the next scheme - call ccpp_xml_ele_next(scheme, CCPP_XML_ELE_SCHEME, & - scheme, ierr) - end do - ! Find the next subcycle - call ccpp_xml_ele_next(subcycle, CCPP_XML_ELE_SUBCYCLE, & - subcycle, ierr) - end do - ! Find the next group - call ccpp_xml_ele_next(group, CCPP_XML_ELE_GROUP, group, ierr) - end do - -#ifdef DEBUG - write(6, '(A)') '--------------------------------------------------------------------------------' - write(6, '(A)') 'CCPP suite configuration parsed from SDF ' // trim(filename) - write(6, '(A)') '--------------------------------------------------------------------------------' - write(6, '(*(A))') & - '' - - write(6, '(A, I0)') '[suite%groups_max] = ', suite%groups_max - do i=1, suite%groups_max - write(6, '(A, A, A)') ' ' - write(6, '(A, I0)') ' [suite%groups(i)%subcycles_max] = ', suite%groups(i)%subcycles_max - do j=1, suite%groups(i)%subcycles_max - write(6, '(A, I0, A)') ' ' - write(6, '(A, I0)') ' [suite%groups(i)%subcycles(j)%schemes_max] = ', & - suite%groups(i)%subcycles(j)%schemes_max - do k=1, suite%groups(i)%subcycles(j)%schemes_max - write(6, '(*(A))') & - ' ' - write(6, '(A, I0)') ' [suite%groups(i)%subcycles(j)%schemes(k)%functions_max] = ', & - suite%groups(i)%subcycles(j)%schemes(k)%functions_max - do l=1, suite%groups(i)%subcycles(j)%schemes(k)%functions_max - write(6, '(*(A))') & - ' ', & - trim(suite%groups(i)%subcycles(j)%schemes(k)%functions(l)%name), & - '' - end do - write(6, '(A)') ' ' - end do - write(6, '(A)') ' ' - end do - write(6, '(A)') ' ' - end do - write(6, '(A)') '' - write(6, '(A)') '--------------------------------------------------------------------------------' -#endif - - ierr = ccpp_xml_unload(xml) - call ccpp_suite_load(suite, ierr) - - end subroutine ccpp_suite_init - - !> - !! Suite finalization subroutine. - !! - !! @param[in,out] suite The suite_t type to finalize. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_suite_finalize(suite, ierr) - type(ccpp_suite_t), intent(inout) :: suite - integer, intent( out) :: ierr - - integer :: i - integer :: j - integer :: k - - ierr = 0 - - call ccpp_debug('Called ccpp_suite_finalize') - -#ifndef STATIC - do i=1, suite%groups_max - do j=1, suite%groups(i)%subcycles_max - do k=1, suite%groups(i)%subcycles(j)%schemes_max - call ccpp_scheme_finalize(suite%groups(i)%subcycles(j)%schemes(k), ierr) - if (ierr /= 0) return - if (allocated(suite%groups(i)%subcycles(j)%schemes(k)%name)) then - deallocate(suite%groups(i)%subcycles(j)%schemes(k)%name) - end if - if (allocated(suite%groups(i)%subcycles(j)%schemes(k)%library)) & - then - deallocate(suite%groups(i)%subcycles(j)%schemes(k)%library) - end if - if (allocated(suite%groups(i)%subcycles(j)%schemes(k)%version)) & - then - deallocate(suite%groups(i)%subcycles(j)%schemes(k)%version) - end if - end do - if (allocated(suite%groups(i)%subcycles(j)%schemes)) then - deallocate(suite%groups(i)%subcycles(j)%schemes) - end if - end do - if (allocated(suite%groups(i)%subcycles)) then - deallocate(suite%groups(i)%subcycles) - end if - end do -#endif - - if (allocated(suite%groups)) then - deallocate(suite%groups) - end if - -#ifndef STATIC - ! Clean up the init scheme - call ccpp_scheme_finalize(suite%init, ierr) - if (ierr /=0) return -#endif - - if (allocated(suite%init%name)) then - deallocate(suite%init%name) - end if - - if (allocated(suite%init%library)) then - deallocate(suite%init%library) - end if - - if (allocated(suite%init%version)) then - deallocate(suite%init%version) - end if - -#ifndef STATIC - ! Clean up the finalize scheme - call ccpp_scheme_finalize(suite%finalize, ierr) - if (ierr /=0) return -#endif - - if (allocated(suite%finalize%name)) then - deallocate(suite%finalize%name) - end if - - if (allocated(suite%finalize%library)) then - deallocate(suite%finalize%library) - end if - - if (allocated(suite%finalize%version)) then - deallocate(suite%finalize%version) - end if - - ! Clean up ourself - if (allocated(suite%name)) then - deallocate(suite%name) - end if - - if (allocated(suite%library)) then - deallocate(suite%library) - end if - - if (allocated(suite%version)) then - deallocate(suite%version) - end if - - suite%groups_max = 0 - - end subroutine ccpp_suite_finalize - - !> - !! Suite sub-components loading. - !! - !! @param[in,out] suite The suite_t type to load all sub-components. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_suite_load(suite, ierr) - type(ccpp_suite_t), intent(inout) :: suite - integer, intent( out) :: ierr - - integer :: i - integer :: j - integer :: k - - ierr = 0 - - call ccpp_debug('Called ccpp_suite_load') - - if (allocated(suite%init%name)) then - call ccpp_scheme_load(suite%init, ierr) - if (ierr /= 0) return - end if - - if (allocated(suite%finalize%name)) then - call ccpp_scheme_load(suite%finalize, ierr) - if (ierr /= 0) return - end if - - do i=1, suite%groups_max - do j=1, suite%groups(i)%subcycles_max - do k=1, suite%groups(i)%subcycles(j)%schemes_max - call ccpp_scheme_load(suite%groups(i)%subcycles(j)%schemes(k), ierr) - if (ierr /= 0) return - end do - end do - end do - - end subroutine ccpp_suite_load - - !> - !! Suite unload subroutine. - !! - !! This loops over all defined schemes to close - !! the handle to the scheme library - !! - !! @param[in,out] cdata The CCPP data of type ccpp_t - !! @param[ out] ierr Integer error flag - ! - subroutine ccpp_suite_unload(suite, ierr) - - type(ccpp_suite_t), intent(inout) :: suite - integer , intent( out) :: ierr - - integer :: i - integer :: j - integer :: k - - ierr = 0 - - call ccpp_debug('Called ccpp_suite_unload') - - if (allocated(suite%init%name)) then - call ccpp_scheme_unload(suite%init, ierr) - if (ierr /= 0) return - end if - - if (allocated(suite%finalize%name)) then - call ccpp_scheme_unload(suite%finalize, ierr) - if (ierr /= 0) return - end if - - do i=1, suite%groups_max - do j=1, suite%groups(i)%subcycles_max - do k=1, suite%groups(i)%subcycles(j)%schemes_max - call ccpp_scheme_unload(suite%groups(i)%subcycles(j)%schemes(k), ierr) - if (ierr /= 0) return - end do - end do - end do - - end subroutine ccpp_suite_unload - -end module ccpp_suite diff --git a/src/ccpp_types.F90 b/src/ccpp_types.F90 index 95bcb1e9..903efd98 100644 --- a/src/ccpp_types.F90 +++ b/src/ccpp_types.F90 @@ -23,38 +23,10 @@ module ccpp_types !! \htmlinclude ccpp_types.html !! - use, intrinsic :: iso_c_binding, & - only: c_ptr, c_funptr - implicit none private - public :: CCPP_STR_LEN, & - CCPP_STAGES, & - CCPP_DEFAULT_STAGE, & - CCPP_DEFAULT_LOOP_CNT, & - CCPP_GENERIC_KIND, & - ccpp_t, & - ccpp_field_t, & - ccpp_scheme_t, & - ccpp_suite_t, & - ccpp_group_t, & - ccpp_subcycle_t - - !> @var CCPP_STR_LEN Parameter defined for string lengths. - integer, parameter :: CCPP_STR_LEN = 256 - - !> @var The stages=functions that are defined for each scheme. - character(len=*), dimension(1:3), parameter :: CCPP_STAGES = & - & (/ 'init ', & - & 'run ', & - & 'finalize' /) - - !> @var The default stage if not specified - character(len=*), parameter :: CCPP_DEFAULT_STAGE = 'run' - - !> @var The default "kind" for a generic pointer / derived data type - integer, parameter :: CCPP_GENERIC_KIND = -999 + public :: ccpp_t !> @var The default loop counter indicating outside of a subcycle loop integer, parameter :: CCPP_DEFAULT_LOOP_CNT = -999 @@ -62,96 +34,9 @@ module ccpp_types !> @var The default values for block and thread numbers indicating invalid data integer, parameter :: CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER = -999 - !> - !! @brief CCPP field type - !! - !! The field type contains all the information/meta-data and data - !! for fields that need to be passed between the atmosphere driver - !! and the physics drivers. - type :: ccpp_field_t - character(len=CCPP_STR_LEN) :: standard_name - character(len=CCPP_STR_LEN) :: long_name - character(len=CCPP_STR_LEN) :: units - integer :: rank - integer, allocatable, dimension(:) :: dims - integer :: kind - type(c_ptr) :: ptr - end type ccpp_field_t - - !> - !! @brief CCPP scheme function type - !! - !! The scheme function type contains one function of a scheme. - ! - type :: ccpp_function_t - character(:), allocatable :: name - type(c_ptr) :: function_hdl - type(c_ptr) :: library_hdl - end type ccpp_function_t - - !> - !! @brief CCPP scheme type - !! - !! The scheme type contains all the scheme information. - ! - type :: ccpp_scheme_t - character(:), allocatable :: name - character(:), allocatable :: library - character(:), allocatable :: version - integer :: functions_max - type(ccpp_function_t), allocatable, dimension(:) :: functions - logical :: initialized = .false. - contains - procedure :: get_function_name => scheme_get_function_name - end type ccpp_scheme_t - - !> - !! @brief CCPP subcycle type - !! - !! The subcycle type contains all the scheme names and the number of - !! times the subcycle will loop. It is a direct mapping to the group - !! suite subcycle XML. - ! - type :: ccpp_subcycle_t - integer :: loops_max - integer :: schemes_max - type(ccpp_scheme_t), allocatable, dimension(:) :: schemes - end type ccpp_subcycle_t - - !> - !! @brief CCPP group type - !! - !! The group type contains all the subcycles and the name of - !! the group call. It is a direct mapping to the group element in XML. - ! - type :: ccpp_group_t - character(:), allocatable :: name - integer :: subcycles_max - type(ccpp_subcycle_t), allocatable, dimension(:) :: subcycles - end type ccpp_group_t - - !> - !! @brief CCPP suite type - !! - !! The suite type contains all the group parts names and number of - !! times the subcycle will loop. It is a direct mapping to the - !! suite element in XML. - ! - type :: ccpp_suite_t - character(:), allocatable :: name - character(:), allocatable :: library - character(:), allocatable :: version - type(ccpp_scheme_t) :: init - type(ccpp_scheme_t) :: finalize - integer :: groups_max - type(ccpp_group_t), allocatable, dimension(:) :: groups - end type ccpp_suite_t - -#if 0 !! \section arg_table_ccpp_t !! \htmlinclude ccpp_t.html !! -#endif !> !! @brief CCPP physics type. !! @@ -162,41 +47,29 @@ module ccpp_types !! - The suite definitions in a ccpp_suite_t type. ! type :: ccpp_t - type(c_ptr) :: fields_idx - type(ccpp_field_t), allocatable, dimension(:) :: fields - type(ccpp_suite_t), pointer :: suite => null() - type(ccpp_suite_t) :: suite_target - logical :: suite_iscopy - logical :: initialized = .false. - ! CCPP-internal variables for physics schemes - integer :: errflg = 0 - character(len=512) :: errmsg = '' - integer :: loop_cnt = CCPP_DEFAULT_LOOP_CNT - integer :: blk_no = CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER - integer :: thrd_no = CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER - end type ccpp_t + ! CCPP-internal variables for physics schemes + integer :: errflg = 0 + character(len=512) :: errmsg = '' + integer :: loop_cnt = CCPP_DEFAULT_LOOP_CNT + integer :: blk_no = CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER + integer :: thrd_no = CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER -contains + contains - !> - !! @brief Internal routine that returns the name of - !! a function for a given scheme and stage - !! - !! @param[in ] scheme The ccpp_scheme_t type - !! @param[in ] stage The current stage - !! @return function_name The name of the function - ! - pure function scheme_get_function_name(s, stage) result(function_name) + procedure :: initialized => ccpp_t_initialized - implicit none - - class(ccpp_scheme_t), intent(in) :: s - character(len=*), intent(in) :: stage - - character(:), allocatable :: function_name + end type ccpp_t - function_name = trim(s%name) // '_' // trim(stage) +contains - end function scheme_get_function_name + function ccpp_t_initialized(ccpp_d) result(initialized) + implicit none + ! + class(ccpp_t) :: ccpp_d + logical :: initialized + ! + initialized = (ccpp_d%blk_no /= CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER .and. & + ccpp_d%thrd_no /= CCPP_DEFAULT_BLOCK_AND_THREAD_NUMBER) + end function ccpp_t_initialized end module ccpp_types diff --git a/src/ccpp_utils.c b/src/ccpp_utils.c deleted file mode 100644 index fa545405..00000000 --- a/src/ccpp_utils.c +++ /dev/null @@ -1,89 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * @file ccpp_utils.c - * - * Utility routines that are commonly used in CCPP. - * - * @ingroup common - * @{ - **/ - -#include -#include -#include -#include -#include -#include -#include - -/** - * Resolves the absolute path when given a relative path. - * - * @param[in] rel Relative path name - * @param[out] abs Absolute path name - * @retval 0 If the path was resolved - * @retval 1 If we were unable to resolve the path - **/ -int -ccpp_abs_path(const char *rel, char **abs) -{ - long bsize = 0; - char *buf = NULL; - struct stat sbuf = {0}; - - /* make sure we were given a relative path */ - if (rel == NULL) { - warn("Unable to resolve null relative filename"); - return(EXIT_FAILURE); - } - - /* make sure the absolute path holder is null */ - if (*abs != NULL) { - warn("Unable to write to non-null absolute filename pointer"); - return(EXIT_FAILURE); - } - - /* make sure relative path actually exists */ - if (stat(rel, &sbuf) < 0) { - warn("Unable to stat %s", rel); - return(EXIT_FAILURE); - } - - if ((bsize = pathconf(".", _PC_PATH_MAX)) < 0) { - warn("Unable to obtain maximum size of pathname"); - return(EXIT_FAILURE); - } - - buf = malloc((bsize + 1) * sizeof(char)); - - /* find the absolute path */ - if (realpath(rel, buf) == NULL) { - warn("Unable to resolve %s an error occurred at %s", rel, buf); - free(buf); - return(EXIT_FAILURE); - } - - bsize = strlen(buf); - /* malloc the absolute path */ - *abs = malloc((bsize + 1) * sizeof(char)); - strncpy(*abs, buf, bsize); - (*abs)[bsize] = '\0'; - - /* free up temporary stuff */ - free(buf); - buf = NULL; - - return(EXIT_SUCCESS); -} diff --git a/src/ccpp_utils.h b/src/ccpp_utils.h deleted file mode 100644 index 78d54fc7..00000000 --- a/src/ccpp_utils.h +++ /dev/null @@ -1,41 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * \file ccpp_utils.h - * - * CCPP utility functions. - * - * \ingroup CCPP - * \{ - **/ -#ifndef CCPP_UTILS_H -#define CCPP_UTILS_H - -#ifdef __cplusplus -extern "C" -{ -#endif - -/** Resolves the absolute path when given a relative path. **/ -int ccpp_abs_path(const char *, char **); - -#ifdef __cplusplus -} /* extern "C" */ -#endif - -#endif /* CCPP_UTILS_H */ - -/** - * \} - **/ diff --git a/src/ccpp_xml.F90 b/src/ccpp_xml.F90 deleted file mode 100644 index 0c90e730..00000000 --- a/src/ccpp_xml.F90 +++ /dev/null @@ -1,396 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief XML functions and subroutines module. -!! -!! @details The XML module provides functions and -!! subroutines for accessing the C versions -!! of the functions. -! -module ccpp_xml - - use, intrinsic :: iso_c_binding - use :: ccpp_types, & - only: ccpp_suite_t, ccpp_group_t, & - ccpp_subcycle_t, ccpp_scheme_t, & - CCPP_STR_LEN - use :: ccpp_strings, & - only: ccpp_fstr, ccpp_cstr, ccpp_free - use :: ccpp_errors, & - only: ccpp_error, ccpp_warn - - - implicit none - - private - public :: ccpp_xml_load, & - ccpp_xml_unload, & - ccpp_xml_ele_find, & - ccpp_xml_ele_next, & - ccpp_xml_parse, & - CCPP_XML_ELE_SUITE, & - CCPP_XML_ELE_INIT, & - CCPP_XML_ELE_FINALIZE, & - CCPP_XML_ELE_GROUP, & - CCPP_XML_ELE_SUBCYCLE, & - CCPP_XML_ELE_SCHEME - - interface ccpp_xml_parse - module procedure ccpp_xml_parse_suite, & - ccpp_xml_parse_group, & - ccpp_xml_parse_subcycle, & - ccpp_xml_parse_fptr - end interface ccpp_xml_parse - - !> - !! @brief XML tags for a suite file. - !! - !! @details These suite xml tags must match the elements and attributes - !! of the suite.xsd. - ! - character(len=*), parameter :: CCPP_XML_ELE_SUITE = "suite" - character(len=*), parameter :: CCPP_XML_ELE_INIT = "init" - character(len=*), parameter :: CCPP_XML_ELE_FINALIZE = "finalize" - character(len=*), parameter :: CCPP_XML_ELE_GROUP = "group" - character(len=*), parameter :: CCPP_XML_ELE_SUBCYCLE = "subcycle" - character(len=*), parameter :: CCPP_XML_ELE_SCHEME = "scheme" - - character(len=*), parameter :: CCPP_XML_ATT_NAME = "name" - character(len=*), parameter :: CCPP_XML_ATT_LOOP = "loop" - character(len=*), parameter :: CCPP_XML_ATT_LIB = "lib" - character(len=*), parameter :: CCPP_XML_ATT_VER = "ver" - - interface - integer(c_int32_t) & - function ccpp_xml_load & - (filename, xml, root) & - bind(c, name='ccpp_xml_load') - import :: c_int32_t, c_char, c_ptr - character(kind=c_char), dimension(*) :: filename - type(c_ptr) :: xml - type(c_ptr) :: root - end function ccpp_xml_load - - integer(c_int32_t) & - function ccpp_xml_unload & - (xml) & - bind(c, name='ccpp_xml_unload') - import :: c_int32_t, c_ptr - type(c_ptr) :: xml - end function ccpp_xml_unload - - integer(c_int32_t) & - function ccpp_xml_ele_find_c & - (xml, name, ele) & - bind(c, name='ccpp_xml_ele_find') - import :: c_int32_t, c_ptr, c_char - type(c_ptr) :: xml - character(kind=c_char), dimension(*) :: name - type(c_ptr) :: ele - end function ccpp_xml_ele_find_c - - integer(c_int32_t) & - function ccpp_xml_ele_next_c & - (xml, name, ele) & - bind(c, name='ccpp_xml_ele_next') - import :: c_int32_t, c_ptr, c_char - type(c_ptr) :: xml - character(kind=c_char), dimension(*) :: name - type(c_ptr) :: ele - end function ccpp_xml_ele_next_c - - integer(c_int32_t) & - function ccpp_xml_ele_contents & - (xml, val) & - bind(c, name='ccpp_xml_ele_contents') - import :: c_int32_t, c_ptr, c_char - type(c_ptr) :: xml - type(c_ptr) :: val - end function ccpp_xml_ele_contents - - integer(c_int32_t) & - function ccpp_xml_ele_count & - (xml, name, n) & - bind(c, name='ccpp_xml_ele_count') - import :: c_int32_t, c_ptr, c_char - type(c_ptr) :: xml - character(kind=c_char), dimension(*) :: name - integer(c_int32_t) :: n - end function ccpp_xml_ele_count - - integer(c_int32_t) & - function ccpp_xml_ele_att & - (node, name, val) & - bind(c, name='ccpp_xml_ele_att') - import :: c_int32_t, c_ptr, c_char - type(c_ptr) :: node - character(kind=c_char), dimension(*) :: name - type(c_ptr) :: val - end function ccpp_xml_ele_att - - end interface - - contains - - !> - !! Find an element in a XML structure. - !! - !! @param[in ] xml The xml structure. - !! @param[in,out] name The element name to find. - !! @param[ out] ele The element (if found). - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_xml_ele_find(xml, name, ele, ierr) - type(c_ptr), intent(in ) :: xml - character(len=*), intent(in ) :: name - type(c_ptr), intent( out) :: ele - integer, intent( out) :: ierr - - ierr = ccpp_xml_ele_find_c(xml, ccpp_cstr(name), ele) - end subroutine ccpp_xml_ele_find - - !> - !! Move to the next occurance of an element in a - !! XML structure. - !! - !! @param[in ] xml The xml structure. - !! @param[in,out] name The element name to find. - !! @param[ out] ele The element (if found). - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_xml_ele_next(xml, name, ele, ierr) - type(c_ptr), intent(inout) :: xml - character(len=*), intent(in ) :: name - type(c_ptr), intent(inout) :: ele - integer, intent( out) :: ierr - - ierr = ccpp_xml_ele_next_c(xml, ccpp_cstr(name), ele) - end subroutine ccpp_xml_ele_next - - !> - !! Parse a suite element from an XML structure. - !! - !! @param[in ] node The current xml node. - !! @param[in,out] suite The ccpp_suite_t type to parse into. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_xml_parse_suite(node, suite, ierr) - type(c_ptr), intent(in ) :: node - type(ccpp_suite_t), intent(inout) :: suite - integer, intent( out) :: ierr - - type(c_ptr), target :: tmp - - tmp = c_null_ptr - - ! Get the suite name - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_NAME), tmp) - if (ierr /= 0) then - call ccpp_error('Unable to retrieve suite name') - return - end if - suite%name = ccpp_fstr(tmp) - call ccpp_free(tmp) - - tmp = c_null_ptr - - ! Get the optional library name - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_LIB), tmp) - if (ierr == 0) then - suite%library = ccpp_fstr(tmp) - call ccpp_free(tmp) - tmp = c_null_ptr - else - suite%library = suite%name - end if - - ! Get the optional library version - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_VER), tmp) - if (ierr == 0) then - suite%version = ccpp_fstr(tmp) - call ccpp_free(tmp) - tmp = c_null_ptr - else - allocate(character(CCPP_STR_LEN) :: suite%version, stat=ierr) - if (ierr /= 0) then - call ccpp_error('Unable to allocate suite library version') - return - end if - suite%version = '' - ierr = 0 - end if - - ! Count the number of groups - ierr = ccpp_xml_ele_count(node, ccpp_cstr(CCPP_XML_ELE_GROUP), suite%groups_max) - if (ierr /= 0) then - call ccpp_error('Unable count the number of groups') - return - end if - - allocate(suite%groups(suite%groups_max), stat=ierr) - if (ierr /= 0) then - call ccpp_error('Unable to allocate groups') - return - end if - - end subroutine ccpp_xml_parse_suite - - !! Group parsing from an XML file. - !! - !! @param[in ] node The current xml node. - !! @param[in ] max_groups The maximum number of groups. - !! @param[in,out] group The ccpp_group_t type to parse into. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_xml_parse_group(node, max_groups, group, ierr) - type(c_ptr), intent(in ) :: node - integer, intent(in ) :: max_groups - type(ccpp_group_t), intent(inout) :: group - integer, intent( out) :: ierr - - type(c_ptr), target :: tmp - character(kind=c_char), target :: stmp(CCPP_STR_LEN) - - tmp = c_null_ptr - - ! Get the group name - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_NAME), tmp) - if (ierr /= 0) then - call ccpp_error('Unable to retrieve group name') - return - end if - group%name = ccpp_fstr(tmp) - call ccpp_free(tmp) - - tmp = c_null_ptr - - ! Count the number of subcycles in this group - ierr = ccpp_xml_ele_count(node, ccpp_cstr(CCPP_XML_ELE_SUBCYCLE), & - group%subcycles_max) - if (ierr /= 0) then - call ccpp_error('Unable to count the number of: ' // & - CCPP_XML_ELE_SUBCYCLE) - return - end if - - allocate(group%subcycles(group%subcycles_max), stat=ierr) - if (ierr /= 0) then - call ccpp_error('Unable to allocate subcycles') - return - end if - - end subroutine ccpp_xml_parse_group - - !> - !! Subcycle parsing from an XML file. - !! - !! @param[in ] node The current xml node. - !! @param[in ] max_subcycles The maximum number of subcycles. - !! @param[in,out] subcycle The ccpp_subcycle_t type to parse into. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_xml_parse_subcycle(node, max_subcycles, subcycle, ierr) - type(c_ptr), intent(in ) :: node - integer, intent(in ) :: max_subcycles - type(ccpp_subcycle_t), intent(inout) :: subcycle - integer, intent( out) :: ierr - - type(c_ptr), target :: tmp - character(kind=c_char), target :: stmp(CCPP_STR_LEN) - - - tmp = c_null_ptr - - ! Get the subcycle loop number - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_LOOP), tmp) - if (ierr /= 0) then - call ccpp_error('Unable to find subcycle attribute: ' // CCPP_XML_ATT_LOOP) - return - else - stmp = ccpp_fstr(tmp) - read(stmp, *, iostat=ierr) subcycle%loops_max - call ccpp_free(tmp) - tmp = c_null_ptr - if (ierr /= 0) then - call ccpp_error('Unable to convert subcycle attribute "' // & - CCPP_XML_ATT_LOOP // '" to an integer') - return - end if - end if - - ! Count the number of schemes - ierr = ccpp_xml_ele_count(node, ccpp_cstr(CCPP_XML_ELE_SCHEME), & - subcycle%schemes_max) - if (ierr /= 0) then - call ccpp_error('Unable to count the number of: ' // & - CCPP_XML_ELE_SCHEME) - return - end if - - allocate(subcycle%schemes(subcycle%schemes_max), stat=ierr) - if (ierr /= 0) then - call ccpp_error('Unable to allocate subcycles') - return - end if - - end subroutine ccpp_xml_parse_subcycle - - !> - !! Function pointer (scheme/init/finalize) parsing from an XML file. - !! - !! @param[in ] node The current xml node. - !! @param[in ] lib The default library name. - !! @param[in ] ver The default library version. - !! @param[in,out] fptr The ccpp_scheme_t type to load into. - !! @param[ out] ierr Integer error flag. - ! - subroutine ccpp_xml_parse_fptr(node, lib, ver, fptr, ierr) - type(c_ptr), intent(in ) :: node - character(len=*), intent(in ) :: lib - character(len=*), intent(in ) :: ver - type(ccpp_scheme_t), intent(inout) :: fptr - integer, intent( out) :: ierr - - type(c_ptr), target :: tmp - - tmp = c_null_ptr - - ierr = ccpp_xml_ele_contents(node, tmp) - if (ierr /= 0) then - return - end if - - fptr%name = ccpp_fstr(tmp) - call ccpp_free(tmp) - - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_LIB), tmp) - if (ierr == 0) then - fptr%library = ccpp_fstr(tmp) - call ccpp_free(tmp) - else - fptr%library = lib - end if - - ierr = ccpp_xml_ele_att(node, ccpp_cstr(CCPP_XML_ATT_VER), tmp) - if (ierr == 0) then - fptr%version = ccpp_fstr(tmp) - call ccpp_free(tmp) - else - fptr%version = ver - end if - - ierr = 0 - end subroutine ccpp_xml_parse_fptr - -end module ccpp_xml diff --git a/src/ccpp_xml.c b/src/ccpp_xml.c deleted file mode 100644 index 0335d074..00000000 --- a/src/ccpp_xml.c +++ /dev/null @@ -1,246 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * @file ccpp_xml.c - * - * @brief Routines and functions for processing a XML file. - * This is a very thin layer around libxml2. - * - * - * @ingroup XML - * @{ - **/ - -#include -#include -#include -#include -#include - -#include -#include - -#include "ccpp_xml.h" - -/** - * Read a xml file and load the information. - * - * @param[in] filename The xml file name. - * @param[out] xml The xml document pointer. - * @param[out] root The root node of the xml document. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_load(const char *filename, void **xml, void **root) -{ - - /* Read the file into a document tree */ - *xml = (void *)xmlReadFile(filename, NULL, 0); - if (*xml == NULL) { - warnx("Failed to parse %s", filename); - return(EXIT_FAILURE); - } - - *root = (void *)xmlDocGetRootElement((xmlDocPtr)(*xml)); - - return(EXIT_SUCCESS); -} - -/** - * Unload the XML document and clean-up the XML parser. - * - * @param[in] xml The xml document pointer. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_unload(void **xml) -{ - xmlDocPtr doc = NULL; /**< XML document tree **/ - - doc = (xmlDocPtr)(*xml); - - /* Free the document tree */ - xmlFreeDoc(doc); - - /* Clean up the parser */ - xmlCleanupParser(); - - return(EXIT_SUCCESS); -} - -/** - * Get the first occurance of the node. - * - * @param[in] node The toplevel node pointer to start from. - * @param[in] name The name element to retrieve. - * @param[out] ele The first occurance of the element. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_ele_find(void **node, const char *name, void **ele) -{ - xmlNodePtr cur = NULL; /**< XML tree root node **/ - - cur = (xmlNodePtr)(*node); - - /* Loop through all children finding the first requested element*/ - cur = cur->xmlChildrenNode; - while (cur != NULL) { - if (xmlStrcmp(cur->name, (const xmlChar *)name) == 0) { - *ele = (void *)cur; - break; - } - cur = cur->next; - } - if (!*ele) { - return(EXIT_FAILURE); - } - - return(EXIT_SUCCESS); -} - -/** - * Get the next occurance of the node. - * - * This uses xmlNextElementSibling() followed by a check of - * the name. - * - * @param[in] node The toplevel node pointer to start from. - * @param[in] name The name element to retrieve. - * @param[out] ele The next occurance of the element. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_ele_next(void **node, const char *name, void **ele) -{ - xmlNodePtr cur = NULL; /**< XML tree root node **/ - - cur = (xmlNodePtr)(*node); - - cur = xmlNextElementSibling(cur); - /* Loop through all siblings finding the element requested */ - while (cur != NULL) { - if (xmlStrcmp(cur->name, (const xmlChar *)name) == 0) { - *ele = (void *)cur; - break; - } - cur = xmlNextElementSibling(cur); - } - if (!*ele) { - return(EXIT_FAILURE); - } - - return(EXIT_SUCCESS); -} - -/** - * Count the number of elements within the XML node. - * - * @param[in] node The toplevel node pointer to start from. - * @param[in] name The name element to count. - * @param[out] n The number of times the element was found. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_ele_count(void **node, const char *name, int *n) -{ - xmlNodePtr cur = NULL; /**< XML tree root node **/ - - cur = (xmlNodePtr)(*node); - - *n = 0; - - /* Count the number of elements */ - cur = cur->xmlChildrenNode; - while (cur != NULL) { - if (xmlStrcmp(cur->name, (const xmlChar *)name) == 0) { - ++(*n); - } - cur = cur->next; - } - - return(EXIT_SUCCESS); -} - -/** - * Get the contents of a node. - * - * @param[in] node The toplevel node pointer to start from. - * @param[out] value The value of the attribute. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_ele_contents(void **node, char **value) -{ - int n = 0; /**< String length **/ - xmlNodePtr cur = NULL; /**< XML tree node **/ - xmlChar *tmp = NULL; /**< The contents value **/ - - cur = (xmlNodePtr)(*node); - - tmp = xmlNodeGetContent(cur); - if (!tmp) { - return(EXIT_FAILURE); - } - - n = strlen((char *)tmp); - *value = malloc((n+1) * sizeof(char)); - strncpy(*value, (char *)tmp, n * sizeof(char)); - (*value)[n] = '\0'; - xmlFree(tmp); - - return(EXIT_SUCCESS); -} - -/** - * Get the attribute at the node. - * - * @param[in] node The toplevel node pointer to start from. - * @param[in] name The name of the attribute to get. - * @param[out] value The value of the attribute. - * @retval 0 If it was sucessful. - * @retval 1 If there was an error. - **/ -int -ccpp_xml_ele_att(void **node, const char *name, char **value) -{ - int n = 0; /**< String length **/ - xmlNodePtr cur = NULL; /**< XML tree node **/ - xmlChar *tmp = NULL; /**< The attribute value **/ - - cur = (xmlNodePtr)(*node); - - tmp = xmlGetProp(cur, (const xmlChar *)name); - if (!tmp) { - return(EXIT_FAILURE); - } - - n = strlen((char *)tmp); - *value = malloc((n+1) * sizeof(char)); - strncpy(*value, (char *)tmp, n * sizeof(char)); - (*value)[n] = '\0'; - xmlFree(tmp); - - return(EXIT_SUCCESS); -} - -/** - * @} - **/ diff --git a/src/ccpp_xml.h b/src/ccpp_xml.h deleted file mode 100644 index 7274bf3d..00000000 --- a/src/ccpp_xml.h +++ /dev/null @@ -1,60 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * @file ccpp_xml.h - * - * Routines and functions for processing xml files. - * - * @ingroup XML - * @{ - **/ -#ifndef CCPP_XML_H -#define CCPP_XML_H - -#ifdef __cplusplus -extern "C" -{ -#endif - -/** Load a XML file. **/ -int ccpp_xml_load(const char *, void **, void **); - -/** Unload the XML document and finish using the XML library **/ -int ccpp_xml_unload(void **); - -/** Find the first occurance of the specified element within in a XML - * document/node **/ -int ccpp_xml_ele_find(void **, const char *, void **); - -/** Find the next occurance of the specified element within in a XML node **/ -int ccpp_xml_ele_next(void **, const char *, void **); - -/** Get the contents of the node **/ -int ccpp_xml_ele_contents(void **, char **); - -/** Count the number of specifid elements within in a XML document/node **/ -int ccpp_xml_ele_count(void **, const char *, int *); - -/** Get the attribute at the node. **/ -int ccpp_xml_ele_att(void **, const char *, char **); - -#ifdef __cplusplus -} /* extern "C" */ -#endif - -#endif /* CCPP_XML_H */ - -/** - * @} - **/ diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt deleted file mode 100644 index 4342303f..00000000 --- a/src/tests/CMakeLists.txt +++ /dev/null @@ -1,53 +0,0 @@ - -#------------------------------------------------------------------------------ -# Add all the tests -add_executable(test_init_finalize test_init_finalize.f90) -target_link_libraries(test_init_finalize ccpp) - -add_executable(test_fields test_fields.c) -target_link_libraries(test_fields ccpp) - -add_executable(test_check test_check.f90) -target_link_libraries(test_check ccpp) - - -#------------------------------------------------------------------------------ -# Run all the tests - -# Make sure we can accept valid xml suites and reject invalid ones -add_test(XML_1 test_init_finalize ${CMAKE_CURRENT_SOURCE_DIR}/suite_noop_1.xml) -add_test(XML_2 test_init_finalize ${CMAKE_CURRENT_SOURCE_DIR}/suite_noop_2.xml) -add_test(XML_3 test_init_finalize ${CMAKE_CURRENT_SOURCE_DIR}/suite_noop_3.xml) -add_test(XML_4 test_init_finalize ${CMAKE_CURRENT_SOURCE_DIR}/suite_noop_4.xml) -add_test(XML_5 test_init_finalize ${CMAKE_CURRENT_SOURCE_DIR}/suite_noop_5.xml) -add_test(XML_6 test_init_finalize ${CMAKE_CURRENT_SOURCE_DIR}/suite_noop_6.xml) - -# Make sure we can grow the fields index -add_test(FIELDS test_fields) - -# Make sure we can do the cap call -add_test(CHECK_1 test_check ${CMAKE_CURRENT_SOURCE_DIR}/suite_check_1.xml) -add_test(CHECK_2 test_check ${CMAKE_CURRENT_SOURCE_DIR}/suite_check_2.xml) -add_test(CHECK_3 test_check ${CMAKE_CURRENT_SOURCE_DIR}/suite_check_3.xml) - -set_tests_properties(XML_3 PROPERTIES WILL_FAIL TRUE) - -set_tests_properties(XML_1 - XML_2 - XML_3 - XML_4 - XML_5 - XML_6 - CHECK_1 - CHECK_2 - CHECK_3 - PROPERTIES ENVIRONMENT "LD_LIBRARY_PATH=${CMAKE_CURRENT_BINARY_DIR}/../../schemes/check/src/check-build:$ENV{LD_LIBRARY_PATH}") - -#------------------------------------------------------------------------------ -# Coverage tests -if(CMAKE_COMPILER_IS_GNUCC AND (CMAKE_BUILD_TYPE STREQUAL "Coverage")) - setup_target_for_coverage(coverage - "test_check - ${CMAKE_CURRENT_SOURCE_DIR}/suite_check_1.xml" - coverage) -endif() diff --git a/src/tests/suite.xsd b/src/tests/suite.xsd deleted file mode 100644 index df7e9c6c..00000000 --- a/src/tests/suite.xsd +++ /dev/null @@ -1,49 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/src/tests/suite_EXAMPLE.xml b/src/tests/suite_EXAMPLE.xml deleted file mode 100644 index 5e45643e..00000000 --- a/src/tests/suite_EXAMPLE.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - test - - - - diff --git a/src/tests/suite_check_1.xml b/src/tests/suite_check_1.xml deleted file mode 100644 index b77e1be5..00000000 --- a/src/tests/suite_check_1.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - test - - - - diff --git a/src/tests/suite_check_2.xml b/src/tests/suite_check_2.xml deleted file mode 100644 index 562c1b7c..00000000 --- a/src/tests/suite_check_2.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - test - - - - diff --git a/src/tests/suite_check_3.xml b/src/tests/suite_check_3.xml deleted file mode 100644 index ae6949b9..00000000 --- a/src/tests/suite_check_3.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - test - - - - diff --git a/src/tests/suite_noop_1.xml b/src/tests/suite_noop_1.xml deleted file mode 100644 index 8066e51c..00000000 --- a/src/tests/suite_noop_1.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - noop - - - - diff --git a/src/tests/suite_noop_2.xml b/src/tests/suite_noop_2.xml deleted file mode 100644 index 2cdcce84..00000000 --- a/src/tests/suite_noop_2.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - noop - - - - diff --git a/src/tests/suite_noop_3.xml b/src/tests/suite_noop_3.xml deleted file mode 100644 index 36e6d4d9..00000000 --- a/src/tests/suite_noop_3.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - noop - - - - diff --git a/src/tests/suite_noop_4.xml b/src/tests/suite_noop_4.xml deleted file mode 100644 index a53ee1df..00000000 --- a/src/tests/suite_noop_4.xml +++ /dev/null @@ -1,22 +0,0 @@ - - - - - - noop - - - - - noop - - - - - noop - noop - noop - - - - diff --git a/src/tests/suite_noop_5.xml b/src/tests/suite_noop_5.xml deleted file mode 100644 index 2aeb67c2..00000000 --- a/src/tests/suite_noop_5.xml +++ /dev/null @@ -1,13 +0,0 @@ - - - - - - noop - - - noop - - - - diff --git a/src/tests/suite_noop_6.xml b/src/tests/suite_noop_6.xml deleted file mode 100644 index 711ee02e..00000000 --- a/src/tests/suite_noop_6.xml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - noop - - - - diff --git a/src/tests/test_check.f90 b/src/tests/test_check.f90 deleted file mode 100644 index 68016019..00000000 --- a/src/tests/test_check.f90 +++ /dev/null @@ -1,168 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief A Test Atmospheric Driver Program. -!! -program test_check - -!! \section arg_table_test_check -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-------------------------------------------|----------------------------|---------|------|-----------|----------|--------|----------| -!! | gravity | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | | none | F | -!! | u | x_wind | zonal wind | m s-1 | 2 | real | | none | F | -!! | v | y_wind | meridional wind | m s-1 | 2 | real | | none | F | -!! | tsfc | surface_skin_temperature | surface skin temperature | K | 1 | real | | none | F | -!! - - use, intrinsic :: iso_c_binding, & - only: c_loc, c_f_pointer - use :: ccpp_api, & - only: CCPP_STR_LEN, & - ccpp_t, & - ccpp_init, & - ccpp_finalize, & - ccpp_physics_init, & - ccpp_physics_run, & - ccpp_physics_finalize, & - ccpp_field_add - - implicit none - - type(ccpp_t), target :: cdata - character(len=CCPP_STR_LEN) :: filename - integer :: len - integer :: ierr - integer :: asize - real, target :: gravity - real, target, allocatable, dimension(:,:) :: u - real, target, allocatable, dimension(:,:) :: v - real, target, allocatable, dimension(:) :: tsfc - - ierr = 0 - - call get_command_argument(1, filename, len, ierr) - if (ierr /= 0) then - call exit(1) - end if - - ! Allocate the data - asize = 5 - allocate(tsfc(asize), stat=ierr) - if (ierr /= 0) then - print *, 'Unable to allocate surface temperature array' - call exit(1) - end if - - allocate(u(asize,asize), stat=ierr) - if (ierr /= 0) then - print *, 'Unable to allocate U array' - call exit(1) - end if - - allocate(v(asize,asize), stat=ierr) - if (ierr /= 0) then - print *, 'Unable to allocate U array' - call exit(1) - end if - - ! Generate data to pass into a physics driver - gravity = 9.80665 - tsfc = [290.0, 291.0, 292.0, 293.0, 294.0] - u = 0.0 - v = 10.0 - - ! Initalize the CCPP framework (with the filename - ! of the suite to load instead of the suite name) - call ccpp_init(trim(filename), cdata, ierr, is_filename=.true.) - if (ierr /= 0) then - call exit(1) - end if - - call ccpp_field_add(cdata, 'ccpp_error_flag', cdata%errflg, ierr, 'flag') - if (ierr /= 0) then - call exit(1) - end if - - call ccpp_field_add(cdata, 'ccpp_error_message', cdata%errmsg, ierr, 'none') - if (ierr /= 0) then - call exit(1) - end if - - call ccpp_field_add(cdata, 'ccpp_loop_counter', cdata%loop_cnt, ierr, 'index') - if (ierr /= 0) then - call exit(1) - end if - - ! Add all the fields we want to expose to the physics driver. - call ccpp_field_add(cdata, 'gravitational_acceleration', gravity, ierr, 'm s-2') - if (ierr /= 0) then - call exit(1) - end if - - call ccpp_field_add(cdata, 'surface_skin_temperature', tsfc, ierr, 'K') - if (ierr /= 0) then - call exit(1) - end if - - call ccpp_field_add(cdata, 'x_wind', u, ierr, 'm s-1') - if (ierr /= 0) then - call exit(1) - end if - - call ccpp_field_add(cdata, 'y_wind', v, ierr, 'm s-1') - if (ierr /= 0) then - call exit(1) - end if - - ! Initialize the test scheme - call ccpp_physics_init(cdata, ierr=ierr) - if (ierr /= 0) then - call exit(1) - end if - - ! Run the test scheme - call ccpp_physics_run(cdata, scheme_name="test", ierr=ierr) - if (ierr /= 0) then - print *, "Call to scheme test failed, error message: '" // trim(cdata%errmsg) // "'" - call exit(1) - end if - - print *, 'In test dummy main' - print *, 'gravity: ', gravity - print *, 'tsfc: ', tsfc(1:2) - print *, 'u: ', u(1,1) - print *, 'v: ', v(1,1) - - ! Finalize the test scheme - call ccpp_physics_finalize(cdata, ierr=ierr) - if (ierr /= 0) then - call exit(1) - end if - - ! Finalize the CCPP framework - call ccpp_finalize(cdata, ierr) - - if (allocated(tsfc)) then - deallocate(tsfc) - end if - - if (allocated(u)) then - deallocate(u) - end if - - if (allocated(v)) then - deallocate(v) - end if - -end program test_check diff --git a/src/tests/test_fields.c b/src/tests/test_fields.c deleted file mode 100644 index 235e2b35..00000000 --- a/src/tests/test_fields.c +++ /dev/null @@ -1,50 +0,0 @@ -/* - * This work (Common Community Physics Package), identified by NOAA, NCAR, - * CU/CIRES, is free of known copyright restrictions and is placed in the - * public domain. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL - * THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER - * IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN - * CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -/** - * A test to make sure the field array is growable. - **/ - -#include -#include - -#include "ccpp_fields_idx.h" - -int -main(int argc, char **argv) -{ - int i = 0; - int n = 100; - char f[10] = {0}; - void *cdata = NULL; - - if (ccpp_field_idx_init(&cdata)) { - return(EXIT_FAILURE); - } - - for (i = 0; i < n; ++i) { - sprintf(f, "f_%d", i); - if (ccpp_field_idx_add(f, &cdata) <= 0) { - return(EXIT_FAILURE); - } - } - - i = ccpp_field_idx_find("f_90", &cdata); - printf("%d\n", i); - - if (ccpp_field_idx_finalize(&cdata)) { - return(EXIT_FAILURE); - } - - return(EXIT_SUCCESS); -} diff --git a/src/tests/test_init_finalize.f90 b/src/tests/test_init_finalize.f90 deleted file mode 100644 index b922173f..00000000 --- a/src/tests/test_init_finalize.f90 +++ /dev/null @@ -1,58 +0,0 @@ -! -! This work (Common Community Physics Package), identified by NOAA, NCAR, -! CU/CIRES, is free of known copyright restrictions and is placed in the -! public domain. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -! THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -! - -!> -!! @brief A test program to test the CCPP. -!! -!! @details This will test the -!! - initialization and finalization subroutines of -!! -- CCPP -!! -- Suite -!! -- Fields -!! It can be used multipile times to test the parsing -!! of various suite XML files. -! -program test_init_finalize - - use :: ccpp_types, & - only: CCPP_STR_LEN, ccpp_t - use :: ccpp, & - only: ccpp_init, ccpp_finalize - - implicit none - - integer :: ierr - integer :: len - character(len=CCPP_STR_LEN) :: filename - type(ccpp_t), target :: cdata - - - ierr = 0 - - call get_command_argument(1, filename, len, ierr) - if (ierr /= 0) then - print *, 'Error: no suite XML file specified.' - call exit(ierr) - end if - - call ccpp_init(trim(filename), cdata, ierr, is_filename=.true.) - if (ierr /= 0) then - call exit(ierr) - end if - - call ccpp_finalize(cdata, ierr) - if (ierr /= 0) then - call exit(ierr) - end if - -end program test_init_finalize