diff --git a/.dockerignore b/.dockerignore index e3158026..69a3598b 100644 --- a/.dockerignore +++ b/.dockerignore @@ -3,6 +3,7 @@ # include things to copy !src/ +!include/ !etc/ !data/ !cmake/ diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f9497bd8..6ed66a73 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -17,7 +17,7 @@ jobs: - name: build Docker image run: docker build -t tuv-x-test . - name: run tests in container - run: docker run --name test-container -t tuv-x-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' + run: docker run --name test-container -t tuv-x-test bash -c 'make test ARGS="--rerun-failed --output-on-failure"' build_test_with_mpi_no_memcheck: runs-on: ubuntu-latest if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name @@ -28,7 +28,7 @@ jobs: - name: build Docker image for MPI tests run: docker build -t tuv-x-mpi-test . -f Dockerfile.mpi - name: run MPI tests in container - run: docker run -t tuv-x-mpi-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' + run: docker run -t tuv-x-mpi-test bash -c 'make test ARGS="--rerun-failed --output-on-failure"' build_test_no_mpi_with_memcheck: runs-on: ubuntu-latest if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name @@ -39,24 +39,13 @@ jobs: - name: build Docker image run: docker build -t tuv-x-test . -f Dockerfile.memcheck - name: run tests in container - run: docker run --name test-container -t tuv-x-test bash -c 'make coverage ARGS="--rerun-failed --output-on-failure -j8"' + run: docker run --name test-container -t tuv-x-test bash -c 'make coverage ARGS="--rerun-failed --output-on-failure"' - name: copy coverage from container run: docker cp test-container:build/coverage.info . - uses: codecov/codecov-action@v2 with: token: ${{ secrets.CODECOV_TOKEN }} files: coverage.info - build_test_yaml_no_mpi_with_memcheck: - runs-on: ubuntu-latest - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - name: build Docker image with YAML and memcheck - run: docker build -t tuv-x-yaml-test . -f Dockerfile.yaml.memcheck - - name: run tests in container - run: docker run -t tuv-x-yaml-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' build_test_with_mpi_with_memcheck: runs-on: ubuntu-latest if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name @@ -67,15 +56,4 @@ jobs: - name: build Docker image for MPI tests run: docker build -t tuv-x-mpi-test . -f Dockerfile.mpi.memcheck - name: run MPI tests in container - run: docker run -t tuv-x-mpi-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' - build_test_yaml_with_mpi_with_memcheck: - runs-on: ubuntu-latest - if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - name: build Docker image with YAML and memcheck for MPI tests - run: docker build -t tuv-x-mpi-yaml-test . -f Dockerfile.yaml.mpi.memcheck - - name: run MPI tests in container - run: docker run -t tuv-x-mpi-yaml-test bash -c 'make test ARGS="--rerun-failed --output-on-failure -j8"' \ No newline at end of file + run: docker run -t tuv-x-mpi-test bash -c 'make test ARGS="--rerun-failed --output-on-failure"' \ No newline at end of file diff --git a/CMakeLists.txt b/CMakeLists.txt index 78f7e96d..5d159c87 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -34,7 +34,6 @@ option(ENABLE_COVERAGE "Enable code coverage output" OFF) option(ENABLE_MEMCHECK "Enable memory checking in tests" ON) option(ENABLE_NC_CONFIG "Use nc-config to determine NetCDF libraries" OFF) option(BUILD_DOCS "Build the documentation" OFF) -option(ENABLE_YAML "Uses YAML parser instead of JSON" OFF) # Set up include and lib directories set(TUVX_MOD_DIR "${PROJECT_BINARY_DIR}/include") @@ -79,11 +78,16 @@ add_executable(tuv-x src/tuvx.F90 version.F90) target_link_libraries(tuv-x PUBLIC musica::tuvx - musica::musicacore + yaml-cpp::yaml-cpp ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES} ) +target_include_directories(tuv-x + PUBLIC + $ + $) + if(ENABLE_OPENMP) target_link_libraries(tuv-x PUBLIC OpenMP::OpenMP_Fortran) endif() diff --git a/Dockerfile b/Dockerfile index 8f225029..47cc7390 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf -y install \ @@ -15,34 +15,17 @@ RUN dnf -y update \ python3 \ python3-pip \ lapack-devel \ + yaml-cpp-devel \ && dnf clean all RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - -# add a symlink -# Create symlinks in the Docker container -RUN ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.a /usr/local/lib64/libjsonfortran.a && \ - ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.so.8.2 /usr/local/lib64/libjsonfortran.so.8.2 && \ - ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.so /usr/local/lib64/libjsonfortran.so && \ - ln -s /usr/local/jsonfortran-gnu-8.2.0/lib/libjsonfortran.so.8.2.0 /usr/local/lib64/libjsonfortran.so.8.2.0 - ENV LD_LIBRARY_PATH=/usr/local/lib64 # build the tuv-x tool COPY . /tuv-x/ RUN mkdir /build \ && cd /build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D CMAKE_BUILD_TYPE=release \ -D ENABLE_MEMCHECK=OFF \ /tuv-x \ diff --git a/Dockerfile.docs b/Dockerfile.docs index 51dd6d18..4868ebd1 100644 --- a/Dockerfile.docs +++ b/Dockerfile.docs @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf -y install \ @@ -16,18 +16,9 @@ RUN dnf -y update \ python3 \ python3-pip \ lapack-devel \ + yaml-cpp-devel \ && dnf clean all -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - # build the tuv-x tool COPY . /tuv-x/ @@ -40,7 +31,6 @@ RUN echo "The suffix is '$SWITCHER_SUFFIX'" RUN mkdir /build \ && cd /build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D ENABLE_TESTS=OFF \ -D BUILD_DOCS=ON \ /tuv-x \ diff --git a/Dockerfile.memcheck b/Dockerfile.memcheck index 18187aab..26c827f4 100644 --- a/Dockerfile.memcheck +++ b/Dockerfile.memcheck @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf -y install \ @@ -15,25 +15,15 @@ RUN dnf -y update \ python3 \ python3-pip \ lapack-devel \ + yaml-cpp-devel \ && dnf clean all RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - # build the tuv-x tool COPY . /tuv-x/ RUN mkdir /build \ && cd /build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D ENABLE_COVERAGE:BOOL=TRUE \ -D CMAKE_BUILD_TYPE=COVERAGE \ /tuv-x \ diff --git a/Dockerfile.mpi b/Dockerfile.mpi index 79065e3e..f2595b32 100644 --- a/Dockerfile.mpi +++ b/Dockerfile.mpi @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf install -y sudo \ @@ -24,6 +24,7 @@ RUN sudo dnf -y install \ python3-pip \ valgrind-openmpi \ lapack-devel \ + yaml-cpp-devel \ && sudo dnf clean all ENV PATH="${PATH}:/usr/lib64/openmpi/bin/" @@ -31,24 +32,14 @@ ENV OMP_NUM_THREADS=5 RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - - # build the tuv-x tool COPY . tuv-x/ RUN mkdir build \ && cd build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D CMAKE_BUILD_TYPE=release \ -D CMAKE_Fortran_COMPILER=/usr/lib64/openmpi/bin/mpif90 \ + -D CMAKE_C_COMPILER=/usr/lib64/openmpi/bin/mpicc \ + -D CMAKE_CXX_COMPILER=/usr/lib64/openmpi/bin/mpicxx \ -D ENABLE_OPENMP:BOOL=TRUE \ -D ENABLE_MPI:BOOL=TRUE \ -D ENABLE_MEMCHECK:BOOL=FALSE \ diff --git a/Dockerfile.mpi.memcheck b/Dockerfile.mpi.memcheck index 6856fa4c..7d1eb662 100644 --- a/Dockerfile.mpi.memcheck +++ b/Dockerfile.mpi.memcheck @@ -1,4 +1,4 @@ -FROM fedora:35 +FROM fedora:37 RUN dnf -y update \ && dnf install -y sudo \ @@ -24,6 +24,7 @@ RUN sudo dnf -y install \ python3-pip \ valgrind-openmpi \ lapack-devel \ + yaml-cpp-devel \ && sudo dnf clean all ENV PATH="${PATH}:/usr/lib64/openmpi/bin/" @@ -31,23 +32,14 @@ ENV OMP_NUM_THREADS=5 RUN pip3 install numpy scipy -# install json-fortran -RUN curl -LO https://github.com/jacobwilliams/json-fortran/archive/8.2.0.tar.gz \ - && tar -zxvf 8.2.0.tar.gz \ - && cd json-fortran-8.2.0 \ - && export FC=gfortran \ - && mkdir build \ - && cd build \ - && cmake -D SKIP_DOC_GEN:BOOL=TRUE .. \ - && sudo make install - # build the tuv-x tool COPY . tuv-x/ RUN mkdir build \ && cd build \ - && export JSON_FORTRAN_HOME="/usr/local/jsonfortran-gnu-8.2.0" \ && cmake -D CMAKE_BUILD_TYPE=debug \ -D CMAKE_Fortran_COMPILER=/usr/lib64/openmpi/bin/mpif90 \ + -D CMAKE_C_COMPILER=/usr/lib64/openmpi/bin/mpicc \ + -D CMAKE_CXX_COMPILER=/usr/lib64/openmpi/bin/mpicxx \ -D ENABLE_OPENMP:BOOL=TRUE \ -D ENABLE_MPI:BOOL=TRUE \ -D ENABLE_MEMCHECK:BOOL=TRUE \ diff --git a/Dockerfile.yaml.memcheck b/Dockerfile.yaml.memcheck deleted file mode 100644 index f7904ce7..00000000 --- a/Dockerfile.yaml.memcheck +++ /dev/null @@ -1,33 +0,0 @@ -FROM fedora:37 - -RUN dnf -y update \ - && dnf -y install \ - gcc-fortran \ - gcc-c++ \ - gcc \ - gdb \ - git \ - netcdf-fortran-devel \ - cmake \ - make \ - lcov \ - valgrind \ - python3 \ - python3-pip \ - lapack-devel \ - yaml-cpp-devel \ - && dnf clean all - -RUN pip3 install numpy scipy - -# build the tuv-x tool with YAML support -COPY . /tuv-x/ -RUN mkdir /build \ - && cd /build \ - && cmake -D ENABLE_COVERAGE:BOOL=TRUE \ - -D CMAKE_BUILD_TYPE=COVERAGE \ - -D ENABLE_YAML=ON \ - /tuv-x \ - && make -j 8 - -WORKDIR /build diff --git a/Dockerfile.yaml.mpi.memcheck b/Dockerfile.yaml.mpi.memcheck deleted file mode 100644 index 3c3fdea8..00000000 --- a/Dockerfile.yaml.mpi.memcheck +++ /dev/null @@ -1,50 +0,0 @@ -FROM fedora:35 - -RUN dnf -y update \ - && dnf install -y sudo \ - && adduser test_user \ - && echo "test_user ALL=(root) NOPASSWD:ALL" > /etc/sudoers.d/test_user \ - && chmod 0440 /etc/sudoers.d/test_user - -USER test_user -WORKDIR /home/test_user - -RUN sudo dnf -y install \ - openmpi-devel \ - gcc-fortran \ - gcc-c++ \ - gcc \ - gdb \ - git \ - netcdf-fortran-devel \ - cmake \ - make \ - lcov \ - python3 \ - python3-pip \ - valgrind-openmpi \ - lapack-devel \ - yaml-cpp-devel \ - && sudo dnf clean all - -ENV PATH="${PATH}:/usr/lib64/openmpi/bin/" -ENV OMP_NUM_THREADS=5 - -RUN pip3 install numpy scipy - -# build the tuv-x tool -COPY . tuv-x/ -RUN mkdir build \ - && cd build \ - && cmake -D CMAKE_BUILD_TYPE=debug \ - -D CMAKE_Fortran_COMPILER=/usr/lib64/openmpi/bin/mpif90 \ - -D CMAKE_C_COMPILER=/usr/lib64/openmpi/bin/mpicc \ - -D CMAKE_CXX_COMPILER=/usr/lib64/openmpi/bin/mpicxx \ - -D ENABLE_YAML=ON \ - -D ENABLE_OPENMP:BOOL=TRUE \ - -D ENABLE_MPI:BOOL=TRUE \ - -D ENABLE_MEMCHECK:BOOL=TRUE \ - ../tuv-x \ - && make -j 8 - -WORKDIR /home/test_user/build diff --git a/README.md b/README.md index 28eb9c4a..a775bd76 100644 --- a/README.md +++ b/README.md @@ -10,7 +10,7 @@ Tropospheric ultraviolet-extended (TUV-x): A photolysis rate calculator [![DOI](https://zenodo.org/badge/396946468.svg)](https://zenodo.org/badge/latestdoi/396946468) [![](https://img.shields.io/badge/Contribute%20with-Gitpod-908a85?logo=gitpod)](https://gitpod.io/#https://github.com/NCAR/tuv-x) -Copyright (C) 2020 National Center for Atmospheric Research +Copyright (C) 2020-4 National Center for Atmospheric Research # Try it out! @@ -22,7 +22,7 @@ a tutorial on how to use TUV-x. # Building and installing To build and install TUV-x locally, you must have the following libraries installed: -- [json-fortran](https://github.com/jacobwilliams/json-fortran) +- [yaml-cpp](https://github.com/jbeder/yaml-cpp/) - [NetCDF](https://www.unidata.ucar.edu/software/netcdf/) (both C and Fortran libraries) You must also have CMake installed on your machine. @@ -185,4 +185,4 @@ installation and usage instructions. # License - [Apache 2.0](/LICENSE) -- Copyright (C) 2022 National Center for Atmospheric Research +- Copyright (C) 2020-4 National Center for Atmospheric Research diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 46430c5d..23e8a8cd 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -1,3 +1,6 @@ +find_package(PkgConfig REQUIRED) +include(FetchContent) + ################################################################################ # LAPACK @@ -43,23 +46,14 @@ find_package(PkgConfig REQUIRED) pkg_check_modules(netcdff IMPORTED_TARGET REQUIRED netcdf-fortran) ################################################################################ -# musica-core library - -if(${CMAKE_VERSION} VERSION_LESS "3.24") - find_package(musicacore REQUIRED) -else() - include(FetchContent) +# yaml-cpp - set(ENABLE_UTIL_ONLY ON) - - FetchContent_Declare(musicacore - GIT_REPOSITORY https://github.com/NCAR/musica-core.git - GIT_TAG v0.4.3 - FIND_PACKAGE_ARGS NAMES musicacore - ) - - FetchContent_MakeAvailable(musicacore) -endif() +FetchContent_Declare( + yaml-cpp + GIT_REPOSITORY https://github.com/jbeder/yaml-cpp/ + GIT_TAG 0.8.0 +) +FetchContent_MakeAvailable(yaml-cpp) ################################################################################ # Docs diff --git a/cmake/test_util.cmake b/cmake/test_util.cmake index e1bffb9b..e3a5b728 100644 --- a/cmake/test_util.cmake +++ b/cmake/test_util.cmake @@ -25,7 +25,7 @@ function(create_standard_test) include(CMakeParseArguments) cmake_parse_arguments(${prefix} " " "${singleValues}" "${multiValues}" ${ARGN}) add_executable(test_${TEST_NAME} ${TEST_SOURCES}) - target_link_libraries(test_${TEST_NAME} PUBLIC musica::tuvx tuvx_test_utils musica::musicacore ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES}) + target_link_libraries(test_${TEST_NAME} PUBLIC musica::tuvx tuvx_test_utils ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES}) if(ENABLE_OPENMP) target_link_libraries(test_${TEST_NAME} PUBLIC OpenMP::OpenMP_Fortran) endif() @@ -48,7 +48,7 @@ function(add_tuvx_test test_name test_binary test_args working_dir) COMMAND ${test_binary} ${test_args} WORKING_DIRECTORY ${working_dir}) endif() - set(MEMORYCHECK_COMMAND_OPTIONS "--error-exitcode=1 --trace-children=yes --leak-check=full --gen-suppressions=all ${MEMCHECK_SUPPRESS}") + set(MEMORYCHECK_COMMAND_OPTIONS "--error-exitcode=1 --trace-children=yes --leak-check=full -s --gen-suppressions=all ${MEMCHECK_SUPPRESS}") set(memcheck "${MEMORYCHECK_COMMAND} ${MEMORYCHECK_COMMAND_OPTIONS}") separate_arguments(memcheck) if(ENABLE_MPI AND MEMORYCHECK_COMMAND AND ENABLE_MEMCHECK) @@ -77,5 +77,16 @@ function(add_regression_test test_name command memcheck_command) endfunction(add_regression_test) +################################################################################ +# Link tuv-x to a test and add it to the suite as a bash script + +macro(add_std_test_script test_name script_path) + target_include_directories(${test_name} PUBLIC ${CMAKE_BINARY_DIR}/src) + target_link_libraries(${test_name} PUBLIC musica::tuvx) + if(ENABLE_OPENMP) + target_link_libraries(${test_name} PUBLIC OpenMP::OpenMP_Fortran) + endif() + add_test(NAME ${test_name} COMMAND ${script_path}) +endmacro(add_std_test_script) ################################################################################ diff --git a/include/util/config_yaml.h b/include/util/config_yaml.h new file mode 100644 index 00000000..7fcd6111 --- /dev/null +++ b/include/util/config_yaml.h @@ -0,0 +1,285 @@ +// Copyright (C) 2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include + +#ifdef __cplusplus +#include + +extern "C" { + typedef YAML::Node Yaml; + typedef YAML::iterator YamlIterator; +#endif + +/// @brief Interoperatble string type +struct string_t { + char* ptr_; + int size_; +}; + +/// @brief Interoperable array type for strings +struct string_array_t { + string_t* ptr_; + int size_; +}; + +/// @brief Interoperable array type for doubles +struct double_array_t { + double* ptr_; + int size_; +}; + +/// @brief Interoperable array type for YAML nodes +struct node_array_t { + Yaml** ptr_; + int size_; +}; + +/// @brief Creates a YAML node from a string +/// @param yaml_string YAML in string form +/// @return pointer to the new YAML node +Yaml* yaml_create_from_string(const char* yaml_string); + +/// @brief Creates a YAML node from a YAML file +/// @param file_path path to the YAML file +/// @return pointer to the new YAML node +Yaml* yaml_create_from_file(const char* file_path); + +/// @brief Outputs a YAML node to a file +/// @param node YAML node to output +/// @param file_path path to file to create (any existing file will be overwritten) +void yaml_to_file(Yaml* node, const char* file_path); + +/// @brief Returns the number of child elements in the node +/// This works for vectors and maps +/// @param node YAML node to return size of +/// @return number of node elements +int yaml_size(Yaml* node); + +/// @brief Returns an iterator to the first child node +/// @param node YAML node to iterate over +/// @return beginning iterator +YamlIterator* yaml_begin(Yaml* node); + +/// @brief Returns an iterator to one element past the last child node +/// @param node YAML node to iterator over +/// @return ending iterator +YamlIterator* yaml_end(Yaml* node); + +/// @brief Increments a YAML iterator +/// @param iter YAML iterator to increment +/// @param end YAML iterator one element past end +/// @return true if incremented iter < end, false otherwise +bool yaml_increment(YamlIterator* iter, YamlIterator* end); + +/// @brief Checks if a YAML iterator is at the end +/// @param iter YAML iterator to check +/// @param end YAML iterator one element past end +/// @return true if iter == end, false otherwise +bool yaml_at_end(YamlIterator* iter, YamlIterator* end); + +/// @brief Returns the key associated with a YAML iterator +/// @param iter YAML iterator to return key for +/// @return key as a c string +string_t yaml_key(YamlIterator* iter); + +/// @brief Returns a sub-node +/// @param node parent YAML node +/// @param key key to find +/// @param found true if successful, false otherwise +/// @return sub-node +Yaml* yaml_get_node(Yaml* node, const char* key, bool& found); + +/// @brief Gets a string from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return Pointer to string as const char array +string_t yaml_get_string(Yaml* node, const char* key, bool& found); + +/// @brief Gets an integer from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return integer value +int yaml_get_int(Yaml* node, const char* key, bool& found); + +/// @brief Gets a float from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return float value +float yaml_get_float(Yaml* node, const char* key, bool& found); + +/// @brief Gets a double from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return double value +double yaml_get_double(Yaml* node, const char* key, bool& found); + +/// @brief Gets a boolean from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return boolean value +bool yaml_get_bool(Yaml* node, const char* key, bool& found); + +/// @brief Gets an array of strings from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return string array +string_array_t yaml_get_string_array(Yaml* node, const char* key, bool& found); + +/// @brief Gets an array of doubles from a YAML node +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return double array +double_array_t yaml_get_double_array(Yaml* node, const char* key, bool& found); + +/// @brief Gets an array of YAML nodes from a YAML node +/// @details It is expected that the caller takes ownership of the individual +/// pointers to YAML nodes in the array +/// @param node YAML node +/// @param key key to search for +/// @param found true if successful, false otherwise +/// @return node array +node_array_t yaml_get_node_array(Yaml* node, const char* key, bool& found); + +/// @brief Gets a node from a YAML iterator +/// @param iter YAML iterator +/// @return YAML node +Yaml* yaml_get_node_from_iterator(YamlIterator* iter); + +/// @brief Gets a string from a YAML iterator +/// @param iter YAML iterator +/// @return string as a c string +string_t yaml_get_string_from_iterator(YamlIterator* iter); + +/// @brief Gets an int from a YAML iterator +/// @param iter YAML iterator +/// @return integer value +int yaml_get_int_from_iterator(YamlIterator* iter); + +/// @brief Gets a float from a YAML iterator +/// @param iter YAML iterator +/// @return float value +float yaml_get_float_from_iterator(YamlIterator* iter); + +/// @brief Gets a double from a YAML iterator +/// @param iter YAML iterator +/// @return double value +double yaml_get_double_from_iterator(YamlIterator* iter); + +/// @brief Gets a boolean from a YAML iterator +/// @param iter YAML iterator +/// @return boolean value +bool yaml_get_bool_from_iterator(YamlIterator* iter); + +/// @brief Gets an array of strings from a YAML iterator +/// @param iter YAML iterator +/// @return string array +string_array_t yaml_get_string_array_from_iterator(YamlIterator* iter); + +/// @brief Adds a YAML node to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value YAML node to add +void yaml_add_node(Yaml* node, const char* key, Yaml* value); + +/// @brief Adds a string to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value string to add +void yaml_add_string(Yaml* node, const char* key, const char* value); + +/// @brief Adds an int to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value integer to add +void yaml_add_int(Yaml* node, const char* key, int value); + +/// @brief Adds a float to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value float to add +void yaml_add_float(Yaml* node, const char* key, float value); + +/// @brief Adds a double to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value double to add +void yaml_add_double(Yaml* node, const char* key, double value); + +/// @brief Adds a boolean to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value boolean to add +void yaml_add_bool(Yaml* node, const char* key, bool value); + +/// @brief Adds an array of strings to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value string array to add +void yaml_add_string_array(Yaml* node, const char* key, string_array_t value); + +/// @brief Adds an array of doubles to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value double array to add +void yaml_add_double_array(Yaml* node, const char* key, double_array_t value); + +/// @brief Adds an array of YAML nodes to a YAML node +/// @param node YAML node +/// @param key key to apply value to +/// @param value node array to add +void yaml_add_node_array(Yaml* node, const char* key, node_array_t value); + +/// @brief Copies a YAML node +/// @param node YAML node to copy +/// @return pointer to the new YAML node +Yaml* yaml_copy_node(Yaml* node); + +/// @brief Copies a YAML node to a string +/// @param node YAML node to copy +/// @return pointer to the new string +string_t yaml_to_string(Yaml* node); + +/// @brief Merges one YAML node into another +/// @param dest destination YAML node +/// @param src source YAML node +/// @return true if successful, false otherwise +bool yaml_merge_node(Yaml* dest, const Yaml* src); + +/// @brief Cleans up memory for a YAML node +/// @param ptr Node pointer to free memory for +void yaml_delete_node(Yaml* ptr); + +/// @brief Cleans up memory for a char array +/// @param string String to free memory for +void yaml_delete_string(string_t string); + +/// @brief Cleans up memory for an array of strings +/// @param array array to free memory for +void yaml_delete_string_array(string_array_t array); + +/// @brief Cleans up memory for an array of doubles +/// @param array array to free memory for +void yaml_delete_double_array(double_array_t array); + +/// @brief Cleans up memory for an array of YAML nodes +/// @details It is expected that the caller retains ownership of the +/// individual node pointers in the array +/// @param array array to free memory for +void yaml_delete_node_array(node_array_t array); + +/// @brief Cleans up memory for a YAML iterator +/// @param ptr Iterator to free memory for +void yaml_delete_iterator(YamlIterator* ptr); + +#ifdef __cplusplus +} +#endif \ No newline at end of file diff --git a/packaging/CMakeLists.txt b/packaging/CMakeLists.txt index 59973b4f..430f418e 100644 --- a/packaging/CMakeLists.txt +++ b/packaging/CMakeLists.txt @@ -11,6 +11,14 @@ install( RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} ) +# install yaml-cpp +install( + TARGETS + yaml-cpp + EXPORT + tuvx_Exports +) + # install the mod files install( DIRECTORY diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index bb185d68..741992a8 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -7,15 +7,20 @@ set_target_properties(tuvx_object PROPERTIES Fortran_MODULE_DIRECTORY ${TUVX_MOD_DIR} ) +target_include_directories(tuvx_object + PUBLIC + $ + $ +) + message(INFO "lapack libraries: ${LAPACK_LIBRARIES}") target_link_libraries(tuvx_object PUBLIC - musica::musicacore PkgConfig::netcdff + yaml-cpp::yaml-cpp ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES} - ${JSON_LIB} ) # tuvx library @@ -28,10 +33,20 @@ set_target_properties(tuvx PROPERTIES SOVERSION ${PROJECT_VERSION_MAJOR} ) +target_link_libraries(tuvx + PUBLIC + PkgConfig::netcdff + yaml-cpp::yaml-cpp + ${BLAS_LIBRARIES} + ${LAPACK_LIBRARIES} +) + target_include_directories(tuvx PUBLIC $ + $ $ + $ ) target_sources(tuvx_object @@ -71,6 +86,6 @@ add_subdirectory(profiles) add_subdirectory(quantum_yields) add_subdirectory(radiative_transfer) add_subdirectory(spectral_weights) - +add_subdirectory(util) ################################################################################ diff --git a/src/cross_sections/o3_tint.F90 b/src/cross_sections/o3_tint.F90 index 826bacfd..9e485ae8 100644 --- a/src/cross_sections/o3_tint.F90 +++ b/src/cross_sections/o3_tint.F90 @@ -157,7 +157,7 @@ function constructor( config, grid_warehouse, profile_warehouse ) & monopos = all( Xsection%deltaT > rZERO ) if( .not. monopos ) then if( any( Xsection%deltaT > rZERO ) ) then - write(msg,*) Iam//'File: '//file_path// & + write(msg,*) Iam//'File: '//file_path%val_// & ' temperature array not monotonic' call die_msg( 175583000, msg ) endif diff --git a/src/util/CMakeLists.txt b/src/util/CMakeLists.txt new file mode 100644 index 00000000..4d0e4407 --- /dev/null +++ b/src/util/CMakeLists.txt @@ -0,0 +1,21 @@ +###################################################################### +# Utility source + +target_sources(tuvx_object + PRIVATE + array.F90 + assert.F90 + config.F90 + config.cpp + constants.F90 + iterator.F90 + io.F90 + map.F90 + mpi.F90 + string.F90 + yaml_util.F90 +) + +add_subdirectory(io) + +###################################################################### diff --git a/src/util/array.F90 b/src/util/array.F90 new file mode 100644 index 00000000..18e3c40c --- /dev/null +++ b/src/util/array.F90 @@ -0,0 +1,368 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_array module + +!> Functions for working with allocatable arrays +module musica_array + + use musica_constants, only : musica_ik, musica_dk + + implicit none + private + + public :: find_string_in_array, find_string_in_split_array, & + merge_series, calculate_linear_array, calculate_logarithmic_array + + ! Find a string in an array of strings + interface find_string_in_array + module procedure :: find_string_in_array_string + module procedure :: find_string_in_array_char + end interface find_string_in_array + + ! Find a string in an array of split strings + interface find_string_in_split_array + module procedure :: find_string_in_split_array_string + module procedure :: find_string_in_split_array_char + end interface find_string_in_split_array + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finds a string in a string array (case insensitive by default) + logical function find_string_in_array_char( array, string, id, & + case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + character(len=*), intent(in) :: string + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + type(string_t) :: temp_string, array_string + integer :: i_str + logical :: is_case_sensitive + + is_case_sensitive = .false. + if( present( case_sensitive ) ) then + is_case_sensitive = case_sensitive + end if + id = 0 + find_string_in_array_char = .false. + temp_string = trim( string ) + if( .not. is_case_sensitive ) temp_string = temp_string%to_lower( ) + do i_str = 1, size( array ) + array_string = array( i_str ) + if( .not. is_case_sensitive ) array_string = array_string%to_lower( ) + if( temp_string .eq. array_string ) then + id = i_str + find_string_in_array_char = .true. + exit + end if + end do + + end function find_string_in_array_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finds a string in an array ( case insensitive by default) + logical function find_string_in_array_string( array, string, id, & + case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + type(string_t), intent(in) :: string + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + find_string_in_array_string = find_string_in_array_char( array, & + string%to_char( ), id, case_sensitive ) + + end function find_string_in_array_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Find a string in an array of strings after splitting the array elements + !! + !! Case insensitive by default + logical function find_string_in_split_array_char( array, string, splitter, & + element_id, id, case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + character(len=*), intent(in) :: string + !> Splitting characters + character(len=*), intent(in) :: splitter + !> Element to compare in split strings + integer(kind=musica_ik), intent(in) :: element_id + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + type(string_t) :: temp_string, array_string + type(string_t), allocatable :: split_string(:) + integer :: i_str + logical :: is_case_sensitive + + is_case_sensitive = .false. + if( present( case_sensitive ) ) then + is_case_sensitive = case_sensitive + end if + id = 0 + find_string_in_split_array_char = .false. + temp_string = trim( string ) + if( .not. is_case_sensitive ) temp_string = temp_string%to_lower( ) + do i_str = 1, size( array ) + array_string = array( i_str ) + if( .not. is_case_sensitive ) array_string = array_string%to_lower( ) + split_string = array_string%split( splitter ) + if( size( split_string ) .ge. element_id ) then + array_string = split_string( element_id ) + else + cycle + end if + if( temp_string .eq. array_string ) then + id = i_str + find_string_in_split_array_char = .true. + exit + end if + end do + + end function find_string_in_split_array_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Find a string in an array of strings after splitting the array elements + !! + !! Case insensitive by default + logical function find_string_in_split_array_string( array, string, splitter, & + element_id, id, case_sensitive ) + + use musica_string, only : string_t + + !> Array to search + type(string_t), intent(in) :: array(:) + !> String to search for + type(string_t), intent(in) :: string + !> Splitting characters + character(len=*), intent(in) :: splitter + !> Element to compare in split strings + integer(kind=musica_ik), intent(in) :: element_id + !> Index of located string + integer(kind=musica_ik), intent(out) :: id + !> Do a case sensitive search + logical, intent(in), optional :: case_sensitive + + find_string_in_split_array_string = & + find_string_in_split_array_char( array, string%to_char( ), splitter, & + element_id, id, case_sensitive ) + + end function find_string_in_split_array_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Merge two sets of values into a single set without duplicates + !! + !! Both sets must be arranged in increasing order + !! + function merge_series( a, b, with_bounds_from ) result( new_set ) + + !> New series + real(kind=musica_dk), allocatable :: new_set(:) + !> First series + real(kind=musica_dk), intent(in) :: a(:) + !> Second series + real(kind=musica_dk), intent(in) :: b(:) + !> Restricts series to bounds in this array + real(kind=musica_dk), intent(in), optional :: with_bounds_from(:) + + real(kind=musica_dk) :: curr_val, val_a, val_b, min_val, max_val + integer :: n_total, i_a, i_b, n_a, n_b + + if( present( with_bounds_from ) ) then + min_val = with_bounds_from( 1 ) + max_val = with_bounds_from( size( with_bounds_from ) ) + else + min_val = -huge( 0.0_musica_dk ) + max_val = huge( 0.0_musica_dk ) + endif + + n_a = size( a ) + n_b = size( b ) + if( n_a + n_b .eq. 0 ) then + allocate( new_set( 0 ) ) + return + end if + + curr_val = huge( 1.0_musica_dk ) + if( n_a .gt. 0 ) curr_val = a( 1 ) + if( n_b .gt. 0 ) then + if( b( 1 ) .lt. curr_val ) curr_val = b( 1 ) + end if + if( curr_val .lt. min_val ) curr_val = min_val + if( curr_val .gt. max_val ) curr_val = max_val + + i_a = 1 + i_b = 1 + n_total = 0 + do while( i_a .le. n_a ) + if( a( i_a ) .ge. min_val ) exit + i_a = i_a + 1 + end do + do while( i_b .le. n_b ) + if( b( i_b ) .ge. min_val ) exit + i_b = i_b + 1 + end do + do while( i_a .le. n_a .or. i_b .le. n_b ) + if( i_a .le. n_a ) then + val_a = a( i_a ) + if( val_a .gt. max_val ) then + i_a = n_a + 1 + cycle + end if + else + val_a = huge( 1.0_musica_dk ) + end if + if( i_b .le. n_b ) then + val_b = b( i_b ) + if( val_b .gt. max_val ) then + i_b = n_b + 1 + cycle + end if + else + val_b = huge( 1.0_musica_dk ) + end if + curr_val = min( val_a, val_b ) + n_total = n_total + 1 + if( val_a .le. curr_val ) i_a = i_a + 1 + if( val_b .le. curr_val ) i_b = i_b + 1 + end do + + allocate( new_set( n_total ) ) + + i_a = 1 + i_b = 1 + n_total = 0 + do while( i_a .le. n_a ) + if( a( i_a ) .ge. min_val ) exit + i_a = i_a + 1 + end do + do while( i_b .le. n_b ) + if( b( i_b ) .ge. min_val ) exit + i_b = i_b + 1 + end do + do while( i_a .le. n_a .or. i_b .le. n_b ) + if( i_a .le. n_a ) then + val_a = a( i_a ) + if( val_a .gt. max_val ) then + i_a = n_a + 1 + cycle + end if + else + val_a = huge( 1.0_musica_dk ) + end if + if( i_b .le. n_b ) then + val_b = b( i_b ) + if( val_b .gt. max_val ) then + i_b = n_b + 1 + cycle + end if + else + val_b = huge( 1.0_musica_dk ) + end if + curr_val = min( val_a, val_b ) + n_total = n_total + 1 + new_set( n_total ) = curr_val + if( val_a .le. curr_val ) i_a = i_a + 1 + if( val_b .le. curr_val ) i_b = i_b + 1 + end do + + end function merge_series + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Allocates and calculates an array of linearly increasing value with + !! specified minimum and maximum values and number of elements + function calculate_linear_array( minimum, maximum, number_of_elements ) & + result( new_array ) + + use musica_assert, only : assert + + !> Calculated array + real(kind=musica_dk), allocatable :: new_array(:) + !> Minimum array value + real(kind=musica_dk), intent(in) :: minimum + !> Maximum array value + real(kind=musica_dk), intent(in) :: maximum + !> Number of array elements + integer(kind=musica_ik), intent(in) :: number_of_elements + + integer(kind=musica_ik) :: i_elem + real(kind=musica_dk) :: space + + call assert( 167917803, maximum .gt. minimum ) + call assert( 211868975, number_of_elements .ge. 1 ) + allocate( new_array( number_of_elements ) ) + space = ( maximum - minimum ) / & + real( number_of_elements - 1, kind=musica_dk ) + new_array( 1 ) = minimum + do i_elem = 2, number_of_elements - 1 + new_array( i_elem ) = new_array( i_elem - 1 ) + space + end do + new_array( number_of_elements ) = maximum + + end function calculate_linear_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Allocates and calculates an array of logarithmically increasing value + !! with specified minimum and maximum values and number of elements + function calculate_logarithmic_array( minimum, maximum, number_of_elements )& + result( new_array ) + + use musica_assert, only : assert + + !> Calculated array + real(kind=musica_dk), allocatable :: new_array(:) + !> Minimum array value + real(kind=musica_dk), intent(in) :: minimum + !> Maximum array value + real(kind=musica_dk), intent(in) :: maximum + !> Number of array elements + integer(kind=musica_ik), intent(in) :: number_of_elements + + integer(kind=musica_ik) :: i_elem + real(kind=musica_dk) :: space + + call assert( 527530853, maximum .gt. minimum ) + call assert( 752167543, number_of_elements .gt. 1 ) + allocate( new_array( number_of_elements ) ) + space = ( log( maximum ) - log( minimum ) ) / & + real( number_of_elements - 1, kind=musica_dk ) + new_array( 1 ) = minimum + do i_elem = 2, number_of_elements - 1 + new_array( i_elem ) = exp( log( new_array( i_elem - 1 ) ) + space ) + end do + new_array( number_of_elements ) = maximum + + end function calculate_logarithmic_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_array diff --git a/src/util/assert.F90 b/src/util/assert.F90 new file mode 100644 index 00000000..84e4fdb2 --- /dev/null +++ b/src/util/assert.F90 @@ -0,0 +1,478 @@ +! Portions Copyright (C) 2005-2016 Nicole Riemer and Matthew West +! Licensed under the GNU General Public License version 2 or (at your +! option) any later version. See the file COPYING for details. +! +! Portions Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_assert module. + +!> Assertion functions +module musica_assert + + implicit none + + !> Unit for error output files + integer, parameter :: kErrorFileId = 10 + !> Error output id + integer, parameter :: kErrorId = 0 + + interface assert_msg + procedure :: assert_msg_string + procedure :: assert_msg_char + end interface + + interface assert_warn_msg + procedure :: assert_warn_msg_string + procedure :: assert_warn_msg_char + end interface + + interface die_msg + procedure :: die_msg_string + procedure :: die_msg_char + end interface + + interface almost_equal + procedure :: almost_equal_complex_real + procedure :: almost_equal_complex_double + procedure :: almost_equal_real + procedure :: almost_equal_double + end interface + + interface are_equal + procedure :: compare_arrays_1D_real + procedure :: compare_arrays_2D_real + procedure :: compare_arrays_1D_double + procedure :: compare_arrays_2D_double + end interface + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or fails with provided message + subroutine assert_msg_string( code, condition, error_message ) + + use musica_string, only : string_t + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + type(string_t), intent(in) :: error_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //error_message%val_ + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "'//error_message%val_//'"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert_msg_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or fails with provided message + subroutine assert_msg_char( code, condition, error_message ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + character(len=*), intent(in) :: error_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //error_message + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "'//error_message//'"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert_msg_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or fails + subroutine assert( code, condition ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + + call assert_msg( code, condition, 'assertion failed' ) + + end subroutine assert + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or prints a provided warning message + subroutine assert_warn_msg_string( code, condition, warning_message ) + + use musica_string, only : string_t + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + type(string_t), intent(in) :: warning_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "WARNING (Musica-"//trim( adjustl( str_code ) )// & + "): "//warning_message%val_ + end if + + end subroutine assert_warn_msg_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Asserts condition to be true or prints a provided warning message + subroutine assert_warn_msg_char( code, condition, warning_message ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + character(len=*), intent(in) :: warning_message + + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "WARNING (Musica-"//trim( adjustl( str_code ) )// & + "): "//warning_message + end if + + end subroutine assert_warn_msg_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Errors immediately and prints a provided message + subroutine die_msg_string( code, error_message ) + + use musica_string, only : string_t + + !> Unique code for the failure + integer, intent(in) :: code + !> Message to display with failure + type(string_t), intent(in) :: error_message + + call assert_msg( code, .false., error_message ) + + end subroutine die_msg_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Errors immediately and prints a provided message + subroutine die_msg_char( code, error_message ) + + !> Unique code for the failure + integer, intent(in) :: code + !> Message to display with failure + character(len=*), intent(in) :: error_message + + call assert_msg( code, .false., error_message ) + + end subroutine die_msg_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Errors immediately + subroutine die( code ) + + !> Unique code for the failure + integer, intent(in) :: code + + call die_msg( code, "Internal error" ) + + end subroutine die + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two real numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_real( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_rk + + !> First number to compare + real(kind=musica_rk), intent(in) :: a + !> Second number to compare + real(kind=musica_rk), intent(in) :: b + !> Relative tolerance + real(kind=musica_rk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_rk), intent(in), optional :: absolute_tolerance + + real(kind=musica_rk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_rk + abs_tol = 1.0e-30_musica_rk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + if( 2.0_musica_rk * abs( a - b ) / ( abs( a ) + abs( b ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( abs( a - b ) .le. abs_tol ) then + almost_equal = .true. + end if + end if + + end function almost_equal_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two real numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_double( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_dk + + !> First number to compare + real(kind=musica_dk), intent(in) :: a + !> Second number to compare + real(kind=musica_dk), intent(in) :: b + !> Relative tolerance + real(kind=musica_dk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_dk), intent(in), optional :: absolute_tolerance + + real(kind=musica_dk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_dk + abs_tol = 1.0e-30_musica_dk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + if( 2.0_musica_dk * dabs( a - b ) / ( dabs( a ) + dabs( b ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( dabs( a - b ) .le. abs_tol ) then + almost_equal = .true. + end if + end if + + end function almost_equal_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two complex numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_complex_real( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_rk + + !> First number to compare + complex(kind=musica_rk), intent(in) :: a + !> Second number to compare + complex(kind=musica_rk), intent(in) :: b + !> Relative tolerance + real(kind=musica_rk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_rk), intent(in), optional :: absolute_tolerance + + real(kind=musica_rk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_rk + abs_tol = 1.0e-30_musica_rk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + associate( ra => real( a ), ia => aimag( a ), & + rb => real( b ), ib => aimag( b ) ) + if( 2.0_musica_rk * abs( ra - rb ) / ( abs( ra ) + abs( rb ) ) & + .lt. rel_tol .and. & + 2.0_musica_rk * abs( ia - ib ) / ( abs( ia ) + abs( ib ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( abs( ra - rb ) .le. abs_tol .and. & + abs( ia - ib ) .le. abs_tol ) then + almost_equal = .true. + end if + end associate + end if + + end function almost_equal_complex_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Determines whether two complex numbers are equal within a provided or + !! standard tolerance + logical function almost_equal_complex_double( a, b, relative_tolerance, & + absolute_tolerance ) result( almost_equal ) + + use musica_constants, only : musica_dk + + !> First number to compare + complex(kind=musica_dk), intent(in) :: a + !> Second number to compare + complex(kind=musica_dk), intent(in) :: b + !> Relative tolerance + real(kind=musica_dk), intent(in), optional :: relative_tolerance + !> Absolute tolerance + real(kind=musica_dk), intent(in), optional :: absolute_tolerance + + real(kind=musica_dk) :: rel_tol, abs_tol + + rel_tol = 1.0e-10_musica_dk + abs_tol = 1.0e-30_musica_dk + if( present( relative_tolerance ) ) rel_tol = relative_tolerance + if( present( absolute_tolerance ) ) abs_tol = absolute_tolerance + + almost_equal = .false. + if( a .eq. b ) then + almost_equal = .true. + else + associate( ra => real( a, kind=musica_dk ), ia => aimag( a ), & + rb => real( b, kind=musica_dk ), ib => aimag( b ) ) + if( 2.0_musica_dk * dabs( ra - rb ) / ( dabs( ra ) + dabs( rb ) ) & + .lt. rel_tol .and. & + 2.0_musica_dk * dabs( ia - ib ) / ( dabs( ia ) + dabs( ib ) ) & + .lt. rel_tol ) then + almost_equal = .true. + else if( dabs( ra - rb ) .le. abs_tol .and. & + dabs( ia - ib ) .le. abs_tol ) then + almost_equal = .true. + end if + end associate + end if + + end function almost_equal_complex_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 1D arrays for equality + logical pure function compare_arrays_1D_real( a, b ) result( equal ) + + use musica_constants, only : musica_rk + + !> First array to compare + real(kind=musica_rk), intent(in) :: a(:) + !> Second array to compare + real(kind=musica_rk), intent(in) :: b(:) + + integer :: i_elem + + equal = .false. + if( size( a ) .ne. size( b ) ) return + do i_elem = 1, size( a ) + if( a( i_elem ) .ne. b( i_elem ) ) return + end do + equal = .true. + + end function compare_arrays_1D_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 2D arrays for equality + logical pure function compare_arrays_2D_real( a, b ) result( equal ) + + use musica_constants, only : musica_rk + + !> First array to compare + real(kind=musica_rk), intent(in) :: a(:,:) + !> Second array to compare + real(kind=musica_rk), intent(in) :: b(:,:) + + integer :: i_elem + + equal = .false. + if( size( a, 1 ) .ne. size( b, 1 ) ) return + if( size( a, 2 ) .ne. size( b, 2 ) ) return + do i_elem = 1, size( a, 1 ) + if( .not. compare_arrays_1D_real( a(:,i_elem), b(:,i_elem) ) ) return + end do + equal = .true. + + end function compare_arrays_2D_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 1D arrays for equality + logical pure function compare_arrays_1D_double( a, b ) result( equal ) + + use musica_constants, only : musica_dk + + !> First array to compare + real(kind=musica_dk), intent(in) :: a(:) + !> Second array to compare + real(kind=musica_dk), intent(in) :: b(:) + + integer :: i_elem + + equal = .false. + if( size( a ) .ne. size( b ) ) return + do i_elem = 1, size( a ) + if( a( i_elem ) .ne. b( i_elem ) ) return + end do + equal = .true. + + end function compare_arrays_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares two 2D arrays for equality + logical pure function compare_arrays_2D_double( a, b ) result( equal ) + + use musica_constants, only : musica_dk + + !> First array to compare + real(kind=musica_dk), intent(in) :: a(:,:) + !> Second array to compare + real(kind=musica_dk), intent(in) :: b(:,:) + + integer :: i_elem + + equal = .false. + if( size( a, 1 ) .ne. size( b, 1 ) ) return + if( size( a, 2 ) .ne. size( b, 2 ) ) return + do i_elem = 1, size( a, 1 ) + if( .not. compare_arrays_1D_double( a(:,i_elem), b(:,i_elem) ) ) return + end do + equal = .true. + + end function compare_arrays_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_assert diff --git a/src/util/config.F90 b/src/util/config.F90 new file mode 100644 index 00000000..b9480ddb --- /dev/null +++ b/src/util/config.F90 @@ -0,0 +1,1569 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_config module + +!> The config_t type and related functions +module musica_config + + use iso_c_binding + use musica_constants, only : musica_ik, musica_rk, musica_dk + use musica_iterator, only : iterator_t + use musica_yaml_util + + implicit none + private + + public :: config_t + + !> Model configuration data + !! + !! Instances of type \c config_t can be used to access model configuration + !! data in \c json format. If there is a need to use model configuration + !! in another format (e.g., XML) in the future, an abstract \c config_t + !! type could be set up, that this type and an XML-based type could extend. + !! The rest of the model code would be unaffected. + !! + !! It is assumed that most configuration datasets will be small enough that + !! returned subsets of configuration data can just be a copy of the original + !! data (instead of using a pointer to the start of the subset in the original + !! dataset, or something like this). This avoids ownership problems with + !! cleaning up the memory after a \c config_t object goes out of scope. + !! + !! Only use \c config_t objects during initialization. They are not designed + !! for efficiency. + !! + !! **IMPORTANT:** The order of elements is arbitrary. No user of a \c config_t + !! object can assume anything by the order of key-value pairs in the data. + !! This dataset: + !! \code{yaml} + !! foo: 1 + !! bar: 2 + !! foobar: 3 + !! \endcode + !! ... is the same as: + !! \code{yaml} + !! bar: 2 + !! foobar: 3 + !! foo: 1 + !! \endcode + !! + !! There is no guarantee that an iterator over the elements of a config_t + !! object will return them in the same order they exist in the original + !! file or string. + !! + !! Example of a config_t object generated from a file: + !! \code{f90} + !! use musica_config, only : config_t + !! use musica_constants, only : musica_dk, musica_ik + !! use musica_iterator, only : iterator_t + !! use musica_string, only : string_t + !! + !! character(len=*), parameter :: my_name = "config file example" + !! type(config_t) :: main_config, sub_config, sub_real_config + !! real(musica_dk) :: my_real + !! integer(musica_ik) :: my_int + !! type(string_t) :: my_string + !! class(iterator_t), pointer :: iter + !! logical :: found + !! + !! call main_config%from_file( 'data/config_example.yaml' ) + !! + !! ! this would fail with an error if 'a string' is not found + !! call main_config%get( "a string", my_string, my_name ) + !! write(*,*) "a string value: ", my_string + !! + !! ! add the found argument to avoid failure if the pair is not found + !! call main_config%get( "my int", my_int, my_name, found = found ) + !! if( found ) then + !! write(*,*) "my int value: ", my_int + !! else + !! write(*,*) "'my int' was not found" + !! end if + !! + !! ! when you get a subset of the properties, a new config_t object is + !! ! created containing the subset data. The two config_t objects are + !! ! independent of one another after this point. + !! call main_config%get( "other props", sub_config, my_name ) + !! call sub_config%get( "an int", my_int, my_name ) + !! write(*,*) "other props->an int value: ", my_int + !! + !! ! you can iterate over a set of key-value pairs. but remember that + !! ! the order is always arbitrary. you also must provide the right type + !! ! of variable for the values. + !! call main_config%get( "real props", sub_real_config, my_name ) + !! iter => sub_real_config%get_iterator( ) + !! do while( iter%next( ) ) + !! my_string = sub_real_config%key( iter ) + !! call sub_real_config%get( iter, my_real, my_name ) + !! write(*,*) my_string, " value: ", my_real + !! end do + !! + !! ! you can also get the number of child objects before iterating over + !! ! them, if you want to allocate an array or something first + !! write(*,*) "number of children: ", sub_real_config%number_of_children( ) + !! + !! ! you can add key-value pairs with the add function + !! call main_config%add( "my new int", 43, my_name ) + !! call main_config%get( "my new int", my_int, my_name ) + !! write(*,*) "my new int value: ", my_int + !! + !! ! clean up memory + !! deallocate( iter ) + !! \endcode + !! + !! `data/config_example.json`: + !! \code{yaml} + !! my int: 12 + !! other props: + !! some time [min]: 12 + !! a pressure [bar]: 103.4 + !! an int: 45 + !! real props: + !! foo: 14.2 + !! bar: 64.2 + !! foobar: 920.4 + !! a string: foo + !! \endcode + !! + !! Output: + !! \code{bash} + !! a string value: foo + !! my int value: 12 + !! other props->an int value: 45 + !! other props->some time value: 720.00000000000000 s + !! other props->a pressure value: 10340000.000000000 Pa + !! foo value: 14.199999999999999 + !! bar value: 64.200000000000003 + !! foobar value: 920.39999999999998 + !! number of children: 3 + !! my new int value: 43 + !! \endcode + !! + type :: config_t + private + !> Pointer to YAML node + type(c_ptr) :: node_ = c_null_ptr + contains + !> Empties the configuration + procedure :: empty + !> Loads a configuration with data from a file + procedure :: from_file => construct_from_file + !> Writes a configuration to a file + procedure :: to_file + !> Returns the number of child objects + procedure :: number_of_children + !> Gets an iterator for the configuration data + procedure :: get_iterator + !> Gets the key name for a key-value pair + procedure :: key + !> @name Gets some configuration data + !! + !! Each function includes optional \c found and \c default arguments. If + !! neither is included and the data are not found, execution is stopped + !! with an error message. + !! + !! If a \c default value is included and the data are not found, the + !! returned argument is set to this default value, otherwise it is set to + !! a standard default value. + !! + !! If the \c found argument is included and the data are found, \c found + !! is set to \c true, otherwise it is set to \c false. + !! @{ + procedure, private :: get_config + procedure, private :: get_string_string_default + procedure, private :: get_string + procedure, private :: get_int + procedure, private :: get_float + procedure, private :: get_double + procedure, private :: get_logical + procedure, private :: get_string_array + procedure, private :: get_double_array + procedure, private :: get_config_array + procedure, private :: get_from_iterator + procedure, private :: get_array_from_iterator + generic :: get => get_config, get_string, get_string_string_default, & + get_int, get_float, get_double, & + get_logical, get_string_array, get_double_array, & + get_config_array, get_from_iterator, & + get_array_from_iterator + !> @} + !> @name Adds a named piece of configuration data + !! @{ + procedure, private :: add_config + procedure, private :: add_char_array + procedure, private :: add_string + procedure, private :: add_int + procedure, private :: add_float + procedure, private :: add_double + procedure, private :: add_logical + procedure, private :: add_string_array + procedure, private :: add_double_array + procedure, private :: add_config_array + generic :: add => add_config, add_char_array, add_string, & + add_int, add_float, add_double, add_logical, & + add_string_array, add_double_array, add_config_array + !> @} + !> @name Assignment + !! @{ + procedure, private :: config_assign_config + procedure, private :: config_assign_string + procedure, private :: config_assign_char + procedure, private, pass(config) :: string_assign_config + generic :: assignment(=) => config_assign_config, config_assign_string, & + config_assign_char, string_assign_config + !> @} + !> Merges another config_t object into the config_t object + procedure :: merge_in + !> Validates the format of the configuration file + procedure :: validate + !> Print the raw contents of the configuration + procedure :: print => do_print + !> Returns the number of bytes required to pack the object onto a buffer + procedure :: pack_size + !> Packs the object onto a character buffer + procedure :: mpi_pack + !> Unpacks an object from a character buffer + procedure :: mpi_unpack + !> Cleans up memory + final :: finalize, finalize_1D_array + !> Find a JSON key by prefix + procedure, private :: find_by_prefix + end type config_t + + !> Configuration data iterator + type, extends(iterator_t) :: config_iterator_t + !> Pointer to the node to iterator over (owned by config_t) + type(c_ptr) :: node_ = c_null_ptr + !> Current iterator + type(c_ptr) :: curr_ = c_null_ptr + !> End pointer + type(c_ptr) :: end_ = c_null_ptr + contains + !> Advances to the next key-value pair + procedure :: next => iterator_next + !> Resets the iterator + procedure :: reset => iterator_reset + !> Clean up memory + final :: iterator_finalize + end type config_iterator_t + + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Empties the configuration + subroutine empty( this ) + + !> Configuration + class(config_t), intent(out) :: this + + call initialize_config_t( this ) + + end subroutine empty + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a configuration from a file + subroutine construct_from_file( this, file_name ) + + use musica_assert, only : die + + !> New configuration + class(config_t), intent(out) :: this + !> File name containing configuration data + character(len=*), intent(in) :: file_name + + character(len=1, kind=c_char), allocatable :: c_file_name(:) + + c_file_name = to_c_string( file_name ) + select type( this ) + type is( config_t ) + call finalize( this ) + class default + call die( 316253716 ) + end select + this%node_ = yaml_create_from_file_c( c_file_name ) + + end subroutine construct_from_file + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes a configuration to a file + subroutine to_file( this, file_name ) + + !> Configuration + class(config_t), intent(inout) :: this + !> File name to save configuration with + character(len=*), intent(in) :: file_name + + character(len=1, kind=c_char), allocatable :: c_file_name(:) + + c_file_name = to_c_string( file_name ) + call yaml_to_file_c( this%node_, c_file_name ) + + end subroutine to_file + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of child objects + function number_of_children( this ) + + use musica_assert, only : assert + + !> Number of child objects + integer(kind=musica_ik) :: number_of_children + !> Configuration + class(config_t), intent(inout) :: this + + number_of_children = yaml_size_c( this%node_ ) + + end function number_of_children + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an interator for the configuration data + function get_iterator( this ) + + use musica_assert, only : assert + + !> Pointer to the iterator + class(iterator_t), pointer :: get_iterator + !> Configuration + class(config_t), intent(in), target :: this + + call assert( 398295168, c_associated( this%node_ ) ) + allocate( config_iterator_t :: get_iterator ) + select type( iter => get_iterator ) + type is( config_iterator_t ) + iter%node_ = this%node_ + iter%end_ = yaml_end_c( this%node_ ) + iter%curr_ = c_null_ptr + end select + + end function get_iterator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets the key name using an iterator + function key( this, iterator ) + + use musica_assert, only : assert, die_msg + use musica_string, only : string_t + + !> Key name + type(string_t) :: key + !> Configuration + class(config_t), intent(inout) :: this + !> Configuration iterator + class(iterator_t), intent(in) :: iterator + + type(string_t_c) :: c_key + + select type( iterator ) + class is( config_iterator_t ) + c_key = yaml_key_c( iterator%curr_ ) + key = to_f_string( c_key ) + call yaml_delete_string_c( c_key ) + class default + call die_msg( 790805324, "Config iterator type mismatch" ) + end select + + end function key + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a subset of the configuration data + subroutine get_config( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + class(config_t), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + class(config_t), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value%node_ = yaml_get_node_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 859993455, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a string from the configuration data + subroutine get_string_string_default( this, key, value, caller, default, & + found ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + class(string_t), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + class(string_t), intent(in) :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + call get_string( this, key, value, caller, default = default%val_, & + found = found ) + + end subroutine get_string_string_default + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a string from the configuration data + subroutine get_string( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + class(string_t), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + character(len=*), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + type(string_t_c) :: c_value + + c_value = yaml_get_string_c( this%node_, to_c_string( key ), l_found ) + if( l_found ) then + value%val_ = to_f_string( c_value ) + call yaml_delete_string_c( c_value ) + end if + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 705088796, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an integer from the configuration data + subroutine get_int( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + integer(kind=musica_ik), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + integer(kind=musica_ik), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_int_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 689949329, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a single-precision real number from the configuration data + subroutine get_float( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + real(kind=musica_rk), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + real(kind=musica_rk), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_float_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 337653668, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_float + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a double-precision real number from the configuration data + subroutine get_double( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + real(kind=musica_dk), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + real(kind=musica_dk), intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_double_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 339559202, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a boolean value from the configuration data + subroutine get_logical( this, key, value, caller, default, found ) + + use musica_assert, only : die_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + logical, intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + logical, intent(in), optional :: default + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + logical(kind=c_bool) :: l_found + + value = yaml_get_bool_c( this%node_, to_c_string( key ), l_found ) + if( .not. l_found .and. present( default ) ) value = default + if( present( found ) ) then + found = l_found + return + end if + if( .not. l_found .and. .not. present( default ) ) then + call die_msg( 506357333, "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + end if + + end subroutine get_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array of strings from the configuration data + subroutine get_string_array( this, key, value, caller, default, found ) + + use musica_assert, only : assert, assert_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + type(string_t), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + type(string_t), intent(in), optional :: default(:) + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + type(string_array_t_c) :: c_array + integer(c_int) :: size, i + type(string_t_c), pointer :: c_strings(:) + logical(kind=c_bool) :: l_found + + c_array = yaml_get_string_array_c( this%node_, to_c_string( key ), & + l_found ) + call assert_msg( 469804765, l_found .or. present( default ) .or. & + present( found ), "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + if( present( found ) ) then + found = l_found + if( .not. l_found .and. .not. present( default ) ) return + end if + if( .not. l_found .and. present( default ) ) then + value = default + return + end if + call c_f_pointer( c_array%ptr_, c_strings, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + do i = 1, size( c_strings ) + value(i) = to_f_string( c_strings( i ) ) + end do + call yaml_delete_string_array_c( c_array ) + + end subroutine get_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array of doubles from the configuration data + subroutine get_double_array( this, key, value, caller, default, found ) + + use musica_assert, only : assert, assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + real(musica_dk), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + real(musica_dk), intent(in), optional :: default(:) + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + type(double_array_t_c) :: c_array + real(kind=c_double), pointer :: c_doubles(:) + integer :: i + logical(kind=c_bool) :: l_found + + c_array = yaml_get_double_array_c( this%node_, to_c_string( key ), & + l_found ) + call assert_msg( 507829003, l_found .or. present( default ) & + .or. present( found ), "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + if( present( found ) ) then + found = l_found + if( .not. l_found .and. .not. present( default ) ) return + end if + if( .not. l_found .and. present( default ) ) then + value = default + return + end if + call c_f_pointer( c_array%ptr_, c_doubles, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + value(:) = c_doubles(:) + call yaml_delete_double_array_c( c_array ) + + end subroutine get_double_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array of config_t objects + subroutine get_config_array( this, key, value, caller, default, found ) + + use musica_assert, only : assert, assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key used to find value + character(len=*), intent(in) :: key + !> Returned value + type(config_t), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + !> Default value if not found + type(config_t), intent(in), optional :: default(:) + !> Flag indicating whether key was found + logical, intent(out), optional :: found + + type(node_array_t_c) :: c_array + type(c_ptr), pointer :: c_nodes(:) + integer :: i + logical(kind=c_bool) :: l_found + + c_array = yaml_get_node_array_c( this%node_, to_c_string( key ), l_found ) + call assert_msg( 737497064, l_found .or. present( default ) & + .or. present( found ), "Key '"//trim( key )// & + "' requested by "//trim( caller )//" not found" ) + if( present( found ) ) then + found = l_found + if( .not. l_found .and. .not. present( default ) ) return + end if + if( .not. l_found .and. present( default ) ) then + value = default + return + end if + call c_f_pointer( c_array%ptr_, c_nodes, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + value(:)%node_ = c_nodes(:) + call yaml_delete_node_array_c( c_array ) + + end subroutine get_config_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a value using an iterator + subroutine get_from_iterator( this, iterator, value, caller ) + + use musica_assert, only : assert, die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Iterator to use to find value + class(iterator_t), intent(in) :: iterator + !> Returned value + class(*), intent(out) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(string_t_c) :: str + + select type( iterator ) + class is( config_iterator_t ) + select type( value ) + type is( config_t ) + value%node_ = yaml_get_node_from_iterator_c( iterator%curr_ ) + type is( integer( musica_ik ) ) + value = yaml_get_int_from_iterator_c( iterator%curr_ ) + type is( real( musica_rk ) ) + value = yaml_get_float_from_iterator_c( iterator%curr_ ) + type is( real( musica_dk ) ) + value = yaml_get_double_from_iterator_c( iterator%curr_ ) + type is( logical ) + value = yaml_get_bool_from_iterator_c( iterator%curr_ ) + type is( string_t ) + str = yaml_get_string_from_iterator_c( iterator%curr_ ) + value = to_f_string( str ) + call yaml_delete_string_c( str ) + class default + call die_msg( 227296475, "Unknown type for get function." ) + end select + class default + call die_msg( 446668858, "Iterator type mismatch. Expected "// & + "config_iterator_t" ) + end select + + end subroutine get_from_iterator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets an array value using an iterator + subroutine get_array_from_iterator( this, iterator, value, caller ) + + use musica_assert, only : assert, die_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Iterator to use to find value + class(iterator_t), intent(in) :: iterator + !> Returned value + type(string_t), allocatable, intent(out) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + integer :: i + type(string_array_t_c) :: c_array + type(string_t_c), pointer :: c_strings(:) + + select type( iterator ) + class is( config_iterator_t ) + c_array = yaml_get_string_array_from_iterator_c( iterator%curr_ ) + call c_f_pointer( c_array%ptr_, c_strings, [ c_array%size_ ] ) + allocate( value( c_array%size_ ) ) + do i = 1, size( c_strings ) + value(i) = to_f_string( c_strings( i ) ) + end do + call yaml_delete_string_array_c( c_array ) + class default + call die_msg( 217094588, "Iterator type mismatch. Expected "// & + "config_iterator_t" ) + end select + + end subroutine get_array_from_iterator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a subset of configuration data + subroutine add_config( this, key, value, caller ) + + use musica_assert, only : assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(config_t), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + call assert_msg( 644309796, c_associated( value%node_ ), & + "Trying to add uninitialized config_t object by "// & + caller ) + call yaml_add_node_c( this%node_, c_key, value%node_ ) + + end subroutine add_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a string to the configuration data + subroutine add_char_array( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + character(len=*), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:), c_value(:) + + c_key = to_c_string( key ) + c_value = to_c_string( value ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_string_c( this%node_, c_key, c_value ) + + end subroutine add_char_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a string to the configuration data + subroutine add_string( this, key, value, caller ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(string_t), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:), c_value(:) + + c_key = to_c_string( key ) + c_value = to_c_string( value%val_ ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_string_c( this%node_, c_key, c_value ) + + end subroutine add_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds an integer to the configuration data + subroutine add_int( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + integer, intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_int_c( this%node_, c_key, int( value, kind=c_int ) ) + + end subroutine add_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a single-precision real number to the configuration data + subroutine add_float( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + real(kind=musica_rk), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_float_c( this%node_, c_key, real( value, kind=c_float ) ) + + end subroutine add_float + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a double-precision real number to the configuration data + subroutine add_double( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + real(kind=musica_dk), intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_double_c( this%node_, c_key, real( value, kind=c_double ) ) + + end subroutine add_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a boolean to the configuration data + subroutine add_logical( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + logical, intent(in) :: value + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + character(len=1, kind=c_char), allocatable :: c_key(:) + + c_key = to_c_string( key ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_bool_c( this%node_, c_key, logical( value, kind=c_bool ) ) + + end subroutine add_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a string array to the configuration data + subroutine add_string_array( this, key, value, caller ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(string_t), intent(in) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(string_array_t_c) :: c_array + type(string_t_c), allocatable, target :: c_strings(:) + character(len=1, kind=c_char), pointer :: c_string(:) + integer :: i, size + + allocate( c_strings( size( value ) ) ) + do i = 1, size( value ) + allocate( c_string, source = to_c_string( value( i )%val_ ) ) + c_strings( i )%ptr_ = c_loc( c_string ) + c_strings( i )%size_ = len( value( i )%val_ ) + nullify( c_string ) + end do + c_array%ptr_ = c_loc( c_strings ) + c_array%size_ = size( c_strings ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_string_array_c( this%node_, to_c_string( key ), c_array ) + do i = 1, size( value ) + call c_f_pointer( c_strings( i )%ptr_, c_string, & + [ c_strings( i )%size_ + 1 ] ) + deallocate( c_string ) + c_strings( i )%ptr_ = c_null_ptr + end do + + end subroutine add_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a double array to the configuration data + subroutine add_double_array( this, key, value, caller ) + + !> Configuration + class(config_t), intent(inout) :: this + !> Key to insert + character(len=*), intent(in) :: key + !> Value to set + real(kind=musica_dk), intent(in) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(double_array_t_c) :: c_array + real(kind=c_double), allocatable, target :: c_doubles(:) + + allocate( c_doubles, source = value ) + c_array%ptr_ = c_loc( c_doubles ) + c_array%size_ = size( value ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_double_array_c( this%node_, to_c_string( key ), c_array ) + + end subroutine add_double_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a config_t array to the configuration data + subroutine add_config_array( this, key, value, caller ) + + use musica_assert, only : assert_msg + + !> Configuration + class(config_t), intent(inout) :: this + !> Key in insert + character(len=*), intent(in) :: key + !> Value to set + type(config_t), intent(in) :: value(:) + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + type(node_array_t_c) :: c_array + type(c_ptr), allocatable, target :: c_nodes(:) + integer :: i + + allocate( c_nodes( size( value ) ) ) + do i = 1, size( value ) + c_nodes( i ) = value( i )%node_ + end do + c_array%ptr_ = c_loc( c_nodes ) + c_array%size_ = size( value ) + if( .not. c_associated( this%node_ ) ) call initialize_config_t( this ) + call yaml_add_node_array_c( this%node_, to_c_string( key ), c_array ) + + end subroutine add_config_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a config_t from a config_t + subroutine config_assign_config( a, b ) + + use musica_assert, only : assert + + !> Configuration to assign to + class(config_t), intent(out) :: a + !> Configuration to assign from + class(config_t), intent(in) :: b + + call assert( 864040127, c_associated( b%node_ ) ) + a%node_ = yaml_copy_node_c( b%node_ ) + + end subroutine config_assign_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a config_t from a string + subroutine config_assign_string( config, string ) + + use musica_string, only : string_t + + !> Configuration to assign to + class(config_t), intent(out) :: config + !> String to assign from + class(string_t), intent(in) :: string + + call initialize_config_t( config, string = string%val_ ) + + end subroutine config_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a config_t from a character array + subroutine config_assign_char( config, string ) + + !> Configuration to assign to + class(config_t), intent(out) :: config + !> String to assign from + character(len=*), intent(in) :: string + + call initialize_config_t( config, string = string ) + + end subroutine config_assign_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a configuration + subroutine string_assign_config( string, config ) + + use musica_assert, only : assert + use musica_string, only : string_t + + !> String to assign to + type(string_t), intent(out) :: string + !> Configuration to assign from + class(config_t), intent(in) :: config + + type(string_t_c) :: c_string + + call assert( 675183824, c_associated( config%node_ ) ) + c_string = yaml_to_string_c( config%node_ ) + string = to_f_string( c_string ) + call yaml_delete_string_c( c_string ) + + end subroutine string_assign_config + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory + subroutine finalize( this ) + + !> Configuration + type(config_t), intent(inout) :: this + + if( c_associated( this%node_) ) then + call yaml_delete_node_c( this%node_ ) + this%node_ = c_null_ptr + end if + + end subroutine finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory + subroutine finalize_1D_array( this ) + + !> Configuration + type(config_t), intent(inout) :: this(:) + + integer(kind=musica_ik) :: i_elem + + do i_elem = 1, size( this ) + if( c_associated( this( i_elem )%node_ ) ) then + call yaml_delete_node_c( this( i_elem )%node_ ) + this( i_elem )%node_ = c_null_ptr + end if + end do + + end subroutine finalize_1D_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finds a full key name by a prefix + !! + !! Returns the first instance of the prefix if found + subroutine find_by_prefix( this, prefix, full_key, found ) + + use musica_assert, only : assert + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Prefix to search for (first instance is returned) + character(len=*), intent(in) :: prefix + !> Full key found + type(string_t), intent(out) :: full_key + !> Flag indicating whether the key was found + logical, intent(out) :: found + + type(string_t) :: key + class(iterator_t), pointer :: iter + integer :: length + + length = len( trim( prefix ) ) + iter => this%get_iterator( ) + found = .false. + full_key = "" + do while( iter%next( ) .and. .not. found ) + key = this%key( iter ) + if( len( key%val_ ) .gt. length ) then + if( key%val_(1:length) .eq. trim( prefix ) ) then + full_key = key + found = .true. + end if + end if + end do + deallocate( iter ) + + end subroutine find_by_prefix + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Merges another config_t object into the config_t object + recursive subroutine merge_in( this, other, caller ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Configuration to merge in + class(config_t), intent(inout) :: other + !> Name of the calling function (only for use in error messages) + character(len=*), intent(in) :: caller + + logical :: success + + success = yaml_merge_node_c( this%node_, other%node_ ) + call assert_msg( 208766672, success, & + "Failed to merge configuration data for "// & + trim( caller ) ) + + end subroutine merge_in + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns true if the given key is in the given list of keys + logical function find_key_in_list( key_to_find, list ) result( found ) + + use musica_string, only : string_t + + type(string_t), intent(in) :: key_to_find + type(string_t), intent(in) :: list(:) + + integer :: i_elem + + found = .false. + do i_elem = 1, size( list ) + if( key_to_find .eq. list( i_elem ) ) then + found = .true. + exit + end if + end do + + end function find_key_in_list + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Validates the format of the configuration data + !! + !! Ensures that the required keys are present, and that user-defined keys + !! start with a "`__`" prefix. + logical function validate( this, required_keys, optional_keys ) + + use musica_string, only : string_t + + !> Configuration + class(config_t), intent(inout) :: this + !> Required keys + type(string_t), intent(in) :: required_keys(:) + !> Optional keys + type(string_t), intent(in) :: optional_keys(:) + + integer :: n_req_found + logical :: is_valid + type(string_t) :: key + class(iterator_t), pointer :: iter + character(len=:), allocatable :: error_message + + ! validates JSON format, including check for duplicate keys + + validate = .true. + n_req_found = 0 + iter => this%get_iterator( ) + do while( iter%next( ) ) + key = this%key( iter ) + if( key%length( ) .ge. 2 ) then + if( key%substring( 1, 2 ) .eq. "__" ) cycle + end if + if( find_key_in_list( key, required_keys ) ) then + n_req_found = n_req_found + 1 + else if( .not. find_key_in_list( key, optional_keys ) ) then + validate = .false. + exit + end if + end do + if( n_req_found .ne. size( required_keys ) ) validate = .false. + deallocate( iter ) + + end function validate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Print out the raw contents of the configuration + subroutine do_print( this ) + + use musica_string + + !> Configuration + class(config_t), intent(inout) :: this + + type(string_t) :: str + + str = this + write(*,*) str%val_ + + end subroutine do_print + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the object + integer function pack_size( this, comm ) + + use musica_mpi + use musica_string, only : string_t + + class(config_t), intent(inout) :: this ! configuration to pack + integer, optional, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + type(string_t) :: str + + str = this + pack_size = str%pack_size( comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the configuration onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + use musica_string, only : string_t + + !> Configuration to pack + class(config_t), intent(inout) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, optional, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + type(string_t) :: str + + str = this + prev_position = position + call str%mpi_pack( buffer, position, comm ) + call assert( 125473981, & + position - prev_position <= this%pack_size( comm ) ) +#endif + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks the configuration from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + use musica_string, only : string_t + + !> Configuration to unpack + class(config_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, optional, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position, string_size + type(string_t) :: str + + prev_position = position + call str%mpi_unpack( buffer, position, comm ) + call initialize_config_t( this, string = str%val_ ) + call assert( 237792326, & + position - prev_position <= this%pack_size( comm ) ) +#endif + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Advances the iterator + !! + !! Returns false if the end of the collection has been reached + logical function iterator_next( this ) + + use musica_assert, only : die_msg + + !> Iterator + class(config_iterator_t), intent(inout) :: this + + iterator_next = .false. + select type( this ) + class is( config_iterator_t ) + if( c_associated( this%curr_ ) ) then + iterator_next = yaml_increment_c( this%curr_, this%end_ ) + return + end if + this%curr_ = yaml_begin_c( this%node_ ) + iterator_next = .not. yaml_at_end_c( this%curr_, this%end_ ) + class default + call die_msg( 153127936, "Config iterator type mismatch" ) + end select + + end function iterator_next + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Resets the iterator + subroutine iterator_reset( this, parent ) + + use musica_assert, only : die_msg + + !> Iterator + class(config_iterator_t), intent(inout) :: this + !> Iterator for parent model element + class(iterator_t), intent(in), optional :: parent + + select type( this ) + class is( config_iterator_t ) + if( c_associated( this%curr_ ) ) then + call yaml_delete_iterator_c( this%curr_ ) + end if + this%curr_ = c_null_ptr + class default + call die_msg( 159845482, "Config iterator type mismatch" ) + end select + + end subroutine iterator_reset + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory assoicated with an iterator + subroutine iterator_finalize( this ) + + !> Iterator + type(config_iterator_t), intent(inout) :: this + + if( c_associated( this%curr_ ) ) call yaml_delete_iterator_c( this%curr_ ) + if( c_associated( this%end_ ) ) call yaml_delete_iterator_c( this%end_ ) + + end subroutine iterator_finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Initialize a config_t object + subroutine initialize_config_t( config, string ) + + use musica_assert, only : die + + !> Configuration + class(config_t), intent(inout) :: config + !> YAML string + character(len=*), optional, intent(in) :: string + + character(len=1, kind=c_char), allocatable :: c_string(:) + integer :: N, i + + select type(config) + type is(config_t) + call finalize( config ) + if( present( string ) ) then + c_string = to_c_string( string ) + config%node_ = yaml_create_from_string_c( c_string ) + else + config%node_ = yaml_create_from_string_c( (/ c_null_char /) ) + end if + class default + call die( 288394178 ) + end select + + end subroutine initialize_config_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Convert a fortran character array to a c string + function to_c_string( f_string ) result( c_string ) + + !> String as const char* + character(len=1, kind=c_char), allocatable :: c_string(:) + !> Fortran string to convert + character(len=*), intent(in) :: f_string + + integer :: N, i + + N = len_trim( f_string ) + allocate( c_string( N + 1 ) ) + do i = 1, N + c_string(i) = f_string(i:i) + end do + c_string( N + 1 ) = c_null_char + + end function to_c_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Convert a c string to a fortran character array + function to_f_string( c_string ) result( f_string ) + + !> Converted string for fortran + character(len=:), allocatable :: f_string + !> C pointer to const char* + type(string_t_c), intent(in) :: c_string + + integer :: i + character(len=1, kind=c_char), pointer :: c_char_array(:) + + call c_f_pointer( c_string%ptr_, c_char_array, [ c_string%size_ + 1 ] ) + allocate( character( len = c_string%size_ ) :: f_string ) + do i = 1, c_string%size_ + f_string(i:i) = c_char_array(i) + end do + + end function to_f_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_config \ No newline at end of file diff --git a/src/util/config.cpp b/src/util/config.cpp new file mode 100644 index 00000000..833ea1e2 --- /dev/null +++ b/src/util/config.cpp @@ -0,0 +1,349 @@ +// Copyright (C) 2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include +#include +#include +#include + +Yaml* yaml_create_from_string(const char* yaml_string) +{ + return new YAML::Node(YAML::Load(yaml_string)); +} + +Yaml* yaml_create_from_file(const char* file_path) +{ + return new YAML::Node(YAML::LoadFile(file_path)); +} + +void yaml_to_file(Yaml* node, const char* file_path) +{ + std::ofstream file(file_path, std::ofstream::trunc); + file << *node; + file.close(); +} + +int yaml_size(Yaml* node) +{ + return node->size(); +} + +YamlIterator* yaml_begin(Yaml* node) +{ + return new YAML::iterator(node->begin()); +} + +YamlIterator* yaml_end(Yaml* node) +{ + return new YAML::iterator(node->end()); +} + +bool yaml_at_end(YamlIterator* iter, YamlIterator* end) +{ + return *iter == *end; +} + +bool yaml_increment(YamlIterator* iter, YamlIterator* end) +{ + return ++(*iter) != *end; +} + +string_t yaml_key(YamlIterator* iter) +{ + string_t string; + std::string str = (*iter)->first.as(); + string.size_ = str.length(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, str.c_str()); + return string; +} + +Yaml* yaml_get_node(Yaml* node, const char* key, bool& found) +{ + YAML::Node subnode = (*node)[key]; + found = subnode.IsDefined() && !subnode.IsScalar(); + return new YAML::Node(subnode); +} + +string_t yaml_get_string(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + string_t string; + if (found) { + std::string str = (*node)[key].as(); + string.size_ = str.length(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, str.c_str()); + return string; + } + string.ptr_ = nullptr; + string.size_ = 0; + return string; +} + +int yaml_get_int(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return 0; +} + +float yaml_get_float(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return 0.0f; +} + +double yaml_get_double(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return 0.0; +} + +bool yaml_get_bool(Yaml* node, const char* key, bool& found) +{ + found = (*node)[key].IsDefined(); + if (found) return (*node)[key].as(); + return false; +} + +string_array_t yaml_get_string_array(Yaml* node, const char* key, bool& found) +{ + string_array_t array; + array.size_ = 0; + array.ptr_ = nullptr; + YAML::Node array_node = (*node)[key]; + found = array_node.IsDefined(); + if (!found) return array; + array.size_ = array_node.size(); + array.ptr_ = new string_t[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + std::string str = array_node[i].as(); + array.ptr_[i].size_ = str.length(); + array.ptr_[i].ptr_ = new char[ str.length() + 1 ]; + strcpy(array.ptr_[i].ptr_, str.c_str()); + } + return array; +} + +double_array_t yaml_get_double_array(Yaml* node, const char* key, bool& found) +{ + double_array_t array; + array.size_ = 0; + array.ptr_ = nullptr; + YAML::Node array_node = (*node)[key]; + found = array_node.IsDefined(); + if (!found) return array; + array.size_ = array_node.size(); + array.ptr_ = new double[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + array.ptr_[i] = array_node[i].as(); + } + return array; +} + +node_array_t yaml_get_node_array(Yaml* node, const char* key, bool& found) +{ + node_array_t array; + array.size_ = 0; + array.ptr_ = nullptr; + YAML::Node array_node = (*node)[key]; + found = array_node.IsDefined(); + if (!found) return array; + array.size_ = array_node.size(); + array.ptr_ = new YAML::Node*[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + array.ptr_[i] = new YAML::Node(array_node[i].as()); + } + return array; +} + +Yaml* yaml_get_node_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? new YAML::Node((*iter)->as()) : new YAML::Node((*iter)->second.as()); +} + +string_t yaml_get_string_from_iterator(YamlIterator* iter) +{ + string_t string; + std::string str = (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); + string.size_ = str.length(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, str.c_str()); + return string; +} + +int yaml_get_int_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +float yaml_get_float_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +double yaml_get_double_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +bool yaml_get_bool_from_iterator(YamlIterator* iter) +{ + return (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); +} + +string_array_t yaml_get_string_array_from_iterator(YamlIterator* iter) +{ + string_array_t array; + YAML::Node array_node = (*iter)->IsDefined() ? (*iter)->as() : (*iter)->second.as(); + array.size_ = array_node.size(); + array.ptr_ = new string_t[ array.size_ ]; + for (std::size_t i = 0; i < array_node.size(); ++i) + { + std::string str = array_node[i].as(); + array.ptr_[i].size_ = str.length(); + array.ptr_[i].ptr_ = new char[ str.length() + 1 ]; + strcpy(array.ptr_[i].ptr_, str.c_str()); + } + return array; +} + +void yaml_add_node(Yaml* node, const char* key, Yaml* value) +{ + (*node)[key] = YAML::Clone(*value); +} + +void yaml_add_string(Yaml* node, const char* key, const char* value) +{ + (*node)[key] = value; +} + +void yaml_add_int(Yaml* node, const char* key, int value) +{ + (*node)[key] = value; +} + +void yaml_add_float(Yaml* node, const char* key, float value) +{ + (*node)[key] = value; +} + +void yaml_add_double(Yaml* node, const char* key, double value) +{ + (*node)[key] = value; +} + +void yaml_add_bool(Yaml* node, const char* key, bool value) +{ + (*node)[key] = value; +} + +void yaml_add_string_array(Yaml* node, const char* key, string_array_t value) +{ + YAML::Node array; + for (std::size_t i = 0; i < value.size_; ++i) + { + array.push_back(value.ptr_[i].ptr_); + } + (*node)[key] = array; +} + +void yaml_add_double_array(Yaml* node, const char* key, double_array_t value) +{ + YAML::Node array; + for (std::size_t i = 0; i < value.size_; ++i) + { + array.push_back(value.ptr_[i]); + } + (*node)[key] = array; +} + +void yaml_add_node_array(Yaml* node, const char* key, node_array_t value) +{ + YAML::Node array; + for (std::size_t i = 0; i < value.size_; ++i) + { + array.push_back(*(value.ptr_[i])); + } + (*node)[key] = array; +} + +Yaml* yaml_copy_node(Yaml* node) +{ + return new YAML::Node(YAML::Clone(*node)); +} + +string_t yaml_to_string(Yaml* node) +{ + string_t string; + YAML::Emitter out; + out << *node; + string.size_ = out.size(); + string.ptr_ = new char[string.size_ + 1]; + strcpy(string.ptr_, out.c_str()); + return string; +} + +bool yaml_merge_node(Yaml* node, const Yaml* other) +{ + if (!node->IsMap() || !other->IsMap()) return false; + for(YAML::const_iterator it=(*other).begin(); it!=(*other).end(); ++it) + { + std::string key = it->first.as(); + if ((*node)[key].IsDefined() && (*node)[key].IsMap() && it->second.IsMap()) + { + Yaml subnode = (*node)[key]; + if (!yaml_merge_node(&subnode, &it->second)) return false; + (*node)[key] = subnode; + } + else + { + if ((*node)[key].IsDefined() && !(*node)[key].is(it->second)) + { + return false; + } + (*node)[key] = it->second; + } + } + return true; +} + +void yaml_delete_node(Yaml* ptr) +{ + delete ptr; +} + +void yaml_delete_string(string_t string) +{ + delete [] string.ptr_; +} + +void yaml_delete_string_array(string_array_t array) +{ + if (!array.ptr_) return; + for (std::size_t i = 0; i < array.size_; ++i) + { + delete [] array.ptr_[i].ptr_; + } + delete [] array.ptr_; +} + +void yaml_delete_double_array(double_array_t array) +{ + delete [] array.ptr_; +} + +void yaml_delete_node_array(node_array_t array) +{ + delete [] array.ptr_; +} + +void yaml_delete_iterator(YamlIterator* ptr) +{ + delete ptr; +} \ No newline at end of file diff --git a/src/util/constants.F90 b/src/util/constants.F90 new file mode 100644 index 00000000..44a23349 --- /dev/null +++ b/src/util/constants.F90 @@ -0,0 +1,35 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_constants module + +!> Common physical constants +module musica_constants + + implicit none + public + + !> @name Primitive type kinds + !! @{ + !> Kind of an integer + integer, parameter :: musica_ik = kind(1) + !> Kind of a single-precision real number + integer, parameter :: musica_rk = kind(0.0) + !> Kind of a double-precision real number + integer, parameter :: musica_dk = kind(0.0d0) + !> Kind of a boolean + integer, parameter :: musica_lk = kind(.true.) + !> @} + + !> @name Physical constants + !! @{ + !> Pi + real(kind=musica_dk), parameter :: kPi = 3.14159265358979323846d0 + !> Avagadro's number [molec mol-1] + real(kind=musica_dk), parameter :: kAvagadro = 6.02214179d23 + !> Universal gas constant [J mol-1 K-1]. + real(kind=musica_dk), parameter :: kUniversalGasConstant = 8.314472d0 + !> @} + +end module musica_constants diff --git a/src/util/io.F90 b/src/util/io.F90 new file mode 100644 index 00000000..5be73a60 --- /dev/null +++ b/src/util/io.F90 @@ -0,0 +1,479 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_io module + +!> The io_t type and related functions +module musica_io + + implicit none + private + + public :: io_t + + !> General input/output class + type, abstract :: io_t + contains + !> @name Data read functions + !! @{ + procedure(read_0D_double), deferred :: read_0D_double + procedure(read_1D_double), deferred :: read_1D_double + procedure(read_2D_double), deferred :: read_2D_double + procedure(read_3D_double), deferred :: read_3D_double + procedure(read_4D_double), deferred :: read_4D_double + procedure(read_0D_int), deferred :: read_0D_int + procedure(read_1D_int), deferred :: read_1D_int + generic :: read => read_0D_double, read_1D_double, read_2D_double, & + read_3D_double, read_4D_double, read_0D_int, & + read_1D_int + !> @} + !> @name Data write functions + !! @{ + procedure(write_0D_double), deferred :: write_0D_double + procedure(write_1D_double), deferred :: write_1D_double + procedure(write_2D_double), deferred :: write_2D_double + procedure(write_3D_double), deferred :: write_3D_double + procedure(write_4D_double), deferred :: write_4D_double + procedure(write_0D_int), deferred :: write_0D_int + procedure(write_1D_int), deferred :: write_1D_int + generic :: write => write_0D_double, write_1D_double, write_2D_double, & + write_3D_double, write_4D_double, write_0D_int, & + write_1D_int + !> @} + !> @name Data append functions + !! @{ + procedure(append_0D_double), deferred :: append_0D_double + procedure(append_1D_double), deferred :: append_1D_double + procedure(append_2D_double), deferred :: append_2D_double + procedure(append_3D_double), deferred :: append_3D_double + procedure(append_0D_int), deferred :: append_0D_int + generic :: append => append_0D_double, append_1D_double, append_2D_double,& + append_3D_double, append_0D_int + !> @} + !> Returns whether a variable exists in the file + !! @{ + procedure(exists_char), deferred :: exists_char + procedure(exists_string), deferred :: exists_string + generic :: exists => exists_char, exists_string + !> @} + !> Returns the dimension names for a given variable + procedure(variable_dimensions), deferred :: variable_dimensions + !> Returns the units for a given variable + procedure(variable_units), deferred :: variable_units + !> Sets the units for a given variable + procedure(set_variable_units), deferred :: set_variable_units + end type io_t + +interface + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D double-precision floating-point data + subroutine read_0D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(out) :: container + character(len=*), intent(in) :: requestor_name + end subroutine read_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_1D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + end subroutine read_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 2D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_2D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:) + character(len=*), intent(in) :: requestor_name + end subroutine read_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 3D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_3D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine read_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 4D double-precision floating-point data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_4D_double( this, variable_name, container, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine read_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D integer data + subroutine read_0D_int( this, variable_name, container, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, intent(out) :: container + character(len=*), intent(in) :: requestor_name + end subroutine read_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D integer data + !! + !! If \c container is unallocated, it will be allocated to the dimensions + !! of the read variable. Otherwise, its dimensions must match those of the + !! read variable. + !! + subroutine read_1D_int( this, variable_name, container, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + end subroutine read_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data + subroutine write_0D_double( this, variable_name, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine write_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + end subroutine write_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_2D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + end subroutine write_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_3D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine write_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_4D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(4) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine write_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data + subroutine write_0D_int( this, variable_name, variable_data, & + requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine write_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_int( this, variable_name, dimensions, variable_data, & + requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + integer, intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + end subroutine write_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data to append 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_double( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine append_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data to append 2D data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_1D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + end subroutine append_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data to append 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_2D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + end subroutine append_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data to append 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_3D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + use musica_constants, only : musica_dk + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + end subroutine append_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data to append 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_int( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + end subroutine append_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_char( this, variable_name, requestor_name ) & + result( exists ) + import io_t + class(io_t), intent(in) :: this + character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function exists_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_string( this, variable_name, requestor_name ) & + result( exists ) + use musica_string, only : string_t + import io_t + class(io_t), intent(in) :: this + type(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function exists_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the dimension names for a given variable + function variable_dimensions( this, variable_name, requestor_name ) & + result( dimensions ) + use musica_string, only : string_t + import io_t + type(string_t), allocatable :: dimensions(:) + class(io_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function variable_dimensions + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the units for a given variable + function variable_units( this, variable_name, requestor_name ) + use musica_string, only : string_t + import io_t + type(string_t) :: variable_units + class(io_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + end function variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Sets the units for a given variable + subroutine set_variable_units( this, variable_name, units, requestor_name ) + use musica_string, only : string_t + import io_t + class(io_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + class(string_t), intent(in) :: units + character(len=*), intent(in) :: requestor_name + end subroutine set_variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end interface + +end module musica_io diff --git a/src/util/io/CMakeLists.txt b/src/util/io/CMakeLists.txt new file mode 100644 index 00000000..7bd76972 --- /dev/null +++ b/src/util/io/CMakeLists.txt @@ -0,0 +1,9 @@ +###################################################################### +# IO utilities source + +target_sources(tuvx_object + PRIVATE + netcdf.F90 +) + +###################################################################### diff --git a/src/util/io/netcdf.F90 b/src/util/io/netcdf.F90 new file mode 100644 index 00000000..b1a5780a --- /dev/null +++ b/src/util/io/netcdf.F90 @@ -0,0 +1,1299 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_io_netcdf module + +!> The io_netcdf_t type and related functions +module musica_io_netcdf + + use musica_io, only : io_t + use musica_string, only : string_t + + implicit none + private + + public :: io_netcdf_t + + integer, parameter :: kUnknownFileId = -9999 + + !> NetCDF file reader + type, extends(io_t) :: io_netcdf_t + integer :: file_id_ = kUnknownFileId + type(string_t) :: file_name_ + contains + !> @name Data read functions + !! @{ + procedure :: read_0D_double + procedure :: read_1D_double + procedure :: read_2D_double + procedure :: read_3D_double + procedure :: read_4D_double + procedure :: read_0D_int + procedure :: read_1D_int + !> @} + !> @name Data write functions + !! @{ + procedure :: write_0D_double + procedure :: write_1D_double + procedure :: write_2D_double + procedure :: write_3D_double + procedure :: write_4D_double + procedure :: write_0D_int + procedure :: write_1D_int + !> @} + !> @name Data append functions + !! @{ + procedure :: append_0D_double + procedure :: append_1D_double + procedure :: append_2D_double + procedure :: append_3D_double + procedure :: append_0D_int + !! @} + !> @name Returns whether a variable exists in the file + !! @{ + procedure :: exists_char + procedure :: exists_string + !> @} + !> Returns the dimension names for a given variable + procedure :: variable_dimensions + !> Returns the units for a given variable + procedure :: variable_units + !> Sets the units for a given variable + procedure :: set_variable_units + procedure, private :: is_open + procedure, private :: variable_id + procedure, private :: dimension_sizes + procedure, private :: check_add_dimension + procedure, private :: check_add_variable + final :: finalize + end type io_netcdf_t + + interface io_netcdf_t + procedure :: constructor + end interface + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructor for NetCDF file readers + function constructor( file_name, read_only ) result( new_io ) + + use musica_string, only : string_t + use netcdf, only : nf90_create, nf90_open, & + NF90_NETCDF4, NF90_WRITE, & + NF90_NOWRITE + + type(io_netcdf_t), pointer :: new_io + type(string_t), intent(in) :: file_name + logical, optional, intent(in) :: read_only + + logical :: file_exists + + allocate( new_io ) + new_io%file_name_ = file_name + if( present( read_only ) ) then + if( read_only ) then + call check_status( 233000996, & + nf90_open( file_name%to_char( ), NF90_NOWRITE, new_io%file_id_ ), & + "Error openning file '"//file_name%to_char( )//"'" ) + return + end if + end if + inquire( file = file_name%to_char( ), exist = file_exists ) + if( file_exists ) then + call check_status( 126279520, & + nf90_open( file_name%to_char( ), NF90_WRITE, new_io%file_id_ ), & + "Error openning file '"//file_name%to_char( )//"'" ) + else + call check_status( 427923808, & + nf90_create( file_name%to_char( ), NF90_NETCDF4, new_io%file_id_ ), & + "Error creating file '"//file_name%to_char( )//"'" ) + end if + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D double-precision floating-pointer data + subroutine read_0D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(out) :: container + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 879207328, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 712409197, size( dim_sizes ) .eq. 0, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 0 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + call check_status( 190408927, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D double-precision floating-pointer data + subroutine read_1D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 163123652, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 275441997, size( dim_sizes ) .eq. 1, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 1 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + call assert_msg( 976961669, size( container ) .eq. dim_sizes(1), & + "Wrong size container for "//trim( id_str%to_char( ) ) & + //": Expected "//trim( to_char( dim_sizes(1) ) )// & + " got "//trim( to_char( size( container ) ) ) ) + else + allocate( container( dim_sizes(1) ) ) + end if + call check_status( 722809843, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 2D double-precision floating-pointer data + subroutine read_2D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 675787021, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 400481613, size( dim_sizes ) .eq. 2, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 2 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + do i_dim = 1, 2 + call assert_msg( 230324709, size( container, i_dim ) .eq. & + dim_sizes( i_dim ), & + "Wrong size container for "// & + trim( id_str%to_char( ) )//": Expected "// & + trim( to_char( dim_sizes( i_dim ) ) )// & + " got "//trim( to_char( size( container, i_dim ) ) ) & + //" for dimension "//trim( to_char( i_dim ) ) ) + end do + else + allocate( container( dim_sizes(1), dim_sizes(2) ) ) + end if + call check_status( 960167804, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 3D double-precision floating-pointer data + subroutine read_3D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 539957265, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 603060131, size( dim_sizes ) .eq. 3, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 3 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + do i_dim = 1, 3 + call assert_msg( 715378476, size( container, i_dim ) .eq. & + dim_sizes( i_dim ), & + "Wrong size container for "// & + trim( id_str%to_char( ) )//": Expected "// & + trim( to_char( dim_sizes( i_dim ) ) )// & + " got "//trim( to_char( size( container, i_dim ) ) ) & + //" for dimension "//trim( to_char( i_dim ) ) ) + end do + else + allocate( container( dim_sizes(1), dim_sizes(2), dim_sizes(3) ) ) + end if + call check_status( 210172071, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 4D double-precision floating-pointer data + subroutine read_4D_double( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + real(kind=musica_dk), allocatable, intent(inout) :: container(:,:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 198190218, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 650822371, size( dim_sizes ) .eq. 4, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 4 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + do i_dim = 1, 4 + call assert_msg( 820979275, size( container, i_dim ) .eq. & + dim_sizes( i_dim ), & + "Wrong size container for "// & + trim( id_str%to_char( ) )//": Expected "// & + trim( to_char( dim_sizes( i_dim ) ) )// & + " got "//trim( to_char( size( container, i_dim ) ) ) & + //" for dimension "//trim( to_char( i_dim ) ) ) + end do + else + allocate( container( dim_sizes(1), dim_sizes(2), dim_sizes(3), & + dim_sizes(4) ) ) + end if + call check_status( 708660930, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 0D integer data + subroutine read_0D_int( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, intent(out) :: container + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 418014896, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 747800090, size( dim_sizes ) .eq. 0, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 0 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + call check_status( 860118435, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Reads 1D integer data + subroutine read_1D_int( this, variable_name, container, requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : to_char + use netcdf, only : nf90_get_var + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + integer, allocatable, intent(inout) :: container(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id + integer, allocatable :: dim_sizes(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 121652260, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + dim_sizes = this%dimension_sizes( variable_name ) + call assert_msg( 798921103, size( dim_sizes ) .eq. 1, & + "Wrong number of dimensions for "// & + trim( id_str%to_char( ) )//": Expected 1 got "// & + trim( to_char( size( dim_sizes ) ) ) ) + if( allocated( container ) ) then + call assert_msg( 346288950, size( container ) .eq. dim_sizes(1), & + "Wrong size container for "//trim( id_str%to_char( ) ) & + //": Expected "//trim( to_char( dim_sizes(1) ) )// & + " got "//trim( to_char( size( container ) ) ) ) + else + allocate( container( dim_sizes(1) ) ) + end if + call check_status( 458607295, & + nf90_get_var( this%file_id_, var_id, container ), & + "Error getting value for "//trim( id_str%to_char( ) ) ) + + end subroutine read_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data + subroutine write_0D_double( this, variable_name, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 576950310, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call check_status( 550080126, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 540003807, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(1) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 616828888, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions%to_char( ), & + size( variable_data ) ) + call check_status( 111622483, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 841465578, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_2D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(2) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 186994325, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions(1)%to_char( ), & + size( variable_data, 1 ) ) + dimids(2) = this%check_add_dimension( dimensions(2)%to_char( ), & + size( variable_data, 2 ) ) + call check_status( 916837420, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 464205267, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_3D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(3) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 232851031, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions(1)%to_char( ), & + size( variable_data, 1 ) ) + dimids(2) = this%check_add_dimension( dimensions(2)%to_char( ), & + size( variable_data, 2 ) ) + dimids(3) = this%check_add_dimension( dimensions(3)%to_char( ), & + size( variable_data, 3 ) ) + call check_status( 403007935, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 573164839, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_4D_double( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions(4) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(4) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 338451830, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions(1)%to_char( ), & + size( variable_data, 1 ) ) + dimids(2) = this%check_add_dimension( dimensions(2)%to_char( ), & + size( variable_data, 2 ) ) + dimids(3) = this%check_add_dimension( dimensions(3)%to_char( ), & + size( variable_data, 3 ) ) + dimids(4) = this%check_add_dimension( dimensions(4)%to_char( ), & + size( variable_data, 4 ) ) + call check_status( 233303326, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_DOUBLE, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 680671172, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_4D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data + subroutine write_0D_int( this, variable_name, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_INT + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 834034211, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call check_status( 998926808, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_INT, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 546294655, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine write_1D_int( this, variable_name, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_INT + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: dimensions + integer, intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + + integer :: var_id, dimids(1) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 769478106, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dimids(1) = this%check_add_dimension( dimensions%to_char( ), & + size( variable_data ) ) + call check_status( 257101860, nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + NF90_INT, dimids = dimids, & + varid = var_id ), & + "Error creating "//trim( id_str%to_char( ) ) ) + call check_status( 427258764, & + nf90_put_var( this%file_id_, var_id, variable_data ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine write_1D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D double data to append 1D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_double( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + real(kind=musica_dk), intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: varid, dimids(1), start_ids(1), dim_sizes(0) + type(string_t) :: id_str, dimensions(0) + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 660803774, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 320489966, & + nf90_put_var( this%file_id_, varid, & + (/ variable_data /), start = start_ids, & + count = (/ 1 /) ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_0D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 1D double data to append 2D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_1D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions + real(kind=musica_dk), intent(in) :: variable_data(:) + character(len=*), intent(in) :: requestor_name + + integer :: varid, dim_sizes(1), dimids(2), start_ids(2) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 246721328, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dim_sizes(1) = size( variable_data ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, (/ dimensions /), & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 641514922, & + nf90_put_var( this%file_id_, varid, & + (/ variable_data /), start = start_ids, & + count = (/ 1, size( variable_data ) /) ),& + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_1D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 2D double data to append 3D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_2D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(2) + real(kind=musica_dk), intent(in) :: variable_data(:,:) + character(len=*), intent(in) :: requestor_name + + integer :: varid, dim_sizes(2), dimids(3), start_ids(3) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 264592928, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dim_sizes(1) = size( variable_data, 1 ) + dim_sizes(2) = size( variable_data, 2 ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 889287519, & + nf90_put_var( this%file_id_, varid, & + variable_data, start = start_ids, & + count = (/ 1, size( variable_data, 1 ), & + size( variable_data, 2 ) /) ),& + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_2D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 3D double data to append 4D double data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_3D_double( this, variable_name, variable_units, & + append_dimension, append_index, dimensions, variable_data, & + requestor_name ) + + use musica_assert, only : assert_msg + use musica_constants, only : musica_dk + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_DOUBLE, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + type(string_t), intent(in) :: dimensions(3) + real(kind=musica_dk), intent(in) :: variable_data(:,:,:) + character(len=*), intent(in) :: requestor_name + + integer :: varid, dim_sizes(3), dimids(4), start_ids(4) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 351946623, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + dim_sizes(1) = size( variable_data, 1 ) + dim_sizes(2) = size( variable_data, 2 ) + dim_sizes(3) = size( variable_data, 3 ) + call this%check_add_variable( variable_name, variable_units, NF90_DOUBLE, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 181789719, & + nf90_put_var( this%file_id_, varid, & + variable_data, start = start_ids, & + count = (/ 1, size( variable_data, 1 ), & + size( variable_data, 2 ), & + size( variable_data, 3 ) /) ),& + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_3D_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Writes 0D int data to append 1D int data + !! + !! If the provided dimensions do not exist, they will be created based on + !! the shape of the given data. If they do exist, they must be compatible + !! with the shape of the given data. + subroutine append_0D_int( this, variable_name, variable_units, & + append_dimension, append_index, variable_data, requestor_name ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t + use netcdf, only : nf90_def_var, nf90_put_var, & + NF90_INT, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + type(string_t), intent(in) :: append_dimension + integer, intent(in) :: append_index + integer, intent(in) :: variable_data + character(len=*), intent(in) :: requestor_name + + integer :: varid, dimids(1), start_ids(1), dim_sizes(0) + type(string_t) :: id_str, dimensions(0) + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 896317785, this%is_open( ), & + "Trying to write to an unopen file: "//id_str ) + call this%check_add_variable( variable_name, variable_units, NF90_INT, & + append_dimension, dimensions, & + dim_sizes, varid, dimids, start_ids ) + start_ids(1) = append_index + call check_status( 108636131, & + nf90_put_var( this%file_id_, varid, & + (/ variable_data /), start = start_ids, & + count = (/ 1 /) ), & + "Error writing to "//trim( id_str%to_char( ) ) ) + + end subroutine append_0D_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_char( this, variable_name, requestor_name ) & + result( exists ) + + use netcdf, only : nf90_inq_varid, & + NF90_ENOTVAR + + class(io_netcdf_t), intent(in) :: this + character(len=*), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + integer :: var_id, err_id + + err_id = nf90_inq_varid( this%file_id_, variable_name, var_id ) + + exists = .false. + if( err_id == NF90_ENOTVAR ) return + call check_status( 855364555, err_id, "Error trying to find variable '"// & + variable_name//"' in NetCDF file '"// & + trim( this%file_name_%to_char( ) )//"' for "// & + requestor_name ) + exists = .true. + + end function exists_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a variable exists in the file + logical function exists_string( this, variable_name, requestor_name ) & + result( exists ) + + use musica_string, only : string_t + + class(io_netcdf_t), intent(in) :: this + type(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + exists = this%exists_char( variable_name%to_char( ), requestor_name ) + + end function exists_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the dimension names for a given variable + function variable_dimensions( this, variable_name, requestor_name ) & + result( dimensions ) + + use musica_string, only : to_char + use netcdf, only : NF90_MAX_NAME, & + nf90_inquire_variable, & + nf90_inquire_dimension + + type(string_t), allocatable :: dimensions(:) + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + integer :: var_id, i_dim, n_dims + integer, allocatable :: dimids(:) + type(string_t) :: id_str + character(len=NF90_MAX_NAME) :: dim_name + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + var_id = this%variable_id( variable_name ) + call check_status( 744311319, & + nf90_inquire_variable( this%file_id_, var_id, ndims = n_dims ), & + "Error getting number of dimensions for "//id_str%to_char( ) ) + allocate( dimids( n_dims ) ) + call check_status( 104014576, & + nf90_inquire_variable( this%file_id_, var_id, dimids = dimids ), & + "Error getting dimesions for "//id_str%to_char( ) ) + allocate( dimensions( n_dims ) ) + do i_dim = 1, n_dims + call check_status( 788714786, & + nf90_inquire_dimension( this%file_id_, dimids( i_dim ), & + name = dim_name ),& + "Error getting dimesion size "//trim( to_char( i_dim ) )//" for "// & + id_str%to_char( ) ) + dimensions( i_dim ) = trim( dim_name ) + end do + + end function variable_dimensions + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the units for a given variable + function variable_units( this, variable_name, requestor_name ) + + use netcdf, only : NF90_MAX_NAME, & + nf90_get_att + + type(string_t) :: variable_units + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + character(len=NF90_MAX_NAME) :: units + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + var_id = this%variable_id( variable_name ) + call check_status( 301987512, & + nf90_get_att( this%file_id_, var_id, "units", units ), & + "Error getting units for "//trim( id_str%to_char( ) ) ) + variable_units = trim( units ) + + end function variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Sets the units for a given variable + subroutine set_variable_units( this, variable_name, units, requestor_name ) + + use musica_string, only : string_t + use netcdf, only : nf90_put_att + + class(io_netcdf_t), intent(inout) :: this + class(string_t), intent(in) :: variable_name + class(string_t), intent(in) :: units + character(len=*), intent(in) :: requestor_name + + integer :: var_id + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + var_id = this%variable_id( variable_name ) + call check_status( 235495983, & + nf90_put_att( this%file_id_, var_id, "units", & + units%to_char( ) ), & + "Error setting units for "//trim( id_str%to_char( ) ) ) + + end subroutine set_variable_units + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns whether a file is open or not + logical function is_open( this ) + + class(io_netcdf_t), intent(in) :: this + + is_open = this%file_id_ .ne. kUnknownFileId + + end function is_open + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns a variable's id in the NetCDF file + integer function variable_id( this, variable_name ) + + use musica_assert, only : assert_msg + use netcdf, only : nf90_inq_varid + + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + + call assert_msg( 249726322, this%is_open( ), & + "Trying to read from unopen file: '"// & + this%file_name_//"'" ) + call check_status( 153462424, & + nf90_inq_varid( this%file_id_, & + variable_name%to_char( ), & + variable_id ), & + "Cannot find variable '"// & + trim( variable_name%to_char( ) )//"' in file '"// & + trim( this%file_name_%to_char( ) )//"'" ) + + end function variable_id + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the dimensions for variable in the NetCDF file + function dimension_sizes( this, variable_name ) result( dim_sizes ) + + use musica_assert, only : assert_msg + use musica_string, only : to_char + use netcdf, only : nf90_inquire_variable, & + nf90_inquire_dimension + + integer, allocatable :: dim_sizes(:) + class(io_netcdf_t), intent(in) :: this + class(string_t), intent(in) :: variable_name + + integer :: var_id, n_dims, i_dim + integer, allocatable :: dimids(:) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + call assert_msg( 191887763, this%is_open( ), & + "Trying to read from unopen file: "//id_str ) + var_id = this%variable_id( variable_name ) + call check_status( 516121527, & + nf90_inquire_variable( this%file_id_, var_id, ndims = n_dims ), & + "Error getting number of dimensions for "//trim( id_str%to_char( ) ) ) + allocate( dimids( n_dims ) ) + call check_status( 269878960, & + nf90_inquire_variable( this%file_id_, var_id, dimids = dimids ), & + "Error getting dimensions for "//trim( id_str%to_char( ) ) ) + allocate( dim_sizes( n_dims ) ) + do i_dim = 1, n_dims + call check_status( 770273353, & + nf90_inquire_dimension( this%file_id_, dimids( i_dim ), & + len = dim_sizes( i_dim ) ), & + "Error getting dimension size "//trim( to_char( i_dim ) )//" for "//& + trim( id_str%to_char( ) ) ) + end do + + end function dimension_sizes + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks if a dimension exists and verifies its size + !! + !! If the dimension does not exist, it is created. The dimension id is + !! returned. + function check_add_dimension( this, dim_name, dim_size ) result( dimid ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t, to_char + use netcdf, only : nf90_inq_dimid, & + nf90_inquire_dimension, & + nf90_def_dim, & + NF90_NOERR, NF90_UNLIMITED + + integer :: dimid + class(io_netcdf_t), intent(inout) :: this + character(len=*), intent(in) :: dim_name + integer, intent(in) :: dim_size + + integer :: ierr, curr_size + type(string_t) :: id_str + + id_str = "dimension '"//dim_name//"' in file '"//this%file_name_//"'" + + ierr = nf90_inq_dimid( this%file_id_, dim_name, dimid ) + if( ierr == NF90_NOERR ) then + ! dimension exists, check its size, unless it's unlimited + if( dim_size .ne. NF90_UNLIMITED ) then + call check_status( 737744716, & + nf90_inquire_dimension( this%file_id_, dimid, & + len = curr_size ), & + "NetCDF file error for "// & + trim( id_str%to_char( ) ) ) + call assert_msg( 343403417, curr_size == dim_size, & + "Dimension mismatch for "//trim( id_str%to_char( ) ) & + //"; Expected "//trim( to_char( curr_size ) )// & + ", got "//trim( to_char( dim_size ) ) ) + end if + else + call check_status( 947493075, & + nf90_def_dim( this%file_id_, dim_name, dim_size, & + dimid ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + end if + + end function check_add_dimension + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks for an appendable variable in the file and adds it if it does not + !! exist yet + subroutine check_add_variable( this, variable_name, variable_units, & + variable_type, append_dimension, dimensions, dimension_sizes, varid, & + dimids, start_ids ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t, to_char + use netcdf, only : nf90_inq_varid, & + nf90_inquire_dimension, & + nf90_inquire_variable, & + nf90_def_var, & + nf90_put_att, & + NF90_NOERR, NF90_UNLIMITED + + class(io_netcdf_t), intent(inout) :: this + type(string_t), intent(in) :: variable_name + type(string_t), intent(in) :: variable_units + integer, intent(in) :: variable_type + type(string_t), intent(in) :: append_dimension + type(string_t), intent(in) :: dimensions(:) + integer, intent(in) :: dimension_sizes(:) + integer, intent(out) :: varid + integer, intent(out) :: dimids(size(dimensions)+1) + integer, intent(out) :: start_ids(size(dimensions)+1) + + integer :: ierr, i_dim, ndims, ldimids(size(dimensions)+1) + type(string_t) :: id_str + + id_str = "variable '"//variable_name//"' in file '"//this%file_name_//"'" + + dimids = this%check_add_dimension( trim( append_dimension%to_char( ) ), & + NF90_UNLIMITED ) + do i_dim = 1, size( dimensions ) + dimids( i_dim + 1 ) = & + this%check_add_dimension( trim( dimensions( i_dim )%to_char( ) ), & + dimension_sizes( i_dim ) ) + end do + start_ids = 1 + ierr = nf90_inq_varid( this%file_id_, variable_name%to_char( ), varid ) + if( ierr == NF90_NOERR ) then + ! Check the dimension ids and units + call check_status( 372537549, & + nf90_inquire_variable( this%file_id_, varid, & + ndims = ndims, & + dimids = ldimids ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + call assert_msg( 192756621, ndims == size( dimensions ) + 1, & + "Dimension mismatch for "//trim( id_str%to_char( ) ) ) + do i_dim = 1, size( dimids ) + call assert_msg( 900541544, dimids( i_dim ) == ldimids( i_dim ), & + "Dimension "//trim( to_char( i_dim ) )// & + " mismatch for "//trim( id_str%to_char( ) ) ) + end do + call check_status( 302003316, & + nf90_inquire_dimension( this%file_id_, dimids(1), & + len = start_ids(1) ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + start_ids(1) = start_ids(1) + 1 + else + call check_status( 497577165, & + nf90_def_var( this%file_id_, & + variable_name%to_char( ), & + variable_type, dimids, varid ), & + "NetCDF file error for "//trim( id_str%to_char( ) ) ) + call check_status( 757618738, & + nf90_put_att( this%file_id_, varid, "units", & + variable_units%to_char( ) ), & + "Error setting units for "// & + trim( id_str%to_char( ) ) ) + end if + + end subroutine check_add_variable + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Finalizes a NetCDF file reader + subroutine finalize( this ) + + use netcdf, only : nf90_close + + type(io_netcdf_t), intent(inout) :: this + + if( this%file_id_ .ne. kUnknownFileId ) then + call check_status( 708311006, nf90_close( this%file_id_ ), & + "Error closing file" ) + end if + this%file_id_ = kUnknownFileId + this%file_name_ = "" + + end subroutine finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! @name Private NetCDF support functions +!! @{ +!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks a NetCDF status code and fail with a message if an error occurred + subroutine check_status( code, status, error_message ) + + use musica_assert, only : die_msg + use netcdf, only : NF90_NOERR, nf90_strerror + + !> Unique code to associate with any failure + integer, intent(in) :: code + !> NetCDF status code + integer, intent(in) :: status + !> Error message to display on failure + character(len=*), intent(in) :: error_message + + if( status .eq. NF90_NOERR ) return + call die_msg( 330311277, "NetCDF error: "//trim( error_message )//": "// & + trim( nf90_strerror( status ) ) ) + + end subroutine check_status + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> @} + +end module musica_io_netcdf diff --git a/src/util/iterator.F90 b/src/util/iterator.F90 new file mode 100644 index 00000000..b40411d2 --- /dev/null +++ b/src/util/iterator.F90 @@ -0,0 +1,81 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_iterator module + +!> The abstract iterator_t type and related functions +module musica_iterator + + implicit none + private + + public :: iterator_t + + !> An abstract iterator + !! + !! Extending types should provide a constructor that returns a pointer to a + !! iterator_t that references a newly allocated iterator of the extending + !! type. The iterator must be in the state it would be in after a call to + !! \c reset. + !! + !! Example usage: + !! \code{f90} + !! use musica_foo_iterator, only : foo_iterator_t + !! use musica_iterator, only : iterator_t + !! + !! class(iterator), pointer :: my_iterator + !! + !! my_iterator => foo_iterator_t( ) ! can accept arguments if necessary + !! do while( my_iterator%next( ) ) + !! some_function( my_iterator, ... ) ! use a function that uses a foo_iterator_t + !! end do + !! call my_iterator%reset( ) ! reset the iterator + !! do while( my_iterator%next( ) ) + !! some_other_function( my_iterator, ... ) + !! end do + !! deallocate( my_iterator ) + !! \endcode + !! + type, abstract :: iterator_t + contains + !> Advances the iterator + procedure(next), deferred :: next + !> Resets the iterator to the beginning of the collection + procedure(reset), deferred :: reset + end type iterator_t + +interface +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Advances the iterator + !! + !! Returns true if the iterator was advanced to the next record, returns + !! false if the end of the collection has been reached. + logical function next( this ) + import iterator_t + !> Iterator + class(iterator_t), intent(inout) :: this + end function next + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Resets the iterator to the beginning of the collection + !! + !! For iterators that target nested sets of elements (e.g., cells within a + !! column), the reset function can require a higher-level iterator whose + !! current target will be used to identify the nested set of elements to + !! iterate over. + !! + subroutine reset( this, parent ) + import iterator_t + !> Iterator + class(iterator_t), intent(inout) :: this + !> Iterator for parent model element + class(iterator_t), intent(in), optional :: parent + end subroutine reset + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +end interface + +end module musica_iterator diff --git a/src/util/map.F90 b/src/util/map.F90 new file mode 100644 index 00000000..db35c389 --- /dev/null +++ b/src/util/map.F90 @@ -0,0 +1,637 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_map module + +!> Utility for mapping among arrays +module musica_map + + use musica_constants, only : dk => musica_dk + + implicit none + private + + public :: map_t + + !> Matched pair + type :: pair_t + private + !> Index in source array + integer :: from_index_ + !> Index in destination array + integer :: to_index_ + !> Scaling factor applied to source data + real(kind=dk) :: scale_factor_ = 1.0 + contains + !> Returns the size of a binary buffer required to pack the pair + procedure :: pack_size => pair_pack_size + !> Packs the pair onto a characcter buffer + procedure :: mpi_pack => pair_mpi_pack + !> Unpacks a pair from a character buffer + procedure :: mpi_unpack => pair_mpi_unpack + end type pair_t + + !> Constructor of pair_t objects + interface pair_t + module procedure :: pair_constructor + end interface pair_t + + !> Map between arrays + !! + !! Maps can be used to transfer data from a source to a destination array + !! with optional scaling. + !! + !! The mapped elements are identified by name according to the passed + !! configuration. The configuration format for a map is: + !! \code{json} + !! { + !! "match full source": false, + !! "match full destination": false, + !! "sum multiple matches": true, + !! "default matching": "backup", + !! "pairs": [ + !! { + !! "from": "foo", + !! "to": "bar" + !! }, + !! { + !! "from": "baz", + !! "to": "quz", + !! "scale by": 1.2 + !! } + !! ] + !! } + !! \endcode + !! + !! The "match full source" and "match full destination" terms are optional + !! and default to \c true. + !! When these are \c true unmatched source/destination array elements will + !! trigger an error. + !! If unmatched destination elements are allowed, they will be set to + !! zero when the map is applied to transfer data. + !! The "sum multiple matches" term is optional and defaults to \c false. + !! When this is \c true, multiple matches to a single destination array + !! element will be summed when the map is applied to transfer data. + !! When this is \c false, the second match to a destination array + !! element will trigger an error. + !! The "default matching" term is optional and indicates how matching + !! names that appear in both source and destination label arrays + !! should be treated. + !! The three options for default matching are "always", "backup", + !! and "never"; the default option is "never". + !! Default matching "always" indicates that every time a name appears + !! in both the source and destination label arrays, a set of paired + !! elements should be created in the map with a scaling factor of 1.0. + !! Default matching "backup" indicates that such a pair is only + !! created when no explicit entries for the destination element + !! exist in the configuration. + !! Default mapping "never" means that no such pairs are created. + !! If the default mapping is set to "always" or "backup", the + !! "match full destination" term must be \c true. + !! + !! The "pairs" term is required and is an array that + !! describes each matched pair of elements. The matched pair terms + !! must include "from" and "to" terms. + !! The "scale by" term is optional and defaults to 1.0. + !! This scaling factor will be applied to the source array element + !! before additon to the destination array element. + !! + !! The \c map_t constructor accepts an array of source element labels + !! and an array of destination element labels that are used to + !! identify the mapped array indices. + !! + type :: map_t + private + !> Mapped pairs of array elements + type(pair_t), allocatable :: pairs_(:) + !> Source array size + integer :: from_size_ + !> Destination array size + integer :: to_size_ + contains + !> Transfers data from source to destination arrays + procedure :: apply + !> Returns the size of a character buffer required to pack the map + procedure :: pack_size + !> Packs the map onto a character buffer + procedure :: mpi_pack + !> Unpacks the map from a character buffer + procedure :: mpi_unpack + !> Prints the map + procedure :: print => print_map + !> Adds default matches by name to the map + procedure, private :: add_default_matches + !> Validates the matches based on user-selected options + procedure, private :: validate + end type map_t + + !> Constructor of map_t objects + interface map_t + module procedure :: constructor + end interface map_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a map_t object + type(map_t) function constructor( config, from_labels, to_labels ) & + result( this ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t + + !> Map configuration + type(config_t), intent(inout) :: config + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + + character(len=*), parameter :: my_name = "Map constructor" + type(config_t) :: pairs, pair + class(iterator_t), pointer :: iter + integer :: i_pair + integer, allocatable :: source_match(:), dest_match(:) + type(string_t) :: default_matching + type(string_t) :: required_keys(1), optional_keys(4) + + required_keys(1) = "pairs" + optional_keys(1) = "match full source" + optional_keys(2) = "match full destination" + optional_keys(3) = "sum multiple matches" + optional_keys(4) = "default matching" + + call assert_msg( 170733942, & + config%validate( required_keys, optional_keys ), & + "Bad configuration format for map." ) + call config%get( "default matching", default_matching, my_name, & + default = "never" ) + call config%get( "pairs", pairs, my_name ) + + this%from_size_ = size( from_labels ) + this%to_size_ = size( to_labels ) + + ! Get all matched pairs + allocate( this%pairs_( pairs%number_of_children( ) ) ) + iter => pairs%get_iterator( ) + i_pair = 0 + do while( iter%next( ) ) + call pairs%get( iter, pair, my_name ) + i_pair = i_pair + 1 + this%pairs_( i_pair ) = pair_t( pair, from_labels, to_labels ) + end do + deallocate( iter ) + + if( default_matching == "always" ) then + call this%add_default_matches( from_labels, to_labels, always = .true. ) + else if( default_matching == "backup" ) then + call this%add_default_matches( from_labels, to_labels, always = .false. ) + else + call assert_msg( 135980113, default_matching == "never", & + "Invalid default matching option for map creation: '"//& + default_matching//"'" ) + end if + + call this%validate( config, from_labels, to_labels ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Transfers data from source to destination array based on map + subroutine apply( this, from, to ) + + use musica_assert, only : assert_msg + + !> Map + class(map_t), intent(in) :: this + !> Source array + real(kind=dk), intent(in) :: from(:) + !> Destination array + real(kind=dk), intent(out) :: to(:) + + integer :: i_elem + + call assert_msg( 764798475, size( from ) .eq. this%from_size_, & + "Wrong size for mapped source array." ) + call assert_msg( 133386338, size( to ) .eq. this%to_size_, & + "Wrong size for mapped destination array." ) + to(:) = 0.0_dk + do i_elem = 1, size( this%pairs_ ) + associate( pair => this%pairs_( i_elem ) ) + to( pair%to_index_ ) = to( pair%to_index_ ) + & + from( pair%from_index_ ) * & + pair%scale_factor_ + end associate + end do + + end subroutine apply + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the map + integer function pack_size( this, comm ) + + use musica_mpi + + !> Map to pack + class(map_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: i_pair + + pack_size = musica_mpi_pack_size( allocated( this%pairs_ ), comm ) + if( allocated( this%pairs_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( size( this%pairs_ ), comm ) + do i_pair = 1, size( this%pairs_ ) + pack_size = pack_size + this%pairs_( i_pair )%pack_size( comm ) + end do + end if + pack_size = pack_size + musica_mpi_pack_size( this%from_size_, comm ) + & + musica_mpi_pack_size( this%to_size_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the map onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Map to pack + class(map_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: i_pair, prev_position + + prev_position = position + call musica_mpi_pack( buffer, position, allocated( this%pairs_ ), comm ) + if( allocated( this%pairs_ ) ) then + call musica_mpi_pack( buffer, position, size( this%pairs_ ), comm ) + do i_pair = 1, size( this%pairs_ ) + call this%pairs_( i_pair )%mpi_pack( buffer, position, comm ) + end do + end if + call musica_mpi_pack( buffer, position, this%from_size_, comm ) + call musica_mpi_pack( buffer, position, this%to_size_, comm ) + call assert( 419959778, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a map from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Map to unpack + class(map_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + logical :: alloced + integer :: i_pair, n_pairs, prev_position + + prev_position = position + call musica_mpi_unpack( buffer, position, alloced, comm ) + if( alloced ) then + call musica_mpi_unpack( buffer, position, n_pairs, comm ) + allocate( this%pairs_( n_pairs ) ) + do i_pair = 1, size( this%pairs_ ) + call this%pairs_( i_pair )%mpi_unpack( buffer, position, comm ) + end do + end if + call musica_mpi_unpack( buffer, position, this%from_size_, comm ) + call musica_mpi_unpack( buffer, position, this%to_size_, comm ) + call assert( 576681590, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Prints the map details to a specified output unit + subroutine print_map( this, from_labels, to_labels, out_unit ) + + use musica_assert, only : assert_msg + use musica_string, only : string_t, output_table + + !> Map + class(map_t), intent(in) :: this + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + !> Output unit + integer, intent(in) :: out_unit + + type(string_t) :: header(3) + type(string_t), allocatable :: table(:,:) + integer :: i_pair + + call assert_msg( 727878410, size( from_labels ) .eq. this%from_size_, & + "Wrong size for map source label array." ) + call assert_msg( 161474673, size( to_labels ) .eq. this%to_size_, & + "Wrong size for map destination label array." ) + if( .not. allocated( this%pairs_ ) ) then + write(out_unit,*) "Map not initialized" + return + end if + header(1) = "from" + header(2) = "to" + header(3) = "scaling factor" + allocate( table( 3, size( this%pairs_ ) ) ) + do i_pair = 1, size( this%pairs_ ) + associate( pair => this%pairs_( i_pair ) ) + table( 1, i_pair ) = from_labels( pair%from_index_ ) + table( 2, i_pair ) = to_labels( pair%to_index_ ) + table( 3, i_pair ) = pair%scale_factor_ + end associate + end do + call output_table( header, table, out_unit ) + + end subroutine print_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds default matches by name to the map + !! + !! If the \c always option is set to \c false, only unmatched source + !! elements are included in the default matching + subroutine add_default_matches( this, from_labels, to_labels, always ) + + use musica_array, only : find_string_in_array + use musica_string, only : string_t + + !> Map + class(map_t), intent(inout) :: this + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + !> Flag indicating whether to always add default matches, or only do so + !! for unmatched source elements + logical, intent(in) :: always + + integer :: matches( size( to_labels ) ) + integer :: i_to, i_from, i_pair + type(pair_t) :: pair + + matches(:) = 0 + if( .not. always ) then + do i_pair = 1, size( this%pairs_ ) + i_to = this%pairs_( i_pair )%to_index_ + matches( i_to ) = matches( i_to ) + 1 + end do + end if + do i_to = 1, size( to_labels ) + if( matches( i_to ) > 0 ) cycle + if( find_string_in_array( from_labels, to_labels( i_to ), i_from, & + case_sensitive = .true. ) ) then + pair%to_index_ = i_to + pair%from_index_ = i_from + pair%scale_factor_ = 1.0_dk + this%pairs_ = [ this%pairs_, pair ] + end if + end do + + end subroutine add_default_matches + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Validates the map based on user-selected options + subroutine validate( this, config, from_labels, to_labels ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t + + !> Map + class(map_t), intent(in) :: this + !> Map configuration + type(config_t), intent(inout) :: config + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + + character(len=*), parameter :: my_name = "Map validation" + integer, allocatable :: match(:) + type(string_t) :: default_matching + integer :: i_pair, i_elem + logical :: match_source + logical :: match_dest + logical :: allow_sum + + call config%get( "match full source", match_source, my_name, & + default = .true. ) + call config%get( "match full destination", match_dest, my_name, & + default = .true. ) + call config%get( "sum multiple matches", allow_sum, my_name, & + default = .false. ) + call config%get( "default matching", default_matching, my_name, & + default = "never" ) + + call assert_msg( 548594113, match_dest .or. default_matching == "never", & + "Default matching is only possible when matching the "// & + "full destination array for maps." ) + + if( match_source ) then + allocate( match( this%from_size_ ) ) + match(:) = 0 + do i_pair = 1, size( this%pairs_ ) + associate( match_elem => match( this%pairs_( i_pair )%from_index_ ) ) + match_elem = match_elem + 1 + end associate + end do + do i_elem = 1, size( match ) + call assert_msg( 956987954, match( i_elem ) > 0, & + "Unmatched element '"//from_labels( i_elem )// & + "' in source array of map." ) + end do + deallocate( match ) + end if + + if( match_dest .or. .not. allow_sum ) then + allocate( match( this%to_size_ ) ) + match(:) = 0 + do i_pair = 1, size( this%pairs_ ) + associate( match_elem => match( this%pairs_( i_pair )%to_index_ ) ) + match_elem = match_elem + 1 + end associate + end do + do i_elem = 1, size( match ) + call assert_msg( 200274675, & + match( i_elem ) > 0 .or. .not. match_dest, & + "Unmatched element '"//to_labels( i_elem )// & + "' in destination array of map." ) + call assert_msg( 240867074, & + match( i_elem ) < 2 .or. allow_sum, & + "Multiple matches found for element '"// & + to_labels( i_elem )// & + "' in destination array of map." ) + end do + deallocate( match ) + end if + + end subroutine validate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructor of pair_t objects + type(pair_t) function pair_constructor( config, from_labels, to_labels ) & + result( this ) + + use musica_array, only : find_string_in_array + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t + + !> Matched pair configuration + type(config_t), intent(inout) :: config + !> Source array element labels + type(string_t), intent(in) :: from_labels(:) + !> Destination array element labels + type(string_t), intent(in) :: to_labels(:) + + character(len=*), parameter :: my_name = "Map pair constructor" + type(string_t) :: label + type(string_t) :: required_keys(2), optional_keys(1) + + required_keys(1) = "from" + required_keys(2) = "to" + optional_keys(1) = "scale by" + + call assert_msg( 309595761, & + config%validate( required_keys, optional_keys ), & + "Bad configuration format for map pair." ) + + call config%get( "from", label, my_name ) + call assert_msg( 122570601, & + find_string_in_array( from_labels, label, & + this%from_index_, case_sensitive = .true. ), & + "Cannot find source label '"//label//"' building map." ) + call config%get( "to", label, my_name ) + call assert_msg( 740547646, & + find_string_in_array( to_labels, label, & + this%to_index_, case_sensitive = .true. ), & + "Cannot find destination label '"//label// & + "' building map." ) + call config%get( "scale by", this%scale_factor_, my_name, & + default = 1.0_dk ) + + end function pair_constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the pair + integer function pair_pack_size( this, comm ) result( pack_size ) + + use musica_mpi + + !> Pair to pack + class(pair_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = musica_mpi_pack_size( this%from_index_, comm ) + & + musica_mpi_pack_size( this%to_index_, comm ) + & + musica_mpi_pack_size( this%scale_factor_, comm ) +#else + pack_size = 0 +#endif + + end function pair_pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the pair onto a character buffer + subroutine pair_mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Pair to pack + class(pair_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + + prev_position = position + call musica_mpi_pack( buffer, position, this%from_index_, comm ) + call musica_mpi_pack( buffer, position, this%to_index_, comm ) + call musica_mpi_pack( buffer, position, this%scale_factor_, comm ) + call assert( 995726013, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine pair_mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a pair from a character buffer + subroutine pair_mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi + + !> Pair to unpack + class(pair_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + + prev_position = position + call musica_mpi_unpack( buffer, position, this%from_index_, comm ) + call musica_mpi_unpack( buffer, position, this%to_index_, comm ) + call musica_mpi_unpack( buffer, position, this%scale_factor_, comm ) + call assert( 143488254, & + position - prev_position <= this%pack_size( comm ) ) +#endif + + end subroutine pair_mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_map diff --git a/src/util/mpi.F90 b/src/util/mpi.F90 new file mode 100644 index 00000000..9a1aed77 --- /dev/null +++ b/src/util/mpi.F90 @@ -0,0 +1,1165 @@ +! Copyright (C) 2007-2021 Barcelona Supercomputing Center and University of +! Illinois at Urbana-Champaign +! SPDX-License-Identifier: MIT +module musica_mpi + ! Wrapper functions for MPI. + ! + ! This module was adapted from CAMP (https://github.com/open-atmos/camp). + ! + ! All of these functions can be called irrespective of whether MPI + ! support was compiled in or not. If MPI support is not enabled then + ! they do the obvious trivial thing (normally nothing). + +#ifdef MUSICA_USE_MPI + use mpi +#endif + + use musica_constants, only : dp => musica_dk + + implicit none + + private + public :: musica_mpi_support, musica_mpi_init, musica_mpi_abort, & + musica_mpi_finalize, musica_mpi_barrier, musica_mpi_rank, & + musica_mpi_size, musica_mpi_bcast, musica_mpi_pack_size, & + musica_mpi_pack, musica_mpi_unpack, MPI_COMM_WORLD + +#ifndef MUSICA_USE_MPI + ! Parameter to make a communicator available when MPI support is not + ! compiled in (to avoid a lot of preprocessor flags in tests) + integer, parameter :: MPI_COMM_WORLD = 0 +#endif + + integer, parameter :: dc = dp ! kind for double-precision complex numbers + + ! Broadcasts a variable from the primary process to all other processes + interface musica_mpi_bcast + procedure :: musica_mpi_bcast_integer + procedure :: musica_mpi_bcast_string + procedure :: musica_mpi_bcast_packed + end interface musica_mpi_bcast + + ! Returns the size of a character buffer needed to pack a given variable + interface musica_mpi_pack_size + procedure :: musica_mpi_pack_size_integer + procedure :: musica_mpi_pack_size_string + procedure :: musica_mpi_pack_size_real + procedure :: musica_mpi_pack_size_logical + procedure :: musica_mpi_pack_size_complex + procedure :: musica_mpi_pack_size_integer_array + procedure :: musica_mpi_pack_size_string_array + procedure :: musica_mpi_pack_size_real_array + procedure :: musica_mpi_pack_size_real_array_2d + procedure :: musica_mpi_pack_size_real_array_3d + end interface musica_mpi_pack_size + + ! Packs the given variable onto a character buffer + interface musica_mpi_pack + procedure :: musica_mpi_pack_integer + procedure :: musica_mpi_pack_string + procedure :: musica_mpi_pack_real + procedure :: musica_mpi_pack_logical + procedure :: musica_mpi_pack_complex + procedure :: musica_mpi_pack_integer_array + procedure :: musica_mpi_pack_string_array + procedure :: musica_mpi_pack_real_array + procedure :: musica_mpi_pack_real_array_2d + procedure :: musica_mpi_pack_real_array_3d + end interface musica_mpi_pack + + ! Unpacks a variable from a character buffer + interface musica_mpi_unpack + procedure :: musica_mpi_unpack_integer + procedure :: musica_mpi_unpack_string + procedure :: musica_mpi_unpack_real + procedure :: musica_mpi_unpack_logical + procedure :: musica_mpi_unpack_complex + procedure :: musica_mpi_unpack_integer_array + procedure :: musica_mpi_unpack_string_array + procedure :: musica_mpi_unpack_real_array + procedure :: musica_mpi_unpack_real_array_2d + procedure :: musica_mpi_unpack_real_array_3d + end interface musica_mpi_unpack + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + logical function musica_mpi_support( ) + ! Whether MPI support is compiled in. + +#ifdef MUSICA_USE_MPI + musica_mpi_support = .true. +#else + musica_mpi_support = .false. +#endif + + end function musica_mpi_support + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_check_ierr( ierr ) + ! Dies if ``ierr`` is not ok. + + integer, intent(in) :: ierr ! MPI status code + +#ifdef MUSICA_USE_MPI + if( ierr /= MPI_SUCCESS )then + call musica_mpi_abort(1) + end if +#endif + + end subroutine musica_mpi_check_ierr + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_init( ) + ! Initialize MPI. + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_init( ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_init + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_abort( status ) + ! Abort the program. + + integer, intent(in) :: status ! Status flag to abort with + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_abort( MPI_COMM_WORLD, status, ierr ) +#else + call assert( status, .false. ) + +#endif + + end subroutine musica_mpi_abort + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine musica_mpi_finalize( ) + + ! Shut down MPI. + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_finalize( ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_finalize + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! Synchronize all processes. + subroutine musica_mpi_barrier( comm ) + + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: ierr + + call mpi_barrier( comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_barrier + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_rank( comm ) + ! Returns the rank of the current process. + + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: rank, ierr + + call mpi_comm_rank( comm, rank, ierr ) + call musica_mpi_check_ierr( ierr ) + musica_mpi_rank = rank +#else + musica_mpi_rank = 0 +#endif + + end function musica_mpi_rank + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_size( comm ) + ! Returns the total number of processes. + + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: size, ierr + + call mpi_comm_size( comm, size, ierr ) + call musica_mpi_check_ierr( ierr ) + musica_mpi_size = size +#else + musica_mpi_size = 1 +#endif + + end function musica_mpi_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_bcast_integer( val, comm ) + ! Broadcast the given value from process 0 to all other processes. + + integer, intent(inout) :: val ! value to broadcast + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: root, ierr + + root = 0 ! source of data to broadcast + call mpi_bcast( val, 1, MPI_INTEGER, root, comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_bcast_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_bcast_string( val, comm ) + ! Broadcast the given value from process 0 to all other processes. + + character(len=*), intent(inout) :: val ! value to broadcast + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: root, ierr + + root = 0 ! source of data to broadcast + call mpi_bcast( val, len( val ), MPI_CHARACTER, root, comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_bcast_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_bcast_packed( val, comm ) + ! Broadcast the given value from process 0 to all other processes. + + character, intent(inout) :: val(:) ! value to be broadcast + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: root, ierr + + root = 0 ! source of data to broadcast + call mpi_bcast( val, size( val ), MPI_CHARACTER, root, comm, ierr ) + call musica_mpi_check_ierr( ierr ) +#endif + + end subroutine musica_mpi_bcast_packed + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_integer( val, comm ) + ! Determines the number of bytes required to pack the given value. + + integer, intent(in) :: val ! value to be packed + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_INTEGER, comm, & + musica_mpi_pack_size_integer, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_integer = 0 +#endif + + end function musica_mpi_pack_size_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_DOUBLE_PRECISION, comm, & + musica_mpi_pack_size_real, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_real = 0 +#endif + + end function musica_mpi_pack_size_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_string( val, comm ) + ! Determines the number of bytes required to pack the given value. + + character(len=*), intent(in) :: val ! value to be packed + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( len_trim( val ), MPI_CHARACTER, comm, & + musica_mpi_pack_size_string, ierr ) + call musica_mpi_check_ierr( ierr ) + musica_mpi_pack_size_string = musica_mpi_pack_size_string & + + musica_mpi_pack_size_integer( len_trim( val ), comm ) +#else + musica_mpi_pack_size_string = 0 +#endif + + end function musica_mpi_pack_size_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_logical( val, comm ) + ! Determines the number of bytes required to pack the given value. + + logical, intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_LOGICAL, comm, & + musica_mpi_pack_size_logical, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_logical = 0 +#endif + + end function musica_mpi_pack_size_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_complex( val, comm ) + ! Determines the number of bytes required to pack the given value. + + complex(kind=dc), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: ierr + +#ifdef MUSICA_USE_MPI + + call mpi_pack_size( 1, MPI_DOUBLE_COMPLEX, comm, & + musica_mpi_pack_size_complex, ierr ) + call musica_mpi_check_ierr( ierr ) +#else + musica_mpi_pack_size_complex = 0 +#endif + + end function musica_mpi_pack_size_complex + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_integer_array( val, comm ) + ! Determines the number of bytes required to pack the given value. + + integer, allocatable, intent(in) :: val(:) ! value to be packed + integer, intent(in) :: comm ! MPI communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_INTEGER, comm, total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size + & + musica_mpi_pack_size_integer( size( val ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_integer_array = total_size + + end function musica_mpi_pack_size_integer_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real_array( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_DOUBLE_PRECISION, comm, & + total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size + & + musica_mpi_pack_size_integer( size( val ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_real_array = total_size + + end function musica_mpi_pack_size_real_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_string_array( val, comm ) + ! Determines the number of bytes required to pack the given value. + + character(len=*), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + + integer :: i, total_size +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + is_allocated = allocated( val ) + if( is_allocated ) then + total_size = musica_mpi_pack_size_integer( size( val ), comm ) + do i = 1, size( val ) + total_size = total_size + & + musica_mpi_pack_size_string( val( i ), comm ) + end do + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) + musica_mpi_pack_size_string_array = total_size +#else + total_size = 0 +#endif + + end function musica_mpi_pack_size_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real_array_2d( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), allocatable, intent(in) :: val(:,:) ! value to pack + integer, intent(in) :: comm ! MPI Communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_DOUBLE_PRECISION, comm, & + total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size & + + musica_mpi_pack_size_integer( size( val, 1 ), comm ) & + + musica_mpi_pack_size_integer( size( val, 2 ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_real_array_2d = total_size + + end function musica_mpi_pack_size_real_array_2d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function musica_mpi_pack_size_real_array_3d( val, comm ) + ! Determines the number of bytes required to pack the given value. + + real(kind=dp), allocatable, intent(in) :: val(:,:,:) ! value to pack + integer, intent(in) :: comm ! MPI Communicator + + integer :: total_size, ierr + +#ifdef MUSICA_USE_MPI + logical :: is_allocated + + + total_size = 0 + is_allocated = allocated( val ) + if( is_allocated ) then + call mpi_pack_size( size( val ), MPI_DOUBLE_PRECISION, comm, & + total_size, ierr ) + call musica_mpi_check_ierr( ierr ) + total_size = total_size & + + musica_mpi_pack_size_integer( size( val, 1 ), comm ) & + + musica_mpi_pack_size_integer( size( val, 2 ), comm ) & + + musica_mpi_pack_size_integer( size( val, 3 ), comm ) + end if + total_size = total_size + & + musica_mpi_pack_size_logical( is_allocated, comm ) +#else + total_size = 0 +#endif + + musica_mpi_pack_size_real_array_3d = total_size + + end function musica_mpi_pack_size_real_array_3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_integer( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_INTEGER, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 913495993, & + position - prev_position <= & + musica_mpi_pack_size_integer( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + real(kind=dp), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_DOUBLE_PRECISION, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 395354132, & + position - prev_position <= & + musica_mpi_pack_size_real( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_string( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, length, ierr + + + prev_position = position + length = len_trim( val ) + call musica_mpi_pack_integer( buffer, position, length, comm ) + call mpi_pack( val, length, MPI_CHARACTER, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 607212018, & + position - prev_position <= & + musica_mpi_pack_size_string( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_logical( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + logical, intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_LOGICAL, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 104535200, & + position - prev_position <= & + musica_mpi_pack_size_logical( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_complex( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + complex(kind=dc), intent(in) :: val ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_pack( val, 1, MPI_DOUBLE_COMPLEX, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 640416372, & + position - prev_position <= & + musica_mpi_pack_size_complex( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_complex + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_integer_array( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + integer, allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n = size( val ) + call musica_mpi_pack_integer( buffer, position, n, comm ) + call mpi_pack( val, n, MPI_INTEGER, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 698601296, & + position - prev_position <= & + musica_mpi_pack_size_integer_array( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_integer_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real_array( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n = size( val ) + call musica_mpi_pack_integer( buffer, position, n, comm ) + call mpi_pack( val, n, MPI_DOUBLE_PRECISION, buffer, size( buffer ), & + position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 825718791, & + position - prev_position <= & + musica_mpi_pack_size_real_array( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_string_array( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), allocatable, intent(in) :: val(:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, i, n + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated) then + n = size( val ) + call musica_mpi_pack_integer( buffer, position, n, comm ) + do i = 1, n + call musica_mpi_pack_string( buffer, position, val( i ), comm ) + end do + end if + call assert( 630900704, & + position - prev_position <= & + musica_mpi_pack_size_string_array( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real_array_2d( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(in) :: val(:,:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n1 = size( val, 1 ) + n2 = size( val, 2 ) + call musica_mpi_pack_integer( buffer, position, n1, comm ) + call musica_mpi_pack_integer( buffer, position, n2, comm ) + call mpi_pack( val, n1 * n2, MPI_DOUBLE_PRECISION, buffer, & + size( buffer ), position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 567349745, & + position - prev_position <= & + musica_mpi_pack_size_real_array_2d( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real_array_2d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_pack_real_array_3d( buffer, position, val, comm ) + ! Packs the given value into the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(in) :: val(:,:,:) ! value to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, n3, ierr + logical :: is_allocated + + + prev_position = position + is_allocated = allocated( val ) + call musica_mpi_pack_logical( buffer, position, is_allocated, comm ) + if( is_allocated ) then + n1 = size( val, 1 ) + n2 = size( val, 2 ) + n3 = size( val, 3 ) + call musica_mpi_pack_integer( buffer, position, n1, comm ) + call musica_mpi_pack_integer( buffer, position, n2, comm ) + call musica_mpi_pack_integer( buffer, position, n3, comm ) + call mpi_pack( val, n1 * n2 * n3, MPI_DOUBLE_PRECISION, buffer, & + size( buffer ), position, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 851684870, & + position - prev_position <= & + musica_mpi_pack_size_real_array_3d( val, comm ) ) +#endif + + end subroutine musica_mpi_pack_real_array_3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_integer( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + integer, intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, MPI_INTEGER, & + comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 890243339, & + position - prev_position <= & + musica_mpi_pack_size_integer( val, comm ) ) +#else + val = 0 +#endif + + end subroutine musica_mpi_unpack_integer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 570771632, & + position - prev_position <= & + musica_mpi_pack_size_real( val, comm ) ) +#else + val = real( 0.0, kind = dp ) +#endif + + end subroutine musica_mpi_unpack_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_string( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, length, ierr + + + prev_position = position + call musica_mpi_unpack_integer( buffer, position, length, comm ) + call assert(946399479, length <= len( val ) ) + val = '' + call mpi_unpack( buffer, size( buffer ), position, val, length, & + MPI_CHARACTER, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 503378058, & + position - prev_position <= & + musica_mpi_pack_size_string( val, comm ) ) +#else + val = '' +#endif + + end subroutine musica_mpi_unpack_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_logical( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + logical, intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, MPI_LOGICAL, & + comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 694750528, & + position - prev_position <= & + musica_mpi_pack_size_logical( val, comm ) ) +#else + val = .false. +#endif + + end subroutine musica_mpi_unpack_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_complex( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + complex(kind=dc), intent(out) :: val ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, ierr + + + prev_position = position + call mpi_unpack( buffer, size( buffer ), position, val, 1, & + MPI_DOUBLE_COMPLEX, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + call assert( 969672634, & + position - prev_position <= & + musica_mpi_pack_size_complex( val, comm ) ) +#else + val = cmplx( 0 ) +#endif + + end subroutine musica_mpi_unpack_complex + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_integer_array( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + integer, allocatable, intent(inout) :: val(:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n, comm ) + allocate( val( n ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n, MPI_INTEGER,& + comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 565840919, & + position - prev_position <= & + musica_mpi_pack_size_integer_array( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_integer_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real_array( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(inout) :: val(:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n, comm ) + allocate( val( n ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 782875761, & + position - prev_position <= & + musica_mpi_pack_size_real_array( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_real_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_string_array( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + character(len=*), allocatable, intent(inout) :: val(:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, i, n + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n, comm ) + allocate( val( n ) ) + do i = 1, n + call musica_mpi_unpack_string( buffer, position, val( i ), comm ) + end do + end if + call assert( 320065648, & + position - prev_position <= & + musica_mpi_pack_size_string_array( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_string_array + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real_array_2d( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(inout) :: val(:,:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n1, comm ) + call musica_mpi_unpack_integer( buffer, position, n2, comm ) + allocate( val( n1, n2 ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n1 * n2, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 781681739, position - prev_position & + <= musica_mpi_pack_size_real_array_2d( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_real_array_2d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine musica_mpi_unpack_real_array_3d( buffer, position, val, comm ) + ! Unpacks the given value from the buffer, advancing position. + + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! curent buffer position + real(kind=dp), allocatable, intent(inout) :: val(:,:,:) ! value to unpack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_position, n1, n2, n3, ierr + logical :: is_allocated + + + prev_position = position + call musica_mpi_unpack_logical( buffer, position, is_allocated, comm ) + if( allocated( val ) ) deallocate( val ) + if( is_allocated ) then + call musica_mpi_unpack_integer( buffer, position, n1, comm ) + call musica_mpi_unpack_integer( buffer, position, n2, comm ) + call musica_mpi_unpack_integer( buffer, position, n3, comm ) + allocate( val( n1, n2, n3 ) ) + call mpi_unpack( buffer, size( buffer ), position, val, n1 * n2 * n3, & + MPI_DOUBLE_PRECISION, comm, ierr ) + call musica_mpi_check_ierr( ierr ) + end if + call assert( 162434174, position - prev_position & + <= musica_mpi_pack_size_real_array_3d( val, comm ) ) +#endif + + end subroutine musica_mpi_unpack_real_array_3d + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !> Local assert + subroutine assert( code, condition ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + + character(len=50) :: str_code + integer, parameter :: kErrorId = 0 + integer, parameter :: kErrorFileId = 10 + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //"assertion failed" + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "assertion failed"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_mpi diff --git a/src/util/string.F90 b/src/util/string.F90 new file mode 100644 index 00000000..7564a51c --- /dev/null +++ b/src/util/string.F90 @@ -0,0 +1,1528 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The musica_string module + +!> The string_t type and related functions +module musica_string + + use musica_constants, only : musica_ik, musica_rk, musica_dk + + implicit none + private + + public :: string_t, to_char, output_table + + !> Length of character array for to_char conversions + integer(kind=musica_ik), parameter :: kConvertCharLength = 100 + + !> Generic string type + type :: string_t + !> the string + character(len=:), allocatable :: val_ + contains + !> @name String assignment + !! @{ + procedure, private, pass(to) :: string_assign_char + procedure, private, pass(to) :: string_assign_int + procedure, private, pass(to) :: string_assign_real + procedure, private, pass(to) :: string_assign_double + procedure, private, pass(to) :: string_assign_logical + procedure, private, pass(from) :: string_assign_string + procedure, private, pass(from) :: char_assign_string + procedure, private, pass(from) :: real_assign_string + procedure, private, pass(from) :: double_assign_string + procedure, private, pass(from) :: int_assign_string + procedure, private, pass(from) :: logical_assign_string + generic :: assignment(=) => string_assign_char, string_assign_int, & + string_assign_real, string_assign_double, & + string_assign_logical, string_assign_string, & + char_assign_string, real_assign_string, & + double_assign_string, int_assign_string, & + logical_assign_string + !> @} + !> @name Joins to a string + !! @{ + procedure, private, pass(a) :: string_join_string + procedure, private, pass(a) :: string_join_char + procedure, private, pass(a) :: string_join_int + procedure, private, pass(a) :: string_join_real + procedure, private, pass(a) :: string_join_double + procedure, private, pass(a) :: string_join_logical + procedure, private, pass(b) :: char_join_string + procedure, private, pass(b) :: int_join_string + procedure, private, pass(b) :: real_join_string + procedure, private, pass(b) :: double_join_string + procedure, private, pass(b) :: logical_join_string + generic :: operator(//) => string_join_string, string_join_char, & + string_join_int, string_join_real, & + string_join_double, string_join_logical, & + char_join_string, int_join_string, & + real_join_string, double_join_string, & + logical_join_string + !> @} + !> @name String equality + !! @{ + procedure, private, pass(a) :: string_equals_string + procedure, private, pass(a) :: string_equals_char + procedure, private, pass(a) :: string_equals_int + procedure, private, pass(a) :: string_equals_real + procedure, private, pass(a) :: string_equals_double + procedure, private, pass(a) :: string_equals_logical + procedure, private, pass(b) :: char_equals_string + procedure, private, pass(b) :: int_equals_string + procedure, private, pass(b) :: real_equals_string + procedure, private, pass(b) :: double_equals_string + procedure, private, pass(b) :: logical_equals_string + generic :: operator(==) => string_equals_string, string_equals_char, & + string_equals_int, string_equals_real, & + string_equals_double, string_equals_logical, & + char_equals_string, int_equals_string, & + real_equals_string, double_equals_string, & + logical_equals_string + procedure, private, pass(a) :: string_not_equals_string + procedure, private, pass(a) :: string_not_equals_char + procedure, private, pass(a) :: string_not_equals_int + procedure, private, pass(a) :: string_not_equals_real + procedure, private, pass(a) :: string_not_equals_double + procedure, private, pass(a) :: string_not_equals_logical + procedure, private, pass(b) :: char_not_equals_string + procedure, private, pass(b) :: int_not_equals_string + procedure, private, pass(b) :: real_not_equals_string + procedure, private, pass(b) :: double_not_equals_string + procedure, private, pass(b) :: logical_not_equals_string + generic :: operator(/=) => string_not_equals_string, & + string_not_equals_char, & + string_not_equals_int, & + string_not_equals_real, & + string_not_equals_double, & + string_not_equals_logical, & + char_not_equals_string, & + int_not_equals_string, & + real_not_equals_string, & + double_not_equals_string, & + logical_not_equals_string + !> @} + !> Returns the string length + procedure :: length + !> Converts a string to upper case + procedure :: to_upper + !> Converts a string to lower case + procedure :: to_lower + !> Gets a substring + procedure :: substring + !> @name Splits a string on a sub-string + !! @{ + procedure, private :: split_char + procedure, private :: split_string + generic :: split => split_char, split_string + !> @} + + !> Replaces substrings within a string + procedure :: replace + !> Converts a string to a character array + procedure :: to_char => string_to_char + !> Returns the size of a binary buffer required to pack the string + procedure :: pack_size + !> Packs the string onto a character buffer + procedure :: mpi_pack + !> Unpacks the string from a character buffer + procedure :: mpi_unpack + end type string_t + + !> Converts values to character arrays + interface to_char + module procedure int_to_char + module procedure real_to_char + module procedure double_to_char + module procedure complex_real_to_char + module procedure complex_double_to_char + module procedure logical_to_char + end interface to_char + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a character array + subroutine string_assign_char( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + character(len=*), intent(in) :: from + + to%val_ = trim( from ) + + end subroutine string_assign_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from an integer + subroutine string_assign_int( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + integer(kind=musica_ik), intent(in) :: from + + character(len=30) :: new_val + + write( new_val, '(i30)' ) from + to%val_ = trim( adjustl( new_val ) ) + + end subroutine string_assign_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a real number + subroutine string_assign_real( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + real(kind=musica_rk), intent(in) :: from + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) from + to%val_ = trim( adjustl( new_val ) ) + + end subroutine string_assign_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a double precision real number + subroutine string_assign_double( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + real(kind=musica_dk), intent(in) :: from + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) from + to%val_ = trim( adjustl( new_val ) ) + + end subroutine string_assign_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a string from a logical + subroutine string_assign_logical( to, from ) + + !> String to assign + class(string_t), intent(out) :: to + !> New string value + logical, intent(in) :: from + + if( from ) then + to%val_ = "true" + else + to%val_ = "false" + end if + + end subroutine string_assign_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a string from a string + subroutine string_assign_string( to, from ) + + !> String to assign + type(string_t), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + if( .not. allocated( from%val_ ) ) then + if( allocated( to%val_ ) ) deallocate( to%val_ ) + return + end if + to%val_ = from%val_ + + end subroutine string_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a character array from a string + subroutine char_assign_string( to, from ) + + !> Variable to assign + character(len=*), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: len_char, len_str + + if( .not. allocated( from%val_ ) ) then + to = "" + return + end if + len_char = len( to ) + len_str = len( from%val_ ) + if( len_char .lt. len_str ) then + to = from%val_(1:len_char) + else + to = from%val_ + end if + + end subroutine char_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a real from a string + subroutine real_assign_string( to, from ) + + !> Variable to assign + real(kind=musica_rk), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: ios + + call assert_msg( 584471137, allocated( from%val_ ), & + "Cannot assign real from unallocated string" ) + call assert_msg( 621504169, len( from%val_ ) .le. 40, & + "Error converting '"//from%val_//"' to real: "// & + "string too long" ) + read( from%val_, '(f40.0)', iostat=ios ) to + call assert_msg( 102862672, ios .eq. 0, & + "Error converting '"//from%val_//"' to real: "// & + "IOSTAT = "//trim( to_char( ios ) ) ) + + end subroutine real_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign a double precision real from a string + subroutine double_assign_string( to, from ) + + !> Variable to assign + real(kind=musica_dk), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: ios + + call assert_msg( 860228840, allocated( from%val_ ), & + "Cannot assign double from unallocated string" ) + call assert_msg( 156176342, len( from%val_ ) .le. 40, & + "Error converting '"//from%val_//"' to double: "// & + "string too long" ) + read( from%val_, '(f40.0)', iostat=ios ) to + call assert_msg( 445821432, ios .eq. 0, & + "Error converting '"//from%val_//"' to double: "// & + "IOSTAT = "//trim( to_char( ios ) ) ) + + end subroutine double_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assign an integer from a string + subroutine int_assign_string( to, from ) + + !> Variable to assign + integer(kind=musica_ik), intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + integer :: ios + + call assert_msg( 121762665, allocated( from%val_ ), & + "Cannot assign integer from unallocated string" ) + call assert_msg( 822629448, len( from%val_ ) .le. 20, & + "Error converting '"//from%val_//"' to integer: "// & + "string too long" ) + read( from%val_, '(i20)', iostat=ios ) to + call assert_msg( 484221174, ios .eq. 0, & + "Error converting '"//from%val_//"' to integer: "// & + "IOSTAT = "//trim( to_char( ios ) ) ) + + end subroutine int_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Assigns a logical from a string + subroutine logical_assign_string( to, from ) + + !> Variable to assign + logical, intent(inout) :: to + !> String to assign from + class(string_t), intent(in) :: from + + call assert_msg( 285202023, allocated( from%val_ ), & + "Cannot assign logical from unallocated string" ) + if( from%val_ .eq. "true" ) then + to = .true. + else if( from%val_ .eq. "false" ) then + to = .false. + else + call assert_msg( 359920976, .false., & + "Cannot convert '"//from%val_//"' to logical" ) + end if + + end subroutine logical_assign_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a string + elemental function string_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + c%val_ = a%val_//b%val_ + + end function string_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a character array + elemental function string_join_char( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Character array to join + character(len=*), intent(in) :: b + + c%val_ = a%val_//trim( b ) + + end function string_join_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to an integer + elemental function string_join_int( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Integer to join + integer(kind=musica_ik), intent(in) :: b + + character(len=30) :: new_val + + write( new_val, '(i30)' ) b + c%val_ = a%val_//adjustl( new_val ) + + end function string_join_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a real number + elemental function string_join_real( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Real number to join + real(kind=musica_rk), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) b + c%val_ = a%val_//adjustl( new_val ) + + end function string_join_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a double precision real number + elemental function string_join_double( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Double precision real number to join + real(kind=musica_dk), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) b + c%val_ = a%val_//adjustl( new_val ) + + end function string_join_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a string to a logical + elemental function string_join_logical( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> String to join + class(string_t), intent(in) :: a + !> Logical to join + logical, intent(in) :: b + + if( b ) then + c%val_ = a%val_//"true" + else + c%val_ = a%val_//"false" + end if + + end function string_join_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a string for equality + logical elemental function string_equals_string( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = trim( a%val_ ) .eq. trim( b%val_ ) + + end function string_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a character array for equality + logical elemental function string_equals_char( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Character array b + character(len=*), intent(in) :: b + + equals = trim( a%val_ ) .eq. trim( b ) + + end function string_equals_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a integer for equality + logical elemental function string_equals_int( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Integer b + integer(kind=musica_ik), intent(in) :: b + + character(len=30) :: comp_val + + write( comp_val, '(i30)' ) b + equals = trim( a%val_ ) .eq. adjustl( comp_val ) + + end function string_equals_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a real number for equality + logical elemental function string_equals_real( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Real number b + real(kind=musica_rk), intent(in) :: b + + character(len=60) :: comp_val + + write( comp_val, '(g30.20)' ) b + equals = trim( a%val_ ) .eq. adjustl( comp_val ) + + end function string_equals_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a double-precision real number for equality + logical elemental function string_equals_double( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Double-precition real number b + real(kind=musica_dk), intent(in) :: b + + character(len=60) :: comp_val + + write( comp_val, '(g30.20)' ) b + equals = trim( a%val_ ) .eq. adjustl( comp_val ) + + end function string_equals_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a logical for equality + logical elemental function string_equals_logical( a, b ) result( equals ) + + !> String a + class(string_t), intent(in) :: a + !> Logical b + logical, intent(in) :: b + + equals = ( trim( a%val_ ) .eq. "true" .and. b ) .or. & + ( trim( a%val_ ) .eq. "false" .and. .not. b ) + + end function string_equals_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a string for equality + logical elemental function string_not_equals_string( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a character array for equality + logical elemental function string_not_equals_char( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Character array b + character(len=*), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a integer for equality + logical elemental function string_not_equals_int( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Integer b + integer(kind=musica_ik), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_int + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a real number for equality + logical elemental function string_not_equals_real( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Real number b + real(kind=musica_rk), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_real + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a double-precision real number for equality + logical elemental function string_not_equals_double( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Double-precition real number b + real(kind=musica_dk), intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_double + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a string to a logical for equality + logical elemental function string_not_equals_logical( a, b ) & + result( not_equals ) + + !> String a + class(string_t), intent(in) :: a + !> Logical b + logical, intent(in) :: b + + not_equals = .not. a .eq. b + + end function string_not_equals_logical + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the length of the string + elemental integer function length( this ) + + !> String + class(string_t), intent(in) :: this + + length = len( this%val_ ) + + end function length + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a string to upper case + !! + !! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) + !! Original author: Clive Page + function to_upper( this ) result( cap_string ) + + !> Converted string + type(string_t) :: cap_string + !> String to convert + class(string_t), intent(in) :: this + + character(26), parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + integer :: i_str, i_char + + cap_string%val_ = this%val_ + do i_str = 1, len( cap_string%val_ ) + i_char = index( low, cap_string%val_(i_str:i_str) ) + if( i_char .gt. 0 ) cap_string%val_(i_str:i_str) = cap(i_char:i_char) + end do + + end function to_upper + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a string to lower case + !! + !! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) + !! Original author: Clive Page + function to_lower( this ) result( low_string ) + + !> Converted string + type(string_t) :: low_string + !> String to convert + class(string_t), intent(in) :: this + + character(26), parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + character(26), parameter :: low = 'abcdefghijklmnopqrstuvwxyz' + integer :: i_str, i_char + + low_string%val_ = this%val_ + do i_str = 1, len( low_string%val_ ) + i_char = index( cap, low_string%val_(i_str:i_str) ) + if( i_char .gt. 0 ) low_string%val_(i_str:i_str) = low(i_char:i_char) + end do + + end function to_lower + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns a substring + !! + !! Example: + !! \code{f90} + !! type(string_t) :: my_string, sub_string + !! my_string = "Hi there!" + !! sub_string = my_string%substring( 4, 5 ) + !! write(*,*) sub_string + !! sub_string = my_string%substring( 9, 50 ) + !! write(*,*) sub_string + !! \endcode + !! + !! Output: + !! \code{bash} + !! there + !! ! + !! \endcode + !! + function substring( this, start_index, length ) + + !> Substring + type(string_t) :: substring + !> Full string + class(string_t), intent(in) :: this + !> Starting character index + integer(kind=musica_ik), intent(in) :: start_index + !> Length of the substring to return + integer(kind=musica_ik), intent(in) :: length + + integer :: l + + if( start_index + length - 1 .gt. len( this%val_ ) ) then + l = len( this%val_ ) - start_index + 1 + else + l = length + end if + substring%val_ = this%val_(start_index:l+start_index-1) + + end function substring + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Splits a string on a substring + !! + !! Example: + !! \code{f90} + !! type(string_t) :: my_string + !! type(string_t), allocatable :: sub_strings(:) + !! integer :: i + !! my_string = "my original string" + !! sub_strings = my_string%split( ' ' ) + !! do i = 1, size( sub_strings ) + !! write(*,*) i, sub_strings( i ) + !! end do + !! sub_strings = my_string%split( ' ', .true. ) + !! do i = 1, size( sub_strings ) + !! write(*,*) i, sub_strings( i ) + !! end do + !! \endcode + !! + !! Output: + !! \code{bash} + !! 1 my + !! 2 original + !! 3 + !! 4 + !! 5 + !! 6 string + !! 1 my + !! 2 original + !! 3 string + !! \endcode + !! + function split_char( this, splitter, compress ) result( sub_strings ) + + !> Split string + type(string_t), allocatable :: sub_strings(:) + !> Full string + class(string_t), intent(in) :: this + !> String to split on + character(len=*), intent(in) :: splitter + !> Compress (default = false) + !! + !! No 0-length substrings will be returned (adjacent tokens will be + !! merged; tokens at the beginning and end of the original string will be + !! ignored) + logical, intent(in), optional :: compress + + integer :: i, start_str, i_substr, sl, count + logical :: l_comp, is_string + + if( .not. allocated( this%val_ ) ) then + allocate( sub_strings( 0 ) ) + return + end if + if( present( compress ) ) then + l_comp = compress + else + l_comp = .false. + end if + + sl = len( splitter ) + if( sl .eq. 0 ) then + allocate( sub_strings( 1 ) ) + sub_strings(1)%val_ = this%val_ + return + end if + + count = 0 + i = 1 + start_str = 1 + is_string = .not. l_comp + do while( i .le. len( this%val_ ) - sl + 1 ) + if( this%val_(i:i+sl-1) .eq. splitter ) then + if( is_string ) then + count = count + 1 + end if + i = i + sl + is_string = .not. l_comp + else + i = i + 1 + is_string = .true. + end if + end do + if( is_string ) count = count + 1 + + allocate( sub_strings( count ) ) + + i = 1 + start_str = 1 + i_substr = 1 + is_string = .not. l_comp + do while( i .le. len( this%val_ ) - sl + 1 ) + if( this%val_(i:i+sl-1) .eq. splitter ) then + if( is_string ) then + if( i .eq. start_str ) then + sub_strings( i_substr ) = "" + else + sub_strings( i_substr ) = this%val_(start_str:i-1) + end if + i_substr = i_substr + 1 + end if + i = i + sl + start_str = i + is_string = .not. l_comp + else + i = i + 1 + is_string = .true. + end if + end do + + if( is_string ) then + if( i .eq. start_str ) then + sub_strings( i_substr ) = "" + else + sub_strings( i_substr ) = this%val_( start_str:len( this%val_ ) ) + end if + end if + + end function split_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Splits a string on a substring + !! + !! See \c string_split_char for description and example + !! + function split_string( this, splitter, compress ) result( sub_strings ) + + !> Split string + type(string_t), allocatable :: sub_strings(:) + !> Full string + class(string_t), intent(in) :: this + !> String to split on + type(string_t), intent(in) :: splitter + !> Compress (default = false) + !! + !! No 0-length substrings will be returned (adjacent tokens will be + !! merged; tokens at the beginning and end of the original string will be + !! ignored) + logical, intent(in), optional :: compress + + sub_strings = this%split_char( splitter%to_char( ), compress ) + + end function split_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> Replaces substrings within a string + !! + !! Example: + !! \code{f90} + !! type(string_t) :: my_string + !! my_string = "foo bar foobar" + !! my_string = my_string%replace( 'foo', 'bar' ) + !! write(*,*) my_string + !! \endcode + !! + !! Output: + !! \code{bash} + !! bar bar barbar + !! \endcode + !! + function replace( this, from, to ) + + !> String with replacements + type(string_t) :: replace + !> Original string + class(string_t) :: this + !> Sub-string to replace + character(len=*), intent(in) :: from + !> Replacement string + character(len=*), intent(in) :: to + + integer :: i_char, start_str, s + logical :: is_string + + start_str = 1 + s = len( from ) + is_string = .false. + replace = "" + i_char = 1 + do while( i_char .le. len( this%val_ ) - s + 1 ) + if( this%val_( i_char:i_char+s-1 ) .eq. from ) then + if( is_string .and. i_char .gt. start_str ) then + replace%val_ = replace%val_//this%val_( start_str:i_char-1 ) + end if + replace = replace//to + i_char = i_char + s + start_str = i_char + is_string = .false. + else + i_char = i_char + 1 + is_string = .true. + end if + end do + + if( start_str .le. len( this%val_ ) ) then + replace%val_ = replace%val_//this%val_( start_str:len( this%val_ ) ) + end if + + end function replace + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a string to a character array + function string_to_char( this ) result( char_array ) + + !> Converted string + character(len=:), allocatable :: char_array + !> String to convert + class(string_t), intent(in) :: this + + char_array = this%val_ + + end function string_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a character array to a string + elemental function char_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Character array to join + character(len=*), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + c%val_ = a//b%val_ + + end function char_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins an integer to a string + elemental function int_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Integer to join + integer(kind=musica_ik), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + character(len=30) :: new_val + + write( new_val, '(i30)' ) a + c%val_ = trim( adjustl( new_val ) )//b%val_ + + end function int_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a real number to a string + elemental function real_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Real number to join + real(kind=musica_rk), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) a + c%val_ = trim( adjustl( new_val ) )//b%val_ + + end function real_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a double precision real number to a string + elemental function double_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Double precision real number to join + real(kind=musica_dk), intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + character(len=60) :: new_val + + write( new_val, '(g30.20)' ) a + c%val_ = trim( adjustl( new_val ) )//b%val_ + + end function double_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Joins a logical to a string + elemental function logical_join_string( a, b ) result( c ) + + !> Joined string + type(string_t) :: c + !> Logical to join + logical, intent(in) :: a + !> String to join + class(string_t), intent(in) :: b + + if( a ) then + c%val_ = "true"//b%val_ + else + c%val_ = "false"//b%val_ + end if + + end function logical_join_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a character array to a string for equality + logical elemental function char_equals_string( a, b ) result( equals ) + + !> Character array a + character(len=*), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function char_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares an integer to a string for equality + logical elemental function int_equals_string( a, b ) result( equals ) + + !> Integer a + integer(kind=musica_ik), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function int_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a real number to a string for equality + logical elemental function real_equals_string( a, b ) result( equals ) + + !> Real number a + real(kind=musica_rk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function real_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a double-precision real number to a string for equality + logical elemental function double_equals_string( a, b ) result( equals ) + + !> Double-precision real number a + real(kind=musica_dk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function double_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a logical to a string for equality + logical elemental function logical_equals_string( a, b ) result( equals ) + + !> Logical a + logical, intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + equals = b .eq. a + + end function logical_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a character array to a string for equality + logical elemental function char_not_equals_string( a, b ) & + result( not_equals ) + + !> Character array a + character(len=*), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function char_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares an integer to a string for equality + logical elemental function int_not_equals_string( a, b ) & + result( not_equals ) + + !> Integer a + integer(kind=musica_ik), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function int_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a real number to a string for equality + logical elemental function real_not_equals_string( a, b ) & + result( not_equals ) + + !> Real number a + real(kind=musica_rk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function real_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a double-precision real number to a string for equality + logical elemental function double_not_equals_string( a, b ) & + result( not_equals ) + + !> Double-precition real number a + real(kind=musica_dk), intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function double_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Compares a logical to a string for equality + logical elemental function logical_not_equals_string( a, b ) & + result( not_equals ) + + !> Logical a + logical, intent(in) :: a + !> String b + class(string_t), intent(in) :: b + + not_equals = .not. b .eq. a + + end function logical_not_equals_string + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a binary buffer required to pack the string + integer function pack_size( this, comm ) + + use musica_mpi + + class(string_t), intent(in) :: this ! string to pack + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + pack_size = musica_mpi_pack_size( allocated( this%val_ ), comm ) + if( allocated( this%val_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( len( this%val_ ), comm ) + & + musica_mpi_pack_size( this%val_, comm ) + end if +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the string onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_mpi + + !> String to pack + class(string_t), intent(in) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position + + prev_position = position + call musica_mpi_pack( buffer, position, allocated( this%val_ ), comm ) + if( allocated( this%val_ ) ) then + call musica_mpi_pack( buffer, position, len( this%val_ ), comm ) + call musica_mpi_pack( buffer, position, this%val_, comm ) + end if + call assert_msg( 408845490, & + position - prev_position <= this%pack_size( comm ), & + "assertion failed" ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a string from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_mpi + + !> String to be unpacked + class(string_t), intent(out) :: this + !> Memory buffer + character, intent(inout) :: buffer(:) + !> Current buffer position + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_position, str_size + logical :: is_allocated + + prev_position = position + call musica_mpi_unpack( buffer, position, is_allocated, comm ) + if( is_allocated ) then + call musica_mpi_unpack( buffer, position, str_size, comm ) + allocate( character( len = str_size ) :: this%val_ ) + call musica_mpi_unpack( buffer, position, this%val_, comm ) + end if + call assert_msg( 838278952, & + position - prev_position <= this%pack_size( comm ), & + "assertion failed" ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts an integer to a char array + character(len=kConvertCharLength) function int_to_char( val ) & + result( ret_val ) + + !> Value to convert + integer(kind=musica_ik), intent(in) :: val + + write( ret_val, '(i30)' ) val + ret_val = adjustl( ret_val ) + + end function int_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a real number to a char array + character(len=kConvertCharLength) function real_to_char( val ) & + result( ret_val ) + + !> Value to convert + real(kind=musica_rk), intent(in) :: val + + write( ret_val, '(g30.20)' ) val + ret_val = adjustl( ret_val ) + + end function real_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a double-precision real number to a char array + character(len=kConvertCharLength) function double_to_char( val ) & + result( ret_val ) + + !> Value to convert + real(kind=musica_dk), intent(in) :: val + + write( ret_val, '(g30.20)' ) val + ret_val = adjustl( ret_val ) + + end function double_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a real complex number to a char array + character(len=kConvertCharLength) function complex_real_to_char( val ) & + result( ret_val ) + + !> Value to convert + complex(kind=musica_rk), intent(in) :: val + + ret_val = "(" // trim( to_char( real( val ) ) ) & + // ", " // trim( to_char( aimag( val ) ) ) // ")" + ret_val = adjustl( ret_val ) + + end function complex_real_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!> Converts a double-precision real complex number to a char array + character(len=kConvertCharLength) function complex_double_to_char( val ) & + result( ret_val ) + + !> Value to convert + complex(kind=musica_dk), intent(in) :: val + + ret_val = "(" // trim( to_char( real( val ) ) ) & + // ", " // trim( to_char( aimag( val ) ) ) // ")" + ret_val = adjustl( ret_val ) + + end function complex_double_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Converts a logical to a char array + character(len=kConvertCharLength) function logical_to_char( val ) & + result( ret_val ) + + !> Value to convert + logical, intent(in) :: val + + if( val ) then + write( ret_val, '(a4)' ) "true" + else + write( ret_val, '(a5)' ) "false" + end if + + end function logical_to_char + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Output tabular data to a given file unit + subroutine output_table( header, table, file_unit ) + + !> Table header + type(string_t), intent(in) :: header(:) + !> Table data (column, row) + type(string_t), intent(in) :: table(:,:) + !> File unit + integer(kind=musica_ik), intent(in) :: file_unit + + integer(kind=musica_ik), parameter :: kMaxWidth = 120 + type(string_t) :: temp_str + character(len=256) :: fmt_row, fmt_div + integer(kind=musica_ik) :: i_col, i_row, table_width, str_len + integer(kind=musica_ik), allocatable :: max_len(:) + real(kind=musica_dk) :: frac + + call assert_msg( 239541866, size( header ) .eq. size( table, dim = 1 ), & + "Mismatched table header/data. Number of header "// & + "columns: "//trim( to_char( size( header ) ) )// & + ". Number of data columns: "// & + trim( to_char( size( table, dim = 1 ) ) ) ) + allocate( max_len( size( header ) ) ) + do i_col = 1, size( header ) + max_len( i_col ) = header( i_col )%length( ) + do i_row = 1, size( table, dim = 2 ) + if( max_len( i_col ) .lt. table( i_col, i_row )%length( ) ) then + max_len( i_col ) = table( i_col, i_row )%length( ) + end if + end do + end do + table_width = 1 + do i_col = 1, size( max_len ) + table_width = table_width + 3 + max_len( i_col ) + end do + if( table_width .gt. kMaxWidth ) then + frac = real( kMaxWidth, kind=musica_dk ) / & + real( ( table_width - 1 - 3*size( max_len ) ), kind=musica_dk ) + table_width = 0 + do i_col = 1, size( max_len ) + max_len( i_col ) = floor( max_len( i_col ) * frac ) + table_width = table_width + 3 + max_len( i_col ) + end do + end if + + if( table_width .ge. 10 .and. table_width .le. 99 ) then + write(fmt_div, '(a,i2,a)') '(', table_width, "('-'))" + else if( table_width .ge. 100 .and. table_width .le. 1000 ) then + write(fmt_div, '(a,i3,a)') '(', table_width, "('-'))" + else + call assert_msg( 289029811, .false., "Invalid table width" ) + end if + write(file_unit, fmt_div) + + temp_str = '("|"' + do i_col = 1, size( max_len ) + temp_str = temp_str//',1x,"' + str_len = header( i_col )%length( ) + if( str_len .ge. max_len( i_col ) ) then + temp_str = temp_str//header( i_col )%val_( 1 : max_len( i_col ) ) + else + temp_str = temp_str//header( i_col )//'",'// & + trim( to_char( max_len( i_col ) - str_len ) )//'x,"' + end if + temp_str = temp_str//' |"' + end do + temp_str = temp_str//')' + write(fmt_row, '(a)') temp_str%val_ + write(file_unit, fmt_row) + + write(file_unit, fmt_div) + + do i_row = 1, size( table, dim = 2 ) + temp_str = '("|"' + do i_col = 1, size( max_len ) + temp_str = temp_str//',1x,"' + str_len = table( i_col, i_row )%length( ) + if( str_len .ge. max_len( i_col ) ) then + temp_str = temp_str// & + table( i_col, i_row )%val_( 1 : max_len( i_col ) ) + else + temp_str = temp_str//table( i_col, i_row )//'",'// & + trim( to_char( max_len( i_col ) - str_len ) )//'x,"' + end if + temp_str = temp_str//' |"' + end do + temp_str = temp_str//')' + write(fmt_row, '(a)') temp_str%val_ + write(file_unit, fmt_row) + end do + + write(file_unit, fmt_div) + + end subroutine output_table + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Local assert function + subroutine assert_msg( code, condition, error_message ) + + !> Unique code for the assertion + integer, intent(in) :: code + !> Condition to evaluate + logical, intent(in) :: condition + !> Message to display on failure + character(len=*), intent(in) :: error_message + + integer, parameter :: kErrorFileId = 10 + integer, parameter :: kErrorId = 0 + character(len=50) :: str_code + + if( .not. condition ) then + write(str_code,'(i30)') code + write(kErrorId,*) "ERROR (Musica-"//trim( adjustl( str_code ) )//"): " & + //error_message + open( unit = kErrorFileId, file = "error.json", action = "WRITE" ) + write(kErrorFileId,'(A)') '{' + write(kErrorFileId,'(A)') ' "code" : "'//trim( adjustl( str_code ) )//'",' + write(kErrorFileId,'(A)') ' "message" : "'//error_message//'"' + write(kErrorFileId,'(A)') '}' + close(kErrorFileId) + stop 3 + end if + + end subroutine assert_msg + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_string diff --git a/src/util/yaml_util.F90 b/src/util/yaml_util.F90 new file mode 100644 index 00000000..2955fcf6 --- /dev/null +++ b/src/util/yaml_util.F90 @@ -0,0 +1,452 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Utility module for YAML parser + +!> Utility module for YAML parser +module musica_yaml_util + + use iso_c_binding + use musica_constants, only : musica_ik, musica_rk, musica_dk + + implicit none + public + + !> Interoperable string type + type, bind(c) :: string_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type string_t_c + + !> Interoperable array type for strings + type, bind(c) :: string_array_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type string_array_t_c + + !> Interoperable array type for doubles + type, bind(c) :: double_array_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type double_array_t_c + + !> Interoperable array type for nodes + type, bind(c) :: node_array_t_c + type(c_ptr) :: ptr_ + integer(c_int) :: size_ + end type node_array_t_c + + !> C wrapper functions for YAML parser + interface + + !> Constructor from a YAML string + function yaml_create_from_string_c(yaml_string) & + bind(c, name="yaml_create_from_string") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_create_from_string_c + character(len=1, kind=c_char), intent(in) :: yaml_string(*) + end function yaml_create_from_string_c + + !> Constructor from a YAML file + function yaml_create_from_file_c(file_path) & + bind(c, name="yaml_create_from_file") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_create_from_file_c + character(len=1, kind=c_char), intent(in) :: file_path(*) + end function yaml_create_from_file_c + + !> Outputs YAML configuration to a file + subroutine yaml_to_file_c(node, file_path) bind(c, name="yaml_to_file") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: file_path(*) + end subroutine yaml_to_file_c + + !> Gets the number of elements + function yaml_size_c(node) bind(c, name="yaml_size") + use iso_c_binding + implicit none + integer(kind=c_int) :: yaml_size_c + type(c_ptr), value :: node + end function yaml_size_c + + !> Gets an beginning iterator for a node + function yaml_begin_c(node) bind(c, name="yaml_begin") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_begin_c + type(c_ptr), value :: node + end function yaml_begin_c + + !> Gets an ending iterator for a node + function yaml_end_c(node) bind(c, name="yaml_end") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_end_c + type(c_ptr), value :: node + end function yaml_end_c + + !> Increments an iterator + !! + !! Returns true if incremented iterator is < end, false otherwise + function yaml_increment_c(iter, end) bind(c, name="yaml_increment") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_increment_c + type(c_ptr), value :: iter + type(c_ptr), value :: end + end function yaml_increment_c + + !> Returns whether an iterator is == end + function yaml_at_end_c(iter, end) bind(c, name="yaml_at_end") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_at_end_c + type(c_ptr), value :: iter + type(c_ptr), value :: end + end function yaml_at_end_c + + !> Gets the key associated with an iterator + function yaml_key_c(iter) bind(c, name="yaml_key") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_key_c + type(c_ptr), value :: iter + end function yaml_key_c + + !> Gets a sub-node by key + function yaml_get_node_c(node, key, found) bind(c, name="yaml_get_node") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_get_node_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_node_c + + !> Gets a string by key + function yaml_get_string_c(node, key, found) bind(c, name="yaml_get_string") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_get_string_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_string_c + + !> Gets an integer by key + function yaml_get_int_c(node, key, found) bind(c, name="yaml_get_int") + use iso_c_binding + implicit none + integer(kind=c_int) :: yaml_get_int_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_int_c + + !> Gets a float by key + function yaml_get_float_c(node, key, found) bind(c, name="yaml_get_float") + use iso_c_binding + implicit none + real(kind=c_float) :: yaml_get_float_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_float_c + + !> Gets a double by key + function yaml_get_double_c(node, key, found) bind(c, name="yaml_get_double") + use iso_c_binding + implicit none + real(kind=c_double) :: yaml_get_double_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_double_c + + !> Gets a boolean by key + function yaml_get_bool_c(node, key, found) bind(c, name="yaml_get_bool") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_get_bool_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_bool_c + + !> Gets a string array by key + function yaml_get_string_array_c(node, key, found) & + bind(c, name="yaml_get_string_array") + use iso_c_binding + import :: string_array_t_c + implicit none + type(string_array_t_c) :: yaml_get_string_array_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_string_array_c + + !> Gets a double array by key + function yaml_get_double_array_c(node, key, found) & + bind(c, name="yaml_get_double_array") + use iso_c_binding + import :: double_array_t_c + implicit none + type(double_array_t_c) :: yaml_get_double_array_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_double_array_c + + !> Gets a node array by key + function yaml_get_node_array_c(node, key, found) & + bind(c, name="yaml_get_node_array") + use iso_c_binding + import :: node_array_t_c + implicit none + type(node_array_t_c) :: yaml_get_node_array_c + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), intent(out) :: found + end function yaml_get_node_array_c + + !> Gets a node using an iterator + function yaml_get_node_from_iterator_c(iter) & + bind(c, name="yaml_get_node_from_iterator") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_get_node_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_node_from_iterator_c + + !> Gets a string using an iterator + function yaml_get_string_from_iterator_c(iter) & + bind(c, name="yaml_get_string_from_iterator") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_get_string_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_string_from_iterator_c + + !> Gets an integer using an iterator + function yaml_get_int_from_iterator_c(iter) & + bind(c, name="yaml_get_int_from_iterator") + use iso_c_binding + implicit none + integer(kind=c_int) :: yaml_get_int_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_int_from_iterator_c + + !> Gets a float using an iterator + function yaml_get_float_from_iterator_c(iter) & + bind(c, name="yaml_get_float_from_iterator") + use iso_c_binding + implicit none + real(kind=c_float) :: yaml_get_float_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_float_from_iterator_c + + !> Gets a double using an iterator + function yaml_get_double_from_iterator_c(iter) & + bind(c, name="yaml_get_double_from_iterator") + use iso_c_binding + implicit none + real(kind=c_double) :: yaml_get_double_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_double_from_iterator_c + + !> Gets a boolean using an iterator + function yaml_get_bool_from_iterator_c(iter) & + bind(c, name="yaml_get_bool_from_iterator") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_get_bool_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_bool_from_iterator_c + + !> Gets a string array using an iterator + function yaml_get_string_array_from_iterator_c(iter) & + bind(c, name="yaml_get_string_array_from_iterator") + use iso_c_binding + import :: string_array_t_c + implicit none + type(string_array_t_c) :: yaml_get_string_array_from_iterator_c + type(c_ptr), value :: iter + end function yaml_get_string_array_from_iterator_c + + !> Adds a YAML node to a YAML node + subroutine yaml_add_node_c(node, key, value) bind(c, name="yaml_add_node") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(c_ptr), value :: value + end subroutine yaml_add_node_c + + !> Adds a string to a YAML node + subroutine yaml_add_string_c(node, key, value) & + bind(c, name="yaml_add_string") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + character(len=1, kind=c_char), intent(in) :: value(*) + end subroutine yaml_add_string_c + + !> Adds an int to a YAML node + subroutine yaml_add_int_c(node, key, value) bind(c, name="yaml_add_int") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + integer(kind=c_int), value :: value + end subroutine yaml_add_int_c + + !> Adds a float to a YAML node + subroutine yaml_add_float_c(node, key, value) & + bind(c, name="yaml_add_float") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + real(kind=c_float), value :: value + end subroutine yaml_add_float_c + + !> Adds a double to a YAML node + subroutine yaml_add_double_c(node, key, value) & + bind(c, name="yaml_add_double") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + real(kind=c_double), value :: value + end subroutine yaml_add_double_c + + !> Adds a boolean to a YAML node + subroutine yaml_add_bool_c(node, key, value) bind(c, name="yaml_add_bool") + use iso_c_binding + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + logical(kind=c_bool), value :: value + end subroutine yaml_add_bool_c + + !> Adds a string array to a YAML node + subroutine yaml_add_string_array_c(node, key, value) & + bind(c, name="yaml_add_string_array") + use iso_c_binding + import :: string_array_t_c + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(string_array_t_c), value :: value + end subroutine yaml_add_string_array_c + + !> Adds a double array to a YAML node + subroutine yaml_add_double_array_c(node, key, value) & + bind(c, name="yaml_add_double_array") + use iso_c_binding + import :: double_array_t_c + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(double_array_t_c), value :: value + end subroutine yaml_add_double_array_c + + !> Adds a node array to a YAML node + subroutine yaml_add_node_array_c(node, key, value) & + bind(c, name="yaml_add_node_array") + use iso_c_binding + import :: node_array_t_c + implicit none + type(c_ptr), value :: node + character(len=1, kind=c_char), intent(in) :: key(*) + type(node_array_t_c), value :: value + end subroutine yaml_add_node_array_c + + !> Copy node + function yaml_copy_node_c(node) bind(c, name="yaml_copy_node") + use iso_c_binding + implicit none + type(c_ptr) :: yaml_copy_node_c + type(c_ptr), value :: node + end function yaml_copy_node_c + + !> Copy node to string + function yaml_to_string_c(node) bind(c, name="yaml_to_string") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c) :: yaml_to_string_c + type(c_ptr), value :: node + end function yaml_to_string_c + + !> Merges one node into another + function yaml_merge_node_c(dest, src) bind(c, name="yaml_merge_node") + use iso_c_binding + implicit none + logical(kind=c_bool) :: yaml_merge_node_c + type(c_ptr), value :: dest + type(c_ptr), value, intent(in) :: src + end function yaml_merge_node_c + + !> Node destructor + subroutine yaml_delete_node_c(node) bind(c, name="yaml_delete_node") + use iso_c_binding + implicit none + type(c_ptr), value :: node + end subroutine yaml_delete_node_c + + !> String destructor + subroutine yaml_delete_string_c(string) bind(c, name="yaml_delete_string") + use iso_c_binding + import :: string_t_c + implicit none + type(string_t_c), value :: string + end subroutine yaml_delete_string_c + + !> String array destructor + subroutine yaml_delete_string_array_c(array) & + bind(c, name="yaml_delete_string_array") + use iso_c_binding + import :: string_array_t_c + implicit none + type(string_array_t_c), value :: array + end subroutine yaml_delete_string_array_c + + !> Double array destructor + subroutine yaml_delete_double_array_c(array) & + bind(c, name="yaml_delete_double_array") + use iso_c_binding + import :: double_array_t_c + implicit none + type(double_array_t_c), value :: array + end subroutine yaml_delete_double_array_c + + !> Node array destructor + subroutine yaml_delete_node_array_c(array) & + bind(c, name="yaml_delete_node_array") + use iso_c_binding + import :: node_array_t_c + implicit none + type(node_array_t_c), value :: array + end subroutine yaml_delete_node_array_c + + !> Iterator destructor + subroutine yaml_delete_iterator_c(iter) & + bind(c, name="yaml_delete_iterator") + use iso_c_binding + implicit none + type(c_ptr), value :: iter + end subroutine yaml_delete_iterator_c + + end interface + +end module musica_yaml_util \ No newline at end of file diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 7d068cae..d2db2fad 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -2,7 +2,7 @@ # Test utilities add_library(tuvx_test_utils unit/test_utils.F90) -target_link_libraries(tuvx_test_utils musica::musicacore) +target_link_libraries(tuvx_test_utils musica::tuvx) set_target_properties(tuvx_test_utils PROPERTIES Fortran_MODULE_DIRECTORY ${PROJECT_BINARY_DIR}/test_include @@ -47,22 +47,20 @@ add_custom_target(link-ts1-tsmlt-example-data ALL COMMAND ${CMAKE_COMMAND} add_test(NAME TS1_TSMLT COMMAND tuv-x ../examples/ts1_tsmlt.json WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_ts1_tsmlt) -if(ENABLE_YAML) - add_custom_target(make-tuv54-yaml-example-dir ALL COMMAND ${CMAKE_COMMAND} - -E make_directory ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml) - add_custom_target(link-tuv54-yaml-example-data ALL COMMAND ${CMAKE_COMMAND} - -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml/data) - add_test(NAME TUV_5_4_YAML COMMAND tuv-x ../examples/tuv_5_4.yml - WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml) - add_test(NAME TUV_5_4_COMPARE COMMAND python3 test/json_yaml_compare.py example_tuv_5_4 example_tuv_5_4_yaml - WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) - add_custom_target(make-ts1-tsmlt-yaml-example-dir ALL COMMAND ${CMAKE_COMMAND} - -E make_directory ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml) - add_custom_target(link-ts1-tsmlt-yaml-example-data ALL COMMAND ${CMAKE_COMMAND} - -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml/data) - add_test(NAME TS1_TSMLT_YAML COMMAND tuv-x ../examples/ts1_tsmlt.yml - WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml) - add_test(NAME TS1_TSMLT_COMPARE COMMAND python3 test/json_yaml_compare.py example_ts1_tsmlt example_ts1_tsmlt_yaml - WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) -endif() +add_custom_target(make-tuv54-yaml-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml) +add_custom_target(link-tuv54-yaml-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml/data) +add_test(NAME TUV_5_4_YAML COMMAND tuv-x ../examples/tuv_5_4.yml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_tuv_5_4_yaml) +add_test(NAME TUV_5_4_COMPARE COMMAND python3 test/json_yaml_compare.py example_tuv_5_4 example_tuv_5_4_yaml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) +add_custom_target(make-ts1-tsmlt-yaml-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml) +add_custom_target(link-ts1-tsmlt-yaml-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml/data) +add_test(NAME TS1_TSMLT_YAML COMMAND tuv-x ../examples/ts1_tsmlt.yml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_ts1_tsmlt_yaml) +add_test(NAME TS1_TSMLT_COMPARE COMMAND python3 test/json_yaml_compare.py example_ts1_tsmlt example_ts1_tsmlt_yaml + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) ################################################################################ diff --git a/test/data/config_example.json b/test/data/config_example.json new file mode 100644 index 00000000..801f221f --- /dev/null +++ b/test/data/config_example.json @@ -0,0 +1,12 @@ +{ + "my int" : 12, + "other props" : { + "an int" : 45 + }, + "real props" : { + "foo" : 14.2, + "bar" : 64.2, + "foobar" : 920.4 + }, + "a string" : "foo" +} diff --git a/test/data/config_example.yml b/test/data/config_example.yml new file mode 100644 index 00000000..d330a3e8 --- /dev/null +++ b/test/data/config_example.yml @@ -0,0 +1,8 @@ +my int: 12 +other props: + an int: 45 +real props: + foo: 14.2 + bar: 64.2 + foobar: 920.4 +a string: foo \ No newline at end of file diff --git a/test/data/io_netcdf_test_data.nc b/test/data/io_netcdf_test_data.nc new file mode 100644 index 00000000..d67beaa5 Binary files /dev/null and b/test/data/io_netcdf_test_data.nc differ diff --git a/test/data/test_config.json b/test/data/test_config.json new file mode 100644 index 00000000..95765940 --- /dev/null +++ b/test/data/test_config.json @@ -0,0 +1,20 @@ +{ + "my integer" : 12, + "this real" : 23.4, + "is it?" : false, + "my sub object" : { + "sub int" : 42, + "sub real" : 87.3, + "a bunch of strings" : [ "bar", "foo", "barfoo" ], + "really?" : true + }, + "that real" : 52.3e-4, + "another int" : 31, + "a bunch of doubles" : [ 12.5, 13.2, 72.5, -142.64 ], + "a bunch of strings" : [ "foo", "bar", "foobar" ], + "a string" : "foo", + "another bunch of strings" : [ "boo", "far" ], + "another bunch of doubles" : [ 52.3, 0.0 ], + "another string" : "bar", + "is it really?" : true +} diff --git a/test/oldtuv/CMakeLists.txt b/test/oldtuv/CMakeLists.txt index 2be3bff6..e0a9f406 100644 --- a/test/oldtuv/CMakeLists.txt +++ b/test/oldtuv/CMakeLists.txt @@ -97,7 +97,7 @@ add_subdirectory(util) add_subdirectory(Profile) add_library(oldphotolib ${PHOTO_SRC} ${GRID_SRC} ${PROFILE_SRC} ${CROSS_SRC} ${QY_SRC} ${RADIATOR_SRC} ${RAD_SRC} ${SW_SRC} ${UTIL_SRC}) -target_link_libraries(oldphotolib musica::musicacore ${NETCDF_LIBS} ${JSON_LIB}) +target_link_libraries(oldphotolib musica::tuvx ${NETCDF_LIBS}) set_target_properties(oldphotolib PROPERTIES OUTPUT_NAME oldphoto) add_executable(oldtuv tuv.f) diff --git a/test/oldtuv/Profile/Profile_factory.F90 b/test/oldtuv/Profile/Profile_factory.F90 index a617332e..3d448806 100644 --- a/test/oldtuv/Profile/Profile_factory.F90 +++ b/test/oldtuv/Profile/Profile_factory.F90 @@ -45,8 +45,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) character(len=*), parameter :: Iam = 'Profile builder: ' type(string_t) :: Profile_type - write(*,*) Iam,'entering' - new_Profile_t => null() call config%get( 'Profile type', Profile_type, Iam ) @@ -73,8 +71,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) call new_Profile_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' - end function Profile_builder !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/Profile/Profile_warehouse.F90 b/test/oldtuv/Profile/Profile_warehouse.F90 index 8f0d7500..2ce6f39a 100644 --- a/test/oldtuv/Profile/Profile_warehouse.F90 +++ b/test/oldtuv/Profile/Profile_warehouse.F90 @@ -62,8 +62,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( Profile_warehouse_obj ) associate(new_obj=>Profile_warehouse_obj) @@ -78,8 +76,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) do while( iter%next() ) keychar = Profile_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call Profile_set%get( iter, Profile_config, Iam ) call Profile_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -91,13 +87,8 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' Profile objects'')') Iam,size(new_obj%Profile_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -121,9 +112,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%Profile_objs_) if( Profile_handle .eq. this%Profile_objs_(ndx)%ptr_%handle_ ) then @@ -138,8 +126,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) call die_msg( 460768214, "Invalid Profile handle: '"// Profile_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_Profile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,14 +142,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'Profile warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%Profile_objs_ ) ) then deallocate( this%Profile_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/Profile/air.from_csv_file.type.F90 b/test/oldtuv/Profile/air.from_csv_file.type.F90 index e8285cf3..d6e0c0f7 100644 --- a/test/oldtuv/Profile/air.from_csv_file.type.F90 +++ b/test/oldtuv/Profile/air.from_csv_file.type.F90 @@ -54,8 +54,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -128,16 +126,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,airlog ) this%edge_val_ = exp( this%edge_val_ ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -154,8 +142,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%burden_dens_(k) = accum enddo - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/from_csv_file.type.F90 b/test/oldtuv/Profile/from_csv_file.type.F90 index a3cefea9..a16d0a27 100644 --- a/test/oldtuv/Profile/from_csv_file.type.F90 +++ b/test/oldtuv/Profile/from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) type(string_t) :: Handle class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -122,24 +120,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = this%mid_val_ * zGrid%delta_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 b/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 index 9cf15a9b..4948119c 100644 --- a/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 +++ b/test/oldtuv/Profile/holdingtank/from_csv_file.type.F90 @@ -44,8 +44,6 @@ subroutine initialize( this, profile_config, zGrid ) character(len=132) :: InputLine type(string_t) :: Filespec - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -94,16 +92,6 @@ subroutine initialize( this, profile_config, zGrid ) allocate( this%edge_val_(this%ncells_+1_ik) ) this%edge_val_ = this%inter1( zGrid, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - allocate( this%mid_val_(this%ncells_) ) allocate( this%delta_val_(this%ncells_) ) this%mid_val_(:) = .5_dk & @@ -112,8 +100,6 @@ subroutine initialize( this, profile_config, zGrid ) close(unit=inUnit) - write(*,*) Iam // 'exiting' - end subroutine initialize end module micm_from_csv_file_vert_Profile diff --git a/test/oldtuv/Profile/o2.from_csv_file.type.F90 b/test/oldtuv/Profile/o2.from_csv_file.type.F90 index a4333e15..3c83c418 100644 --- a/test/oldtuv/Profile/o2.from_csv_file.type.F90 +++ b/test/oldtuv/Profile/o2.from_csv_file.type.F90 @@ -55,8 +55,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -130,16 +128,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = exp( this%edge_val_ ) this%edge_val_ = o2Vmr * this%edge_val_ - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -149,8 +137,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%exo_layer_dens_ = [this%layer_dens_,exo_layer_dens] this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + exo_layer_dens - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/o3.from_csv_file.type.F90 b/test/oldtuv/Profile/o3.from_csv_file.type.F90 index f8f7ec45..3bc8b293 100644 --- a/test/oldtuv/Profile/o3.from_csv_file.type.F90 +++ b/test/oldtuv/Profile/o3.from_csv_file.type.F90 @@ -57,8 +57,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -145,13 +143,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - this%mid_val_ = ONEHALF & *(this%edge_val_(iONE:this%ncells_) + this%edge_val_(iTWO:this%ncells_+iONE)) this%delta_val_ = (this%edge_val_(iTWO:this%ncells_+iONE) - this%edge_val_(iONE:this%ncells_)) @@ -171,12 +162,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) endif endif - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/Profile/sza_from_time.type.F90 b/test/oldtuv/Profile/sza_from_time.type.F90 index 07943e5e..cf93fe11 100644 --- a/test/oldtuv/Profile/sza_from_time.type.F90 +++ b/test/oldtuv/Profile/sza_from_time.type.F90 @@ -319,7 +319,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) DELTA = YEAR - 1949_ik LEAP = DELTA / 4_ik JD = 32916.5_dk + real(DELTA*365_ik + LEAP + DAY,dk) + HOUR / Day2Hrs - write(*,*) 'szaFromTime: delta, leap, day, hour = ',delta, leap, day, hour ! ** last yr of century not leap yr unless divisible ! ** by 400 (not executed for the allowed YEAR range, @@ -338,8 +337,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) MNLONG = MOD( MNLONG, THREE60 ) IF( MNLONG < rZERO ) MNLONG = MNLONG + THREE60 - write(*,*) 'szaFromTime: jd,time = ',jd,time - ! ** mean anomaly in radians between 0 and 2*pi MNANOM = 357.528_dk + 0.9856003_dk*TIME MNANOM = MOD( MNANOM, THREE60 ) @@ -358,8 +355,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) ECLONG = ECLONG*d2r OBLQEC = OBLQEC*d2r - write(*,*) 'szaFromTime: mnlong,mnanom,eclong = ',mnlong,mnanom,eclong - ! ** right ascension NUM = COS( OBLQEC )*SIN( ECLONG ) DEN = COS( ECLONG ) @@ -374,7 +369,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) ! ** declination DEC = ASIN( SIN( OBLQEC )*SIN( ECLONG ) ) - write(*,*) 'szaFromTime: oblqec, eclong = ',oblqec, eclong ! ** Greenwich mean sidereal time in hours GMST = 6.697375_dk + 0.0657098242_dk*TIME + HOUR @@ -402,7 +396,6 @@ function szaFromTime( YEAR, DAY, HOUR, LAT, LONG ) result( solarElevation ) ! ** solar elevation ! noon when HA = 0 - write(*,*) 'szaFromTime: dec,lat,ha = ',dec,lat,ha solarElevation = ASIN( SIN( DEC )*SIN( LAT*d2r ) + COS( DEC )*COS( LAT*d2r )*COS( HA ) ) ! ** Convert elevation to degrees diff --git a/test/oldtuv/cross_section/abstract.cross_section.type.F90 b/test/oldtuv/cross_section/abstract.cross_section.type.F90 index d7c04bba..0d8bb9d4 100644 --- a/test/oldtuv/cross_section/abstract.cross_section.type.F90 +++ b/test/oldtuv/cross_section/abstract.cross_section.type.F90 @@ -91,8 +91,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -122,8 +120,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_upper) call addpnt(x=data_lambda,y=data_parameter,xnew=1.e38_musica_dk,ynew=addpnt_val_upper) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_abs_cross_section_type diff --git a/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 b/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 index 87395df5..5c3f2636 100644 --- a/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/acetone-ch3co_ch3.cross_section.type.F90 @@ -61,8 +61,6 @@ function run( this, environment ) result( cross_section ) call die_msg( 500000001, msg ) endif - write(*,*) Iam,'exiting' - end function run end module micm_ch3coch3_ch3co_ch3_cross_section_type diff --git a/test/oldtuv/cross_section/base.cross_section.type.F90 b/test/oldtuv/cross_section/base.cross_section.type.F90 index 0fe33fcc..4b1e14b9 100644 --- a/test/oldtuv/cross_section/base.cross_section.type.F90 +++ b/test/oldtuv/cross_section/base.cross_section.type.F90 @@ -69,7 +69,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -115,8 +114,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -135,12 +132,8 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'base cross section calculate: ' - write(*,*) Iam,'entering' - cross_section = this%cross_section(1)%array(:,1) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -153,7 +146,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%cross_section) ) then do ndx = 1,size(this%cross_section) if( allocated(this%cross_section(ndx)%array ) ) then @@ -171,7 +163,6 @@ subroutine finalize( this ) if( allocated(this%mdl_lambda_center) ) then deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' end subroutine finalize diff --git a/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 b/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 index ef4f6e31..299b6dbe 100644 --- a/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 +++ b/test/oldtuv/cross_section/bro-br_o.cross_section.type.F90 @@ -57,7 +57,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -102,8 +101,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize end module micm_bro_br_o_cross_section_type diff --git a/test/oldtuv/cross_section/ccl4.cross_section.type.F90 b/test/oldtuv/cross_section/ccl4.cross_section.type.F90 index aa49172f..7e63d8e5 100644 --- a/test/oldtuv/cross_section/ccl4.cross_section.type.F90 +++ b/test/oldtuv/cross_section/ccl4.cross_section.type.F90 @@ -50,8 +50,6 @@ function run( this, environment ) result( cross_section ) real(musica_dk) :: Temp, lambda, Wpoly real(musica_dk) :: w1, w2, w3, w4 - write(*,*) Iam,'entering' - Temp = max( min( 300._musica_dk,environment%temperature ),210._musica_dk ) Temp = Temp - 295._musica_dk do wNdx = 1,size(this%mdl_lambda_center) @@ -67,8 +65,6 @@ function run( this, environment ) result( cross_section ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_ccl4_cross_section_type diff --git a/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 b/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 index 832b6670..3341568d 100644 --- a/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 +++ b/test/oldtuv/cross_section/cfc-11.cross_section.type.F90 @@ -42,13 +42,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'cfc-11->Products cross section run: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = 1.e-4_musica_dk*(environment%temperature - 298._musica_dk) cross_section = this%cross_section(1)%array(:,1)*exp( (this%mdl_lambda_center(:) - 184.9_musica_dk)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_cfc11_cross_section_type diff --git a/test/oldtuv/cross_section/ch2o.cross_section.type.F90 b/test/oldtuv/cross_section/ch2o.cross_section.type.F90 index db7cd8a3..cacbe059 100644 --- a/test/oldtuv/cross_section/ch2o.cross_section.type.F90 +++ b/test/oldtuv/cross_section/ch2o.cross_section.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( cross_section ) Tadj = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1) + this%cross_section(1)%array(:,2) * Tadj - write(*,*) Iam,'exiting' - end function run end module micm_ch2o_cross_section_type diff --git a/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 b/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 index 37aefd0a..2cc77020 100644 --- a/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/ch3ono2-ch3o_no2.cross_section.type.F90 @@ -42,13 +42,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'ch3ono2->ch3o+no2 cross section run: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1)*exp( this%cross_section(1)%array(:,2)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_ch3ono2_ch3o_no2_cross_section_type diff --git a/test/oldtuv/cross_section/chbr3.cross_section.type.F90 b/test/oldtuv/cross_section/chbr3.cross_section.type.F90 index aa0d2851..7e8d7120 100644 --- a/test/oldtuv/cross_section/chbr3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/chbr3.cross_section.type.F90 @@ -48,8 +48,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: wc, Temp, lambda - write(*,*) Iam,'entering' - do wNdx = 1,size(this%mdl_lambda_center) Temp = environment%temperature lambda = this%mdl_lambda_center(wNdx) @@ -62,8 +60,6 @@ function run( this, environment ) result( cross_section ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_chbr3_cross_section_type diff --git a/test/oldtuv/cross_section/chcl3.cross_section.type.F90 b/test/oldtuv/cross_section/chcl3.cross_section.type.F90 index 969c8428..44bd7e67 100644 --- a/test/oldtuv/cross_section/chcl3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/chcl3.cross_section.type.F90 @@ -51,8 +51,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wndx real(musica_dk) :: w1, w2, w3, w4, tcoeff, Tadj - write(*,*) Iam,'entering' - associate( wc => this%mdl_lambda_center, Temp => environment%temperature ) Tadj = min(max(Temp,210._musica_dk),300._musica_dk) - 295._musica_dk do wNdx = 1,size(wc) @@ -69,8 +67,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_chcl3_cross_section_type diff --git a/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 b/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 index d87529cc..5b3bbdc4 100644 --- a/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 +++ b/test/oldtuv/cross_section/cl2-cl_cl.cross_section.type.F90 @@ -43,8 +43,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: aa, bb, bbsq, alpha, ex1, ex2 - write(*,*) Iam,'entering' - aa = 402.7_musica_dk/environment%temperature bb = exp( aa ) bbsq = bb * bb @@ -58,8 +56,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_cl2_cl_cl_cross_section_type diff --git a/test/oldtuv/cross_section/clono2.cross_section.type.F90 b/test/oldtuv/cross_section/clono2.cross_section.type.F90 index d7a9f932..c467e8f3 100644 --- a/test/oldtuv/cross_section/clono2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/clono2.cross_section.type.F90 @@ -45,16 +45,12 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: Tadj - write(*,*) Iam,'entering' - Tadj = environment%temperature - 296._musica_dk associate( polyCoeff => this%cross_section(1)%array ) cross_section = polyCoeff(:,1)*(rONE + Tadj*(polyCoeff(:,2) + Tadj*polyCoeff(:,3))) end associate - write(*,*) Iam,'exiting' - end function run end module micm_clono2_cross_section_type diff --git a/test/oldtuv/cross_section/cross_section_factory.F90 b/test/oldtuv/cross_section/cross_section_factory.F90 index 7247f2c0..e74b40ef 100644 --- a/test/oldtuv/cross_section/cross_section_factory.F90 +++ b/test/oldtuv/cross_section/cross_section_factory.F90 @@ -59,7 +59,6 @@ function cross_section_builder( config, mdlLambdaEdge ) result( new_cross_sectio type(string_t) :: cross_section_type character(len=*), parameter :: Iam = 'cross section builder: ' - write(*,*) Iam,'entering' new_cross_section_t => null( ) call config%get( 'cross section type', cross_section_type, Iam ) @@ -79,7 +78,6 @@ function cross_section_builder( config, mdlLambdaEdge ) result( new_cross_sectio cross_section_type%to_char( )//"'" ) end select call new_cross_section_t%initialize( config, mdlLambdaEdge ) - write(*,*) Iam,'exiting' end function cross_section_builder diff --git a/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 b/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 index 440bc608..654dd4e2 100644 --- a/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 +++ b/test/oldtuv/cross_section/h2o2-oh_oh.cross_section.type.F90 @@ -58,8 +58,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: lambda, sumA, sumB, t, chi, xs - write(*,*) Iam,'entering' - associate( wl => this%mdl_lambda_edge, wc => this%mdl_lambda_center ) do wNdx = 1,size(this%mdl_lambda_center) ! Parameterization (JPL94) @@ -77,8 +75,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_h2o2_oh_oh_cross_section_type diff --git a/test/oldtuv/cross_section/hcfc.cross_section.type.F90 b/test/oldtuv/cross_section/hcfc.cross_section.type.F90 index 3190731b..72b87563 100644 --- a/test/oldtuv/cross_section/hcfc.cross_section.type.F90 +++ b/test/oldtuv/cross_section/hcfc.cross_section.type.F90 @@ -71,8 +71,6 @@ function run( this, environment ) result( cross_section ) cross_section(wNdx) = sigma enddo - write(*,*) Iam,'exiting' - end function run end module micm_hcfc_cross_section_type diff --git a/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 b/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 index b715d706..366a2b16 100644 --- a/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/hno3-oh_no2.cross_section.type.F90 @@ -62,7 +62,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(config_t) :: tmp_config type(string_t) :: addpntVal - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -119,8 +118,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -141,13 +138,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'hno3->oh+no2 cross section calculate: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1)*exp( this%cross_section(1)%array(:,2)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_hno3_oh_no2_cross_section_type diff --git a/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 b/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 index 12986b8c..60048d6b 100644 --- a/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 +++ b/test/oldtuv/cross_section/hobr-oh_br.cross_section.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'hobr_oh_br cross section calculate: ' - write(*,*) Iam,'entering' - associate( wc => this%mdl_lambda_center ) where( wc >= 250._musica_dk .and. wc <= 550._musica_dk ) cross_section = & @@ -60,8 +58,6 @@ function run( this, environment ) result( cross_section ) endwhere end associate - write(*,*) Iam,'exiting' - end function run end module micm_hobr_oh_br_cross_section_type diff --git a/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 b/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 index 6d7cdaf0..0930f8c0 100644 --- a/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 +++ b/test/oldtuv/cross_section/n2o-n2_o1d.cross_section.type.F90 @@ -71,8 +71,6 @@ function run( this, environment ) result( cross_section ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_n2o_n2_o1d_cross_section_type diff --git a/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 b/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 index d56d23c4..898a1923 100644 --- a/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 +++ b/test/oldtuv/cross_section/n2o5-no2_no3.cross_section.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: wNdx real(musica_dk) :: AdjTemp, Tfac - write(*,*) Iam,'entering' - associate( Temp => environment%temperature ) AdjTemp = max( Tlower,min(Temp,Tupper) ) do wNdx = 1,size(this%mdl_lambda_center) @@ -54,8 +52,6 @@ function run( this, environment ) result( cross_section ) enddo end associate - write(*,*) Iam,'exiting' - end function run end module micm_n2o5_no2_no3_cross_section_type diff --git a/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 b/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 index 7c667be2..f1c7a36f 100644 --- a/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 +++ b/test/oldtuv/cross_section/nitroxy_acetone.cross_section.type.F90 @@ -46,16 +46,12 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'nitroxy_acetone cross section calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 284._musica_dk .and. this%mdl_lambda_center <= 335._musica_dk ) cross_section = exp( c + this%mdl_lambda_center*(b + a*this%mdl_lambda_center) ) elsewhere cross_section = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_nitroxy_acetone_cross_section_type diff --git a/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 b/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 index 5fcba685..947a2504 100644 --- a/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 +++ b/test/oldtuv/cross_section/nitroxy_ethanol.cross_section.type.F90 @@ -46,16 +46,12 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'nitroxy_ethanol cross section calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 270._musica_dk .and. this%mdl_lambda_center <= 306._musica_dk ) cross_section = exp( c + this%mdl_lambda_center*(b + a*this%mdl_lambda_center) ) elsewhere cross_section = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_nitroxy_ethanol_cross_section_type diff --git a/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 b/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 index 56c7cc94..6dbf4047 100644 --- a/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 +++ b/test/oldtuv/cross_section/no2.tint.cross_section.type.F90 @@ -71,7 +71,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +153,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +174,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - cross_section = 0.0_musica_dk do fileNdx = 1,size(this%cross_section) associate( Temp => this%cross_section(fileNdx)%temperature, wrkXsect => this%cross_section(fileNdx) ) @@ -198,8 +193,6 @@ function run( this, environment ) result( cross_section ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -212,8 +205,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'no2 tint cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section) ) then do ndx = 1,size(this%cross_section) associate( Xsection => this%cross_section(ndx) ) @@ -237,8 +228,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - - end subroutine finalize + end subroutine finalize end module micm_no2_tint_cross_section_type diff --git a/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 b/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 index 7ab3672e..b0bf8f9f 100644 --- a/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 +++ b/test/oldtuv/cross_section/o3.tint.cross_section.type.F90 @@ -72,7 +72,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -157,8 +156,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -181,8 +178,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: fileNdx, tNdx, wNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - cross_section = rZERO lambda_loop: & @@ -215,8 +210,6 @@ function run( this, environment ) result( cross_section ) end associate enddo lambda_loop - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/cross_section/oclo.cross_section.type.F90 b/test/oldtuv/cross_section/oclo.cross_section.type.F90 index 21a9b16e..cce5f177 100644 --- a/test/oldtuv/cross_section/oclo.cross_section.type.F90 +++ b/test/oldtuv/cross_section/oclo.cross_section.type.F90 @@ -43,8 +43,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: ndx, nParms real(musica_dk) :: Tfac - write(*,*) Iam,'entering' - associate( Temp => environment%temperature, Xsection => this%cross_section ) nParms = size(Xsection) if( Temp <= Xsection(1)%temperature(1) ) then @@ -65,8 +63,6 @@ function run( this, environment ) result( cross_section ) endif end associate - write(*,*) Iam,'exiting' - end function run end module micm_oclo_cross_section_type diff --git a/test/oldtuv/cross_section/rono2.cross_section.type.F90 b/test/oldtuv/cross_section/rono2.cross_section.type.F90 index c587909b..2fcdcf41 100644 --- a/test/oldtuv/cross_section/rono2.cross_section.type.F90 +++ b/test/oldtuv/cross_section/rono2.cross_section.type.F90 @@ -62,7 +62,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(config_t) :: tmp_config type(string_t) :: addpntVal - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -119,8 +118,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -141,13 +138,9 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 'rono2 cross section calculate: ' real(musica_dk) :: Temp - write(*,*) Iam,'entering' - Temp = environment%temperature - 298._musica_dk cross_section = this%cross_section(1)%array(:,1)*exp( this%cross_section(1)%array(:,2)*Temp ) - write(*,*) Iam,'exiting' - end function run end module micm_rono2_cross_section_type diff --git a/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 b/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 index d0223f89..3be6ad4f 100644 --- a/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 +++ b/test/oldtuv/cross_section/t_butyl_nitrate.cross_section.type.F90 @@ -46,16 +46,12 @@ function run( this, environment ) result( cross_section ) character(len=*), parameter :: Iam = 't_butyl_nitrate cross section calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 270._musica_dk .and. this%mdl_lambda_center <= 330._musica_dk ) cross_section = exp( c + this%mdl_lambda_center*(b + a*this%mdl_lambda_center) ) elsewhere cross_section = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_t_butyl_nitrate_cross_section_type diff --git a/test/oldtuv/cross_section/tint.cross_section.type.F90 b/test/oldtuv/cross_section/tint.cross_section.type.F90 index 8544ad37..2f262178 100644 --- a/test/oldtuv/cross_section/tint.cross_section.type.F90 +++ b/test/oldtuv/cross_section/tint.cross_section.type.F90 @@ -71,7 +71,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +153,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +174,6 @@ function run( this, environment ) result( cross_section ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - cross_section = 0.0_musica_dk do fileNdx = 1,size(this%cross_section) associate( Temp => this%cross_section(fileNdx)%temperature, wrkXsect => this%cross_section(fileNdx) ) @@ -196,8 +191,6 @@ function run( this, environment ) result( cross_section ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -210,8 +203,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'tint cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section) ) then do ndx = 1,size(this%cross_section) associate( Xsection => this%cross_section(ndx) ) @@ -235,8 +226,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_tint_cross_section_type diff --git a/test/oldtuv/delta_eddington.f90 b/test/oldtuv/delta_eddington.f90 index 38c4bbe6..13237eca 100644 --- a/test/oldtuv/delta_eddington.f90 +++ b/test/oldtuv/delta_eddington.f90 @@ -244,10 +244,6 @@ subroutine calculate( this, nlyr, nstr, albedo, & mu2(i) = SIGN( MAX(ABS(mu2(i)),rONE/SQRT(largest)),mu2(i) ) END IF - if( initialized .and. i == 2 ) then - write(*,*)'TUV: dsdh diagnostic' - write(*,*) dsdh(i,1:i) - endif END IF !** the following gamma equations are from pg 16,289, Table 1 @@ -301,13 +297,6 @@ subroutine calculate( this, nlyr, nstr, albedo, & cuptn(i) = up*expon1 cdntn(i) = dn*expon1 - if( initialized .and. i == 3 ) then - write(*,*) 'TUV: cup diagnostic' - write(*,*) expon, expon0, expon1, divisr, temp, up, dn - write(*,*) lam(i), mu2(i), gam1, gam2, gam3, gam4 - write(*,*) tauc(i-1:i), tausla(i-1:i) - endif - ENDDO layer_loop if( initialized ) then @@ -377,8 +366,6 @@ subroutine calculate( this, nlyr, nstr, albedo, & call diagout( 'b.old',b ) call diagout( 'd.old',d ) call diagout( 'e.old',e ) - write(*,*) 'e diagnostic' - write(*,*) e(5), e1(2), e3(2), cup(3), cdn(3), cuptn(2), cdntn(2) initialized = .false. endif ! solve tri-diagonal system: diff --git a/test/oldtuv/diagout.f90 b/test/oldtuv/diagout.f90 index c73781d9..8e52f265 100644 --- a/test/oldtuv/diagout.f90 +++ b/test/oldtuv/diagout.f90 @@ -20,8 +20,6 @@ subroutine diagnostic_1d( filename, variable ) integer :: ios - write(*,*) 'diagnostic_1d: entering' - open(unit=44,file='odat/OUTPUTS/'//filename,form='unformatted',iostat=ios) if( ios /= 0 ) then write(*,*) 'diagnostic_1d: failed to open ',filename,'; error = ',ios @@ -33,8 +31,6 @@ subroutine diagnostic_1d( filename, variable ) stop 'OpnErr' endif - write(*,*) 'diagnostic_1d: exiting' - end subroutine diagnostic_1d subroutine diagnostic_1d_dk( filename, variable ) @@ -44,8 +40,6 @@ subroutine diagnostic_1d_dk( filename, variable ) integer :: ios - write(*,*) 'diagnostic_1d_dk: entering' - open(unit=44,file='odat/OUTPUTS/'//filename,form='unformatted',iostat=ios) if( ios /= 0 ) then write(*,*) 'diagnostic_1d: failed to open ',filename,'; error = ',ios @@ -57,8 +51,6 @@ subroutine diagnostic_1d_dk( filename, variable ) stop 'OpnErr' endif - write(*,*) 'diagnostic_1d_dk: exiting' - end subroutine diagnostic_1d_dk subroutine diagnostic_2d( filename, variable ) diff --git a/test/oldtuv/disord_subs.f b/test/oldtuv/disord_subs.f index ecee9843..d5cdfaca 100644 --- a/test/oldtuv/disord_subs.f +++ b/test/oldtuv/disord_subs.f @@ -1416,7 +1416,6 @@ SUBROUTINE FLUXES( tausla, tauslau, REAL :: ANG1, ANG2, DIRINT, FACT, FDNTOT, FNET, PLSORC, ZINT c .. - IF( PRNT( 2 ) ) WRITE( *, 9000 ) c ** Zero DISORT output arrays U0C = 0. FLDIR = 0. @@ -1547,26 +1546,17 @@ SUBROUTINE FLUXES( tausla, tauslau, & ( UAVG( LU ) - PLSORC ) 70 CONTINUE - IF( PRNT( 2 ) ) WRITE( *, FMT = 9010 ) UTAU( LU ), LYU, - & RFLDIR( LU ), RFLDN( LU ), FDNTOT, FLUP( LU ), FNET, - & UAVG( LU ), PLSORC, DFDT( LU ) ENDDO LEVEL_LOOP IF( PRNT( 3 ) ) THEN - WRITE( *, FMT = 9020 ) - DO LU = 1, NTAU - WRITE( *, FMT = 9030 ) UTAU( LU ) - DO IQ = 1, NN ANG1 = 180./ PI* ACOS( CMU( 2*NN - IQ + 1 ) ) ANG2 = 180./ PI* ACOS( CMU( IQ ) ) - WRITE( *, 9040 ) ANG1, CMU(2*NN-IQ+1), U0C(IQ,LU), - $ ANG2, CMU(IQ), U0C(IQ+NN,LU) ENDDO ENDDO @@ -1742,26 +1732,13 @@ SUBROUTINE PRAVIN( UMU, NUMU, UTAU, NTAU, U0U ) IF( NUMU.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ******* AZIMUTHALLY AVERAGED INTENSITIES ' // - & '(at user polar angles) ********' - LENFMT = 8 NPASS = 1 + (NUMU-1) / LENFMT - WRITE( *,'(/,A,/,A)') ' Optical Polar Angle Cosines', - & ' Depth' - DO 20 NP = 1, NPASS IUMIN = 1 + LENFMT * ( NP - 1 ) IUMAX = MIN( LENFMT*NP, NUMU ) - WRITE( *,'(/,10X,8F14.5)') ( UMU(IU), IU = IUMIN, IUMAX ) - - DO 10 LU = 1, NTAU - WRITE( *, '(0P,F10.4,1P,8E14.4)' ) UTAU( LU ), - & ( U0U( IU,LU ), IU = IUMIN, IUMAX ) - 10 CONTINUE 20 CONTINUE @@ -1798,110 +1775,13 @@ SUBROUTINE PRTINP( NLYR, DTAUC, DTAUCP, SSALB, PMOM, c .. - WRITE( *, '(/,A,I4,A,I4)' ) ' No. streams =', NSTR, - & ' No. computational layers =', NLYR - - IF( IBCND /= 1 ) WRITE( *, '(I4,A,10F10.4,/,(26X,10F10.4))' ) - & NTAU,' User optical depths :', ( UTAU(LU), LU = 1, NTAU ) - - IF( .NOT. ONLYFL ) WRITE( *, '(I4,A,10F9.5,/,(31X,10F9.5))' ) - & NUMU,' User polar angle cosines :',( UMU(IU), IU = 1, NUMU ) - - IF( .NOT. ONLYFL .AND. IBCND /= 1 ) - & WRITE( *, '(I4,A,10F9.2,/,(28X,10F9.2))' ) - & NPHI,' User azimuthal angles :',( PHI(J), J = 1, NPHI ) - - IF( .NOT. PLANK .OR. IBCND == 1 ) - & WRITE( *, '(A)' ) ' No thermal emission' - - - WRITE( *, '(A,I2)' ) ' Boundary condition flag: IBCND =', IBCND - - IF( IBCND == 0 ) THEN - - WRITE( *, '(A,1P,E11.3,A,0P,F8.5,A,F7.2,/,A,1P,E11.3)' ) - & ' Incident beam with intensity =', FBEAM, - & ' and polar angle cosine = ', UMU0, - & ' and azimuth angle =', PHI0, - & ' plus isotropic incident intensity =', FISOT - - IF( LAMBER ) WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - - IF( .NOT. LAMBER ) WRITE( *, '(A,/,(10X,10F9.5))' ) - & ' Legendre coeffs of bottom bidirectional reflectivity :', - & ( HL( K ), K = 0, NSTR ) - - ELSE IF( IBCND == 1 ) THEN - - WRITE(*,'(A)') ' Isotropic illumination from top and bottom' - WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - END IF - - - IF( DELTAM ) WRITE( *, '(A)' ) ' Uses delta-M method' - IF( .NOT.DELTAM ) WRITE( *, '(A)' ) ' Does not use delta-M method' - - - IF( IBCND == 1 ) THEN - - WRITE( *, '(A)' ) ' Calculate albedo and transmissivity of'// - & ' medium vs. incident beam angle' - - ELSE IF( ONLYFL ) THEN - - WRITE( *, '(A)' ) - & ' Calculate fluxes and azim-averaged intensities only' - - ELSE - - WRITE( *, '(A)' ) ' Calculate fluxes and intensities' - - END IF - - - WRITE( *, '(A,1P,E11.2)' ) - & ' Relative convergence criterion for azimuth series =', - & ACCUR - - IF( LYRCUT ) WRITE( *, '(A)' ) - & ' Sets radiation = 0 below absorption optical depth 10' - - -c ** Print layer variables - IF( PLANK ) WRITE( *, FMT = 9180 ) - IF( .NOT. PLANK ) WRITE( *, FMT = 9190 ) - YESSCT = rZERO DO LC = 1, NLYR YESSCT = YESSCT + SSALB( LC ) - - IF( PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4,F14.3)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM(1,LC) - - IF( .NOT.PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM( 1,LC ) ENDDO - IF( PRTMOM .AND. YESSCT > rZERO ) THEN - - WRITE( *, '(/,A)' ) ' Layer Phase Function Moments' - - DO LC = 1, NLYR - IF( SSALB( LC ).GT.rZERO ) - & WRITE( *, '(I6,10F11.6,/,(6X,10F11.6))' ) - & LC, ( PMOM( K, LC ), K = 0, NSTR ) - ENDDO - - END IF - c ** (Read every other line in these formats) 9180 FORMAT( /, 37X, '<------------- Delta-M --------------->', /, @@ -1954,17 +1834,9 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) IF( NPHI.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ********* I N T E N S I T I E S *********' - LENFMT = 10 NPASS = 1 + (NPHI-1) / LENFMT - WRITE( *, '(/,A,/,A,/,A)' ) - & ' Polar Azimuth angles (degrees)', - & ' Optical Angle', - & ' Depth Cosine' - DO 30 LU = 1, NTAU DO 20 NP = 1, NPASS @@ -1972,18 +1844,6 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) JMIN = 1 + LENFMT * ( NP - 1 ) JMAX = MIN( LENFMT*NP, NPHI ) - WRITE( *, '(/,18X,10F11.2)' ) ( PHI(J), J = JMIN, JMAX ) - - IF( NP.EQ.1 ) WRITE( *, '(F10.4,F8.4,1P,10E11.3)' ) - & UTAU(LU), UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - IF( NP.GT.1 ) WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - - DO 10 IU = 2, NUMU - WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU( IU ), ( UU( IU, LU, J ), J = JMIN, JMAX ) - 10 CONTINUE - 20 CONTINUE 30 CONTINUE @@ -2764,9 +2624,6 @@ SUBROUTINE SOLEIG( AMB, APB, ARRAY, CMU, CWT, GL, MAZIM, IF( IER.GT.0 ) THEN - WRITE( *, FMT = '(//,A,I4,A)' ) ' ASYMTX--eigenvalue no. ', - & IER, ' didnt converge. Lower-numbered eigenvalues wrong.' - CALL ERRMSG( 'ASYMTX--convergence problems',.True.) END IF @@ -3518,11 +3375,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = OPRIM - IF (DEBUG) THEN - write (*,*) '! *** Neither upward nor downward iteration' - write (*,*) '! *** converged; using original result.' - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -3536,15 +3388,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** The upward iteration did not converge.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -3552,15 +3395,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, *bm if downward iteration did not converge, we are done *bm (the result of the upward iteration will be used) IF (NODN) THEN - IF (DEBUG) THEN - write (*,*) '! *** The downward iteration did not converge.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 998 ENDIF @@ -3578,30 +3412,10 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using downward.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ELSE - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using upward.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. goto 998 ENDIF diff --git a/test/oldtuv/grid/grid_factory.F90 b/test/oldtuv/grid/grid_factory.F90 index b0924d81..a052a7f2 100644 --- a/test/oldtuv/grid/grid_factory.F90 +++ b/test/oldtuv/grid/grid_factory.F90 @@ -39,7 +39,6 @@ function grid_builder( config ) result( new_grid_t ) type(string_t) :: grid_type character(len=*), parameter :: Iam = 'Grid builder: ' - write(*,*) Iam,'entering' new_grid_t => null() call config%get( 'Grid type', grid_type, Iam ) @@ -55,7 +54,6 @@ function grid_builder( config ) result( new_grid_t ) end select call new_grid_t%initialize( config ) - write(*,*) Iam,'exiting' end function grid_builder diff --git a/test/oldtuv/grid/grid_warehouse.F90 b/test/oldtuv/grid/grid_warehouse.F90 index 13c9fa4c..aee7d9b1 100644 --- a/test/oldtuv/grid/grid_warehouse.F90 +++ b/test/oldtuv/grid/grid_warehouse.F90 @@ -62,8 +62,6 @@ function constructor( config ) result( grid_warehouse_obj ) character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( grid_warehouse_obj ) associate(new_obj=>grid_warehouse_obj) @@ -78,8 +76,6 @@ function constructor( config ) result( grid_warehouse_obj ) do while( iter%next() ) keychar = grid_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call grid_set%get( iter, grid_config, Iam ) call grid_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -91,13 +87,8 @@ function constructor( config ) result( grid_warehouse_obj ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' grid objects'')') Iam,size(new_obj%grid_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -121,9 +112,6 @@ function get_grid( this, grid_handle ) result( grid_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%grid_objs_) if( grid_handle .eq. this%grid_objs_(ndx)%ptr_%handle_ ) then @@ -138,8 +126,6 @@ function get_grid( this, grid_handle ) result( grid_ptr ) call die_msg( 460768214, "Invalid grid handle: '"// grid_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_grid !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,14 +142,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'grid warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%grid_objs_ ) ) then deallocate( this%grid_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/grids.f b/test/oldtuv/grids.f index b5b65288..247519fd 100644 --- a/test/oldtuv/grids.f +++ b/test/oldtuv/grids.f @@ -393,7 +393,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) CASE( 1 ) *-----grid option 1: manual ----------------- * entire grid (nz levels) in increments zincr - WRITE(*,*) 'equally spaced z-grid' zincr = (zstop - zstart) / REAL(nz - 1) allocate( z(nz) ) z(1) = zstart @@ -405,7 +404,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) *-----grid option 2: automatic ----------------- * entire grid (nz levels) in increments zincr - WRITE(*,*) 'equally spaced z-grid' zincr = (zstop - zstart) / real(nz - 1) nlev = nz-1 n = 1 @@ -416,7 +414,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) *-----copy & edit this section for non-uniform grid---- * the example provided below is high vertical resolution in * snow, with atmosphere above it. - WRITE(*,*) 'snow-atmosphere grid' * 0.-10. cm from ground, in 1 cm increments ( 1 cm = 1e-5 km): zincr = 1.e-5 nlev = 10 @@ -477,8 +474,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) CASE( 4 ) *-----grid option 4: grid for Mexico City - WRITE(*,*) 'mirage z-grid' - * grid for mirage km: incr(range)i * 0.1(0-4) 2-41 * 0.2(4-8) 42-61 @@ -512,7 +507,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) * nz = total number of altitudes * Table: z(iz), where iz goes from 1 to nz * trivial example of 2-layer (3-altitudes) shown below, user should modify - WRITE(*,*) 'user-defined grid, named...' nz = 3 z(1) = 0. z(2) = 10. @@ -527,8 +521,6 @@ SUBROUTINE gridz(zstart, zstop, nz, z, zout, izout) * nz = total number of altitudes * Table: z(iz), where iz goes from 1 to nz - WRITE(*,*) 'user-defined grid, named...' - END SELECT * Insert additional altitude for selected outputs. diff --git a/test/oldtuv/photo_kinetics.F90 b/test/oldtuv/photo_kinetics.F90 index 87d280b1..75f30773 100644 --- a/test/oldtuv/photo_kinetics.F90 +++ b/test/oldtuv/photo_kinetics.F90 @@ -98,8 +98,6 @@ function constructor( config,mdlLambdaEdge ) result( new_photo_kinetics_obj ) do while( iter%next( ) ) keychar = reaction_set%key(iter) areaction_key = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) new_obj%reaction_key = [new_obj%reaction_key,areaction_key] call reaction_set%get( iter, reaction_config, Iam ) !----------------------------------------------------------------------------- @@ -127,11 +125,7 @@ function constructor( config,mdlLambdaEdge ) result( new_photo_kinetics_obj ) deallocate( iter ) nSize = size(new_obj%cross_section_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' cross sections'')') Iam,nSize nSize = size(new_obj%quantum_yield_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' quantum yields'')') Iam,nSize !----------------------------------------------------------------------------- !> setup cross section, quantum yield arrays @@ -164,9 +158,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) real(musica_dk), allocatable :: a_quantum_yield(:) real(musica_dk), allocatable :: quantum_yield_tray(:) - write(*,*) ' ' - write(*,*) Iam,'entering' - allocate(cross_section_tray(0)) do ndx = 1, size(this%cross_section_objs_) associate( calc_ftn => this%cross_section_objs_(ndx)%val_ ) @@ -178,9 +169,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) this%cross_section_values_ = reshape( cross_section_tray, & (/nwave,size(this%cross_section_objs_) /) ) - write(*,*) Iam,'size of cross section values = ',& - size(this%cross_section_values_,dim=1), size(this%cross_section_values_,dim=2) - allocate(quantum_yield_tray(0)) do ndx = 1, size(this%quantum_yield_objs_) associate( calc_ftn => this%quantum_yield_objs_(ndx) ) @@ -195,11 +183,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) this%quantum_yield_values_ = reshape( quantum_yield_tray, & (/nwave,size(this%quantum_yield_objs_) /) ) - write(*,*) Iam,'size of quantum_yield values = ',& - size(this%quantum_yield_values_,dim=1), size(this%quantum_yield_values_,dim=2) - - write(*,*) Iam,'exiting' - end subroutine update_for_new_environmental_state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -213,8 +196,6 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'photo_kinetics finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%cross_section_values_ ) ) then deallocate( this%cross_section_values_ ) endif @@ -245,8 +226,6 @@ subroutine finalize( this ) deallocate( this%reaction_key ) end if - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 index d5eb0495..46a39e38 100644 --- a/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/abstract.quantum_yield.type.F90 @@ -92,8 +92,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -123,8 +121,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_) call addpnt(x=data_lambda,y=data_parameter,xnew=1.e38_musica_dk,ynew=addpnt_val_) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_abs_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 index 58ce3968..bf1d52f1 100644 --- a/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/acetone-ch3co_ch3.quantum_yield.type.F90 @@ -59,8 +59,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk) :: dumexp real(musica_dk) :: fco, fac - write(*,*) Iam,'entering' - Tadj = environment%temperature/295._musica_dk M = environment%number_density_air lambda_loop: & @@ -112,8 +110,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield(wNdx) = fac enddo lambda_loop - write(*,*) Iam,'exiting' - end function run end module micm_ch3coch3_ch3co_ch3_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 index de77931d..5f36eb5b 100644 --- a/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/base.quantum_yield.type.F90 @@ -69,8 +69,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' - !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -123,8 +121,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) endif endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,12 +139,8 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'base quantum yield calculate: ' - write(*,*) Iam,'entering' - quantum_yield = this%quantum_yield(1)%array(:,1) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -161,8 +153,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base quantum yield finalize: ' integer(musica_dk) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%quantum_yield) ) then do ndx = 1,size(this%quantum_yield) if( allocated(this%quantum_yield(ndx)%array ) ) then @@ -181,8 +171,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_base_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 index c264ff9b..f7be4e1a 100644 --- a/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/c2h5cho.quantum_yield.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'c2h5cho+hv->c2h5+hco calculate: ' real(musica_dk) :: air_den_fac - write(*,*) Iam,'entering' - air_den_fac = environment%number_density_air/2.45e19_musica_dk ! quantum yields: @@ -59,8 +57,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield = min( rONE,quantum_yield ) endwhere - write(*,*) Iam,'exiting' - end function run end module micm_c2h5cho_c2h5_hco_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 index 74429c2c..da91cebb 100644 --- a/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch2chcho.quantum_yield.type.F90 @@ -47,8 +47,6 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'ch2chcho+hv->products calculate: ' real(musica_dk) :: phi0 - write(*,*) Iam,'entering' - associate( M => environment%number_density_air ) if( M > 2.6e19_musica_dk ) then quantum_yield = phiL @@ -62,8 +60,6 @@ function run( this, environment ) result( quantum_yield ) endif end associate - write(*,*) Iam,'exiting' - end function run end module micm_ch2chcho_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 index be645d44..f324195d 100644 --- a/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch2o.quantum_yield.type.F90 @@ -51,8 +51,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk), allocatable :: quantum_yield_tmp(:) real(musica_dk), allocatable :: quantum_yield_wrk(:) - write(*,*) Iam,'entering' - quantum_yield_chnl1 = this%quantum_yield(1)%array(:,1) quantum_yield_chnl2 = this%quantum_yield(1)%array(:,2) quantum_yield_tmp = rONE - quantum_yield_chnl1 @@ -69,8 +67,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield = quantum_yield_chnl2 endwhere - write(*,*) Iam,'exiting' - end function run end module micm_ch2o_h2_co_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 index 98724d11..7e2ff320 100644 --- a/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch3cho-ch3_hco.quantum_yield.type.F90 @@ -48,8 +48,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk), allocatable :: quantum_yield_chnl2(:) real(musica_dk), allocatable :: quantum_yield_wrk(:) - write(*,*) Iam,'entering' - quantum_yield_chnl1 = this%quantum_yield(1)%array(:,2) quantum_yield_chnl2 = rONE - this%quantum_yield(1)%array(:,1) quantum_yield_wrk = (/ (rZERO,m=1,size(this%quantum_yield(1)%array,dim=1)) /) @@ -63,8 +61,6 @@ function run( this, environment ) result( quantum_yield ) /(rONE + quantum_yield_wrk*air_den_factor) quantum_yield = min( rONE,max(rZERO,quantum_yield) ) - write(*,*) Iam,'exiting' - end function run end module micm_ch3cho_ch3_hco_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 index ceb34239..fb573e73 100644 --- a/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch3coch2ch3-ch3co_ch2ch3.quantum_yield.type.F90 @@ -44,14 +44,10 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'ch3coch2ch3+hv->ch3co+ch2ch3 calculate: ' real(musica_dk) :: ptorr - write(*,*) Iam,'entering' - ptorr = 760._musica_dk*environment%number_density_air/2.69e19_musica_dk quantum_yield = rONE/(0.96_musica_dk + 2.22E-3_musica_dk*ptorr) quantum_yield = min(quantum_yield, rONE) - write(*,*) Iam,'exiting' - end function run end module micm_ch3coch2ch3_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 index 5aa10ad5..dca962d5 100644 --- a/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ch3cocho.quantum_yield.type.F90 @@ -75,8 +75,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield(wNdx) = qy enddo - write(*,*) Iam,'exiting' - end function run end module micm_ch3cocho_ch3co_hco_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 index d8ce056b..6a202579 100644 --- a/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clo-cl_o1d.quantum_yield.type.F90 @@ -43,16 +43,12 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'clo+hv->cl+o1d calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center < 263.4_musica_dk ) quantum_yield = rONE elsewhere quantum_yield = rZERO endwhere - write(*,*) Iam,'exiting' - end function run end module micm_clo_cl_o1d_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 index 8e941271..8a268a33 100644 --- a/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clo-cl_o3p.quantum_yield.type.F90 @@ -43,16 +43,12 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'clo+hv->cl+o3p calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center < 263.4_musica_dk ) quantum_yield = rZERO elsewhere quantum_yield = rONE endwhere - write(*,*) Iam,'exiting' - end function run end module micm_clo_cl_o3p_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 index 5aeeb5c2..13c320ee 100644 --- a/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clono2-cl_no3.quantum_yield.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: wNdx real(musica_ik) :: lambda - write(*,*) Iam,'entering' - do wNdx = 1,size(this%mdl_lambda_center) lambda = this%mdl_lambda_center(wNdx) if( lambda < 308._musica_dk ) then @@ -59,8 +57,6 @@ function run( this, environment ) result( quantum_yield ) endif enddo - write(*,*) Iam,'exiting' - end function run end module micm_clono2_cl_no3_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 index f579963c..b642086f 100644 --- a/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/clono2-clo_no2.quantum_yield.type.F90 @@ -46,8 +46,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: wNdx real(musica_ik) :: lambda, qyield - write(*,*) Iam,'entering' - do wNdx = 1,size(this%mdl_lambda_center) lambda = this%mdl_lambda_center(wNdx) if( lambda < 308._musica_dk ) then @@ -60,8 +58,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield(wNdx) = rONE - qyield enddo - write(*,*) Iam,'exiting' - end function run end module micm_clono2_clo_no2_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 index 1abdc0d8..a4f9fb23 100644 --- a/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/ho2.quantum_yield.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk), parameter :: lambda0 = 193._musica_dk character(len=*), parameter :: Iam = 'ho2+hv->oh+o calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center >= 248._musica_dk ) quantum_yield = rONE elsewhere @@ -53,8 +51,6 @@ function run( this, environment ) result( quantum_yield ) quantum_yield = max( rZERO,quantum_yield ) endwhere - write(*,*) Iam,'exiting' - end function run end module micm_ho2_oh_o_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 index 098f3005..96a55e69 100644 --- a/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/mvk.quantum_yield.type.F90 @@ -44,14 +44,10 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'mvk+hv->products calculate: ' real(musica_dk) :: divisor - write(*,*) Iam,'entering' - divisor = 5.5_musica_dk + 9.2e-19_musica_dk*environment%number_density_air quantum_yield = exp( -0.055_musica_dk*(this%mdl_lambda_center - 308._musica_dk)) / divisor quantum_yield = min( quantum_yield,rONE ) - write(*,*) Iam,'exiting' - end function run end module micm_mvk_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 index 3c00800b..3590ff9f 100644 --- a/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/no2.tint.quantum_yield.type.F90 @@ -72,8 +72,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' - !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +152,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +173,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - quantum_yield = 0.0_musica_dk do fileNdx = 1,size(this%quantum_yield) associate( Temp => this%quantum_yield(fileNdx)%temperature, wrkQyield => this%quantum_yield(fileNdx) ) @@ -199,8 +193,6 @@ function run( this, environment ) result( quantum_yield ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -214,7 +206,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'no2 tint quantum yield finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%quantum_yield) ) then do ndx = 1,size(this%quantum_yield) associate( Qyield => this%quantum_yield(ndx) ) @@ -238,8 +229,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_no2_tint_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 index 1179bfcf..2a11c366 100644 --- a/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/no3-_aq.quantum_yield.type.F90 @@ -43,12 +43,8 @@ function run( this, environment ) result( quantum_yield ) character(len=*), parameter :: Iam = 'no3-_(aq)+hv->products calculate: ' - write(*,*) Iam,'entering' - quantum_yield = exp( -2400._musica_dk/environment%temperature + 3.6_musica_dk ) ! Chu & Anastasio, 2003 - write(*,*) Iam,'exiting' - end function run end module micm_no3m_aq_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 index acb01980..4a618d61 100644 --- a/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/o3-o2_o1d.quantum_yield.type.F90 @@ -52,8 +52,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk) :: kt, q1, q2, T300, lambda real(musica_dk) :: qfac1, qfac2 - write(*,*) Iam,'entering' - !-----------------------------------------------------------------------------* != PURPOSE: =* ! function to calculate the quantum yield O3 + hv -> O(1D) + O2, =* @@ -92,8 +90,6 @@ function run( this, environment ) result( quantum_yield ) end associate - write(*,*) Iam,'exiting' - end function run end module micm_o3_o2_o1d_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 index 0b7b3603..7652bebf 100644 --- a/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/o3-o2_o3p.quantum_yield.type.F90 @@ -52,8 +52,6 @@ function run( this, environment ) result( quantum_yield ) real(musica_dk) :: kt, q1, q2, T300, lambda real(musica_dk) :: qfac1, qfac2 - write(*,*) Iam,'entering' - !-----------------------------------------------------------------------------* != PURPOSE: =* ! function to calculate the quantum yield O3 + hv -> O(1D) + O2, =* @@ -90,8 +88,6 @@ function run( this, environment ) result( quantum_yield ) end associate - write(*,*) Iam,'exiting' - end function run end module micm_o3_o2_o3p_quantum_yield_type diff --git a/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 b/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 index 5431e024..b05166f4 100644 --- a/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 +++ b/test/oldtuv/quantum_yield/tint.quantum_yield.type.F90 @@ -72,8 +72,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' - !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -154,8 +152,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -177,8 +173,6 @@ function run( this, environment ) result( quantum_yield ) integer(musica_ik) :: fileNdx, tNdx real(musica_dk) :: Tadj, Tstar - write(*,*) Iam,'entering' - quantum_yield = 0.0_musica_dk do fileNdx = 1,size(this%quantum_yield) associate( Temp => this%quantum_yield(fileNdx)%temperature, wrkQyield => this%quantum_yield(fileNdx) ) @@ -196,8 +190,6 @@ function run( this, environment ) result( quantum_yield ) end associate enddo - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -211,7 +203,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'tint quantum yield finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%quantum_yield) ) then do ndx = 1,size(this%quantum_yield) associate( Qyield => this%quantum_yield(ndx) ) @@ -235,8 +226,6 @@ subroutine finalize( this ) deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_tint_quantum_yield_type diff --git a/test/oldtuv/quantum_yield_factory.F90 b/test/oldtuv/quantum_yield_factory.F90 index 8a256ee1..2b1286bb 100644 --- a/test/oldtuv/quantum_yield_factory.F90 +++ b/test/oldtuv/quantum_yield_factory.F90 @@ -54,7 +54,6 @@ function quantum_yield_builder( config, mdlLambdaEdge ) result( new_quantum_yiel type(string_t) :: quantum_yield_type character(len=*), parameter :: Iam = 'quantum yield builder: ' - write(*,*) Iam,'entering' new_quantum_yield_t => null() call config%get( 'quantum yield type', quantum_yield_type, Iam ) @@ -102,7 +101,6 @@ function quantum_yield_builder( config, mdlLambdaEdge ) result( new_quantum_yiel quantum_yield_type%to_char( )//"'" ) end select call new_quantum_yield_t%initialize( config, mdlLambdaEdge ) - write(*,*) Iam,'exiting' end function quantum_yield_builder diff --git a/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 index 5b82cb7d..97e5a535 100644 --- a/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/abstract.radXfer.cross_section.type.F90 @@ -94,8 +94,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -125,8 +123,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_upper) call addpnt(x=data_lambda,y=data_parameter,xnew=1.e38_musica_dk,ynew=addpnt_val_upper) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_radXfer_abs_cross_section_type diff --git a/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 index 4e9e408a..1948dc30 100644 --- a/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/base.cross_section.type.F90 @@ -77,7 +77,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) type(string_t), allocatable :: netcdfFiles(:) class(base_grid_t), pointer :: lambdaGrid - write(*,*) Iam,'entering' !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -123,8 +122,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -152,8 +149,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) type(string_t) :: Handle real(musica_dk), allocatable :: wrkCrossSection(:,:) - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) @@ -166,8 +161,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -180,8 +173,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section_parms) ) then do ndx = 1,size(this%cross_section_parms) if( allocated(this%cross_section_parms(ndx)%array ) ) then @@ -194,8 +185,6 @@ subroutine finalize( this ) deallocate(this%cross_section_parms) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_radXfer_base_cross_section_type diff --git a/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 index 80817cb0..2da0d5a7 100644 --- a/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/o2.cross_section.type.F90 @@ -79,7 +79,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) type(string_t), allocatable :: netcdfFiles(:) class(base_grid_t), pointer :: lambdaGrid - write(*,*) Iam,'entering' !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -133,8 +132,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) call this%la_srb_obj_%initialize( lambdaGrid ) - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -162,8 +159,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) type(string_t) :: Handle real(musica_dk), allocatable :: wrkCrossSection(:,:) - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) @@ -176,8 +171,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -190,8 +183,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section_parms) ) then do ndx = 1,size(this%cross_section_parms) if( allocated(this%cross_section_parms(ndx)%array ) ) then @@ -208,8 +199,6 @@ subroutine finalize( this ) deallocate(this%la_srb_obj_) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_radXfer_o2_cross_section_type diff --git a/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 index d503310f..c3c32196 100644 --- a/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/o3.tint.cross_section.type.F90 @@ -79,8 +79,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) class(base_grid_t), pointer :: lambdaGrid type(string_t) :: Handle - write(*,*) Iam,'entering' - !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -165,8 +163,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -202,8 +198,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) class(base_profile_t), pointer :: mdlTemperature type(string_t) :: Handle - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' @@ -250,8 +244,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 b/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 index bf215450..22ee28db 100644 --- a/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 +++ b/test/oldtuv/radXfer_cross_section/radXfer_xsect_factory.F90 @@ -42,7 +42,6 @@ function cross_section_builder( config, gridWareHouse, ProfileWareHouse ) result type(string_t) :: cross_section_type character(len=*), parameter :: Iam = 'cross section builder: ' - write(*,*) Iam,'entering' new_cross_section_t => null( ) call config%get( 'cross section type', cross_section_type, Iam ) @@ -64,7 +63,6 @@ function cross_section_builder( config, gridWareHouse, ProfileWareHouse ) result cross_section_type%to_char( )//"'" ) end select call new_cross_section_t%initialize( config, gridWareHouse, ProfileWareHouse ) - write(*,*) Iam,'exiting' end function cross_section_builder diff --git a/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 b/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 index c305d0ae..68314542 100644 --- a/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 +++ b/test/oldtuv/radXfer_cross_section/radXfer_xsect_warehouse.F90 @@ -74,9 +74,6 @@ function constructor( config, gridWareHouse, ProfileWareHouse ) result( radXfer_ type(string_t), allocatable :: netcdfFiles(:) logical(musica_lk) :: found - write(*,*) ' ' - write(*,*) Iam // 'entering' - allocate( radXfer_xsect_obj ) associate(new_obj=>radXfer_xsect_obj) @@ -97,8 +94,6 @@ function constructor( config, gridWareHouse, ProfileWareHouse ) result( radXfer_ do while( iter%next( ) ) keychar = reaction_set%key(iter) areaction_key = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) new_obj%handles_ = [new_obj%handles_,areaction_key] call reaction_set%get( iter, reaction_config, Iam ) !----------------------------------------------------------------------------- @@ -112,14 +107,9 @@ function constructor( config, gridWareHouse, ProfileWareHouse ) result( radXfer_ endif has_radXfer_xsects nSize = size(new_obj%cross_section_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' cross sections'')') Iam,nSize end associate - write(*,*) ' ' - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,9 +133,6 @@ function get_radXfer_cross_section( this, radXfer_cross_section_handle ) result( integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%handles_) if( radXfer_cross_section_handle .eq. this%handles_(ndx) ) then @@ -160,8 +147,6 @@ function get_radXfer_cross_section( this, radXfer_cross_section_handle ) result( call die_msg( 460768224, "Invalid radXfer_cross_section_handle: '"// radXfer_cross_section_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_radXfer_cross_section !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -175,8 +160,6 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'radXfer_xsect finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%cross_section_objs_ ) ) then do ndx = 1,size(this%cross_section_objs_) if( associated( this%cross_section_objs_(ndx)%val_ ) ) then @@ -190,8 +173,6 @@ subroutine finalize( this ) deallocate( this%handles_ ) end if - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 index c662eed4..8457d0d8 100644 --- a/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/rayliegh.cross_section.type.F90 @@ -47,10 +47,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) character(len=*), parameter :: Iam = 'rayliegh cross section initialize: ' - write(*,*) Iam,'entering' - - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -81,8 +77,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) real(musica_dk), allocatable :: pwr(:), wrk(:) real(musica_dk), allocatable :: wrkCrossSection(:,:) - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' @@ -110,8 +104,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 b/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 index e9e7189b..2dc9d2b8 100644 --- a/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 +++ b/test/oldtuv/radXfer_cross_section/tint.cross_section.type.F90 @@ -78,7 +78,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) class(base_grid_t), pointer :: lambdaGrid type(string_t) :: Handle - write(*,*) Iam,'entering' !> Get model wavelength grids Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -161,8 +160,6 @@ subroutine initialize( this, config, gridWareHouse, ProfileWareHouse ) call die_msg( 400000008, msg ) endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -196,8 +193,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) class(base_profile_t), pointer :: mdlTemperature type(string_t) :: Handle - write(*,*) Iam,'entering' - Handle = 'Vertical Z' zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' @@ -228,8 +223,6 @@ function run( this, gridWareHouse, ProfileWareHouse ) result( cross_section ) cross_section = transpose( wrkCrossSection ) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -242,8 +235,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'tint cross section finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' - if( allocated(this%cross_section_parms) ) then do ndx = 1,size(this%cross_section_parms) associate( Xsection => this%cross_section_parms(ndx) ) @@ -261,8 +252,6 @@ subroutine finalize( this ) deallocate(this%cross_section_parms) endif - write(*,*) Iam,'exiting' - end subroutine finalize end module micm_radXfer_tint_cross_section_type diff --git a/test/oldtuv/radiator/aerosol.radiator.type.F90 b/test/oldtuv/radiator/aerosol.radiator.type.F90 index d26c5c0a..af7bf417 100644 --- a/test/oldtuv/radiator/aerosol.radiator.type.F90 +++ b/test/oldtuv/radiator/aerosol.radiator.type.F90 @@ -66,9 +66,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) class(base_grid_t), pointer :: zGrid, lambdaGrid class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) ' ' - write(*,*) Iam,'entering' - Handle = 'Vertical Z' ; zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -76,7 +73,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) !> Get radiator "Handle" !----------------------------------------------------------------------------- call radiator_config%get( 'Handle', this%handle_, Iam ) - write(*,*) Iam // 'handle = ',this%handle_%to_char() !> allocate radiator state variables allocate( this%state_%layer_OD_(zGrid%ncells_,lambdaGrid%ncells_) ) @@ -89,25 +85,14 @@ subroutine initialize( this, radiator_config, gridWareHouse ) nInputBins = size(input_OD) if( nInputBins > 1 ) then !> interpolate input OD to state variable - write(*,*) Iam // 'OD from config' - write(*,*) Iam // 'size input_OD = ',nInputBins - write(*,*) Iam // 'input_OD' - write(*,'(1p10g15.7)') input_OD call diagout( 'rawOD.new',input_OD ) input_OD(:nInputBins-1) = .5_dk*(input_OD(:nInputBins-1)+input_OD(2:)) - write(*,'(1p10g15.7)') input_OD(:nInputBins-1) call diagout( 'inpaerOD.new',input_OD(:nInputBins-1) ) allocate( interp3_t :: theInterpolator ) input_zgrid = (/ (real(k,dk),k=0,nInputBins-1) /) - write(*,*) Iam // 'input zgrid' - write(*,'(1p10g15.7)') input_zgrid rad_OD = theInterpolator%interpolate( zGrid%edge_, input_zgrid,input_OD, 1 ) call diagout( 'cz.aer.new',rad_OD ) - write(*,*) 'size interpolated_OD = ',size(rad_OD) - write(*,*) 'size interpolated_OD = ',sizeof(rad_OD) - write(*,*) Iam // 'interpolated OD' - write(*,'(1p10g15.7)') rad_OD do binNdx = 1,lambdaGrid%ncells_ this%state_%layer_OD_(:,binNdx) = rad_OD enddo @@ -128,9 +113,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) do binNdx = 2,lambdaGrid%ncells_ this%state_%layer_SSA_(:,binNdx) = this%state_%layer_SSA_(:,1) enddo - write(*,*) Iam // 'SSA from config' - write(*,*) Iam // 'size SSA = ',size(input_SSA) - write(*,*) input_SSA endif call radiator_config%get( "Asymmetry factor", Aerosol_config, Iam ) @@ -146,15 +128,10 @@ subroutine initialize( this, radiator_config, gridWareHouse ) do binNdx = 2,lambdaGrid%ncells_ this%state_%layer_G_(:,binNdx) = this%state_%layer_G_(:,1) enddo - write(*,*) Iam // 'G from config' - write(*,*) Iam // 'size G = ',size(input_G) - write(*,*) input_G endif call radiator_config%get( "550 optical depth", tau550, Iam, default=0._dk ) call radiator_config%get( "Alpha", alpha, Iam, default=1._dk ) - write(*,*) Iam // 'tau550, alpha from config' - write(*,*) tau550, alpha if( tau550 > 0.235_dk ) then coldens = max( sum( this%state_%layer_OD_(:,1) ),pzero ) @@ -176,26 +153,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) endwhere enddo - write(*,*) Iam // 'layer OD @ lambda = ',lambdaGrid%mid_(1) - write(*,'(1p10g15.7)') this%state_%layer_OD_(:,1) - write(*,*) Iam // 'layer OD @ lambda = ',lambdaGrid%mid_(lambdaGrid%ncells_) - write(*,'(1p10g15.7)') this%state_%layer_OD_(:,lambdaGrid%ncells_) - write(*,*) ' ' - write(*,*) Iam // 'layer SSA @ lambda = ',lambdaGrid%mid_(1) - write(*,'(1p10g15.7)') this%state_%layer_SSA_(:,1) - write(*,*) Iam // 'layer SSA @ lambda = ',lambdaGrid%mid_(lambdaGrid%ncells_) - write(*,'(1p10g15.7)') this%state_%layer_SSA_(:,lambdaGrid%ncells_) - write(*,*) ' ' - write(*,*) Iam // 'layer G @ lambda = ',lambdaGrid%mid_(1) - write(*,'(1p10g15.7)') this%state_%layer_G_(:,1) - write(*,*) Iam // 'layer G @ lambda = ',lambdaGrid%mid_(lambdaGrid%ncells_) - write(*,'(1p10g15.7)') this%state_%layer_G_(:,lambdaGrid%ncells_) - - write(*,*) ' ' - write(*,*) Iam,'exiting' - -! stop 'Debugging' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -228,25 +185,17 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH class(base_grid_t), pointer :: zGrid class(base_grid_t), pointer :: lambdaGrid - write(*,*) ' ' - write(*,*) Iam,'entering' - - write(*,*) Iam // 'handle = ',this%handle_%to_char() !----------------------------------------------------------------------------- !> get specific grids and profiles !----------------------------------------------------------------------------- Handle = 'Vertical Z' ; zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) - write(*,*) Iam // 'nlyr,nbins = ',zGrid%ncells_,lambdaGrid%ncells_ !> check that radiator state is allocated if( .not. allocated( this%state_%layer_OD_ ) ) then call die_msg( 2222222,"In radiator%upDateState radiator state not allocate" ) endif - write(*,*) ' ' - write(*,*) Iam,'exiting' - end subroutine upDateState end module micm_aerosol_radiator_type diff --git a/test/oldtuv/radiator/base.radiator.type.F90 b/test/oldtuv/radiator/base.radiator.type.F90 index 84d2051d..539fb7c9 100644 --- a/test/oldtuv/radiator/base.radiator.type.F90 +++ b/test/oldtuv/radiator/base.radiator.type.F90 @@ -49,9 +49,6 @@ subroutine initialize( this, radiator_config, gridWareHouse ) type(string_t) :: Handle class(base_grid_t), pointer :: zGrid, lambdaGrid - write(*,*) ' ' - write(*,*) Iam,'entering' - Handle = 'Vertical Z' ; zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) @@ -59,19 +56,11 @@ subroutine initialize( this, radiator_config, gridWareHouse ) !> Get radiator "Handle" !----------------------------------------------------------------------------- call radiator_config%get( 'Handle', this%handle_, Iam ) - write(*,*) Iam // 'handle = ',this%handle_%to_char() !> allocate radiator state_ variables allocate( this%state_%layer_OD_(zGrid%ncells_,lambdaGrid%ncells_) ) allocate( this%state_%layer_SSA_(zGrid%ncells_,lambdaGrid%ncells_) ) allocate( this%state_%layer_G_(zGrid%ncells_,lambdaGrid%ncells_) ) - write(*,*) Iam // 'state_%layer_OD_ is allocated = ',allocated(this%state_%layer_OD_) - write(*,*) Iam // 'state_%layer_SSA_ is allocated = ',allocated(this%state_%layer_SSA_) - write(*,*) Iam // 'state_%layer_G_ is allocated = ',allocated(this%state_%layer_G_) - write(*,*) Iam // 'state_%layer_OD_ is (',size(this%state_%layer_OD_,dim=1),' x ',size(this%state_%layer_OD_,dim=2),')' - - write(*,*) ' ' - write(*,*) Iam,'exiting' end subroutine initialize @@ -111,10 +100,6 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH class(base_profile_t), pointer :: radiatorProfile class(abs_cross_section_t), pointer :: radiatorCrossSection - write(*,*) ' ' - write(*,*) Iam,'entering' - - write(*,*) Iam // 'handle = ',this%handle_%to_char() !----------------------------------------------------------------------------- !> get specific grids and profiles !----------------------------------------------------------------------------- @@ -122,7 +107,6 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH zGrid => gridWareHouse%get_grid( Handle ) Handle = 'Photolysis, wavelength' lambdaGrid => gridWareHouse%get_grid( Handle ) - write(*,*) Iam // 'nlyr,nbins = ',zGrid%ncells_,lambdaGrid%ncells_ !> Note: uses radiator handle for Profile handle radiatorProfile => ProfileWareHouse%get_Profile( this%handle_ ) @@ -133,11 +117,7 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH !> check radiator state type allocation if( .not. allocated( this%state_%layer_OD_ ) ) then call die_msg( 2222222,"In radiator%upDateState radiator state not allocate" ) - else - write(*,*) Iam // 'radiator state is allocated' endif - write(*,*) Iam // 'size OD = ',size(this%state_%layer_OD_,dim=1),' x ', & - size(this%state_%layer_OD_,dim=2) !> set radiator state members CrossSection = radiatorCrossSection%calculate( gridWareHouse, ProfileWareHouse ) @@ -155,9 +135,6 @@ subroutine upDateState( this, gridWareHouse, ProfileWareHouse, radXferXsectWareH this%state_%layer_G_ = 0._dk endif - write(*,*) ' ' - write(*,*) Iam,'exiting' - end subroutine upDateState end module micm_base_radiator_type diff --git a/test/oldtuv/radiator/radiator_factory.F90 b/test/oldtuv/radiator/radiator_factory.F90 index 83df2c7b..c18c1a40 100644 --- a/test/oldtuv/radiator/radiator_factory.F90 +++ b/test/oldtuv/radiator/radiator_factory.F90 @@ -39,7 +39,6 @@ function radiator_builder( config, gridWareHouse ) result( new_radiator_t ) type(string_t) :: radiator_type character(len=*), parameter :: Iam = 'Radiator builder: ' - write(*,*) Iam,'entering' new_radiator_t => null() call config%get( 'radiator type', radiator_type, Iam ) @@ -53,7 +52,6 @@ function radiator_builder( config, gridWareHouse ) result( new_radiator_t ) end select call new_radiator_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' end function radiator_builder diff --git a/test/oldtuv/radiator/radiator_warehouse.F90 b/test/oldtuv/radiator/radiator_warehouse.F90 index ee8cc152..45c6743c 100644 --- a/test/oldtuv/radiator/radiator_warehouse.F90 +++ b/test/oldtuv/radiator/radiator_warehouse.F90 @@ -87,8 +87,6 @@ function constructor( config, gridWareHouse ) result( radiator_warehouse ) character(len=32) :: keychar type(string_t) :: keyString - write(*,*) Iam // 'entering' - call config%get( 'Radiators', radiator_config_set, Iam ) allocate( radiator_warehouse ) @@ -98,8 +96,6 @@ function constructor( config, gridWareHouse ) result( radiator_warehouse ) iter => radiator_config_set%get_iterator() do while( iter%next() ) keychar = radiator_config_set%key(iter) - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) keyString = keychar call radiator_config_set%get( iter, radiator_config, Iam ) call radiator_config%add( 'Handle', keyString, Iam ) @@ -113,15 +109,6 @@ function constructor( config, gridWareHouse ) result( radiator_warehouse ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' radiators'')') Iam,size(radiator_warehouse%radiators_) - write(*,*) 'radiator handles' - do ndx = 1,size(radiator_warehouse%handle_) - write(*,'(a)') radiator_warehouse%handle_(ndx)%to_char() - enddo - - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -144,9 +131,6 @@ function get_radiator_from_handle( this, radiator_handle ) result( radiator ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%handle_) if( radiator_handle .eq. this%handle_(ndx) ) then @@ -161,8 +145,6 @@ function get_radiator_from_handle( this, radiator_handle ) result( radiator ) call die_msg( 460768324, "Invalid radiator handle: '"// radiator_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_radiator_from_handle !> Get index of a specific radiator object @@ -183,9 +165,6 @@ function get_radiator_ndx_from_handle( this, radiator_handle ) result( Index ) character(len=*), parameter :: Iam = 'radiator warehouse get_radiator_ndx: ' logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do Index = 1,size(this%handle_) if( radiator_handle .eq. this%handle_(Index) ) then @@ -199,8 +178,6 @@ function get_radiator_ndx_from_handle( this, radiator_handle ) result( Index ) Index = -1 endif - write(*,*) Iam,'exiting' - end function get_radiator_ndx_from_handle !> Get copy of a radiator object using an iterator @@ -219,25 +196,10 @@ function get_radiator_from_iterator( this, iterator ) result( radiator ) character(len=*), parameter :: Iam = 'radiator warehouse get_radiator from iterator: ' integer(ik) :: ndx - write(*,*) ' ' - write(*,*) Iam,'entering' - ndx = iterator%id_ - write(*,*) Iam,'radiator handle = ',this%radiators_(ndx)%val_%handle_%to_char() radiator => this%radiators_(ndx)%val_ - write(*,*) Iam,'radiator diagnostics' - write(*,*) Iam,'radiator handle = ',radiator%handle_%to_char() - write(*,*) Iam,'radiator state OD is allocated = ',allocated(radiator%state_%layer_OD_) - write(*,*) Iam,'radiator state SSA is allocated = ',allocated(radiator%state_%layer_SSA_) - write(*,*) Iam,'radiator state G is allocated = ',allocated(radiator%state_%layer_G_) - - write(*,*) ' ' - write(*,*) Iam,'exiting' - -! stop 'debugging' - end function get_radiator_from_iterator !> Is a radiator in the warehouse? @@ -258,9 +220,6 @@ function in_warehouse( this, radiator_handle ) character(len=*), parameter :: Iam = 'radiator in warehouse: ' integer(ik) :: ndx - write(*,*) ' ' - write(*,*) Iam,'entering' - in_warehouse = .false._lk do ndx = 1,size(this%handle_) if( radiator_handle == this%handle_(ndx) ) then @@ -269,8 +228,6 @@ function in_warehouse( this, radiator_handle ) endif end do - write(*,*) Iam,'exiting' - end function in_warehouse !> Gets an interator for the radiator warehouse @@ -333,14 +290,10 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'radiator_warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%radiators_ ) ) then deallocate( this%radiators_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/radiator/radiator_warehouse.v0.F90 b/test/oldtuv/radiator/radiator_warehouse.v0.F90 index bf3df3d9..400477d6 100644 --- a/test/oldtuv/radiator/radiator_warehouse.v0.F90 +++ b/test/oldtuv/radiator/radiator_warehouse.v0.F90 @@ -62,8 +62,6 @@ function constructor( config ) result( radiator_warehouse ) character(len=32) :: keychar type(string_t) :: keyString - write(*,*) Iam // 'entering' - call config%get( 'Radiators', radiator_config_set, Iam ) iter => radiator_config_set%get_iterator() @@ -73,8 +71,6 @@ function constructor( config ) result( radiator_warehouse ) do while( iter%next() ) keychar = radiator_config_set%key(iter) - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) keyString = keychar call radiator_config_set%get( iter, radiator_config, Iam ) call radiator_config%add( 'Handle', keyString, Iam ) @@ -88,9 +84,6 @@ function constructor( config ) result( radiator_warehouse ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' radiators'')') Iam,size(radiator_warehouse%radiators_) - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -114,9 +107,6 @@ function get_radiator( this, radiator_handle ) result( radiator_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%handle_) if( radiator_handle .eq. this%handle_(ndx) ) then @@ -131,8 +121,6 @@ function get_radiator( this, radiator_handle ) result( radiator_ptr ) call die_msg( 460768324, "Invalid radiator handle: '"// radiator_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -146,14 +134,10 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'radiator_warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%radiators_ ) ) then deallocate( this%radiators_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/rdetfl.f b/test/oldtuv/rdetfl.f index 7ff2bad8..2217aa25 100644 --- a/test/oldtuv/rdetfl.f +++ b/test/oldtuv/rdetfl.f @@ -99,20 +99,6 @@ SUBROUTINE rdetfl(nw,wl,f) CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) CALL addpnt(x1,y1,kdata,n, 1.e+38,0.) - write(*,*) ' ' - write(*,*) 'Diagnostics for atlas3_1994_317_a' - write(*,*) 'read1: size model lambdaGrid = ',nw - write(*,*) 'read1: lambdaGrid' - write(*,'(1p10g15.7)') wl(:nw) - write(*,*) ' ' - write(*,*) 'read1: size inputGrid = ',n - write(*,*) 'read1: inputGrid' - write(*,'(1p10g15.7)') x1(:n) - write(*,*) ' ' - write(*,*) 'read1: size inputData = ',n - write(*,*) 'read1: inputData' - write(*,'(1p10g15.7)') y1(:n) - call diagout( 'atlas.inputGrid.old', x1(:n) ) call diagout( 'atlas.inputData.old', y1(:n) ) @@ -124,11 +110,6 @@ SUBROUTINE rdetfl(nw,wl,f) call diagout( 'atlas.interpolated.old', yg2(:nw-1) ) - write(*,*) ' ' - write(*,*) 'read1: size yg2 = ',size(yg2) - write(*,*) 'read1: interpolated Etfl' - write(*,'(1p10g15.7)') yg2(:nw-1) - fil = 'odat/DATAE1/SUN/neckel.flx' write(kout,*) fil OPEN(UNIT=kin,FILE=fil,STATUS='old') @@ -156,24 +137,7 @@ SUBROUTINE rdetfl(nw,wl,f) call diagout( 'neckel.inputGrid.old', x1(:n+1) ) call diagout( 'neckel.inputData.old', y1(:n+1) ) - write(*,*) ' ' - write(*,*) 'Diagnostics for neckel.flx' - write(*,*) 'read1: size model lambdaGrid = ',nw - write(*,*) 'read1: lambdaGrid' - write(*,'(1p10g15.7)') wl(:nw) - write(*,*) ' ' - write(*,*) 'read1: size inputGrid = ',n+1 - write(*,*) 'read1: inputGrid' - write(*,'(1p10g15.7)') x1(:n+1) - write(*,*) ' ' - write(*,*) 'read1: size inputData = ',n+1 - write(*,*) 'read1: inputData' - write(*,'(1p10g15.7)') y1(:n+1) call inter4(nw,wl,yg3,n+1,x1,y1,0) - write(*,*) ' ' - write(*,*) 'read1: size yg3 = ',size(yg3) - write(*,*) 'read1: interpolated Etfl' - write(*,'(1p10g15.7)') yg3(:nw-1) call diagout( 'neckel.interpolated.old', yg3(:nw-1) ) nhead = 8 @@ -309,20 +273,6 @@ SUBROUTINE read1(nw,wl,f) > lambda_hi(n)*(1.+deltax),0.) CALL addpnt(lambda_hi,irrad_hi,10000,n, 1.e38,0.) - write(*,*) ' ' - write(*,*) 'Diagnostics for susim_hi.flx' - write(*,*) 'read1: size model lambdaGrid = ',nw - write(*,*) 'read1: lambdaGrid' - write(*,'(1p10g15.7)') wl(:nw) - write(*,*) ' ' - write(*,*) 'read1: size inputGrid = ',n - write(*,*) 'read1: inputGrid' - write(*,'(1p10g15.7)') lambda_hi(:n) - write(*,*) ' ' - write(*,*) 'read1: size inputData = ',n - write(*,*) 'read1: inputData' - write(*,'(1p10g15.7)') irrad_hi(:n) - call diagout( 'susim.inputGrid.old', lambda_hi(:n) ) call diagout( 'susim.inputData.old', irrad_hi(:n) ) @@ -334,11 +284,6 @@ SUBROUTINE read1(nw,wl,f) call diagout( 'susim.interpolated.old', f(:nw-1) ) - write(*,*) ' ' - write(*,*) 'read1: size f = ',size(f) - write(*,*) 'read1: interpolated Etfl' - write(*,'(1p10g15.7)') f(:nw-1) - END SUBROUTINE read1 *=============================================================================* diff --git a/test/oldtuv/rdxs.f b/test/oldtuv/rdxs.f index 245053ea..2c33c89c 100644 --- a/test/oldtuv/rdxs.f +++ b/test/oldtuv/rdxs.f @@ -1261,8 +1261,6 @@ SUBROUTINE no2xs_jpl06a(nz,t,nw,wl, no2xs) CALL addpnt(x2,y2,kdata,n2, 1.e+38, 0.) CALL inter2(nw,wl,yg2,n2,x2,y2,ierr) - write(*,*) 'no2xs_jpl06a: n1,n2 = ',n1,n2 - Tadj = max( 220.,min( 294.,t ) ) Tfac = (Tadj - 220.)/74. DO iw = 1, nw-1 diff --git a/test/oldtuv/rtrans.f b/test/oldtuv/rtrans.f index 278fd45d..df7fda80 100644 --- a/test/oldtuv/rtrans.f +++ b/test/oldtuv/rtrans.f @@ -1618,7 +1618,6 @@ SUBROUTINE FLUXES( tausla, tauslau, REAL :: ANG1, ANG2, DIRINT, FACT, FDNTOT, FNET, PLSORC, ZINT c .. - IF( PRNT( 2 ) ) WRITE( *, 9000 ) c ** Zero DISORT output arrays U0C = 0. FLDIR = 0. @@ -1749,26 +1748,16 @@ SUBROUTINE FLUXES( tausla, tauslau, & ( UAVG( LU ) - PLSORC ) 70 CONTINUE - IF( PRNT( 2 ) ) WRITE( *, FMT = 9010 ) UTAU( LU ), LYU, - & RFLDIR( LU ), RFLDN( LU ), FDNTOT, FLUP( LU ), FNET, - & UAVG( LU ), PLSORC, DFDT( LU ) - ENDDO LEVEL_LOOP IF( PRNT( 3 ) ) THEN - WRITE( *, FMT = 9020 ) - DO LU = 1, NTAU - WRITE( *, FMT = 9030 ) UTAU( LU ) - DO IQ = 1, NN ANG1 = 180./ PI* ACOS( CMU( 2*NN - IQ + 1 ) ) ANG2 = 180./ PI* ACOS( CMU( IQ ) ) - WRITE( *, 9040 ) ANG1, CMU(2*NN-IQ+1), U0C(IQ,LU), - $ ANG2, CMU(IQ), U0C(IQ+NN,LU) ENDDO ENDDO @@ -1944,26 +1933,13 @@ SUBROUTINE PRAVIN( UMU, NUMU, UTAU, NTAU, U0U ) IF( NUMU.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ******* AZIMUTHALLY AVERAGED INTENSITIES ' // - & '(at user polar angles) ********' - LENFMT = 8 NPASS = 1 + (NUMU-1) / LENFMT - WRITE( *,'(/,A,/,A)') ' Optical Polar Angle Cosines', - & ' Depth' - DO 20 NP = 1, NPASS IUMIN = 1 + LENFMT * ( NP - 1 ) IUMAX = MIN( LENFMT*NP, NUMU ) - WRITE( *,'(/,10X,8F14.5)') ( UMU(IU), IU = IUMIN, IUMAX ) - - DO 10 LU = 1, NTAU - WRITE( *, '(0P,F10.4,1P,8E14.4)' ) UTAU( LU ), - & ( U0U( IU,LU ), IU = IUMIN, IUMAX ) - 10 CONTINUE 20 CONTINUE @@ -2000,110 +1976,12 @@ SUBROUTINE PRTINP( NLYR, DTAUC, DTAUCP, SSALB, PMOM, c .. - WRITE( *, '(/,A,I4,A,I4)' ) ' No. streams =', NSTR, - & ' No. computational layers =', NLYR - - IF( IBCND /= 1 ) WRITE( *, '(I4,A,10F10.4,/,(26X,10F10.4))' ) - & NTAU,' User optical depths :', ( UTAU(LU), LU = 1, NTAU ) - - IF( .NOT. ONLYFL ) WRITE( *, '(I4,A,10F9.5,/,(31X,10F9.5))' ) - & NUMU,' User polar angle cosines :',( UMU(IU), IU = 1, NUMU ) - - IF( .NOT. ONLYFL .AND. IBCND /= 1 ) - & WRITE( *, '(I4,A,10F9.2,/,(28X,10F9.2))' ) - & NPHI,' User azimuthal angles :',( PHI(J), J = 1, NPHI ) - - IF( .NOT. PLANK .OR. IBCND == 1 ) - & WRITE( *, '(A)' ) ' No thermal emission' - - - WRITE( *, '(A,I2)' ) ' Boundary condition flag: IBCND =', IBCND - - IF( IBCND == 0 ) THEN - - WRITE( *, '(A,1P,E11.3,A,0P,F8.5,A,F7.2,/,A,1P,E11.3)' ) - & ' Incident beam with intensity =', FBEAM, - & ' and polar angle cosine = ', UMU0, - & ' and azimuth angle =', PHI0, - & ' plus isotropic incident intensity =', FISOT - - IF( LAMBER ) WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - - IF( .NOT. LAMBER ) WRITE( *, '(A,/,(10X,10F9.5))' ) - & ' Legendre coeffs of bottom bidirectional reflectivity :', - & ( HL( K ), K = 0, NSTR ) - - ELSE IF( IBCND == 1 ) THEN - - WRITE(*,'(A)') ' Isotropic illumination from top and bottom' - WRITE( *, '(A,0P,F8.4)' ) - & ' Bottom albedo (Lambertian) =', ALBEDO - END IF - - - IF( DELTAM ) WRITE( *, '(A)' ) ' Uses delta-M method' - IF( .NOT.DELTAM ) WRITE( *, '(A)' ) ' Does not use delta-M method' - - - IF( IBCND == 1 ) THEN - - WRITE( *, '(A)' ) ' Calculate albedo and transmissivity of'// - & ' medium vs. incident beam angle' - - ELSE IF( ONLYFL ) THEN - - WRITE( *, '(A)' ) - & ' Calculate fluxes and azim-averaged intensities only' - - ELSE - - WRITE( *, '(A)' ) ' Calculate fluxes and intensities' - - END IF - - - WRITE( *, '(A,1P,E11.2)' ) - & ' Relative convergence criterion for azimuth series =', - & ACCUR - - IF( LYRCUT ) WRITE( *, '(A)' ) - & ' Sets radiation = 0 below absorption optical depth 10' - - -c ** Print layer variables - IF( PLANK ) WRITE( *, FMT = 9180 ) - IF( .NOT. PLANK ) WRITE( *, FMT = 9190 ) - YESSCT = rZERO DO LC = 1, NLYR YESSCT = YESSCT + SSALB( LC ) - - IF( PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4,F14.3)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM(1,LC) - - IF( .NOT.PLANK ) - & WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4)') - & LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ), - & DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM( 1,LC ) ENDDO - - IF( PRTMOM .AND. YESSCT > rZERO ) THEN - - WRITE( *, '(/,A)' ) ' Layer Phase Function Moments' - - DO LC = 1, NLYR - IF( SSALB( LC ).GT.rZERO ) - & WRITE( *, '(I6,10F11.6,/,(6X,10F11.6))' ) - & LC, ( PMOM( K, LC ), K = 0, NSTR ) - ENDDO - - END IF - c ** (Read every other line in these formats) 9180 FORMAT( /, 37X, '<------------- Delta-M --------------->', /, @@ -2156,17 +2034,9 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) IF( NPHI.LT.1 ) RETURN - WRITE( *, '(//,A)' ) - & ' ********* I N T E N S I T I E S *********' - LENFMT = 10 NPASS = 1 + (NPHI-1) / LENFMT - WRITE( *, '(/,A,/,A,/,A)' ) - & ' Polar Azimuth angles (degrees)', - & ' Optical Angle', - & ' Depth Cosine' - DO 30 LU = 1, NTAU DO 20 NP = 1, NPASS @@ -2174,18 +2044,6 @@ SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI ) JMIN = 1 + LENFMT * ( NP - 1 ) JMAX = MIN( LENFMT*NP, NPHI ) - WRITE( *, '(/,18X,10F11.2)' ) ( PHI(J), J = JMIN, JMAX ) - - IF( NP.EQ.1 ) WRITE( *, '(F10.4,F8.4,1P,10E11.3)' ) - & UTAU(LU), UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - IF( NP.GT.1 ) WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU(1), (UU(1, LU, J), J = JMIN, JMAX) - - DO 10 IU = 2, NUMU - WRITE( *, '(10X,F8.4,1P,10E11.3)' ) - & UMU( IU ), ( UU( IU, LU, J ), J = JMIN, JMAX ) - 10 CONTINUE - 20 CONTINUE 30 CONTINUE @@ -2966,9 +2824,6 @@ SUBROUTINE SOLEIG( AMB, APB, ARRAY, CMU, CWT, GL, MAZIM, IF( IER.GT.0 ) THEN - WRITE( *, FMT = '(//,A,I4,A)' ) ' ASYMTX--eigenvalue no. ', - & IER, ' didnt converge. Lower-numbered eigenvalues wrong.' - CALL ERRMSG( 'ASYMTX--convergence problems',.True.) END IF @@ -3738,15 +3593,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** The upward iteration did not converge.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -3754,15 +3600,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, *bm if downward iteration did not converge, we are done *bm (the result of the upward iteration will be used) IF (NODN) THEN - IF (DEBUG) THEN - write (*,*) '! *** The downward iteration did not converge.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 998 ENDIF @@ -3780,30 +3617,10 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using downward.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ELSE - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using upward.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. goto 998 ENDIF @@ -4227,7 +4044,6 @@ SUBROUTINE ErrMsg( MESSAG, FATAL ) IF ( NumMsg.LE.MaxMsg ) THEN WRITE ( *, '(/,2A,/)' ) ' ******* WARNING >>>>>> ', MESSAG ELSE - WRITE ( *,99 ) MsgLim = .True. ENDIF diff --git a/test/oldtuv/setaer.f b/test/oldtuv/setaer.f index a4fb1a11..1503a749 100644 --- a/test/oldtuv/setaer.f +++ b/test/oldtuv/setaer.f @@ -90,7 +90,6 @@ SUBROUTINE setaer( * Altitudes corresponding to Elterman profile, from bottom to top: - WRITE(kout,*)'aerosols: Elterman (1968) continental profile' nd = 51 zd = (/ (REAL(i-1),i=1,kdata) /) @@ -105,9 +104,6 @@ SUBROUTINE setaer( call diagout( 'rawOD.old',aer ) call diagout( 'inpaerOD.old',cd ) - write(*,*) 'setaer: hardwired OD' - write(*,'(1p10g15.7)') aer - write(*,'(1p10g15.7)') cd *********** end data input. @@ -164,7 +160,6 @@ SUBROUTINE setaer( *! overwrite for pbl: IF(ipbl > 0) THEN - write (*,*) 'pbl aerosols, aod330 = ', aod330 * create wavelength-dependent optical depth and single scattering albedo: DO iw = 1, nbins aodw(iw) = aod330*(wc(iw)/330.)**(-1.0) diff --git a/test/oldtuv/seth2o.f b/test/oldtuv/seth2o.f index ee5ebfa2..3074b73b 100644 --- a/test/oldtuv/seth2o.f +++ b/test/oldtuv/seth2o.f @@ -159,8 +159,6 @@ SUBROUTINE inter1(nz,z,cz, n,x,y) *! overwrite for specified pbl height IF(ipbl .GT. 0) THEN - write(*,*) 'pbl H2O = ', xpbl, ' ppb' - DO i = 1, nz-1 IF (i .LE. ipbl) THEN cz(i) = xpbl*1.E-9 * dcol(i) diff --git a/test/oldtuv/setno2.f b/test/oldtuv/setno2.f index 1a217061..25ba7799 100644 --- a/test/oldtuv/setno2.f +++ b/test/oldtuv/setno2.f @@ -126,7 +126,6 @@ FUNCTION setno2(ipbl, zpbl, xpbl, *! overwrite for specified pbl height IF(ipbl > 0) THEN - write(*,*) 'pbl NO2 = ', xpbl, ' ppb' DO i = 1, nz-1 IF (i .LE. ipbl) THEN cz(i) = xpbl * ppb * dcol(i) diff --git a/test/oldtuv/setsnw.f b/test/oldtuv/setsnw.f index e1ca9115..ccc4b988 100644 --- a/test/oldtuv/setsnw.f +++ b/test/oldtuv/setsnw.f @@ -133,18 +133,6 @@ SUBROUTINE setsnw(z,wl,dtsnw,omsnw,gsnw) cd(is) = rsct(is) + rabs(is) omd(is)= rsct(is) / cd(is) - if(iw == 1)then - print*,"Snowpack: is =",is,"; zs =",zs(is) - PRINT*," ksct =", ksct(is) - PRINT*," density =",snwdens(is) - PRINT*," csoot =",csoot(is) - PRINT*, 'cd = ',cd(is),' omd = ',omd(is),' gd = ',gd - WRITE(kout,*)'snwdens = ',snwdens,' g/cm3' - WRITE(kout,*)'ksct_snow = ',ksct(is),' m2.kg-1' - WRITE(kout,*)'soot = ',csoot(is),' ng/g' - WRITE(kout,*)'cd = ',cd(is),'omd = ',omd(is),'gd = ',gd - endif - * compute integrals and averages over snow layers: * for g and omega, use averages weighted by optical depth womd(is) = omd(is) * cd(is) diff --git a/test/oldtuv/setso2.f b/test/oldtuv/setso2.f index d3b593c2..2c6c2a33 100644 --- a/test/oldtuv/setso2.f +++ b/test/oldtuv/setso2.f @@ -123,7 +123,6 @@ FUNCTION setso2(ipbl, zpbl, xpbl, *! overwrite for specified pbl height, set concentration here IF(ipbl > 0) THEN - write(*,*) 'pbl SO2 = ', xpbl, ' ppb' DO i = 1, nz-1 IF (i <= ipbl) THEN cz(i) = xpbl * ppb * dcol(i) diff --git a/test/oldtuv/solvec.f b/test/oldtuv/solvec.f index 544192a2..2176539e 100644 --- a/test/oldtuv/solvec.f +++ b/test/oldtuv/solvec.f @@ -198,11 +198,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = OPRIM - IF (DEBUG) THEN - write (*,*) '! *** Neither upward nor downward iteration' - write (*,*) '! *** converged; using original result.' - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -216,15 +211,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** The upward iteration did not converge.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ENDIF @@ -232,15 +218,6 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, *bm if downward iteration did not converge, we are done *bm (the result of the upward iteration will be used) IF (NODN) THEN - IF (DEBUG) THEN - write (*,*) '! *** The downward iteration did not converge.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 998 ENDIF @@ -258,30 +235,10 @@ SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, SSA = DSSA - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using downward.' - write (*,*) '! *** Had to iterate ', DAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. GOTO 777 ELSE - IF (DEBUG) THEN - write (*,*) '! *** Both iterations converged;', - $ ' using upward.' - write (*,*) '! *** Had to iterate ', UAGAIN, - $ ' times in layer LC =', LC,';' - write (*,*) '! *** changed SSA from ', - $ OPRIM, ' to ', SSA,',' - write (*,*) '! *** by a factor of ', SSA/OPRIM - ENDIF - DONE = .TRUE. goto 998 ENDIF diff --git a/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 index 63f42040..db776978 100644 --- a/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/UV_Index.spectral_wght.type.F90 @@ -41,12 +41,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_index calculate: ' - write(*,*) Iam,'entering' - spectral_wght = 40._musica_dk*fery( this%mdl_lambda_center ) - write(*,*) Iam,'exiting' - end function run FUNCTION fery(w) diff --git a/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 index 0e85652f..ff1dd9ec 100644 --- a/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/abstract.spectral_wght.type.F90 @@ -93,8 +93,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) logical :: found character(len=:), allocatable :: number - write(*,*) Iam,'entering' - !> add endpoints to data arrays; first the lower bound nRows = size(data_lambda) lowerLambda = data_lambda(1) ; upperLambda = data_lambda(nRows) @@ -124,8 +122,6 @@ subroutine addpnts( this, config, data_lambda, data_parameter ) call addpnt(x=data_lambda,y=data_parameter,xnew=(rONE+deltax)*upperLambda,ynew=addpnt_val_upper) call addpnt(x=data_lambda,y=data_parameter,xnew=large,ynew=addpnt_val_upper) - write(*,*) Iam,'exiting' - end subroutine addpnts end module micm_abs_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 index 71ed480c..1f936d79 100644 --- a/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/base.spectral_wght.type.F90 @@ -69,7 +69,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) type(netcdf_t), allocatable :: netcdf_obj type(string_t), allocatable :: netcdfFiles(:) - write(*,*) Iam,'entering' !> set model wavelength array this%mdl_lambda_edge = mdlLambdaEdge nmdlLambda = size( this%mdl_lambda_edge ) @@ -115,8 +114,6 @@ subroutine initialize( this, config, mdlLambdaEdge ) enddo file_loop endif has_netcdf_file - write(*,*) Iam,'exiting' - end subroutine initialize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -135,12 +132,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'base spectral wght calculate: ' - write(*,*) Iam,'entering' - spectral_wght = this%spectral_wght(1)%array(:,1) - write(*,*) Iam,'exiting' - end function run !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -153,7 +146,6 @@ subroutine finalize( this ) character(len=*), parameter :: Iam = 'base spectral wght finalize: ' integer(musica_ik) :: ndx - write(*,*) Iam,'entering' if( allocated(this%spectral_wght) ) then do ndx = 1,size(this%spectral_wght) if( allocated(this%spectral_wght(ndx)%array ) ) then @@ -171,7 +163,6 @@ subroutine finalize( this ) if( allocated(this%mdl_lambda_center) ) then deallocate(this%mdl_lambda_center) endif - write(*,*) Iam,'exiting' end subroutine finalize diff --git a/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 index c0630262..1b384394 100644 --- a/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/eppley_uv_photometer.spectral_wght.type.F90 @@ -42,15 +42,11 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'eppley_uv_photometer spectral wght calculate: ' - write(*,*) Iam,'entering' - nLambda = size(this%mdl_lambda_edge) spectral_wght = this%spectral_wght(1)%array(:,1) accum = sum( spectral_wght*(this%mdl_lambda_edge(2:nLambda) - this%mdl_lambda_edge(1:nLambda-1)) ) spectral_wght = 90._musica_dk*spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_eppley_uv_photometer_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 index 3f5c6cdd..5b27b54c 100644 --- a/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/exponential_decay.spectral_wght.type.F90 @@ -41,12 +41,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'exponential_decay calculate: ' - write(*,*) Iam,'entering' - spectral_wght = 10._musica_dk**((300._musica_dk - this%mdl_lambda_center)/14._musica_dk) - write(*,*) Iam,'exiting' - end function run end module micm_exponential_decay_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 index 6f4bbef3..73e22d02 100644 --- a/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_305_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_305_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 305._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_305_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 index 9e34d6c2..2fbca2b1 100644 --- a/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_320_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_320_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 320._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_320_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 index b18bd3be..3fe03d3e 100644 --- a/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_340_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_340_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 340._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_340_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 index b7e23bbb..0d13fccb 100644 --- a/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/gaussian_380_nm_10_nm_FWHM.spectral_wght.type.F90 @@ -41,14 +41,10 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: accum character(len=*), parameter :: Iam = 'gaussian_380_nm_10_nm_FWHM calculate: ' - write(*,*) Iam,'entering' - spectral_wght = exp( -(log(2._musica_dk)*.04_musica_dk*(this%mdl_lambda_center(:) - 380._musica_dk)**2) ) accum = sum( spectral_wght ) spectral_wght = spectral_wght/accum - write(*,*) Iam,'exiting' - end function run end module micm_gaussian_380_nm_10_nm_FWHM_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 index 29327226..511bfe92 100644 --- a/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/par_400-700nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'par_400_700nm calculate: ' - write(*,*) Iam,'entering' - where( 400._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 700._musica_dk ) spectral_wght = 8.36e-3_musica_dk*this%mdl_lambda_center elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_par_400_700nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 index dee38747..457130d8 100644 --- a/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/phytoplankton_boucher.spectral_wght.type.F90 @@ -44,16 +44,12 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: c = 7.67e-4_musica_dk character(len=*), parameter :: Iam = 'phytoplankton_boucher calculate: ' - write(*,*) Iam,'entering' - where( this%mdl_lambda_center > 290._musica_dk .and. this%mdl_lambda_center < 400._musica_dk ) spectral_wght = em + exp( a + this%mdl_lambda_center*(b + this%mdl_lambda_center*c) ) elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_phytoplankton_boucher_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 index 6ae17ada..07d1d47f 100644 --- a/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/plant_damage.spectral_wght.type.F90 @@ -44,15 +44,11 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: a3 = -1.13118e-5_musica_dk character(len=*), parameter :: Iam = 'plant_damage calculate: ' - write(*,*) Iam,'entering' - spectral_wght = a0 + this%mdl_lambda_center*(a1 + this%mdl_lambda_center*(a2 + this%mdl_lambda_center*a3)) where( spectral_wght < 0.0_musica_dk .or. this%mdl_lambda_center > 313._musica_dk ) spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_plant_damage_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 index 1c4cbc49..97fa40d3 100644 --- a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell.spectral_wght.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: w2 = 390._musica_dk character(len=*), parameter :: Iam = 'plant_damage_flint_caldwell calculate: ' - write(*,*) Iam,'entering' - spectral_wght = EXP( a0*EXP(-EXP(a1*(this%mdl_lambda_center - w1)/1.15_musica_dk)) & + ((w2 - this%mdl_lambda_center)/121.7557_musica_dk - 4.183832_musica_dk) ) spectral_wght = spectral_wght * this%mdl_lambda_center / 300._musica_dk @@ -53,8 +51,6 @@ function run( this, environment ) result( spectral_wght ) spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_plant_damage_flint_caldwell_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 index 4eb857c6..eb986c74 100644 --- a/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/plant_damage_flint_caldwell_ext.spectral_wght.type.F90 @@ -44,8 +44,6 @@ function run( this, environment ) result( spectral_wght ) real(musica_dk), parameter :: w2 = 390._musica_dk character(len=*), parameter :: Iam = 'plant_damage_flint_caldwell_ext calculate: ' - write(*,*) Iam,'entering' - spectral_wght = EXP( a0*EXP(-EXP(a1*(this%mdl_lambda_center - w1)/1.15_musica_dk)) & + ((w2 - this%mdl_lambda_center)/121.7557_musica_dk - 4.183832_musica_dk) ) spectral_wght = spectral_wght * this%mdl_lambda_center / 300._musica_dk @@ -53,8 +51,6 @@ function run( this, environment ) result( spectral_wght ) spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_plant_damage_flint_caldwell_ext_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 index 4368cc38..127efe21 100644 --- a/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/scup_mice.spectral_wght.type.F90 @@ -42,13 +42,9 @@ function run( this, environment ) result( spectral_wght ) real(kind=musica_dk) :: factor(1) character(len=*), parameter :: Iam = 'scup_mice calculate: ' - write(*,*) Iam,'entering' - factor = 1._musica_dk/sw_futr( (/300._musica_dk/) ) spectral_wght = sw_futr( this%mdl_lambda_center ) * factor(1) - write(*,*) Iam,'exiting' - end function run FUNCTION sw_futr(w) diff --git a/test/oldtuv/spectral_wght/spectral_wght_factory.F90 b/test/oldtuv/spectral_wght/spectral_wght_factory.F90 index 52622bfb..113f88a0 100644 --- a/test/oldtuv/spectral_wght/spectral_wght_factory.F90 +++ b/test/oldtuv/spectral_wght/spectral_wght_factory.F90 @@ -53,7 +53,6 @@ function spectral_wght_builder( config, mdlLambdaEdge ) result( new_spectral_wgh type(string_t) :: spectral_wght_type character(len=*), parameter :: Iam = 'spectral wght builder: ' - write(*,*) Iam,'entering' new_spectral_wght_t => null() call config%get( 'spectral wght type', spectral_wght_type, Iam ) @@ -101,7 +100,6 @@ function spectral_wght_builder( config, mdlLambdaEdge ) result( new_spectral_wgh spectral_wght_type%to_char()//"'" ) end select call new_spectral_wght_t%initialize( config, mdlLambdaEdge ) - write(*,*) Iam,'exiting' end function spectral_wght_builder diff --git a/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 b/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 index a02c90c4..5242fada 100644 --- a/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 +++ b/test/oldtuv/spectral_wght/spectral_wght_warehouse.F90 @@ -85,8 +85,6 @@ function constructor( config,mdlLambdaEdge ) result( spectral_wght_warehouse_obj do while( iter%next() ) keychar = spectral_weight_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) new_obj%spectral_wght_key = [new_obj%spectral_wght_key,aswkey] call spectral_weight_set%get( iter, spectrum_config, Iam ) !----------------------------------------------------------------------------- @@ -100,8 +98,6 @@ function constructor( config,mdlLambdaEdge ) result( spectral_wght_warehouse_obj deallocate( iter ) nSize = size(new_obj%spectral_wght_objs_) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' spectral wghts'')') Iam,nSize !----------------------------------------------------------------------------- !> setup spectral weight arrays @@ -130,9 +126,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) real(musica_dk), allocatable :: a_spectral_wght(:) real(musica_dk), allocatable :: spectral_wght_tray(:) - write(*,*) ' ' - write(*,*) Iam,'entering' - allocate(spectral_wght_tray(0)) do ndx = 1, size(this%spectral_wght_objs_) associate( calc_ftn => this%spectral_wght_objs_(ndx)%val_ ) @@ -144,11 +137,6 @@ subroutine update_for_new_environmental_state( this, environment, nwave ) this%spectral_wght_values_ = reshape( spectral_wght_tray, & (/nwave,size(this%spectral_wght_objs_) /) ) - write(*,*) Iam,'size of spectral weight values = ',& - size(this%spectral_wght_values_,dim=1), size(this%spectral_wght_values_,dim=2) - - write(*,*) Iam,'exiting' - end subroutine update_for_new_environmental_state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -162,8 +150,6 @@ subroutine finalize( this ) integer(kind=musica_ik) :: ndx character(len=*), parameter :: Iam = 'spectral_wght_warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%spectral_wght_values_ ) ) then deallocate( this%spectral_wght_values_ ) endif @@ -180,8 +166,6 @@ subroutine finalize( this ) deallocate( this%spectral_wght_key ) end if - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 index 1a9ce652..6c00d574 100644 --- a/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/standard_human_erythema.spectral_wght.type.F90 @@ -41,12 +41,8 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'standard_human_erythema calculate: ' - write(*,*) Iam,'entering' - spectral_wght = fery( this%mdl_lambda_center ) - write(*,*) Iam,'exiting' - end function run FUNCTION fery(w) diff --git a/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 index 715b56d8..7e2d43a7 100644 --- a/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/uv-a_315_400_nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_a_315_400_nm calculate: ' - write(*,*) Iam,'entering' - where( 315._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 400._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_uv_a_315_400_nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 index 8032617b..6d312e78 100644 --- a/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/uv-b_280_315_nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_b_280_315_nm calculate: ' - write(*,*) Iam,'entering' - where( 280._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 315._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_uv_b_280_315_nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 index 7b72bd03..d0a861e5 100644 --- a/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/uv-b_280_320_nm.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'uv_b_280_320_nm calculate: ' - write(*,*) Iam,'entering' - where( 280._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 320._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_uv_b_280_320_nm_spectral_wght_type diff --git a/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 b/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 index 16ebc04e..6baf9dc8 100644 --- a/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 +++ b/test/oldtuv/spectral_wght/visplus.spectral_wght.type.F90 @@ -41,16 +41,12 @@ function run( this, environment ) result( spectral_wght ) character(len=*), parameter :: Iam = 'visplus calculate: ' - write(*,*) Iam,'entering' - where( 400._musica_dk < this%mdl_lambda_center(:) .and. this%mdl_lambda_center(:) < 700._musica_dk ) spectral_wght = 1.0_musica_dk elsewhere spectral_wght = 0.0_musica_dk endwhere - write(*,*) Iam,'exiting' - end function run end module micm_visplus_spectral_wght_type diff --git a/test/oldtuv/swchem.f b/test/oldtuv/swchem.f index 35c9c944..c0215a8a 100644 --- a/test/oldtuv/swchem.f +++ b/test/oldtuv/swchem.f @@ -386,7 +386,6 @@ SUBROUTINE swchem(nw,wl,nz,tlev,airden, **************************************************************** IF (j .GT. kj) STOP '1002' - write(*,'(''swchem: Set '',i3,'' photorates'')') j END SUBROUTINE swchem diff --git a/test/oldtuv/tuv.f b/test/oldtuv/tuv.f index 03f6417a..7c93c45f 100644 --- a/test/oldtuv/tuv.f +++ b/test/oldtuv/tuv.f @@ -309,18 +309,15 @@ PROGRAM tuv command_tokens(1) = command_tokens(1)%to_upper() select case( command_tokens(1)%to_char() ) case( 'RADXFER_CONFIG_FILESPEC' ) - write(*,*) 'Processing radXfer json config file' radXfer_config_filespec = command_tokens(2)%to_char() CALL radXfer_config%from_file( radXfer_config_filespec ) Obj_radXfer_xsects = .true. case( 'PHOTO_RATE_CONFIG_FILESPEC' ) - write(*,*) 'Processing photo_rate json config file' photo_rate_config_filespec = command_tokens(2)%to_char() CALL $ photo_rate_config%from_file( photo_rate_config_filespec ) Obj_photo_rates = .true. case( 'SPECTRAL_WGHT_CONFIG_FILESPEC' ) - write(*,*) 'Processing spectral_wght json config file' spectral_wght_config_filespec = command_tokens(2)%to_char() CALL $ spectral_wght_config%from_file( @@ -343,13 +340,6 @@ PROGRAM tuv end select enddo - write(*,*) - $ 'TUV: uses xsect objects in radXfer = ',Obj_radXfer_xsects - write(*,*) - $ 'TUV: uses photo_rate objects = ',Obj_photo_rates - write(*,*) - $ 'TUV: uses spectral wght objects = ',Obj_spectral_wghts - * re-entry point 1000 CONTINUE @@ -493,15 +483,6 @@ PROGRAM tuv * nmj: number of j-values that will be reported. Selections must be * made interactively, or by editing input file. - IF(nstr < 2) THEN - WRITE(kout,*) 'Delta-Eddington 2-stream radiative transfer' - ELSE - WRITE(kout,*) 'Discrete ordinates ', - $ nstr, '-stream radiative transfer' - ENDIF - - WRITE(*,*) 'calculating....' - * ___ SECTION 2: SET GRIDS _________________________________________________ * altitudes (creates altitude grid, locates index for selected output, izout) @@ -578,7 +559,6 @@ PROGRAM tuv ENDDO ipbl = iz - 1 - write(*,*) 'top of PBL index, height (km) ', ipbl, z(ipbl) * specify pbl concetrations, in parts per billion @@ -828,10 +808,6 @@ PROGRAM tuv wdosei = rZERO dose(1:ks) = rZERO - write(*,*) 'Date, Lat, Lon, Min_SZA' - write(*,222) iyear,imonth,iday,lat,lon,sznoon - 222 format(i4,'/',i2,'/',i2,3(1x,F7.3)) - * Initialize lymana-alpha, schumann-runge bands call init_la_srb(wl) @@ -904,7 +880,6 @@ PROGRAM tuv zen = sza(it) - WRITE(*,200) it, zen, esfact(it) WRITE(kout,200) it, zen, esfact(it) 200 FORMAT('step = ', I4,' sza = ', F9.3, $ ' Earth-sun factor = ', F10.7) @@ -958,20 +933,6 @@ PROGRAM tuv if( .not. do_clouds ) then omcld = rZERO ; omsnw = rZERO endif - if( all( dtrl == 0. ) ) write(*,*) 'TUV: dtrl = 0' - if( all( dto3 == 0. ) ) write(*,*) 'TUV: dto3 = 0' - if( all( dto2 == 0. ) ) write(*,*) 'TUV: dto2 = 0' - if( all( dtso2 == 0. ) ) write(*,*) 'TUV: dtso2 = 0' - if( all( dtno2 == 0. ) ) write(*,*) 'TUV: dtno2 = 0' - if( all( dtcld == 0. ) ) write(*,*) 'TUV: dtcld = 0' - if( all( omcld == 0. ) ) write(*,*) 'TUV: omcld = 0' - if( all( gcld == 0. ) ) write(*,*) 'TUV: gcld = 0' - if( all( dtaer == 0. ) ) write(*,*) 'TUV: dtaer = 0' - if( all( omaer == 0. ) ) write(*,*) 'TUV: omaer = 0' - if( all( gaer == 0. ) ) write(*,*) 'TUV: gaer = 0' - if( all( dtsnw == 0. ) ) write(*,*) 'TUV: dtsnw = 0' - if( all( omsnw == 0. ) ) write(*,*) 'TUV: omsnw = 0' - if( all( gsnw == 0. ) ) write(*,*) 'TUV: gsnw = 0' * ____ SECTION 8: WAVELENGTH LOOP ______________________________________ diff --git a/test/oldtuv/util/la_srb.type.F90 b/test/oldtuv/util/la_srb.type.F90 index 29184801..f8e208f0 100644 --- a/test/oldtuv/util/la_srb.type.F90 +++ b/test/oldtuv/util/la_srb.type.F90 @@ -69,9 +69,6 @@ subroutine initialize( this, gridWareHouse ) type(string_t) :: Handle class(base_grid_t), pointer :: lambdaGrid - write(*,*) ' ' - write(*,*) Iam // 'entering' - Handle = 'Photolysis, wavelength' ; lambdaGrid => gridWareHouse%get_grid( Handle ) !> Are la and srb grids fully "inside" the model grid? @@ -129,9 +126,6 @@ subroutine initialize( this, gridWareHouse ) endif endif has_la_srb - write(*,*) ' ' - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine la_srb_OD( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,dto2 ) @@ -201,9 +195,6 @@ subroutine la_srb_OD( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,dto2 ) !---------------------------------------------------------------------- real(dk) :: dto2k(size(Airvcol),nsrb) - write(*,*) ' ' - write(*,*) Iam // 'entering' - has_la_srb: & if( this%has_la_srb ) then !----------------------------------------------------------------------------- @@ -257,9 +248,6 @@ subroutine la_srb_OD( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,dto2 ) endif endif has_la_srb - write(*,*) ' ' - write(*,*) Iam // 'exiting' - end subroutine la_srb_OD subroutine la_srb_xs( this,gridWareHouse,ProfileWareHouse,Airvcol,Airscol,o2xs ) diff --git a/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 b/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 index e8285cf3..d6e0c0f7 100644 --- a/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/air.from_csv_file.type.F90 @@ -54,8 +54,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -128,16 +126,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,airlog ) this%edge_val_ = exp( this%edge_val_ ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -154,8 +142,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%burden_dens_(k) = accum enddo - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/from_csv_file.type.F90 b/test/oldtuv/vert_Profile/from_csv_file.type.F90 index a3cefea9..a16d0a27 100644 --- a/test/oldtuv/vert_Profile/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) type(string_t) :: Handle class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -122,24 +120,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = this%mid_val_ * zGrid%delta_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 b/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 index 9cf15a9b..4948119c 100644 --- a/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/holdingtank/from_csv_file.type.F90 @@ -44,8 +44,6 @@ subroutine initialize( this, profile_config, zGrid ) character(len=132) :: InputLine type(string_t) :: Filespec - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -94,16 +92,6 @@ subroutine initialize( this, profile_config, zGrid ) allocate( this%edge_val_(this%ncells_+1_ik) ) this%edge_val_ = this%inter1( zGrid, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - allocate( this%mid_val_(this%ncells_) ) allocate( this%delta_val_(this%ncells_) ) this%mid_val_(:) = .5_dk & @@ -112,8 +100,6 @@ subroutine initialize( this, profile_config, zGrid ) close(unit=inUnit) - write(*,*) Iam // 'exiting' - end subroutine initialize end module micm_from_csv_file_vert_Profile diff --git a/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 b/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 index a4333e15..3c83c418 100644 --- a/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/o2.from_csv_file.type.F90 @@ -55,8 +55,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -130,16 +128,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = exp( this%edge_val_ ) this%edge_val_ = o2Vmr * this%edge_val_ - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -149,8 +137,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%exo_layer_dens_ = [this%layer_dens_,exo_layer_dens] this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + exo_layer_dens - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 b/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 index 69e0000f..af7aff3b 100644 --- a/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile/o3.from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -139,24 +137,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = zGrid%delta_ * this%mid_val_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile/vert_Profile_factory.F90 b/test/oldtuv/vert_Profile/vert_Profile_factory.F90 index b4190363..2f341ac7 100644 --- a/test/oldtuv/vert_Profile/vert_Profile_factory.F90 +++ b/test/oldtuv/vert_Profile/vert_Profile_factory.F90 @@ -42,8 +42,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) character(len=*), parameter :: Iam = 'Vert Profile builder: ' type(string_t) :: Profile_type - write(*,*) Iam,'entering' - new_Profile_t => null() call config%get( 'Vert Profile type', Profile_type, Iam ) @@ -62,8 +60,6 @@ function Profile_builder( config, gridWareHouse ) result( new_Profile_t ) call new_Profile_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' - end function Profile_builder !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 b/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 index 1a60266d..e086410e 100644 --- a/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 +++ b/test/oldtuv/vert_Profile/vert_Profile_warehouse.F90 @@ -62,8 +62,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( Profile_warehouse_obj ) associate(new_obj=>Profile_warehouse_obj) @@ -78,8 +76,6 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) do while( iter%next() ) keychar = Profile_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call Profile_set%get( iter, Profile_config, Iam ) call Profile_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -91,13 +87,8 @@ function constructor( config, gridwarehouse ) result( Profile_warehouse_obj ) deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' Profile objects'')') Iam,size(new_obj%Profile_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -121,9 +112,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%Profile_objs_) if( Profile_handle .eq. this%Profile_objs_(ndx)%ptr_%handle_ ) then @@ -138,8 +126,6 @@ function get_Profile( this, Profile_handle ) result( Profile_ptr ) call die_msg( 460768214, "Invalid Profile handle: '"// Profile_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_Profile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -156,14 +142,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'Profile warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%Profile_objs_ ) ) then deallocate( this%Profile_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 index 5eb02e9e..b1a4fba1 100644 --- a/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/air.from_csv_file.type.F90 @@ -54,8 +54,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -128,16 +126,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,airlog ) this%edge_val_ = exp( this%edge_val_ ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -154,8 +142,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%burden_dens_(k) = accum enddo - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 index 289bfe04..6d9cc213 100644 --- a/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) type(string_t) :: Handle class(abs_interpolator_t), pointer :: theInterpolator - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -122,24 +120,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = this%mid_val_ * zGrid%delta_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 index 9cf15a9b..4948119c 100644 --- a/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/holdingtank/from_csv_file.type.F90 @@ -44,8 +44,6 @@ subroutine initialize( this, profile_config, zGrid ) character(len=132) :: InputLine type(string_t) :: Filespec - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -94,16 +92,6 @@ subroutine initialize( this, profile_config, zGrid ) allocate( this%edge_val_(this%ncells_+1_ik) ) this%edge_val_ = this%inter1( zGrid, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - allocate( this%mid_val_(this%ncells_) ) allocate( this%delta_val_(this%ncells_) ) this%mid_val_(:) = .5_dk & @@ -112,8 +100,6 @@ subroutine initialize( this, profile_config, zGrid ) close(unit=inUnit) - write(*,*) Iam // 'exiting' - end subroutine initialize end module micm_from_csv_file_vert_Profile diff --git a/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 index 9dfeacfb..7bf80a77 100644 --- a/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/o2.from_csv_file.type.F90 @@ -55,8 +55,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -130,16 +128,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = exp( this%edge_val_ ) this%edge_val_ = o2Vmr * this%edge_val_ - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) @@ -149,8 +137,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%exo_layer_dens_ = [this%layer_dens_,exo_layer_dens] this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + exo_layer_dens - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 b/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 index 3b5d49e2..92e3a647 100644 --- a/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 +++ b/test/oldtuv/vert_Profile_v0/o3.from_csv_file.type.F90 @@ -52,8 +52,6 @@ subroutine initialize( this, profile_config, gridWareHouse ) class(abs_interpolator_t), pointer :: theInterpolator class(base_grid_t), pointer :: zGrid - write(*,*) Iam // 'entering' - !> Get the configuration settings call profile_config%get( 'Filespec', Filespec, Iam ) call profile_config%get( 'Handle', this%handle_, Iam, default = 'None' ) @@ -139,24 +137,12 @@ subroutine initialize( this, profile_config, gridWareHouse ) this%edge_val_ = theInterpolator%interpolate( zGrid%edge_, zdata,Profile ) - write(*,*) ' ' - write(*,*) Iam // 'data z grid' - write(*,'(1p10g15.7)') zdata - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' on data z grid' - write(*,'(1p10g15.7)') Profile - write(*,*) ' ' - write(*,*) Iam // this%handle_%to_char() // ' @ mdl z grid edges' - write(*,'(1p10g15.7)') this%edge_val_ - this%mid_val_ = .5_dk & *(this%edge_val_(1_ik:this%ncells_) + this%edge_val_(2_ik:this%ncells_+1_ik)) this%delta_val_ = (this%edge_val_(2_ik:this%ncells_+1_ik) - this%edge_val_(1_ik:this%ncells_)) this%layer_dens_ = zGrid%delta_ * this%mid_val_ * km2cm this%layer_dens_(this%ncells_) = this%layer_dens_(this%ncells_) + this%edge_val_(this%ncells_+1_ik) * this%hscale_ * km2cm - write(*,*) Iam // 'exiting' - end subroutine initialize subroutine finalize( this ) diff --git a/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 b/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 index 01da715f..5a343d61 100644 --- a/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 +++ b/test/oldtuv/vert_Profile_v0/vert_Profile_factory.F90 @@ -42,8 +42,6 @@ function vert_Profile_builder( config, gridWareHouse ) result( new_vert_Profile_ character(len=*), parameter :: Iam = 'Vert Profile builder: ' type(string_t) :: vert_Profile_type - write(*,*) Iam,'entering' - new_vert_Profile_t => null() call config%get( 'Vert Profile type', vert_Profile_type, Iam ) @@ -62,8 +60,6 @@ function vert_Profile_builder( config, gridWareHouse ) result( new_vert_Profile_ call new_vert_Profile_t%initialize( config, gridWareHouse ) - write(*,*) Iam,'exiting' - end function vert_Profile_builder !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 b/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 index 285ef1b5..eb2abdf5 100644 --- a/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 +++ b/test/oldtuv/vert_Profile_v0/vert_Profile_warehouse.F90 @@ -61,8 +61,6 @@ function constructor( config, gridwarehouse ) result( vert_Profile_warehouse_obj character(len=32) :: keychar type(string_t) :: aswkey - write(*,*) Iam // 'entering' - allocate( vert_Profile_warehouse_obj ) associate(new_obj=>vert_Profile_warehouse_obj) @@ -77,8 +75,6 @@ function constructor( config, gridwarehouse ) result( vert_Profile_warehouse_obj do while( iter%next() ) keychar = vert_Profile_set%key(iter) aswkey = keychar - write(*,*) ' ' - write(*,*) Iam,'key = ',trim(keychar) call vert_Profile_set%get( iter, vert_Profile_config, Iam ) call vert_Profile_config%add( 'Handle', aswkey, Iam ) !----------------------------------------------------------------------------- @@ -90,13 +86,8 @@ function constructor( config, gridwarehouse ) result( vert_Profile_warehouse_obj deallocate( iter ) - write(*,*) ' ' - write(*,'(a,''There are '',i3,'' vert Profile objects'')') Iam,size(new_obj%vert_Profile_objs_) - end associate - write(*,*) Iam // 'exiting' - end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -120,9 +111,6 @@ function get_vert_Profile( this, vert_Profile_handle ) result( vert_Profile_ptr integer(ik) :: ndx logical(lk) :: found - write(*,*) ' ' - write(*,*) Iam,'entering' - found = .false._lk do ndx = 1,size(this%vert_Profile_objs_) if( vert_Profile_handle .eq. this%vert_Profile_objs_(ndx)%ptr_%handle_ ) then @@ -137,8 +125,6 @@ function get_vert_Profile( this, vert_Profile_handle ) result( vert_Profile_ptr call die_msg( 460768214, "Invalid vert Profile handle: '"// vert_Profile_handle%to_char()//"'" ) endif - write(*,*) Iam,'exiting' - end function get_vert_Profile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -155,14 +141,10 @@ subroutine finalize( this ) integer(kind=ik) :: ndx character(len=*), parameter :: Iam = 'vert Profile warehouse finalize: ' - write(*,*) Iam,'entering' - if( allocated( this%vert_Profile_objs_ ) ) then deallocate( this%vert_Profile_objs_ ) endif - write(*,*) Iam,'exiting' - end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/test/oldtuv/vpo3.f b/test/oldtuv/vpo3.f index 1d971fcb..0a6a5293 100644 --- a/test/oldtuv/vpo3.f +++ b/test/oldtuv/vpo3.f @@ -130,12 +130,6 @@ END FUNCTION inter1 nlyr = nz - 1 con = inter1(z, zd,xd ) - write(*,*) 'vpo3: data z grid' - write(*,'(1p10g15.7)') zd - write(*,*) ' ' - write(*,*) 'vpo3: o3 on data z grid' - write(*,'(1p10g15.7)') xd - * compute column increments DO i = 1, nlyr @@ -171,17 +165,11 @@ END FUNCTION inter1 con(nz) = con(nz) * scale ENDIF - write(*,*) ' ' - write(*,*) 'vpo3: o3 on mdl z grid edges' - write(*,'(1p10g15.7)') con - write(*,*) ' ' - *-----------------------------------------------------------------------------* *! overwrite column increments for specified pbl height * use mixing ratio in pbl *-----------------------------------------------------------------------------* IF(ipbl > 0) THEN - write(*,*) 'pbl O3 = ', mr_pbl, ' ppb' DO i = 1, nlyr IF (i <= ipbl) THEN col(i) = mr_pbl*1.E-9 * aircol(i) diff --git a/test/oldtuv/vptmp.f b/test/oldtuv/vptmp.f index 60e930a7..a7f87542 100644 --- a/test/oldtuv/vptmp.f +++ b/test/oldtuv/vptmp.f @@ -78,16 +78,6 @@ END FUNCTION inter1 nz = size(z) tlev = inter1(z, zd,td) - write(*,*) 'vptmp: data z grid' - write(*,'(1p10g15.7)') zd - write(*,*) ' ' - write(*,*) 'vptmp: Temp on data z grid' - write(*,'(1p10g15.7)') td - write(*,*) ' ' - write(*,*) 'vptmp: Temp on mdl z grid edges' - write(*,'(1p10g15.7)') tlev - write(*,*) ' ' - * compute layer-averages tlay(1:nz-1) = .5*(tlev(2:nz) + tlev(1:nz-1)) c tlay(nz) = tlay(nz-1) diff --git a/test/regression/dose_rates/sw.compare.py b/test/regression/dose_rates/sw.compare.py index 15af0ae1..7f3f26d9 100644 --- a/test/regression/dose_rates/sw.compare.py +++ b/test/regression/dose_rates/sw.compare.py @@ -33,9 +33,6 @@ def compare_var(var_name,tolerance,var_old,var_new): diff = np.abs(diff) diff_2d = np.reshape( diff,[156,1] ) - print(f"Shape diff_2d = {np.shape(diff_2d)}") - print(f"Max diff @ (row,col) = {np.unravel_index(np.argmax(diff_2d),diff_2d.shape)}") - print(f"Max diff @ {np.argmax( diff_2d )}") # get comparison stats results = {} results["minimum difference"] = np.amin( diff ) @@ -79,40 +76,14 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): nlabels_new = len( labels_new ) nlabels_old = len( labels_old ) - print(f"\nsw.new type = {sw_new.dtype}") ndata = int(sw_new.shape[0]/nlabels_new) - print(f"sw.new size = {ndata}") - - print( f"\nThere are {nlabels_new} new arrays") - print( f"There are {nlabels_old} old arrays\n") SW_new = np.reshape( sw_new,[nlabels_new,ndata] ) - print(f"\nSW_new type = {SW_new.dtype}") - print(f"SW_new shape = {SW_new.shape}") - print( SW_new[0,:] ) - print("") - # check reshape maxind = np.argmax( sw_new ) - print(f"\nMax val sw_new @ {maxind}") - print(f" {maxind-4} <= n <= {maxind+4}") - print("sw_new near Max") - print( sw_new[maxind-4:maxind-1] ) - print( sw_new[maxind] ) - print( sw_new[maxind+1:maxind+4] ) maxind = np.unravel_index( np.argmax(SW_new),SW_new.shape ) - print(f"\nMax val SW_new @ {maxind}") - print("SW_new near Max") - print( SW_new[maxind[0],maxind[1]-4:maxind[1]-1] ) - print( SW_new[maxind[0],maxind[1]] ) - print( SW_new[maxind[0],maxind[1]+1:maxind[1]+4] ) - print("") SW_old = np.reshape( sw_old,[nlabels_old,ndata] ) - print( SW_old.dtype ) - print( SW_old.shape ) - print( SW_old[0,:] ) - print("") success = True @@ -129,17 +100,8 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): if( not indatasets ): print(f"\nNo match for {match} in old dataset") continue - print(f"\n{match} in both datasets; (old,new) = {ndx_old},{ndx_new}") # compare datasets; old first - print("old dataset") - print(f"Min = {np.amin(SW_old[ndx_old,:])}") - print(f"Max = {np.amax(SW_old[ndx_old,:])}") - print(f"Non-zero count = {np.count_nonzero(SW_old[ndx_old,:])}") # new last - print("\nnew dataset") - print(f"Min = {np.amin(SW_new[ndx_new,:])}") - print(f"Max = {np.amax(SW_new[ndx_new,:])}") - print(f"Non-zero count = {np.count_nonzero(SW_new[ndx_new,:])}\n") results = compare_var( match, options["maximum difference"], SW_old[ndx_old,:], SW_new[ndx_new,:] ) for metric, tolerance in options.items(): if not metric in results.keys(): @@ -160,8 +122,6 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): print(f" Fail cnt = {results['fail count']}\n") success = False continue - else: - print(f"{match} {metric} within tolerance: {results[metric]}% <= {tolerance}%") # close open files fsw_old.close() @@ -174,10 +134,6 @@ def compare_output(fsw_new_path, fsw_old_path, labels_new, labels_old, config): script_path, old_output_path, new_output_path = get_paths() labels_new, labels_old = get_labels(script_path) -print("\nslabels.new\n-----------") -for label in labels_new: - print(label.strip()) - with open(os.path.join(script_path, f"sw.compare.json"),"r") as f : config=json.load(f) diff --git a/test/regression/photolysis_rates/xsqy.compare.py b/test/regression/photolysis_rates/xsqy.compare.py index caf8f233..470c2f7b 100644 --- a/test/regression/photolysis_rates/xsqy.compare.py +++ b/test/regression/photolysis_rates/xsqy.compare.py @@ -33,9 +33,6 @@ def compare_var(var_name,tolerance,var_old,var_new): diff = np.abs(diff) diff_2d = np.reshape( diff,[156,121] ) - print(f"Shape diff_2d = {np.shape(diff_2d)}") - print(f"Max diff @ (row,col) = {np.unravel_index(np.argmax(diff_2d),diff_2d.shape)}") - print(f"Max diff @ {np.argmax( diff_2d )}") # get comparison stats results = {} results["minimum difference"] = np.amin( diff ) @@ -79,40 +76,15 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi nlabels_new = len( labels_new ) nlabels_old = len( labels_old ) - print(f"\nxsqy.new type = {xsqy_new.dtype}") ndata = int(xsqy_new.shape[0]/nlabels_new) - print(f"xsqy.new size = {ndata}") - - print( f"\nThere are {nlabels_new} new arrays") - print( f"There are {nlabels_old} old arrays\n") XSQY_new = np.reshape( xsqy_new,[nlabels_new,ndata] ) - print(f"\nXSQY_new type = {XSQY_new.dtype}") - print(f"XSQY_new shape = {XSQY_new.shape}") - print( XSQY_new[0,:] ) - print("") # check reshape maxind = np.argmax( xsqy_new ) - print(f"\nMax val xsqy_new @ {maxind}") - print(f" {maxind-4} <= n <= {maxind+4}") - print("xsqy_new near Max") - print( xsqy_new[maxind-4:maxind-1] ) - print( xsqy_new[maxind] ) - print( xsqy_new[maxind+1:maxind+4] ) maxind = np.unravel_index( np.argmax(XSQY_new),XSQY_new.shape ) - print(f"\nMax val XSQY_new @ {maxind}") - print("XSQY_new near Max") - print( XSQY_new[maxind[0],maxind[1]-4:maxind[1]-1] ) - print( XSQY_new[maxind[0],maxind[1]] ) - print( XSQY_new[maxind[0],maxind[1]+1:maxind[1]+4] ) - print("") XSQY_old = np.reshape( xsqy_old,[nlabels_old,ndata] ) - print( XSQY_old.dtype ) - print( XSQY_old.shape ) - print( XSQY_old[0,:] ) - print("") success = True @@ -129,17 +101,8 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi if( not indatasets ): print(f"\nNo match for {match} in old dataset") continue - print(f"\n{match} in both datasets; (old,new) = {ndx_old},{ndx_new}") # compare datasets; old first - print("old dataset") - print(f"Min = {np.amin(XSQY_old[ndx_old,:])}") - print(f"Max = {np.amax(XSQY_old[ndx_old,:])}") - print(f"Non-zero count = {np.count_nonzero(XSQY_old[ndx_old,:])}") # new last - print("\nnew dataset") - print(f"Min = {np.amin(XSQY_new[ndx_new,:])}") - print(f"Max = {np.amax(XSQY_new[ndx_new,:])}") - print(f"Non-zero count = {np.count_nonzero(XSQY_new[ndx_new,:])}\n") results = compare_var( match, options["maximum difference"], XSQY_old[ndx_old,:], XSQY_new[ndx_new,:] ) for metric, tolerance in options.items(): if not metric in results.keys(): @@ -160,8 +123,6 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi print(f" Fail cnt = {results['fail count']}\n") success = False continue - else: - print(f"{match} {metric} within tolerance: {results[metric]}% <= {tolerance}%") # close open files fxsqy_old.close() @@ -174,10 +135,6 @@ def compare_output(fxsqy_new_path, fxsqy_old_path, labels_new, labels_old, confi script_path, old_output_path, new_output_path = get_paths() labels_new, labels_old = get_labels(script_path) -print("\njlabels.new\n-----------") -for label in labels_new: - print(label.strip()) - with open(os.path.join(script_path, f"xsqy.compare.json"),"r") as f : config=json.load(f) diff --git a/test/unit/CMakeLists.txt b/test/unit/CMakeLists.txt index 296c17aa..262cf009 100644 --- a/test/unit/CMakeLists.txt +++ b/test/unit/CMakeLists.txt @@ -14,6 +14,7 @@ add_subdirectory(radiative_transfer) add_subdirectory(radiator) add_subdirectory(spectral_weight) add_subdirectory(tuv_doug) +add_subdirectory(util) ################################################################################ # TUV-x tests diff --git a/test/unit/profile/from_host.F90 b/test/unit/profile/from_host.F90 index ced5d7e4..d23ee0ea 100644 --- a/test/unit/profile/from_host.F90 +++ b/test/unit/profile/from_host.F90 @@ -96,7 +96,6 @@ subroutine test_profile_from_host_t( ) call check_values( 447131776, my_profile%layer_dens_, dens, tol ) call check_values( 612024373, my_profile%exo_layer_dens_, exos, tol ) call check_values( 159392220, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) ! specify edges, mids, dens edges = (/ 0.5_dk, 9.8_dk, 15.4_dk, 45.0_dk /) @@ -115,7 +114,6 @@ subroutine test_profile_from_host_t( ) call check_values( 613341306, my_profile%layer_dens_, dens, tol ) call check_values( 466544996, my_profile%exo_layer_dens_, exos, tol ) call check_values( 796782485, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) ! specify edges, dens, scale height edges = (/ 1.0_dk, 2.0_dk, 4.0_dk, 10.0_dk /) @@ -136,7 +134,6 @@ subroutine test_profile_from_host_t( ) call check_values( 927373531, my_profile%layer_dens_, dens, tol ) call check_values( 192266129, my_profile%exo_layer_dens_, exos, tol ) call check_values( 639633975, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) ! specify edges, mids, dens, exo density edges = (/ 0.5_dk, 9.8_dk, 15.4_dk, 45.0_dk /) @@ -158,7 +155,6 @@ subroutine test_profile_from_host_t( ) call check_values( 124351251, my_profile%layer_dens_, dens, tol ) call check_values( 571719097, my_profile%exo_layer_dens_, exos, tol ) call check_values( 184095344, my_profile%burden_dens_, burden, tol ) - call my_profile%output( ) deallocate( my_profile ) diff --git a/test/unit/quantum_yield/h2so4_mills.F90 b/test/unit/quantum_yield/h2so4_mills.F90 index 734dae28..90822fd0 100644 --- a/test/unit/quantum_yield/h2so4_mills.F90 +++ b/test/unit/quantum_yield/h2so4_mills.F90 @@ -163,12 +163,6 @@ subroutine test_quantum_yield_h2so4_mills_t( ) do i_pres = 1, size( file_pressures ) i_height = i_height + 1 do i_wl = 1, i_file_offset - 1 - write(*,*) i_wl, wavelength_grid%edge_( i_wl ), & - wavelength_grid%mid_( i_wl ), & - quantum_yields( i_height, i_wl ) * & - cross_sections( i_height, i_wl ), & - quantum_yields( i_height, i_wl ), & - cross_sections( i_height, i_wl ) call assert( 897976065, & almost_equal( quantum_yields( i_height, i_wl ), & 1.0_dk ) ) @@ -183,23 +177,6 @@ subroutine test_quantum_yield_h2so4_mills_t( ) end if end do do i_wl = i_file_offset, n_wl - write(*,*) i_temp, file_temperatures( i_temp ), & - temperature_profile%edge_val_( i_height ), & - air_profile%edge_val_( i_height ), & - i_pres, file_pressures( i_pres ), & - air_profile%edge_val_( i_height ) & - * gas_constant & - * temperature_profile%edge_val_( i_height ) & - / Avogadro * 1.0e6_dk, & - i_wl, file_wavelengths( i_wl - i_file_offset + 1), & - wavelength_grid%edge_( i_wl ), & - wavelength_grid%mid_( i_wl ), & - file_photo_rates( i_wl - i_file_offset + 1, i_temp, & - i_pres ), & - quantum_yields( i_height, i_wl ) * & - cross_sections( i_height, i_wl ), & - quantum_yields( i_height, i_wl ), & - cross_sections( i_height, i_wl ) ! the top pressure level has different logic, but we're putting ! all pressure/temperature combos in one profile for this test, ! so skip the lowest pressure util we're on the last profile element diff --git a/test/unit/radiative_transfer/radiative_transfer_core.F90 b/test/unit/radiative_transfer/radiative_transfer_core.F90 index 95940791..2624223e 100644 --- a/test/unit/radiative_transfer/radiative_transfer_core.F90 +++ b/test/unit/radiative_transfer/radiative_transfer_core.F90 @@ -94,8 +94,6 @@ subroutine run( this ) class(cross_section_t), pointer :: RaylieghCrossSection type(string_t) :: Handle - write(*,*) Iam // 'entering' - !> Get copy of grid zGrid => this%theGridWarehouse_%get_grid( "height", "km" ) call assert( 412238768, zGrid%ncells_ .eq. 120_ik ) @@ -110,13 +108,6 @@ subroutine run( this ) AirProfile => this%theProfileWarehouse_%get_profile( "air", "molecule cm-3" ) call assert( 412238771, all( AirProfile%delta_val_ < 0._dk ) ) call assert( 412238771, all( AirProfile%layer_dens_ > 0._dk ) ) - write(*,*) ' ' - write(*,*) Iam // 'Air layer density' - write(*,'(1p10g15.7)') AirProfile%layer_dens_ - - write(*,*) ' ' - write(*,*) Iam // 'Air burden density' - write(*,'(1p10g15.7)') AirProfile%burden_dens_ !> Get copy of the temperature Profile TemperatureProfile => this%theProfileWarehouse_%get_profile( "temperature", "K" ) @@ -131,15 +122,9 @@ subroutine run( this ) call assert( 412238776, all( aCrossSection >= 0._dk ) ) call assert( 412238776, all( aCrossSection < 1._dk ) ) - write(*,*) ' ' - write(*,*) Iam // 'aCrossSection is (',size(aCrossSection,dim=1),' x ',size(aCrossSection,dim=2),')' - tstCrossSection = aCrossSection(1,1) call assert( 412238774, all( aCrossSection(:,1) == tstCrossSection ) ) - write(*,*) ' ' - write(*,*) Iam // 'Rayliegh cross section' - write(*,'(1p10g15.7)') aCrossSection(1,:) call assert( 412238775, all( aCrossSection(1,:) == aCrossSection(zGrid%ncells_,:) ) ) deallocate( zGrid ) @@ -147,7 +132,6 @@ subroutine run( this ) deallocate( TemperatureProfile ) deallocate( AirProfile ) deallocate( RaylieghCrossSection ) - write(*,*) Iam // 'exiting' end subroutine run diff --git a/test/unit/radiator/radiator_core.F90 b/test/unit/radiator/radiator_core.F90 index bff23859..e21addf2 100644 --- a/test/unit/radiator/radiator_core.F90 +++ b/test/unit/radiator/radiator_core.F90 @@ -120,8 +120,6 @@ subroutine run( this ) logical :: found integer, parameter :: comm = MPI_COMM_WORLD - write(*,*) Iam // 'entering' - !> Get copy of grid zGrid => this%theGridWarehouse_%get_grid( "height", "km" ) call assert( 412238768, zGrid%ncells_ .eq. 120_ik ) @@ -136,13 +134,6 @@ subroutine run( this ) AirProfile => this%theProfileWarehouse_%get_profile( "air", "molecule cm-3" ) call assert( 412238771, all( AirProfile%delta_val_ < 0._dk ) ) call assert( 412238771, all( AirProfile%layer_dens_ > 0._dk ) ) - write(*,*) ' ' - write(*,*) Iam // 'Air layer density' - write(*,'(1p10g15.7)') AirProfile%layer_dens_ - - write(*,*) ' ' - write(*,*) Iam // 'Air burden density' - write(*,'(1p10g15.7)') AirProfile%burden_dens_ !> Get copy of the temperature Profile TemperatureProfile => this%theProfileWarehouse_%get_profile( "temperature", "K" ) @@ -158,15 +149,9 @@ subroutine run( this ) call assert( 412238776, all( aCrossSection < 1._dk ) ) deallocate( RaylieghCrossSection ) - write(*,*) ' ' - write(*,*) Iam // 'aCrossSection is (',size(aCrossSection,dim=1),' x ',size(aCrossSection,dim=2),')' - tstCrossSection = aCrossSection(1,1) call assert( 412238774, all( aCrossSection(:,1) == tstCrossSection ) ) - write(*,*) ' ' - write(*,*) Iam // 'Rayliegh cross section' - write(*,'(1p10g15.7)') aCrossSection(1,:) call assert( 412238775, all( aCrossSection(1,:) == aCrossSection(zGrid%ncells_,:) ) ) ! Get copy of the rayliegh radiator and test MPI functions @@ -201,23 +186,9 @@ subroutine run( this ) ! Evaluate radiator state call assert( 312238775, all( RaylieghRadiator%state_%layer_OD_ >= 0._dk ) ) - write(*,*) Iam // 'layer_OD_ is (',size(RaylieghRadiator%state_%layer_OD_,dim=1),' x ', & - size(RaylieghRadiator%state_%layer_OD_,dim=2),')' call assert( 312238776, all( RaylieghRadiator%state_%layer_SSA_ >= 0._dk ) ) - write(*,*) Iam // 'layer_SSA_ is (',size(RaylieghRadiator%state_%layer_SSA_,dim=1),' x ', & - size(RaylieghRadiator%state_%layer_SSA_,dim=2),')' call assert( 312238777, all( RaylieghRadiator%state_%layer_G_ >= 0._dk ) ) call assert( 312238778, all( RaylieghRadiator%state_%layer_SSA_ == 1._dk ) ) - write(*,*) Iam // 'layer_G_ is (',size(RaylieghRadiator%state_%layer_G_,dim=1),' x ', & - size(RaylieghRadiator%state_%layer_G_,dim=2),')' - write(*,*) ' ' - write(*,*) Iam // 'Air radiator OD @ top of model' - write(*,'(1p10g15.7)') RaylieghRadiator%state_%layer_OD_(zGrid%ncells_,:) - write(*,*) ' ' - write(*,*) Iam // 'Air radiator OD @ ground' - write(*,'(1p10g15.7)') RaylieghRadiator%state_%layer_OD_(1,:) - - write(*,*) Iam // 'Before radiator iterator test' !> Test warehouse iterator and MPI passed warehouse found = .false. @@ -244,7 +215,6 @@ subroutine run( this ) deallocate( lambdaGrid ) deallocate( AirProfile ) deallocate( TemperatureProfile ) - write(*,*) Iam // 'exiting' end subroutine run diff --git a/test/unit/tuv_doug/CMakeLists.txt b/test/unit/tuv_doug/CMakeLists.txt index d26e4fc5..5de66475 100644 --- a/test/unit/tuv_doug/CMakeLists.txt +++ b/test/unit/tuv_doug/CMakeLists.txt @@ -29,7 +29,7 @@ target_sources(tuv_doug add_subdirectory(JCALC) -target_link_libraries(tuv_doug PUBLIC musica::tuvx musica::musicacore) +target_link_libraries(tuv_doug PUBLIC musica::tuvx) ################################################################################ diff --git a/test/unit/tuv_doug/data_sets.F90 b/test/unit/tuv_doug/data_sets.F90 index 2cc7a4da..4347753f 100644 --- a/test/unit/tuv_doug/data_sets.F90 +++ b/test/unit/tuv_doug/data_sets.F90 @@ -151,21 +151,6 @@ subroutine test_data_set( ) real( temperature%edge_val_(:temperature%ncells_+1) ), & real( air%edge_val_ ), doug_xsqy ) - wavelength => grids%get_grid( "wavelength", "nm" ) - write(*,*) label%val_, " temperature = ", & - temperature%edge_val_(OUTPUT_LEVEL) - write(*,*) "i_wl wl_edge wl_mid xs_TUVx qy_TUVx j_TUVx wl_LUT j_LUT" - do i = 1, size( tuvx_xsqy, dim=2 ) - write(*,*) i, wavelength%edge_(i), wavelength%mid_(i), & - cross_section_data(OUTPUT_LEVEL,i), & - quantum_yield_data(OUTPUT_LEVEL,i), & - tuvx_xsqy(OUTPUT_LEVEL,i), wl(i), & - real( doug_xsqy(OUTPUT_LEVEL,i), kind=dk ) - end do - write(*,*) size( tuvx_xsqy, dim=2 ) + 1, & - wavelength%edge_(wavelength%ncells_+1) - deallocate( wavelength ) - ! Skip first two bins because Lyman-Alpha bins are different in ! Doug's version of TUV-x. Data sets were adapted to have Lyman-Alpha ! specific data go into the TUV-x Lyman-Alpha bin 121.4-121.9 nm diff --git a/test/unit/util/CMakeLists.txt b/test/unit/util/CMakeLists.txt new file mode 100644 index 00000000..8ea1a485 --- /dev/null +++ b/test/unit/util/CMakeLists.txt @@ -0,0 +1,29 @@ +################################################################################ +# Test utilities + +include(test_util) + +################################################################################ +# Utility tests + +create_standard_test(NAME util_array SOURCES array.F90) + +create_standard_test(NAME util_assert SOURCES assert.F90) +add_executable(util_assert_failure assert.F90) +add_std_test_script(util_assert_failure assert.sh) + +create_standard_test(NAME util_config SOURCES config.F90) + +create_standard_test(NAME util_map SOURCES map.F90) +add_executable(util_map_failure map.F90) +add_std_test_script(util_map_failure map.sh) + +create_standard_test(NAME util_mpi SOURCES mpi.F90) + +create_standard_test(NAME util_string SOURCES string.F90) +add_executable(util_string_failure string.F90) +add_std_test_script(util_string_failure string.sh) + +add_subdirectory(io) + +################################################################################ diff --git a/test/unit/util/array.F90 b/test/unit/util/array.F90 new file mode 100644 index 00000000..2e2f16a6 --- /dev/null +++ b/test/unit/util/array.F90 @@ -0,0 +1,152 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_array module + +!> Tests for the musica_array module +program test_util_array + + use musica_assert, only : assert, almost_equal + use musica_array + use musica_constants, only : musica_ik, musica_rk, musica_dk + use musica_string, only : string_t +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + +#ifdef MUSICA_USE_OPENMP + write(*,*) "Testing with ", omp_get_max_threads( ), " threads" +#else + write(*,*) "Testing without OpenMP support" +#endif + + !$omp parallel + call test_array_functions( ) + !$omp end parallel + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests array functions + subroutine test_array_functions( ) + + type(string_t) :: str_array(3) + real(kind=musica_dk), allocatable :: dbl_array(:), dbl_array_2(:) + real(kind=musica_dk), allocatable :: merged_array(:) + real(kind=musica_rk), allocatable :: flt_array(:) + integer(kind=musica_ik), allocatable :: int_array(:) + logical, allocatable :: bool_array(:) + type(string_t) :: str + integer(kind=musica_ik) :: idx + + allocate( dbl_array( 0 ) ) + allocate( flt_array( 0 ) ) + allocate( int_array( 0 ) ) + allocate( bool_array( 0 ) ) + + ! test find_string_in_array( ) + str_array(1) = "foo" + str_array(2) = "bar" + str_array(3) = "foObar" + + call assert( 301097835, size( str_array ) .eq. 3 ) + call assert( 184681299, find_string_in_array( str_array, "foo", idx ) ) + call assert( 360841928, idx .eq. 1 ) + call assert( 520470218, find_string_in_array( str_array, "foObar", idx, & + case_sensitive = .true. ) ) + call assert( 745106908, idx .eq. 3 ) + call assert( 239900503, .not. find_string_in_array( str_array, "fooBar", & + idx, case_sensitive = .true. ) ) + call assert( 234636196, .not. find_string_in_array( str_array, & + "not there", idx ) ) + str = "bar" + call assert( 911905039, find_string_in_array( str_array, str, idx ) ) + call assert( 689173883, idx .eq. 2 ) + str = "Bar" + call assert( 183967478, .not. find_string_in_array( str_array, str, idx, & + case_sensitive = .true. ) ) + str = "not there" + call assert( 231277423, .not. find_string_in_array( str_array, str, idx ) ) + + ! test find_string_in_split_array( ) + str_array( 1 ) = "foo.BaR" + str_array( 2 ) = "Bar.foO" + str_array( 3 ) = "justfoo" + + call assert( 100527721, find_string_in_split_array( str_array, "foo", ".",& + 1, idx ) ) + call assert( 253438465, idx .eq. 1 ) + call assert( 192693428, find_string_in_split_array( str_array, "foo", ".",& + 2, idx ) ) + call assert( 522478622, idx .eq. 2 ) + call assert( 634796967, .not. find_string_in_split_array( str_array, & + "foo", ".", 2, idx, case_sensitive = .true. ) ) + call assert( 747115312, find_string_in_split_array( str_array, "BaR", ".",& + 2, idx, case_sensitive = .true. ) ) + call assert( 859433657, idx .eq. 1 ) + str = "foo" + call assert( 929884076, find_string_in_split_array( str_array, str, ".", & + 1, idx ) ) + call assert( 477251923, idx .eq. 1 ) + call assert( 924619769, find_string_in_split_array( str_array, str, ".", & + 2, idx ) ) + call assert( 471987616, idx .eq. 2 ) + call assert( 366839112, .not. find_string_in_split_array( str_array, & + str, ".", 2, idx, case_sensitive = .true. ) ) + str = "BaR" + call assert( 196682208, find_string_in_split_array( str_array, str, ".", & + 2, idx, case_sensitive = .true. ) ) + call assert( 926525303, idx .eq. 1 ) + + ! test merge_series( ) + if( allocated( dbl_array ) ) deallocate( dbl_array ) + if( allocated( dbl_array_2 ) ) deallocate( dbl_array_2 ) + dbl_array = [ 3.5_musica_dk, 5.0_musica_dk, 12.3_musica_dk ] + dbl_array_2 = [ 1.0_musica_dk, 4.2_musica_dk, 5.0_musica_dk, & + 12.3_musica_dk, 24.3_musica_dk ] + merged_array = merge_series( dbl_array, dbl_array_2 ) + call assert( 182507698, size( merged_array ) .eq. 6 ) + call assert( 105969740, merged_array( 1 ) .eq. 1.0_musica_dk ) + call assert( 835812835, merged_array( 2 ) .eq. 3.5_musica_dk ) + call assert( 948131180, merged_array( 3 ) .eq. 4.2_musica_dk ) + call assert( 777974276, merged_array( 4 ) .eq. 5.0_musica_dk ) + call assert( 607817372, merged_array( 5 ) .eq. 12.3_musica_dk ) + call assert( 155185219, merged_array( 6 ) .eq. 24.3_musica_dk ) + merged_array = merge_series( dbl_array, dbl_array_2, & + with_bounds_from = dbl_array ) + call assert( 267503564, size( merged_array ) .eq. 4 ) + call assert( 162355060, merged_array( 1 ) .eq. 3.5_musica_dk ) + call assert( 609722906, merged_array( 2 ) .eq. 4.2_musica_dk ) + call assert( 439566002, merged_array( 3 ) .eq. 5.0_musica_dk ) + call assert( 886933848, merged_array( 4 ) .eq. 12.3_musica_dk ) + + ! test calculate_linear_array( ) + if( allocated( dbl_array ) ) deallocate( dbl_array ) + dbl_array = calculate_linear_array( 1.0_musica_dk, 5.0_musica_dk, 5 ) + call assert( 781682679, size( dbl_array ) .eq. 5 ) + call assert( 106319370, dbl_array( 1 ) .eq. 1.0_musica_dk ) + call assert( 824180612, almost_equal( dbl_array( 2 ), 2.0_musica_dk ) ) + call assert( 654023708, almost_equal( dbl_array( 3 ), 3.0_musica_dk ) ) + call assert( 201391555, almost_equal( dbl_array( 4 ), 4.0_musica_dk ) ) + call assert( 996243050, dbl_array( 5 ) .eq. 5.0_musica_dk ) + + ! test calculate_logarithmic_array( ) + if( allocated( dbl_array ) ) deallocate( dbl_array ) + dbl_array = & + calculate_logarithmic_array( 1.0_musica_dk, 10000.0_musica_dk, 5 ) + call assert( 764888814, size( dbl_array ) .eq. 5 ) + call assert( 312256661, dbl_array( 1 ) .eq. 1.0_musica_dk ) + call assert( 142099757, almost_equal( dbl_array( 2 ), 10.0_musica_dk ) ) + call assert( 589467603, almost_equal( dbl_array( 3 ), 100.0_musica_dk ) ) + call assert( 136835450, almost_equal( dbl_array( 4 ), 1000.0_musica_dk ) ) + call assert( 931686945, dbl_array( 5 ) .eq. 10000.0_musica_dk ) + + end subroutine test_array_functions + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_array diff --git a/test/unit/util/assert.F90 b/test/unit/util/assert.F90 new file mode 100644 index 00000000..aaa7b300 --- /dev/null +++ b/test/unit/util/assert.F90 @@ -0,0 +1,255 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_assert module + +!> Test module for the musica_assert module +program test_util_assert + + use musica_assert +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + + character(len=256) :: failure_test_type + + if( command_argument_count( ) .eq. 0 ) then +#ifdef MUSICA_USE_OPENMP + write(*,*) "Testing with ", omp_get_max_threads( ), " threads" +#else + write(*,*) "Testing without OpenMP support" +#endif + !$omp parallel + call test_assert( ) + !$omp end parallel + else if( command_argument_count( ) .eq. 1 ) then + call get_command_argument( 1, failure_test_type ) + call failure_test( failure_test_type ) + else + call die( 233227610 ) + end if + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test assert functions + subroutine test_assert( ) + + use musica_constants, only : rk => musica_rk, dk => musica_dk + use musica_string, only : string_t + + type(string_t) :: str + real(kind=dk) :: a1d(3), b1d(3), c1d(2), a2d(3,3), b2d(3,3), c2d(2,3) + real(kind=rk) :: a1r(3), b1r(3), c1r(2), a2r(3,3), b2r(3,3), c2r(2,3) + + str = "foo" + + call assert_msg( 449241220, .true., "foo" ) + call assert_msg( 612680578, .true., str ) + call assert( 549577712, .true. ) + + ! test almost_equal( ) + ! for real + call assert( 126460695, almost_equal( 12.5_rk, 12.5_rk ) ) + call assert( 740626672, .not. almost_equal( 12.5_rk, 12.6_rk ) ) + call assert( 172317401, almost_equal( 12.5_rk, 12.6_rk, & + relative_tolerance = 0.11_rk ) ) + call assert( 955187043, almost_equal( 12.5_rk, 12.6_rk, & + absolute_tolerance = 0.11_rk ) ) + call assert( 293998244, .not. & + almost_equal( 12.5e34_rk, & + 12.5e34_rk + 12.5e34_rk * 1.0e-5_rk ) ) + call assert( 881294037, & + almost_equal( 12.5e-34_rk, 12.5e-34_rk + 1.0e-32_rk ) ) + call assert( 151450942, .not. & + almost_equal( 12.5e34_rk, & + 12.5e34_rk - 12.5e34_rk * 1.0e-5_rk ) ) + call assert( 328325392, & + almost_equal( 12.5e-34_rk, 12.5e-34_rk - 1.0e-32_rk ) ) + call assert( 597365549, & + almost_equal( 12.5e34_rk, & + 12.5e34_rk + 12.5e34_rk * 1.0e-5_rk, & + relative_tolerance = 1.0e-4_rk ) ) + call assert( 709683894, .not. & + almost_equal( 12.5e-34_rk, 12.5e-34_rk + 1.0e-32_rk, & + absolute_tolerance = 1.0e-33_rk ) ) + call assert( 539526990, & + almost_equal( 12.5e34_rk, & + 12.5e34_rk - 12.5e34_rk * 1.0e-5_rk, & + relative_tolerance = 1.0e-4_rk ) ) + call assert( 986894836, .not. & + almost_equal( 12.5e-34_rk, 12.5e-34_rk - 1.0e-32_rk, & + absolute_tolerance = 1.0e-33_rk ) ) + + ! for double + call assert( 799568563, almost_equal( 12.5_dk, 12.5_dk ) ) + call assert( 794304256, .not. almost_equal( 12.5_dk, 12.6_dk ) ) + call assert( 341672103, almost_equal( 12.5_dk, 12.6_dk, & + relative_tolerance = 0.11_dk ) ) + call assert( 236523599, almost_equal( 12.5_dk, 12.6_dk, & + absolute_tolerance = 0.11_dk ) ) + call assert( 966366694, .not. & + almost_equal( 12.5e94_dk, & + 12.5e94_dk + 12.5e94_dk * 1.0e-5_dk ) ) + call assert( 796209790, & + almost_equal( 12.5e-94_dk, 12.5e-94_dk + 1.0e-92_dk ) ) + call assert( 343577637, .not. & + almost_equal( 12.5e94_dk, & + 12.5e94_dk - 12.5e94_dk * 1.0e-5_dk ) ) + call assert( 173420733, & + almost_equal( 12.5e-94_dk, 12.5e-94_dk - 1.0e-92_dk ) ) + call assert( 903263828, & + almost_equal( 12.5e94_dk, & + 12.5e94_dk + 12.5e94_dk * 1.0e-5_dk, & + relative_tolerance = 1.0e-4_dk ) ) + call assert( 733106924, .not. & + almost_equal( 12.5e-94_dk, 12.5e-94_dk + 1.0e-92_dk, & + absolute_tolerance = 1.0e-93_dk ) ) + call assert( 562950020, & + almost_equal( 12.5e94_dk, & + 12.5e94_dk - 12.5e94_dk * 1.0e-5_dk, & + relative_tolerance = 1.0e-4_dk ) ) + call assert( 675268365, .not. & + almost_equal( 12.5e-94_dk, 12.5e-94_dk - 1.0e-92_dk, & + absolute_tolerance = 1.0e-93_dk ) ) + + ! for cmplx real + call assert( 677913317, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.5_rk, 3.2_rk, kind=rk ) ) ) + call assert( 837993902, .not. & + almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.2_rk, kind=rk ) ) ) + call assert( 264420324, .not. & + almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.3_rk, kind=rk ) ) ) + call assert( 827917583, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.2_rk, kind=rk ), & + relative_tolerance = 0.11_rk ) ) + call assert( 538724788, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.5_rk, 3.3_rk, kind=rk ), & + relative_tolerance = 0.11_rk ) ) + call assert( 754738398, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.6_rk, 3.2_rk, kind=rk ), & + absolute_tolerance = 0.11_rk ) ) + call assert( 584581494, almost_equal( cmplx( 12.5_rk, 3.2_rk, kind=rk ), & + cmplx( 12.5_rk, 3.3_rk, kind=rk ), & + absolute_tolerance = 0.11_rk ) ) + + ! for cmplx double + call assert( 556258071, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.5_dk, 3.2_dk, kind=dk ) ) ) + call assert( 268518515, .not. & + almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.2_dk, kind=dk ) ) ) + call assert( 163370011, .not. & + almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.3_dk, kind=dk ) ) ) + call assert( 610737857, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.2_dk, kind=dk ), & + relative_tolerance = 0.11_dk ) ) + call assert( 440580953, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.5_dk, 3.3_dk, kind=dk ), & + relative_tolerance = 0.11_dk ) ) + call assert( 270424049, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.6_dk, 3.2_dk, kind=dk ), & + absolute_tolerance = 0.11_dk ) ) + call assert( 100267145, almost_equal( cmplx( 12.5_dk, 3.2_dk, kind=dk ), & + cmplx( 12.5_dk, 3.3_dk, kind=dk ), & + absolute_tolerance = 0.11_dk ) ) + + ! test are_equal( ) + ! for 1d real arrays + a1r = [ 2.3_rk, 4.2_rk, 5.2_rk ] + b1r = [ 2.3_rk, 4.2_rk, 5.2_rk ] + c1r = [ 2.3_rk, 4.2_rk ] + call assert( 197244864, are_equal( a1r, b1r ) ) + call assert( 316733050, .not. are_equal( a1r, c1r ) ) + b1r(3) = 42.5_rk + call assert( 478266874, .not. are_equal( a1r, b1r ) ) + + ! for 1d double arrays + a1d = [ 2.3_dk, 4.2_dk, 5.2_dk ] + b1d = [ 2.3_dk, 4.2_dk, 5.2_dk ] + c1d = [ 2.3_dk, 4.2_dk ] + call assert( 197244864, are_equal( a1d, b1d ) ) + call assert( 316733050, .not. are_equal( a1d, c1d ) ) + b1d(3) = 42.5_dk + call assert( 478266874, .not. are_equal( a1d, b1d ) ) + + ! for 2d real arrays + a2r(1,:) = [ 2.3_rk, 4.2_rk, 5.2_rk ] + a2r(2,:) = [ 5.2_rk, 3.2_rk, -42.3_rk ] + a2r(3,:) = [ 7.3_rk, 1.2_rk, 423.1_rk ] + b2r(1,:) = [ 2.3_rk, 4.2_rk, 5.2_rk ] + b2r(2,:) = [ 5.2_rk, 3.2_rk, -42.3_rk ] + b2r(3,:) = [ 7.3_rk, 1.2_rk, 423.1_rk ] + c2r(1,:) = [ 2.3_rk, 4.2_rk, 5.2_rk ] + c2r(2,:) = [ 5.2_rk, 3.2_rk, -42.3_rk ] + call assert( 787185609, are_equal( a2r, b2r ) ) + call assert( 341723297, .not. are_equal( a2r, c2r ) ) + b2r(3,3) = 94.2_rk + call assert( 613669932, .not. are_equal( a2r, b2r ) ) + + ! for 2d double arrays + a2d(1,:) = [ 2.3_dk, 4.2_dk, 5.2_dk ] + a2d(2,:) = [ 5.2_dk, 3.2_dk, -42.3_dk ] + a2d(3,:) = [ 7.3_dk, 1.2_dk, 423.1_dk ] + b2d(1,:) = [ 2.3_dk, 4.2_dk, 5.2_dk ] + b2d(2,:) = [ 5.2_dk, 3.2_dk, -42.3_dk ] + b2d(3,:) = [ 7.3_dk, 1.2_dk, 423.1_dk ] + c2d(1,:) = [ 2.3_dk, 4.2_dk, 5.2_dk ] + c2d(2,:) = [ 5.2_dk, 3.2_dk, -42.3_dk ] + call assert( 787185609, are_equal( a2d, b2d ) ) + call assert( 341723297, .not. are_equal( a2d, c2d ) ) + b2d(3,3) = 94.2_dk + call assert( 613669932, .not. are_equal( a2d, b2d ) ) + + end subroutine test_assert + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Failure tests for assert functions + subroutine failure_test( test_type ) + + character(len=*), intent(in) :: test_type + + if( test_type .eq. "903602145" ) then + call failure_test_903602145( ) + else if( test_type .eq. "151700878" ) then + call failure_test_151700878( ) + else + call die( 634624772 ) + end if + + end subroutine failure_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test failure of assert_msg with string + subroutine failure_test_903602145( ) + + use musica_string, only : string_t + + type(string_t) :: msg + + msg = "foo" + call assert_msg( 903602145, .false., msg ) + + end subroutine failure_test_903602145 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test failure of assert_msg with char array + subroutine failure_test_151700878( ) + + call assert_msg( 151700878, .false., "bar" ) + + end subroutine failure_test_151700878 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_assert diff --git a/test/unit/util/assert.sh b/test/unit/util/assert.sh new file mode 100755 index 00000000..8685a3ee --- /dev/null +++ b/test/unit/util/assert.sh @@ -0,0 +1,34 @@ +#!/bin/bash + +# turn on command echoing +set -v +# move to the directory this script is in +cd ${0%/*} +# define a function for failure tests +failure_test () { + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\).*/\1/p') + local output=$(../../../util_assert_failure $1 2>&1) + local failure_code=$(echo $output | sed -n 's/[[:space:]]*ERROR (Musica-\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure" + echo "Got output: $output" + exit 1 + else + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\)/\1/p') + local failure_code=$(cat error.json | sed -n 's/[[:space:]]*\"code\" : \"\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure in file 'error.json'" + echo "Got: $(cat error.json)" + rm -f error.json + exit 1 + else + rm -f error.json + echo $output + fi + fi +} + +failure_test 903602145 +failure_test 151700878 + +exit 0 diff --git a/test/unit/util/config.F90 b/test/unit/util/config.F90 new file mode 100644 index 00000000..1fdd874c --- /dev/null +++ b/test/unit/util/config.F90 @@ -0,0 +1,629 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_config module + +!> Test module for the musica_config module +program test_config + + use musica_assert + use musica_config + use musica_mpi + + implicit none + + call musica_mpi_init( ) + call test_config_t_mpi( ) + call test_config_t( ) + call config_example( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test config_t MPI functions + subroutine test_config_t_mpi( ) + + use musica_string, only : string_t + + type(config_t) :: a, b + type(string_t) :: sa + character, allocatable :: buffer(:) + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + character(len=*), parameter :: my_name = "config tests" + + if( musica_mpi_rank( comm ) == 0 ) then + a = '{ "foo": "bar" }' + pack_size = a%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call a%mpi_pack( buffer, pos, comm ) + end if + + call musica_mpi_bcast( pack_size, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) allocate( buffer( pack_size ) ) + + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + pos = 0 + call b%mpi_unpack( buffer, pos, comm ) + call b%get( "foo", sa, my_name ) + call assert( 529948470, sa == "bar" ) + end if + + end subroutine test_config_t_mpi + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test config_t functionality + subroutine test_config_t( ) + + use musica_constants, only : musica_rk, musica_dk, musica_ik + use musica_iterator, only : iterator_t + use musica_string, only : string_t + + type(config_t) :: a, a_file, b, c, array + type(config_t), allocatable :: orig_array(:), dest_array(:) + real(kind=musica_rk) :: ra + real(kind=musica_dk) :: da + real(kind=musica_dk), allocatable :: daa(:), dab(:) + integer(kind=musica_ik) :: ia + logical :: la, found + type(string_t) :: sa, sb + type(string_t), allocatable :: saa(:), sab(:) + character(len=*), parameter :: my_name = "config tests" + class(iterator_t), pointer :: iterator + + ! constructors + a = '{ "foo": "bar" }' + call a%empty( ) + call a_file%from_file( "test/data/test_config.json" ) + if( musica_mpi_rank( MPI_COMM_WORLD ) .eq. 0 ) then + call a_file%to_file( "temp_file.json" ) + call a_file%empty( ) + call a_file%from_file( "temp_file.json" ) + end if + + ! size + a = '{ "foo": "bar", "baz": "qux" }' + call assert( 917322918, a%number_of_children() .eq. 2 ) + + ! get config + call a_file%get( "my sub object", b, my_name, found = found ) + call assert( 169832207, found ) + + call b%get( "sub real", da, my_name ) + call assert( 630635145, almost_equal( da, 87.3d0 ) ) + + call b%get( "sub int", ia, my_name ) + call assert( 892957756, ia .eq. 42 ) + + call b%get( "really?", la, my_name ) + call assert( 389656885, la ) + + call b%get( "a bunch of strings", saa, my_name ) + call assert( 603764961, size( saa ) .eq. 3 ) + call assert( 210876901, saa(1) .eq. "bar" ) + call assert( 325100780, saa(2) .eq. "foo" ) + call assert( 202253821, saa(3) .eq. "barfoo" ) + + call a_file%get( "not there", b, my_name, found = found ) + call assert( 430701579, .not. found ) + + c = '{ "an int" : 13, "foo" : "bar" }' + call a_file%get( "not there", b, my_name, default = c, found = found ) + call assert( 250468356, .not. found ) + call b%get( "foo", sa, my_name ) + call assert( 464576432, sa .eq. "bar" ) + call b%get( "an int", ia, my_name ) + call assert( 457145065, ia .eq. 13 ) + + ! get string + + call a_file%get( "a string", sa, my_name ) + call assert( 651552798, sa .eq. "foo" ) + call a_file%get( "another string", sa, my_name, found = found ) + call assert( 411575482, found ) + call assert( 927310501, sa .eq. "bar" ) + call a_file%get( "a string", sa, my_name, default = "default value" ) + call assert( 292539591, sa .eq. "foo" ) + call a_file%get( "not there", sa, my_name, default = "default value", found = found ) + call assert( 968355195, .not. found ) + call assert( 345566138, sa .eq. "default value" ) + call a_file%get( "also not there", sa, my_name, found = found ) + call assert( 564491555, .not. found ) + + ! get integer + + call a_file%get( "another int", ia, my_name ) + call assert( 851875875, ia .eq. 31 ) + call a_file%get( "my integer", ia, my_name, found = found ) + call assert( 338046390, found ) + call assert( 397790483, ia .eq. 12 ) + call a_file%get( "another int", ia, my_name, default = 42 ) + call assert( 271584751, ia .eq. 31 ) + call a_file%get( "not there", ia, my_name, default = 96, found = found ) + call assert( 440288416, .not. found ) + call assert( 382449857, ia .eq. 96 ) + call a_file%get( "also not there", ia, my_name, found = found ) + call assert( 395787890, .not. found ) + + ! get real + + call a_file%get( "this real", ra, my_name ) + call assert( 821646918, almost_equal( ra, 23.4 ) ) + call a_file%get( "that real", ra, my_name, found = found ) + call assert( 425400085, found ) + call assert( 702611027, almost_equal( ra, 52.3e-4 ) ) + call a_file%get( "this real", ra, my_name, default = 432.5 ) + call assert( 901830772, almost_equal( ra, 23.4e0 ) ) + call a_file%get( "not there", ra, my_name, default = 643.78, found = found ) + call assert( 505583939, .not. found ) + call assert( 165270131, ra .eq. 643.78 ) + call a_file%get( "also not there", ra, my_name, found = found ) + call assert( 736101698, .not. found ) + + ! get double + + call a_file%get( "this real", da, my_name ) + call assert( 155933230, almost_equal( da, 23.4d0 ) ) + call a_file%get( "that real", da, my_name, found = found ) + call assert( 550726824, found ) + call assert( 663045169, almost_equal( da, 52.3d-4 ) ) + call a_file%get( "this real", da, my_name, default = 432.5d0 ) + call assert( 775363514, almost_equal( da, 23.4d0 ) ) + call a_file%get( "not there", da, my_name, default = 643.78d0, found = found ) + call assert( 887681859, .not. found ) + call assert( 435049706, da .eq. 643.78d0 ) + call a_file%get( "also not there", da, my_name, found = found ) + call assert( 228989759, .not. found ) + + ! get boolean + + call a_file%get( "is it?", la, my_name ) + call assert( 807245669, .not. la ) + call a_file%get( "is it really?", la, my_name, found = found ) + call assert( 405734529, found ) + call assert( 630371219, la ) + call a_file%get( "is it?", la, my_name, default = .false. ) + call assert( 511335328, .not. la ) + call a_file%get( "not there", la, my_name, default = .true., found = found ) + call assert( 672869152, .not. found ) + call assert( 227406840, la ) + call a_file%get( "also not there", la, my_name, found = found ) + call assert( 344666877, .not. found ) + + ! get double array + + call a_file%get( "a bunch of doubles", daa, my_name ) + call assert( 302144795, size( daa ) .eq. 4 ) + call assert( 421632981, daa(1) .eq. 12.5_musica_dk ) + call assert( 976054865, daa(2) .eq. 13.2_musica_dk ) + call assert( 465584153, daa(3) .eq. 72.5_musica_dk ) + call assert( 972696092, daa(4) .eq. -142.64_musica_dk ) + call a_file%get( "another bunch of doubles", daa, my_name, found = found ) + call assert( 707754126, found ) + call assert( 460772141, size( daa ) .eq. 2 ) + call assert( 511893154, daa(1) .eq. 52.3_musica_dk ) + call assert( 401480343, daa(2) .eq. 0.0_musica_dk ) + allocate( dab( 2 ) ) + dab(1) = 83.32_musica_dk + dab(2) = -64.23_musica_dk + call a_file%get( "a bunch of doubles", daa, my_name, default = dab ) + call assert( 607417634, size( daa ) .eq. 4 ) + call assert( 826790017, daa(1) .eq. 12.5_musica_dk ) + call assert( 656633113, daa(2) .eq. 13.2_musica_dk ) + call assert( 204000960, daa(3) .eq. 72.5_musica_dk ) + call assert( 998852455, daa(4) .eq. -142.64_musica_dk ) + call a_file%get( "not there", daa, my_name, default = dab, found = found ) + call assert( 369345852, .not. found ) + call assert( 611515825, size( daa ) .eq. 2 ) + call assert( 441358921, daa(1) .eq. 83.32_musica_dk ) + call assert( 836152515, daa(2) .eq. -64.23_musica_dk ) + call a_file%get( "also not there", daa, my_name, found = found ) + call assert( 242877146, .not. found ) + + ! get string array + + call a_file%get( "a bunch of strings", saa, my_name ) + call assert( 215424987, size( saa ) .eq. 3 ) + call assert( 834855271, saa(1) .eq. "foo" ) + call assert( 376958811, saa(2) .eq. "bar" ) + call assert( 884070750, saa(3) .eq. "foobar" ) + call a_file%get( "another bunch of strings", saa, my_name, found = found ) + call assert( 821420179, found ) + call assert( 533680623, size( saa ) .eq. 2 ) + call assert( 875899965, saa(1) .eq. "boo" ) + call assert( 135528256, saa(2) .eq. "far" ) + allocate( sab(2) ) + sab(1) = "default 1" + sab(2) = "default 2" + call a_file%get( "a bunch of strings", saa, my_name, default = sab ) + call assert( 802720780, size( saa ) .eq. 3 ) + call assert( 632563876, saa(1) .eq. "foo" ) + call assert( 127357471, saa(2) .eq. "bar" ) + call assert( 857200566, saa(3) .eq. "foobar" ) + call a_file%get( "not there", saa, my_name, default = sab, found = found ) + call assert( 801267541, .not. found ) + call assert( 513527985, size( saa ) .eq. 2 ) + call assert( 120639925, saa(1) .eq. "default 1" ) + call assert( 792644461, saa(2) .eq. "default 2" ) + call a_file%get( "also not there", saa, my_name, found = found ) + call assert( 354743196, .not. found ) + + ! add config + + a = '{ "some int" : 1263 }' + b = '{ "some real" : 14.3, "some string" : "foo" }' + call a%add( "sub props", b, my_name ) + call b%add( "some string", "bar", my_name ) + call b%get( "some string", sa, my_name ) + call assert( 384683830, sa .eq. "bar" ) + call a%get( "some int", ia, my_name ) + call assert( 762415504, ia .eq. 1263 ) + call a%get( "sub props", c, my_name ) + call c%get( "some string", sa, my_name ) + call assert( 643379613, sa .eq. "foo" ) + call c%get( "some real", da, my_name ) + call assert( 252397087, almost_equal( da, 14.3d0 ) ) + + ! add char array + + call a%add( "new char array", "new char array value", my_name ) + call a%get( "some int", ia, my_name ) + call assert( 575490332, ia .eq. 1263 ) + call a%get( "new char array", sa, my_name ) + call assert( 110876326, sa .eq. "new char array value" ) + + ! add string + + sa = "new string value" + call a%add( "new string", sa, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 428870436, ia .eq. 1263 ) + call a%get( "new string", sb, my_name ) + call assert( 258713532, sb .eq. "new string value" ) + + ! add int + + call a%add( "new int", 432, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 601194400, ia .eq. 1263 ) + call a%get( "new int", ia, my_name ) + call assert( 827736624, ia .eq. 432 ) + + ! add float + + call a%add( "new float", 12.75, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 313907139, ia .eq. 1263 ) + call a%get( "new float", ra, my_name ) + call assert( 875498864, almost_equal( ra, 12.75 ) ) + + ! add double + + call a%add( "new double", 53.6d0, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 470628951, ia .eq. 1263 ) + call a%get( "new double", da, my_name ) + call assert( 468723417, almost_equal( da, 53.60d0 ) ) + + ! add logical + + call a%add( "new logical", .true., my_name ) + call a%get( "some int", ia, my_name ) + call assert( 570965443, ia .eq. 1263 ) + call a%get( "new logical", la, my_name ) + call assert( 128861904, la ) + + ! add double array + + if( allocated( daa ) ) deallocate( daa ) + if( allocated( dab ) ) deallocate( dab ) + allocate( daa(2) ) + daa(1) = -32.51_musica_dk + daa(2) = 10.324_musica_dk + call a%add( "new double array", daa, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 971982271, ia .eq. 1263 ) + call a%get( "new double array", dab, my_name ) + call assert( 456247252, size( dab ) .eq. 2 ) + call assert( 115933444, dab(1) .eq. -32.51_musica_dk ) + call assert( 570471131, dab(2) .eq. 10.324_musica_dk ) + + ! add string array + + if( allocated( saa ) ) deallocate( saa ) + if( allocated( sab ) ) deallocate( sab ) + allocate( saa(2) ) + saa(1) = "foo" + saa(2) = "bar" + call a%add( "new string array", saa, my_name ) + call a%get( "some int", ia, my_name ) + call assert( 729592789, ia .eq. 1263 ) + call a%get( "new string array", sab, my_name ) + call assert( 225839623, size( sab ) .eq. 2 ) + call assert( 115426812, sab(1) .eq. "foo" ) + call assert( 275055102, sab(2) .eq. "bar" ) + + ! assignment + + a = '{ "my favorite int" : 42 }' + b = a + call a%add( "my favorite int", 43, my_name ) + call a%get( "my favorite int", ia, my_name ) + call assert( 277177497, ia .eq. 43 ) + call b%get( "my favorite int", ia, my_name ) + call assert( 679211194, ia .eq. 42 ) + sa = '{ "another int" : 532 }' + c = sa + call c%get( "another int", ia, my_name ) + call assert( 842650552, ia .eq. 532 ) + + ! iterator + a = '{ "my int" : 2,'//& + ' "my real" : 4.2,'//& + ' "my double" : 5.2,'//& + ' "my logical" : true,'//& + ' "my string" : "foo bar",'//& + ' "my sub config" : { "an int" : 3, "a double" : 6.7 },'//& + ' "my string array" : [ "foo", "bar", "foobar" ] }' + call assert( 494127713, a%number_of_children( ) .eq. 7 ) + iterator => a%get_iterator( ) + call assert( 909667855, iterator%next( ) ) + call assert( 432671110, a%key( iterator ) .eq. "my int" ) + call a%get( iterator, ia, my_name ) + call assert( 227587000, ia .eq. 2 ) + call assert( 217058386, iterator%next( ) ) + call a%get( iterator, ra, my_name ) + call assert( 391026358, almost_equal( ra, 4.2 ) ) + call assert( 270084933, iterator%next( ) ) + call a%get( iterator, da, my_name ) + call assert( 384308812, almost_equal( da, 5.2d0 ) ) + call assert( 826412351, iterator%next( ) ) + call a%get( iterator, la, my_name ) + call assert( 258103080, la ) + call assert( 147690269, iterator%next( ) ) + call a%get( iterator, sa, my_name ) + call assert( 361110121, sa .eq. "foo bar" ) + call assert( 468164159, iterator%next( ) ) + call a%get( iterator, b, my_name ) + call b%get( "a double", da, my_name ) + call assert( 749186169, almost_equal( da, 6.7d0 ) ) + call b%get( "an int", ia, my_name ) + call assert( 915984300, ia .eq. 3 ) + call assert( 182782432, iterator%next( ) ) + call a%get( iterator, saa, my_name ) + call assert( 902549208, saa(1) .eq. "foo" ) + call assert( 334239937, saa(2) .eq. "bar" ) + call assert( 164083033, saa(3) .eq. "foobar" ) + call assert( 441293975, .not. iterator%next( ) ) + call iterator%reset( ) + call assert( 102885701, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 162629794, ia .eq. 2 ) + deallocate( iterator ) + + ! sequence iterator + a = '[ 2, 3, "foo", { "bar": 4 } ]' + call assert( 443487346, a%number_of_children( ) .eq. 4 ) + iterator => a%get_iterator( ) + call assert( 447298414, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 612191011, ia .eq. 2 ) + call assert( 442034107, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 889401953, ia .eq. 3 ) + call assert( 101720299, iterator%next( ) ) + call a%get( iterator, sa, my_name ) + call assert( 214038644, sa .eq. "foo" ) + call assert( 661406490, iterator%next( ) ) + call a%get( iterator, b, my_name ) + call b%get( "bar", ia, my_name ) + call assert( 208774337, ia .eq. 4 ) + call assert( 103625833, .not. iterator%next( ) ) + call iterator%reset( ) + call assert( 685807284, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 233175131, ia .eq. 2 ) + call assert( 410501876, iterator%next( ) ) + call a%get( iterator, ia, my_name ) + call assert( 857869722, ia .eq. 3 ) + call assert( 122762320, iterator%next( ) ) + call a%get( iterator, sa, my_name ) + call assert( 852605415, sa .eq. "foo" ) + call assert( 682448511, iterator%next( ) ) + call a%get( iterator, b, my_name ) + call b%get( "bar", ia, my_name ) + call assert( 229816358, ia .eq. 4 ) + call assert( 124667854, .not. iterator%next( ) ) + deallocate( iterator ) + + ! empty object iterator + a = "" + call assert( 753171096, a%number_of_children( ) .eq. 0 ) + iterator => a%get_iterator( ) + call assert( 358377502, .not. iterator%next( ) ) + deallocate( iterator ) + + ! merging + a = '{ "a key" : 12,'//& + ' "another key" : 14.2,'//& + ' "sub stuff" : {'//& + ' "orig key" : 72'//& + ' },'//& + ' "yet another key" : "hi" }' + b = '{ "a new key" : true, '//& + ' "sub stuff" : {'//& + ' "new key" : "foo"'//& + ' },'//& + ' "another new key" : 51 }' + call a%merge_in( b, my_name ) + call a%get( "a key", ia, my_name ) + call assert( 111746421, ia .eq. 12 ) + call a%get( "another key", da, my_name ) + call assert( 838230743, almost_equal( da, 14.2d0 ) ) + call a%get( "yet another key", sa, my_name ) + call assert( 259845153, sa .eq. "hi" ) + call a%get( "a new key", la, my_name ) + call assert( 879275437, la ) + call a%get( "another new key", ia, my_name ) + call assert( 756880773, ia .eq. 51 ) + call a%get( "sub stuff", c, my_name ) + call c%get( "orig key", ia, my_name ) + call assert( 172568249, ia .eq. 72 ) + call c%get( "new key", sa, my_name ) + call b%get( "a new key", la, my_name ) + call assert( 816624866, la ) + call b%get( "another new key", ia, my_name ) + call assert( 877822198, ia .eq. 51 ) + call b%get( "sub stuff", c, my_name ) + call c%get( "new key", sa, my_name ) + call assert( 597877923, sa .eq. "foo" ) + call c%get( "orig key", ia, my_name, found = found ) + call assert( 933379719, .not. found ) + call b%get( "a key", ia, my_name, found = found ) + call assert( 597164102, .not. found ) + call b%get( "another key", da, my_name, found = found ) + call assert( 293082976, .not. found ) + call b%get( "yet another key", sa, my_name, found = found ) + call assert( 907248953, .not. found ) + + ! get and set config array + allocate( orig_array( 3 ) ) + call orig_array( 1 )%empty( ) + call orig_array( 1 )%add( "a key", "a", my_name ) + call orig_array( 1 )%add( "same key", "same value", my_name ) + call orig_array( 2 )%empty( ) + call orig_array( 2 )%add( "b key", "b", my_name ) + call orig_array( 2 )%add( "same key", "same value", my_name ) + call orig_array( 3 )%empty( ) + call orig_array( 3 )%add( "c key", "c", my_name ) + call orig_array( 3 )%add( "same key", "same value", my_name ) + call array%empty( ) + call array%add( "my array", orig_array, my_name ) + deallocate( orig_array ) + call array%get( "my array", dest_array, my_name ) + call assert( 706554286, allocated( dest_array ) ) + call assert( 874805656, size( dest_array ) .eq. 3 ) + call dest_array( 1 )%get( "a key", sa, my_name ) + call assert( 308401919, sa .eq. "a" ) + call dest_array( 2 )%get( "b key", sa, my_name ) + call assert( 475200050, sa .eq. "b" ) + call dest_array( 3 )%get( "c key", sa, my_name ) + call assert( 640092647, sa .eq. "c" ) + deallocate( dest_array ) + call array%get( "my array", b, my_name ) + iterator => b%get_iterator( ) + call assert( 259072462, b%number_of_children( ) .eq. 3 ) + do while( iterator%next( ) ) + call b%get( iterator, a, my_name ) + call a%get( "same key", sa, my_name ) + call assert( 322175328, sa .eq. "same value" ) + end do + deallocate( iterator ) + + ! string assignment + + a = '{ "foo": 12, "bar": false }' + sa = a + b = sa + call assert( 618824101, b%number_of_children( ) .eq. 2 ) + call b%get( "foo", ia, my_name ) + call assert( 733047980, ia .eq. 12 ) + call b%get( "bar", la, my_name ) + call assert( 787527766, .not. la ) + + ! JSON/YAML validation + a = '{ "a reqd key": 12.3,'// & + ' "an optional key": "abcd",'// & + ' "another reqd key": false,'// & + ' "__a user key": { "foo": "bar" } }' + if( allocated( saa ) ) deallocate( saa ) + if( allocated( sab ) ) deallocate( sab ) + allocate( saa( 2 ) ) + allocate( sab( 2 ) ) + saa(1) = "a reqd key" + saa(2) = "another reqd key" + sab(1) = "an optional key" + sab(2) = "another optional key" + call assert( 645591305, a%validate( saa, sab ) ) + deallocate( saa ) + allocate( saa( 1 ) ) + saa(1) = "a reqd key" + call assert( 264571120, .not. a%validate( saa, sab ) ) + + end subroutine test_config_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test the \c config_t example code + subroutine config_example( ) + +use musica_config, only : config_t +use musica_constants, only : musica_dk, musica_ik +use musica_iterator, only : iterator_t +use musica_string, only : string_t + +character(len=*), parameter :: my_name = "config file example" +type(config_t) :: main_config, sub_config, sub_real_config +real(musica_dk) :: my_real +integer(musica_ik) :: my_int +type(string_t) :: my_string +class(iterator_t), pointer :: iter +logical :: found + +call main_config%from_file( 'test/data/config_example.json' ) + +! this would fail with an error if 'a string' is not found +call main_config%get( "a string", my_string, my_name ) +write(*,*) "a string value: ", my_string%val_ + +! add the found argument to avoid failure if the pair is not found +call main_config%get( "my int", my_int, my_name, found = found ) +if( found ) then + write(*,*) "my int value: ", my_int +else + write(*,*) "'my int' was not found" +end if + +! when you get a subset of the properties, a new config_t object is +! created containing the subset data. The two config_t objects are +! independent of one another after this point. +call main_config%get( "other props", sub_config, my_name ) +call sub_config%get( "an int", my_int, my_name ) +write(*,*) "other props->an int value: ", my_int + +! you can iterate over a set of key-value pairs. but remember that +! the order is always arbitrary. you also must provide the right type +! of variable for the values. +call main_config%get( "real props", sub_real_config, my_name ) +iter => sub_real_config%get_iterator( ) +do while( iter%next( ) ) + my_string = sub_real_config%key( iter ) + call sub_real_config%get( iter, my_real, my_name ) + write(*,*) my_string%val_, " value: ", my_real +end do + +! you can also get the number of child objects before iterating over +! them, if you want to allocate an array or something first +write(*,*) "number of children: ", sub_real_config%number_of_children( ) + +! you can add key-value pairs with the add function +call main_config%add( "my new int", 43, my_name ) +call main_config%get( "my new int", my_int, my_name ) +write(*,*) "my new int value: ", my_int + +! clean up memory +deallocate( iter ) + + end subroutine config_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_config diff --git a/test/unit/util/io/CMakeLists.txt b/test/unit/util/io/CMakeLists.txt new file mode 100644 index 00000000..fe480cd3 --- /dev/null +++ b/test/unit/util/io/CMakeLists.txt @@ -0,0 +1,17 @@ +################################################################################ +# Test utilities + +include(test_util) + +################################################################################ +# IO Utility tests + +# There is a small memory leak in the NetCDF library code when +# creating a new file, so skip the memory check +# Also, since this creates a file, don't run with multiple cores +add_executable(test_util_io_netcdf netcdf.F90) +target_link_libraries(test_util_io_netcdf PUBLIC musica::tuvx) +target_include_directories(test_util_io_netcdf PUBLIC ${CMAKE_BINARY_DIR}/src) +add_test(NAME util_io_netcdf COMMAND ${CMAKE_BINARY_DIR}/test_util_io_netcdf) + +################################################################################ diff --git a/test/unit/util/io/netcdf.F90 b/test/unit/util/io/netcdf.F90 new file mode 100644 index 00000000..a0178d96 --- /dev/null +++ b/test/unit/util/io/netcdf.F90 @@ -0,0 +1,623 @@ +! Copyright (C) 2021 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> The test_io_netcdf program + +!> Tests for the io_netcdf_t type +program test_io_netcdf + + use musica_assert + use musica_io_netcdf + use musica_string, only : string_t + + implicit none + + integer :: stat + type(string_t) :: file_name + + ! Test read functions with an existing NetCDF file + file_name = "../../../data/io_netcdf_test_data.nc" + call test_read_netcdf( file_name ) + + ! Test creating the same file with write functions and testing it + ! (delete any files from previous tests first) + file_name = "test_io_netcdf_write.nc" + open( unit = 16, iostat = stat, file = file_name%to_char( ), status = 'old' ) + if( stat == 0 ) close( 16, status = 'delete' ) + call test_write_netcdf( file_name ) + call test_read_netcdf( file_name ) + + ! Test append functions + ! (delete any files from previous tests first) + file_name = "test_io_netcdf_append.nc" + open( unit = 16, iostat = stat, file = file_name%to_char( ), status = 'old' ) + if( stat == 0 ) close( 16, status = 'delete' ) + call test_append_netcdf( file_name ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests NetCDF functions using a file that is expected to be in a known + !! state. + subroutine test_read_netcdf( file_name ) + + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + + type(string_t), intent(in) :: file_name + + character(len=*), parameter :: my_name = "io_netcdf_t read tests" + class(io_t), pointer :: my_file + type(string_t) :: var_name + real(kind=dk) :: real0D + real(kind=dk), allocatable :: real1D(:) + real(kind=dk), allocatable :: real2D(:,:) + real(kind=dk), allocatable :: real3D(:,:,:) + real(kind=dk), allocatable :: real4D(:,:,:,:) + integer :: int0D + integer, allocatable :: int1D(:) + type(string_t), allocatable :: dim_names(:) + + my_file => io_netcdf_t( file_name ) + call assert( 312726817, associated( my_file ) ) + + ! check units + var_name = "foo" + call assert( 600672797, my_file%variable_units( var_name, my_name ) & + .eq. "foobits" ) + + ! check for variables + var_name = "foo" + call assert( 745691162, my_file%exists( var_name, my_name ) ) + call assert( 852745200, .not. my_file%exists( "not there", my_name ) ) + + ! scalar real + var_name = "qux" + call my_file%read( var_name, real0D, my_name ) + call assert( 322376438, real0D .eq. 92.37_dk ) + + ! scalar int + var_name = "quux" + call my_file%read( var_name, int0D, my_name ) + call assert( 330171719, int0D .eq. 7 ) + + ! unallocated 1D real + var_name = "foo" + call my_file%read( var_name, real1D, my_name ) + call assert( 441036825, allocated( real1D ) ) + call assert( 442942359, size( real1D ) .eq. 4 ) + call assert( 567529680, almost_equal( real1D( 1 ), 15.32_dk ) ) + call assert( 846646156, almost_equal( real1D( 2 ), 3.14_dk ) ) + call assert( 394014003, almost_equal( real1D( 3 ), 26.71_dk ) ) + call assert( 558906600, almost_equal( real1D( 4 ), 19.34_dk ) ) + deallocate( real1D ) + + ! pre-allocatted 1D real + allocate( real1D( 3 ) ) + var_name = "bar" + call my_file%read( var_name, real1D, my_name ) + call assert( 329457898, allocated( real1D ) ) + call assert( 889144089, size( real1D ) .eq. 3 ) + call assert( 155942221, almost_equal( real1D( 1 ), 51.43_dk ) ) + call assert( 885785316, almost_equal( real1D( 2 ), 123.01_dk ) ) + call assert( 150677914, almost_equal( real1D( 3 ), 32.61_dk ) ) + deallocate( real1D ) + + ! unallocated 1D int + var_name = "quuz" + call my_file%read( var_name, int1D, my_name ) + call assert( 595878700, allocated( int1D ) ) + call assert( 820515390, size( int1D ) .eq. 4 ) + call assert( 145152081, int1D( 1 ) .eq. 9 ) + call assert( 199631867, int1D( 2 ) .eq. 3 ) + call assert( 364524464, int1D( 3 ) .eq. 12 ) + call assert( 811892310, int1D( 4 ) .eq. 1 ) + deallocate( int1D ) + + ! pre-allocated 1D int + allocate( int1D( 4 ) ) + var_name = "quuz" + call my_file%read( var_name, int1D, my_name ) + call assert( 917493109, allocated( int1D ) ) + call assert( 182385707, size( int1D ) .eq. 4 ) + call assert( 977237202, int1D( 1 ) .eq. 9 ) + call assert( 807080298, int1D( 2 ) .eq. 3 ) + call assert( 971972895, int1D( 3 ) .eq. 12 ) + call assert( 519340742, int1D( 4 ) .eq. 1 ) + deallocate( int1D ) + + ! unallocated 2D real + var_name = "baz" + call my_file%read( var_name, real2D, my_name ) + call assert( 910775563, allocated( real2D ) ) + call assert( 517887503, size( real2D, 1 ) .eq. 3 ) + call assert( 454784637, size( real2D, 2 ) .eq. 4 ) + call assert( 961896576, almost_equal( real2D( 1, 1 ), 31.2_dk ) ) + call assert( 337654280, almost_equal( real2D( 2, 1 ), 41.3_dk ) ) + call assert( 785022126, almost_equal( real2D( 3, 1 ), 623.34_dk ) ) + call assert( 332389973, almost_equal( real2D( 1, 2 ), 124.24_dk ) ) + call assert( 227241469, almost_equal( real2D( 2, 2 ), 1592.3_dk ) ) + call assert( 674609315, almost_equal( real2D( 3, 2 ), 42.53_dk ) ) + call assert( 221977162, almost_equal( real2D( 1, 3 ), 1.3e-7_dk ) ) + call assert( 669345008, almost_equal( real2D( 2, 3 ), -31.6_dk ) ) + call assert( 499188104, almost_equal( real2D( 3, 3 ), 82.3_dk ) ) + call assert( 111564351, almost_equal( real2D( 1, 4 ), 51.64_dk ) ) + call assert( 558932197, almost_equal( real2D( 2, 4 ), -61.7_dk ) ) + call assert( 106300044, almost_equal( real2D( 3, 4 ), -423000.0_dk ) ) + deallocate( real2D ) + + ! pre-allocated 2D real + allocate( real2D( 3, 4 ) ) + call my_file%read( var_name, real2D, my_name ) + call assert( 301447195, allocated( real2D ) ) + call assert( 748815041, size( real2D, 1 ) .eq. 3 ) + call assert( 861133386, size( real2D, 2 ) .eq. 4 ) + call assert( 408501233, almost_equal( real2D( 1, 1 ), 31.2_dk ) ) + call assert( 303352729, almost_equal( real2D( 2, 1 ), 41.3_dk ) ) + call assert( 133195825, almost_equal( real2D( 3, 1 ), 623.34_dk ) ) + call assert( 863038920, almost_equal( real2D( 1, 2 ), 124.24_dk ) ) + call assert( 410406767, almost_equal( real2D( 2, 2 ), 1592.3_dk ) ) + call assert( 857774613, almost_equal( real2D( 3, 2 ), 42.53_dk ) ) + call assert( 405142460, almost_equal( real2D( 1, 3 ), 1.3e-7_dk ) ) + call assert( 234985556, almost_equal( real2D( 2, 3 ), -31.6_dk ) ) + call assert( 129837052, almost_equal( real2D( 3, 3 ), 82.3_dk ) ) + call assert( 577204898, almost_equal( real2D( 1, 4 ), 51.64_dk ) ) + call assert( 742097495, almost_equal( real2D( 2, 4 ), -61.7_dk ) ) + call assert( 854415840, almost_equal( real2D( 3, 4 ), -423000.0_dk ) ) + deallocate( real2D ) + + ! 3D unallocated variable + var_name = "foobar" + call my_file%read( var_name, real3D, my_name ) + call assert( 628827846, allocated( real3D ) ) + call assert( 688571939, size( real3D, 1 ) .eq. 1 ) + call assert( 230675479, size( real3D, 2 ) .eq. 3 ) + call assert( 125526975, size( real3D, 3 ) .eq. 4 ) + call assert( 850105763, almost_equal( real3D( 1, 1, 1 ), 532.123_dk ) ) + call assert( 231414897, almost_equal( real3D( 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 343733242, almost_equal( real3D( 1, 3, 1 ), 42.5_dk ) ) + call assert( 723638505, almost_equal( real3D( 1, 1, 2 ), 39.25_dk ) ) + call assert( 835956850, almost_equal( real3D( 1, 2, 2 ), 4293.12_dk ) ) + call assert( 383324697, almost_equal( real3D( 1, 3, 2 ), 9753.231_dk ) ) + call assert( 926217023, almost_equal( real3D( 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 473584870, almost_equal( real3D( 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 368436366, almost_equal( real3D( 1, 3, 3 ), 7264.12_dk ) ) + call assert( 133271062, almost_equal( real3D( 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 757965653, almost_equal( real3D( 1, 2, 4 ), 13.2_dk ) ) + call assert( 310597807, almost_equal( real3D( 1, 3, 4 ), 8293.12_dk ) ) + deallocate( real3D ) + + ! 3D pre-allocated variable + var_name = "foobar" + allocate( real3D( 1, 3, 4 ) ) + call my_file%read( var_name, real3D, my_name ) + call assert( 506458779, allocated( real3D ) ) + call assert( 618777124, size( real3D, 1 ) .eq. 1 ) + call assert( 166144971, size( real3D, 2 ) .eq. 3 ) + call assert( 895988066, size( real3D, 3 ) .eq. 4 ) + call assert( 443355913, almost_equal( real3D( 1, 1, 1 ), 532.123_dk ) ) + call assert( 338207409, almost_equal( real3D( 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 168050505, almost_equal( real3D( 1, 3, 1 ), 42.5_dk ) ) + call assert( 615418351, almost_equal( real3D( 1, 1, 2 ), 39.25_dk ) ) + call assert( 727736696, almost_equal( real3D( 1, 2, 2 ), 4293.12_dk ) ) + call assert( 892629293, almost_equal( real3D( 1, 3, 2 ), 9753.231_dk ) ) + call assert( 439997140, almost_equal( real3D( 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 334848636, almost_equal( real3D( 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 164691732, almost_equal( real3D( 1, 3, 3 ), 7264.12_dk ) ) + call assert( 612059578, almost_equal( real3D( 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 441902674, almost_equal( real3D( 1, 2, 4 ), 13.2_dk ) ) + call assert( 606795271, almost_equal( real3D( 1, 3, 4 ), 8293.12_dk ) ) + deallocate( real3D ) + + ! 4D unallocated variable + var_name = "corge" + call my_file%read( var_name, real4D, my_name ) + call assert( 464572470, allocated( real4D ) ) + call assert( 911940316, size( real4D, 1 ) .eq. 2 ) + call assert( 124258662, size( real4D, 2 ) .eq. 1 ) + call assert( 571626508, size( real4D, 3 ) .eq. 3 ) + call assert( 118994355, size( real4D, 4 ) .eq. 4 ) + call assert( 913845850, almost_equal( real4D( 1, 1, 1, 1 ), 532.123_dk ) ) + call assert( 743688946, almost_equal( real4D( 2, 1, 1, 1 ), 632.123_dk ) ) + call assert( 291056793, almost_equal( real4D( 1, 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 738424639, almost_equal( real4D( 2, 1, 2, 1 ), 2.5e28_dk ) ) + call assert( 285792486, almost_equal( real4D( 1, 1, 3, 1 ), 42.5_dk ) ) + call assert( 115635582, almost_equal( real4D( 2, 1, 3, 1 ), 52.5_dk ) ) + call assert( 227953927, almost_equal( real4D( 1, 1, 1, 2 ), 39.25_dk ) ) + call assert( 221236381, almost_equal( real4D( 2, 1, 1, 2 ), 49.25_dk ) ) + call assert( 398563126, almost_equal( real4D( 1, 1, 2, 2 ), 4293.12_dk ) ) + call assert( 563455723, almost_equal( real4D( 2, 1, 2, 2 ), 5293.12_dk ) ) + call assert( 170567663, almost_equal( real4D( 1, 1, 3, 2 ), 9753.231_dk ) ) + call assert( 335460260, almost_equal( real4D( 2, 1, 3, 2 ), 1753.231_dk ) ) + call assert( 782828106, almost_equal( real4D( 1, 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 395204353, almost_equal( real4D( 2, 1, 1, 3 ), 4.25e-19_dk ) ) + call assert( 225047449, almost_equal( real4D( 1, 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 389940046, almost_equal( real4D( 2, 1, 2, 3 ), 5.629e10_dk ) ) + call assert( 554832643, almost_equal( real4D( 1, 1, 3, 3 ), 7264.12_dk ) ) + call assert( 384675739, almost_equal( real4D( 2, 1, 3, 3 ), 8264.12_dk ) ) + call assert( 897051985, almost_equal( real4D( 1, 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 444419832, almost_equal( real4D( 2, 1, 1, 4 ), 9.4918e7_dk ) ) + call assert( 556738177, almost_equal( real4D( 1, 1, 2, 4 ), 13.2_dk ) ) + call assert( 104106024, almost_equal( real4D( 2, 1, 2, 4 ), 23.2_dk ) ) + call assert( 551473870, almost_equal( real4D( 1, 1, 3, 4 ), 8293.12_dk ) ) + call assert( 446325366, almost_equal( real4D( 2, 1, 3, 4 ), 9293.12_dk ) ) + deallocate( real4D ) + + ! 4D allocated variable + var_name = "corge" + allocate( real4D( 2, 1, 3, 4 ) ) + call my_file%read( var_name, real4D, my_name ) + call assert( 493635311, allocated( real4D ) ) + call assert( 106011558, size( real4D, 1 ) .eq. 2 ) + call assert( 553379404, size( real4D, 2 ) .eq. 1 ) + call assert( 100747251, size( real4D, 3 ) .eq. 3 ) + call assert( 830590346, size( real4D, 4 ) .eq. 4 ) + call assert( 660433442, almost_equal( real4D( 1, 1, 1, 1 ), 532.123_dk ) ) + call assert( 207801289, almost_equal( real4D( 2, 1, 1, 1 ), 632.123_dk ) ) + call assert( 102652785, almost_equal( real4D( 1, 1, 2, 1 ), 1.5e28_dk ) ) + call assert( 550020631, almost_equal( real4D( 2, 1, 2, 1 ), 2.5e28_dk ) ) + call assert( 997388477, almost_equal( real4D( 1, 1, 3, 1 ), 42.5_dk ) ) + call assert( 262281075, almost_equal( real4D( 2, 1, 3, 1 ), 52.5_dk ) ) + call assert( 157132571, almost_equal( real4D( 1, 1, 1, 2 ), 39.25_dk ) ) + call assert( 886975666, almost_equal( real4D( 2, 1, 1, 2 ), 49.25_dk ) ) + call assert( 151868264, almost_equal( real4D( 1, 1, 2, 2 ), 4293.12_dk ) ) + call assert( 264186609, almost_equal( real4D( 2, 1, 2, 2 ), 5293.12_dk ) ) + call assert( 711554455, almost_equal( real4D( 1, 1, 3, 2 ), 9753.231_dk ) ) + call assert( 258922302, almost_equal( real4D( 2, 1, 3, 2 ), 1753.231_dk ) ) + call assert( 771298548, almost_equal( real4D( 1, 1, 1, 3 ), 3.25e-19_dk ) ) + call assert( 601141644, almost_equal( real4D( 2, 1, 1, 3 ), 4.25e-19_dk ) ) + call assert( 766034241, almost_equal( real4D( 1, 1, 2, 3 ), 4.629e10_dk ) ) + call assert( 313402088, almost_equal( real4D( 2, 1, 2, 3 ), 5.629e10_dk ) ) + call assert( 208253584, almost_equal( real4D( 1, 1, 3, 3 ), 7264.12_dk ) ) + call assert( 655621430, almost_equal( real4D( 2, 1, 3, 3 ), 8264.12_dk ) ) + call assert( 202989277, almost_equal( real4D( 1, 1, 1, 4 ), 8.4918e7_dk ) ) + call assert( 932832372, almost_equal( real4D( 2, 1, 1, 4 ), 9.4918e7_dk ) ) + call assert( 762675468, almost_equal( real4D( 1, 1, 2, 4 ), 13.2_dk ) ) + call assert( 874993813, almost_equal( real4D( 2, 1, 2, 4 ), 23.2_dk ) ) + call assert( 139886411, almost_equal( real4D( 1, 1, 3, 4 ), 8293.12_dk ) ) + call assert( 317213156, almost_equal( real4D( 2, 1, 3, 4 ), 9293.12_dk ) ) + deallocate( real4D ) + + ! dimension names + var_name = "qux" + dim_names = my_file%variable_dimensions( var_name, my_name ) + call assert( 685336671, allocated( dim_names ) ) + call assert( 410031263, size( dim_names ) .eq. 0 ) + deallocate( dim_names ) + + var_name = "corge" + dim_names = my_file%variable_dimensions( var_name, my_name ) + call assert( 513726528, allocated( dim_names ) ) + call assert( 562942007, size( dim_names ) .eq. 4 ) + call assert( 282372292, dim_names( 1 ) .eq. "i" ) + call assert( 619327327, dim_names( 2 ) .eq. "h" ) + call assert( 166695174, dim_names( 3 ) .eq. "g" ) + call assert( 896538269, dim_names( 4 ) .eq. "f" ) + deallocate( dim_names ) + + ! clean up + deallocate( my_file ) + + end subroutine test_read_netcdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests NetCDF write functions to generate a NetCDF file that is in the + !! state expected by `test_read_netcdf( )` + subroutine test_write_netcdf( file_name ) + + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + + type(string_t), intent(in) :: file_name + + character(len=*), parameter :: my_name = "io_netcdf_t write tests" + class(io_t), pointer :: my_file + type(string_t) :: var_name, units + type(string_t) :: dim_names(4) + real(kind=dk), allocatable :: real2D(:,:) + real(kind=dk), allocatable :: real3D(:,:,:) + real(kind=dk), allocatable :: real4D(:,:,:,:) + + my_file => io_netcdf_t( file_name ) + call assert( 362264371, associated( my_file ) ) + + var_name = "qux" + call my_file%write( var_name, 92.37_dk, my_name ) + + var_name = "foo" + dim_names(1) = "f" + units = "foobits" + call my_file%write( var_name, dim_names(1), & + (/ 15.32_dk, 3.14_dk, 26.71_dk, 19.34_dk /), my_name ) + call my_file%set_variable_units( var_name, units, my_name ) + + var_name = "bar" + dim_names(1) = "g" + call my_file%write( var_name, dim_names(1), & + (/ 51.43_dk, 123.01_dk, 32.61_dk /), my_name ) + + var_name = "baz" + dim_names(1) = "g" + dim_names(2) = "f" + allocate( real2D( 3, 4 ) ) + real2D(:,1) = (/ 31.2_dk, 41.3_dk, 623.34_dk /) + real2D(:,2) = (/ 124.24_dk, 1592.3_dk, 42.53_dk /) + real2D(:,3) = (/ 1.3e-7_dk, -31.6_dk, 82.3_dk /) + real2D(:,4) = (/ 51.64_dk, -61.7_dk, -423000.0_dk /) + call my_file%write( var_name, dim_names(1:2), real2D, my_name ) + + var_name = "foobar" + dim_names(1) = "h" + dim_names(2) = "g" + dim_names(3) = "f" + allocate( real3D( 1, 3, 4 ) ) + real3D(1,:,1) = (/ 532.123_dk, 1.5e+28_dk, 42.5_dk /) + real3D(1,:,2) = (/ 39.25_dk, 4293.12_dk, 9753.231_dk /) + real3D(1,:,3) = (/ 3.25e-19_dk, 46290000000.0_dk, 7264.12_dk /) + real3D(1,:,4) = (/ 84918000.0_dk, 13.2_dk, 8293.12_dk /) + call my_file%write( var_name, dim_names(1:3), real3D, my_name ) + + var_name = "corge" + dim_names(1) = "i" + dim_names(2) = "h" + dim_names(3) = "g" + dim_names(4) = "f" + allocate( real4D( 2, 1, 3, 4 ) ) + real4D(:,1,1,1) = (/ 532.123_dk, 632.123_dk /) + real4D(:,1,2,1) = (/ 1.5e+28_dk, 2.5e+28_dk /) + real4D(:,1,3,1) = (/ 42.5_dk, 52.5_dk /) + real4D(:,1,1,2) = (/ 39.25_dk, 49.25_dk /) + real4D(:,1,2,2) = (/ 4293.12_dk, 5293.12_dk /) + real4D(:,1,3,2) = (/ 9753.231_dk, 1753.231_dk /) + real4D(:,1,1,3) = (/ 3.25e-19_dk, 4.25e-19_dk /) + real4D(:,1,2,3) = (/ 46290000000.0_dk, 56290000000.0_dk /) + real4D(:,1,3,3) = (/ 7264.12_dk, 8264.12_dk /) + real4D(:,1,1,4) = (/ 84918000.0_dk, 94918000.0_dk /) + real4D(:,1,2,4) = (/ 13.2_dk, 23.2_dk /) + real4D(:,1,3,4) = (/ 8293.12_dk, 9293.12_dk /) + call my_file%write( var_name, dim_names(1:4), real4D, my_name ) + + var_name = "quux" + call my_file%write( var_name, 7, my_name ) + + var_name = "quuz" + dim_names(1) = "f" + call my_file%write( var_name, dim_names(1), (/ 9, 3, 12, 1 /), my_name ) + + ! clean up + deallocate( my_file ) + + end subroutine test_write_netcdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Tests NetCDF append functions + subroutine test_append_netcdf( file_name ) + + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + + type(string_t), intent(in) :: file_name + + character(len=*), parameter :: my_name = "io_netcdf_t append tests" + class(io_t), pointer :: my_file + type(string_t) :: var_name, units + type(string_t) :: dim_names(4), append_dim + integer, allocatable :: int1D(:) + real(kind=dk), allocatable :: real1D(:) + real(kind=dk), allocatable :: real2D(:,:) + real(kind=dk), allocatable :: real3D(:,:,:) + real(kind=dk), allocatable :: real4D(:,:,:,:) + + my_file => io_netcdf_t( file_name ) + + ! 1D real + var_name = "foo" + append_dim = "f" + units = "foobits" + call my_file%append( var_name, units, append_dim, 1, 15.32_dk, my_name ) + call my_file%append( var_name, units, append_dim, 2, 3.14_dk, my_name ) + call my_file%append( var_name, units, append_dim, 3, 26.71_dk, my_name ) + call my_file%append( var_name, units, append_dim, 4, 19.34_dk, my_name ) + + ! 2D real + var_name = "baz" + append_dim = "f" + dim_names(1) = "g" + allocate( real1D( 3 ) ) + real1D(:) = (/ 31.2_dk, 41.3_dk, 623.34_dk /) + call my_file%append( var_name, units, append_dim, 1, dim_names(1), real1D,& + my_name ) + real1D(:) = (/ 124.24_dk, 1592.3_dk, 42.53_dk /) + call my_file%append( var_name, units, append_dim, 2, dim_names(1), real1D,& + my_name ) + real1D(:) = (/ 1.3e-7_dk, -31.6_dk, 82.3_dk /) + call my_file%append( var_name, units, append_dim, 3, dim_names(1), real1D,& + my_name ) + real1D(:) = (/ 51.64_dk, -61.7_dk, -423000.0_dk /) + call my_file%append( var_name, units, append_dim, 4, dim_names(1), real1D,& + my_name ) + deallocate( real1D ) + + ! 3D real + var_name = "foobar" + append_dim = "f" + dim_names(1) = "h" + dim_names(2) = "g" + allocate( real2D( 1, 3 ) ) + real2D(1,:) = (/ 532.123_dk, 1.5e+28_dk, 42.5_dk /) + call my_file%append( var_name, units, append_dim, 1, dim_names, real2D, & + my_name ) + real2D(1,:) = (/ 39.25_dk, 4293.12_dk, 9753.231_dk /) + call my_file%append( var_name, units, append_dim, 2, dim_names, real2D, & + my_name ) + real2D(1,:) = (/ 3.25e-19_dk, 46290000000.0_dk, 7264.12_dk /) + call my_file%append( var_name, units, append_dim, 3, dim_names, real2D, & + my_name ) + real2D(1,:) = (/ 84918000.0_dk, 13.2_dk, 8293.12_dk /) + call my_file%append( var_name, units, append_dim, 4, dim_names, real2D, & + my_name ) + deallocate( real2D ) + + ! 4D real + var_name = "corge" + append_dim = "f" + dim_names(1) = "i" + dim_names(2) = "h" + dim_names(3) = "g" + allocate( real3D( 2, 1, 3 ) ) + real3D(:,1,1) = (/ 532.123_dk, 632.123_dk /) + real3D(:,1,2) = (/ 1.5e+28_dk, 2.5e+28_dk /) + real3D(:,1,3) = (/ 42.5_dk, 52.5_dk /) + call my_file%append( var_name, units, append_dim, 1, dim_names, real3D, & + my_name ) + real3D(:,1,1) = (/ 39.25_dk, 49.25_dk /) + real3D(:,1,2) = (/ 4293.12_dk, 5293.12_dk /) + real3D(:,1,3) = (/ 9753.231_dk, 1753.231_dk /) + call my_file%append( var_name, units, append_dim, 2, dim_names, real3D, & + my_name ) + real3D(:,1,1) = (/ 3.25e-19_dk, 4.25e-19_dk /) + real3D(:,1,2) = (/ 46290000000.0_dk, 56290000000.0_dk /) + real3D(:,1,3) = (/ 7264.12_dk, 8264.12_dk /) + call my_file%append( var_name, units, append_dim, 3, dim_names, real3D, & + my_name ) + real3D(:,1,1) = (/ 84918000.0_dk, 94918000.0_dk /) + real3D(:,1,2) = (/ 13.2_dk, 23.2_dk /) + real3D(:,1,3) = (/ 8293.12_dk, 9293.12_dk /) + call my_file%append( var_name, units, append_dim, 4, dim_names, real3D, & + my_name ) + deallocate( real3D ) + + ! 1D int + var_name = "quuz" + append_dim = "f" + call my_file%append( var_name, units, append_dim, 1, 9, my_name ) + call my_file%append( var_name, units, append_dim, 2, 3, my_name ) + call my_file%append( var_name, units, append_dim, 3, 12, my_name ) + call my_file%append( var_name, units, append_dim, 4, 1, my_name ) + + deallocate( my_file ) + + + !! Check appended data !! + + my_file => io_netcdf_t( file_name ) + call assert( 829668994, associated( my_file ) ) + + ! check units + var_name = "foo" + call assert( 606937838, my_file%variable_units( var_name, my_name ) & + .eq. "foobits" ) + + ! check for variables + var_name = "foo" + call assert( 154305685, my_file%exists( var_name, my_name ) ) + call assert( 601673531, .not. my_file%exists( "not there", my_name ) ) + + ! 1D real + var_name = "foo" + call my_file%read( var_name, real1D, my_name ) + call assert( 214049778, allocated( real1D ) ) + call assert( 661417624, size( real1D ) .eq. 4 ) + call assert( 826310221, almost_equal( real1D( 1 ), 15.32_dk ) ) + call assert( 373678068, almost_equal( real1D( 2 ), 3.14_dk ) ) + call assert( 886054314, almost_equal( real1D( 3 ), 26.71_dk ) ) + call assert( 433422161, almost_equal( real1D( 4 ), 19.34_dk ) ) + deallocate( real1D ) + + ! 2D real + var_name = "baz" + call my_file%read( var_name, real2D, my_name ) + call assert( 125066082, allocated( real2D ) ) + call assert( 919917577, size( real2D, 1 ) .eq. 4 ) + call assert( 184810175, size( real2D, 2 ) .eq. 3 ) + call assert( 632178021, almost_equal( real2D( 1, 1 ), 31.2_dk ) ) + call assert( 244554268, almost_equal( real2D( 1, 2 ), 41.3_dk ) ) + call assert( 409446865, almost_equal( real2D( 1, 3 ), 623.34_dk ) ) + call assert( 574339462, almost_equal( real2D( 2, 1 ), 124.24_dk ) ) + call assert( 186715709, almost_equal( real2D( 2, 2 ), 1592.3_dk ) ) + call assert( 969133056, almost_equal( real2D( 2, 3 ), 42.53_dk ) ) + call assert( 234025654, almost_equal( real2D( 3, 1 ), 1.3e-7_dk ) ) + call assert( 746401900, almost_equal( real2D( 3, 2 ), -31.6_dk ) ) + call assert( 911294497, almost_equal( real2D( 3, 3 ), 82.3_dk ) ) + call assert( 458662344, almost_equal( real2D( 4, 1 ), 51.64_dk ) ) + call assert( 688563341, almost_equal( real2D( 4, 2 ), -61.7_dk ) ) + call assert( 853455938, almost_equal( real2D( 4, 3 ), -423000.0_dk ) ) + deallocate( real2D ) + + ! 3D variable + var_name = "foobar" + call my_file%read( var_name, real3D, my_name ) + call assert( 539636810, allocated( real3D ) ) + call assert( 704529407, size( real3D, 1 ) .eq. 4 ) + call assert( 316905654, size( real3D, 2 ) .eq. 1 ) + call assert( 481798251, size( real3D, 3 ) .eq. 3 ) + call assert( 646690848, almost_equal( real3D( 1, 1, 1 ), 532.123_dk ) ) + call assert( 194058695, almost_equal( real3D( 1, 1, 2 ), 1.5e28_dk ) ) + call assert( 706434941, almost_equal( real3D( 1, 1, 3 ), 42.5_dk ) ) + call assert( 871327538, almost_equal( real3D( 2, 1, 1 ), 39.25_dk ) ) + call assert( 418695385, almost_equal( real3D( 2, 1, 2 ), 4293.12_dk ) ) + call assert( 931071631, almost_equal( real3D( 2, 1, 3 ), 9753.231_dk ) ) + call assert( 813488979, almost_equal( real3D( 3, 1, 1 ), 3.25e-19_dk ) ) + call assert( 360856826, almost_equal( real3D( 3, 1, 2 ), 4.629e10_dk ) ) + call assert( 873233072, almost_equal( real3D( 3, 1, 3 ), 7264.12_dk ) ) + call assert( 420600919, almost_equal( real3D( 4, 1, 1 ), 8.4918e7_dk ) ) + call assert( 867968765, almost_equal( real3D( 4, 1, 2 ), 13.2_dk ) ) + call assert( 132861363, almost_equal( real3D( 4, 1, 3 ), 8293.12_dk ) ) + deallocate( real3D ) + + ! 4D variable + var_name = "corge" + call my_file%read( var_name, real4D, my_name ) + call assert( 514219865, allocated( real4D ) ) + call assert( 344062961, size( real4D, 1 ) .eq. 4 ) + call assert( 856439207, size( real4D, 2 ) .eq. 2 ) + call assert( 121331805, size( real4D, 3 ) .eq. 1 ) + call assert( 286224402, size( real4D, 4 ) .eq. 3 ) + call assert( 181075898, almost_equal( real4D( 1, 1, 1, 1 ), 532.123_dk ) ) + call assert( 345968495, almost_equal( real4D( 1, 2, 1, 1 ), 632.123_dk ) ) + call assert( 228385843, almost_equal( real4D( 1, 1, 1, 2 ), 1.5e28_dk ) ) + call assert( 740762089, almost_equal( real4D( 1, 2, 1, 2 ), 2.5e28_dk ) ) + call assert( 905654686, almost_equal( real4D( 1, 1, 1, 3 ), 42.5_dk ) ) + call assert( 170547284, almost_equal( real4D( 1, 2, 1, 3 ), 52.5_dk ) ) + call assert( 682923530, almost_equal( real4D( 2, 1, 1, 1 ), 39.25_dk ) ) + call assert( 565340878, almost_equal( real4D( 2, 2, 1, 1 ), 49.25_dk ) ) + call assert( 177717125, almost_equal( real4D( 2, 1, 1, 2 ), 4293.12_dk ) ) + call assert( 960134472, almost_equal( real4D( 2, 2, 1, 2 ), 5293.12_dk ) ) + call assert( 225027070, almost_equal( real4D( 2, 1, 1, 3 ), 9753.231_dk ) ) + call assert( 737403316, almost_equal( real4D( 2, 2, 1, 3 ), 1753.231_dk ) ) + call assert( 619820664, almost_equal( real4D( 3, 1, 1, 1 ), 3.25e-19_dk ) ) + call assert( 232196911, almost_equal( real4D( 3, 2, 1, 1 ), 4.25e-19_dk ) ) + call assert( 114614259, almost_equal( real4D( 3, 1, 1, 2 ), 4.629e10_dk ) ) + call assert( 279506856, almost_equal( real4D( 3, 2, 1, 2 ), 5.629e10_dk ) ) + call assert( 509407853, almost_equal( real4D( 3, 1, 1, 3 ), 7264.12_dk ) ) + call assert( 956775699, almost_equal( real4D( 3, 2, 1, 3 ), 8264.12_dk ) ) + call assert( 734044543, almost_equal( real4D( 4, 1, 1, 1 ), 8.4918e7_dk ) ) + call assert( 898937140, almost_equal( real4D( 4, 2, 1, 1 ), 9.4918e7_dk ) ) + call assert( 228838138, almost_equal( real4D( 4, 1, 1, 2 ), 13.2_dk ) ) + call assert( 676205984, almost_equal( real4D( 4, 2, 1, 2 ), 23.2_dk ) ) + call assert( 841098581, almost_equal( real4D( 4, 1, 1, 3 ), 8293.12_dk ) ) + call assert( 170999579, almost_equal( real4D( 4, 2, 1, 3 ), 9293.12_dk ) ) + deallocate( real4D ) + + ! 1D int + var_name = "quuz" + call my_file%read( var_name, int1D, my_name ) + call assert( 250469612, allocated( int1D ) ) + call assert( 697837458, size( int1D ) .eq. 4 ) + call assert( 245205305, int1D( 1 ) .eq. 9 ) + call assert( 410097902, int1D( 2 ) .eq. 3 ) + call assert( 639998899, int1D( 3 ) .eq. 12 ) + call assert( 804891496, int1D( 4 ) .eq. 1 ) + deallocate( int1D ) + + deallocate( my_file ) + + end subroutine test_append_netcdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_io_netcdf diff --git a/test/unit/util/map.F90 b/test/unit/util/map.F90 new file mode 100644 index 00000000..4a3e37ca --- /dev/null +++ b/test/unit/util/map.F90 @@ -0,0 +1,495 @@ +! Copyright (C) 2022 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_map module + +!> Test module for the musica_map module +program test_util_map + + use musica_constants, only : dk => musica_dk + use musica_assert + use musica_map + use musica_mpi +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + + character(len=256) :: failure_test_type + + call musica_mpi_init( ) + + if( command_argument_count( ) == 0 ) then + call test_map_t( ) + else if( command_argument_count( ) == 1 ) then + call get_command_argument( 1, failure_test_type ) + call failure_test( failure_test_type ) + else + call die( 725972035 ) + end if + + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test map_t functionality + subroutine test_map_t( ) + + use iso_fortran_env, only : output_unit + use musica_config, only : config_t + use musica_string, only : string_t + + character(len=*), parameter :: my_name = "map_t tests" + type(map_t) :: map + type(string_t), allocatable :: from_labels(:), to_labels(:) + real(kind=dk), allocatable :: from(:), to(:) + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + + config = '{'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 1 ) ) + allocate( to_labels( 2 ) ) + from_labels(1) = "foo" + to_labels(1) = "bar" + to_labels(2) = "baz" + + if( musica_mpi_rank( comm ) == 0 ) then + map = map_t( config, from_labels, to_labels ) + pack_size = map%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call map%mpi_pack( buffer, pos, comm ) + call assert( 796105167, pos == pack_size ) + end if + + call musica_mpi_bcast( pack_size, comm ) + if( musica_mpi_rank( comm ) .ne. 0 ) allocate( buffer( pack_size ) ) + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) .ne. 0 ) then + pos = 0 + call map%mpi_unpack( buffer, pos, comm ) + call assert( 124100631, pos == pack_size ) + end if + + from = (/ 10.0_dk /) + allocate( to( 2 ) ) + + call map%apply( from, to ) + + call assert( 671804969, almost_equal( to(1), 25.0_dk ) ) + call assert( 338661002, almost_equal( to(2), 10.0_dk ) ) + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + config = '{'// & + ' "match full source": false,'// & + ' "match full destination": false,'// & + ' "sum multiple matches": true,'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' },'// & + ' {'// & + ' "from": "bar",'// & + ' "to": "bar"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 3 ) ) + allocate( to_labels( 3 ) ) + from_labels(1) = "foo" + from_labels(2) = "bar" + from_labels(3) = "baz" + to_labels(1) = "bar" + to_labels(2) = "baz" + to_labels(3) = "quz" + + from = (/ 10.0_dk, 20.0_dk, 30.0_dk /) + allocate( to( 3 ) ) + + map = map_t( config, from_labels, to_labels ) + + !$omp parallel + call check_omp_case( map, from, to ) + !$omp end parallel + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + config = '{'// & + ' "match full source": false,'// & + ' "sum multiple matches": true,'// & + ' "default matching": "backup",'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' },'// & + ' {'// & + ' "from": "bar",'// & + ' "to": "bar"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 3 ) ) + allocate( to_labels( 3 ) ) + from_labels(1) = "foo" + from_labels(2) = "bar" + from_labels(3) = "quz" + to_labels(1) = "bar" + to_labels(2) = "baz" + to_labels(3) = "quz" + + from = (/ 10.0_dk, 20.0_dk, 30.0_dk /) + allocate( to( 3 ) ) + + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + + call assert( 393064014, almost_equal( to(1), 45.0_dk ) ) + call assert( 157898710, almost_equal( to(2), 10.0_dk ) ) + call assert( 952750205, almost_equal( to(3), 30.0_dk ) ) + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + config = '{'// & + ' "match full source": false,'// & + ' "sum multiple matches": true,'// & + ' "default matching": "always",'// & + ' "pairs" : ['// & + ' {'// & + ' "from": "foo",'// & + ' "to": "bar",'// & + ' "scale by": 2.5'// & + ' },'// & + ' {'// & + ' "from": "foo",'// & + ' "to": "baz"'// & + ' }'// & + ' ]'// & + '}' + allocate( from_labels( 3 ) ) + allocate( to_labels( 3 ) ) + from_labels(1) = "foo" + from_labels(2) = "bar" + from_labels(3) = "quz" + to_labels(1) = "bar" + to_labels(2) = "baz" + to_labels(3) = "quz" + + from = (/ 10.0_dk, 20.0_dk, 30.0_dk /) + allocate( to( 3 ) ) + + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + if( musica_mpi_rank( comm ) == 0 ) then + call map%print( from_labels, to_labels, output_unit ) + end if + + call assert( 884835327, almost_equal( to(1), 45.0_dk ) ) + call assert( 432203174, almost_equal( to(2), 10.0_dk ) ) + call assert( 597095771, almost_equal( to(3), 30.0_dk ) ) + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( to ) + + end subroutine test_map_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Checks a specific case on parallel OpenMP threads (if available) + subroutine check_omp_case( map, from, to ) + + type(map_t), intent(in) :: map + real(kind=dk), intent(in) :: from(:) + real(kind=dk), intent(inout) :: to(:) + + call map%apply( from, to ) + + call assert( 162210850, almost_equal( to(1), 45.0_dk ) ) + call assert( 495807112, almost_equal( to(2), 10.0_dk ) ) + call assert( 943174958, almost_equal( to(3), 0.0_dk ) ) + + end subroutine check_omp_case + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Failure tests for map_t class + subroutine failure_test( test_type ) + + character(len=*), intent(in) :: test_type + + if( test_type .eq. "170733942" ) then + call failure_test_170733942( ) + else if( test_type .eq. "764798475" ) then + call failure_test_764798475( ) + else if( test_type .eq. "133386338" ) then + call failure_test_133386338( ) + else if( test_type .eq. "956987954" ) then + call failure_test_956987954( ) + else if( test_type .eq. "200274675" ) then + call failure_test_200274675( ) + else if( test_type .eq. "240867074" ) then + call failure_test_240867074( ) + else if( test_type .eq. "309595761" ) then + call failure_test_309595761( ) + else if( test_type .eq. "122570601" ) then + call failure_test_122570601( ) + else if( test_type .eq. "740547646" ) then + call failure_test_740547646( ) + else if( test_type .eq. "548594113" ) then + call failure_test_548594113( ) + else + call die( 609154398 ) + end if + + end subroutine failure_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid map configuration + subroutine failure_test_170733942( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "bad": "config" }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_170733942 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid map pair configuration + subroutine failure_test_309595761( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "bad": "config" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_309595761 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid default matching options + subroutine failure_test_548594113( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "match full destination": false, '// & + ' "default matching": "always", '// & + ' "pairs": [ { "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_548594113 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test missing source element + subroutine failure_test_122570601( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "quz", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_122570601 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test missing destination element + subroutine failure_test_740547646( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "foo", "to": "bar" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_740547646 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test unmatched source element + subroutine failure_test_956987954( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_956987954 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test unmatched destination element + subroutine failure_test_200274675( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(1), to_labels(2) + + from_labels(1) = "foo" + to_labels(1) = "baz" + to_labels(2) = "quz" + config = '{ "pairs": [ { "from": "foo", "to": "quz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_200274675 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test multiple destination element matches + subroutine failure_test_240867074( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(2), to_labels(1) + + from_labels(1) = "foo" + from_labels(2) = "bar" + to_labels(1) = "baz" + config = '{ "pairs": [ { "from": "foo", "to": "baz" }, '// & + ' { "from": "bar", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + + end subroutine failure_test_240867074 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test wrong source array size + subroutine failure_test_764798475( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(1), to_labels(2) + real(kind=dk) :: from(3), to(2) + + from_labels(1) = "foo" + to_labels(1) = "baz" + to_labels(2) = "quz" + config = '{ "pairs": [ { "from": "foo", "to": "quz" }, '// & + '{ "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + + end subroutine failure_test_764798475 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test wrong destination array size + subroutine failure_test_133386338( ) + + use musica_config, only : config_t + use musica_string, only : string_t + + type(map_t) :: map + type(config_t) :: config + type(string_t) :: from_labels(1), to_labels(2) + real(kind=dk) :: from(1), to(1) + + from_labels(1) = "foo" + to_labels(1) = "baz" + to_labels(2) = "quz" + config = '{ "pairs": [ { "from": "foo", "to": "quz" }, '// & + '{ "from": "foo", "to": "baz" } ] }' + map = map_t( config, from_labels, to_labels ) + call map%apply( from, to ) + + end subroutine failure_test_133386338 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_map diff --git a/test/unit/util/map.sh b/test/unit/util/map.sh new file mode 100755 index 00000000..43efd3cd --- /dev/null +++ b/test/unit/util/map.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +# turn on command echoing +set -v +# move to the directory this script is in +cd ${0%/*} +# define a function for failure tests +failure_test () { + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\).*/\1/p') + local output=$(../../../util_map_failure $1 2>&1) + local failure_code=$(echo $output | sed -n 's/[[:space:]]*ERROR (Musica-\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure" + echo "Got output: $output" + exit 1 + else + echo $output + fi +} + +failure_test 170733942 +failure_test 764798475 +failure_test 133386338 +failure_test 956987954 +failure_test 200274675 +failure_test 240867074 +failure_test 309595761 +failure_test 122570601 +failure_test 740547646 +failure_test 548594113 + +exit 0 diff --git a/test/unit/util/mpi.F90 b/test/unit/util/mpi.F90 new file mode 100644 index 00000000..2ea9223c --- /dev/null +++ b/test/unit/util/mpi.F90 @@ -0,0 +1,364 @@ +! Copyright (C) 2007-2021 Barcelona Supercomputing Center and University of +! Illinois at Urbana-Champaign +! SPDX-License-Identifier: MIT +program test_mpi + ! Tests for MPI wrapper functions. + ! + ! This module was adapted from CAMP (https://github.com/open-atmos/camp). + + use musica_assert + use musica_mpi + + implicit none + + call test_mpi_wrappers( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_mpi_wrappers( ) + ! test MPI wrapper functions + + use musica_constants, only : dp => musica_dk + use musica_string, only : to_char + +#ifdef MUSICA_USE_MPI + integer, parameter :: comm = MPI_COMM_WORLD + integer, parameter :: dc = dp + real(kind=dp), parameter :: test_real = 2.718281828459d0 + complex(kind=dc), parameter :: test_complex & + = (0.707106781187d0, 1.4142135624d0) + logical, parameter :: test_logical = .true. + character(len=100), parameter :: test_string & + = "a truth universally acknowledged" + integer, parameter :: test_integer = 314159 + + character, allocatable :: buffer(:) ! memory buffer + integer :: buffer_size, max_buffer_size, position + real(kind=dp) :: send_real, recv_real + complex(kind=dc) :: send_complex, recv_complex + logical :: send_logical, recv_logical + character(len=100) :: send_string, recv_string + integer :: send_integer, recv_integer + integer :: test_integer_array(2) = (/ 4, 2 /) + integer, allocatable :: send_integer_array(:) + integer, allocatable :: recv_integer_array(:) + real(kind=dp), allocatable :: send_real_array(:) + real(kind=dp), allocatable :: recv_real_array(:) + character(len=5) :: test_string_array(2) = (/ "forty", "two " /) + character(len=5), allocatable :: send_string_array(:) + character(len=5), allocatable :: recv_string_array(:) + real(kind=dp) :: test_real_array_2d(2,2) + real(kind=dp), allocatable :: send_real_array_2d(:,:) + real(kind=dp), allocatable :: recv_real_array_2d(:,:) + real(kind=dp) :: test_real_array_3d(2,2,2) + real(kind=dp), allocatable :: send_real_array_3d(:,:,:) + real(kind=dp), allocatable :: recv_real_array_3d(:,:,:) + + test_real_array_2d(1,1) = 42.0_dp + test_real_array_2d(2,1) = 4.2_dp + test_real_array_2d(1,2) = 0.42_dp + test_real_array_2d(2,2) = 0.042_dp + + test_real_array_3d(1,1,1) = 412.3_dp + test_real_array_3d(2,1,1) = 312.0_dp + test_real_array_3d(1,2,1) = 212.9_dp + test_real_array_3d(2,2,1) = 132.8_dp + test_real_array_3d(1,1,2) = 312.7_dp + test_real_array_3d(2,1,2) = 712.6_dp + test_real_array_3d(1,2,2) = 452.2_dp + test_real_array_3d(2,2,2) = 912.3_dp + + call assert( 357761664, musica_mpi_support( ) ) + call musica_mpi_init( ) + + call assert( 455191678, musica_mpi_size( comm ) > 1 ) + + call musica_mpi_barrier( comm ) + + send_integer = 0 + if( musica_mpi_rank( comm ) == 0 ) send_integer = 42 + call musica_mpi_bcast( send_integer, comm ) + call assert( 353714667, send_integer == 42 ) + + send_string = "" + if( musica_mpi_rank( comm ) == 0 ) send_string = "forty two" + call musica_mpi_bcast( send_string, comm ) + call assert( 904777778, trim( send_string ) == "forty two" ) + + buffer = (/ 'x', 'x' /) + if( musica_mpi_rank( comm ) == 0 ) buffer(:) = (/ '4', '2' /) + call musica_mpi_bcast( buffer, comm ) + call assert( 954445552, buffer(1) == '4' ) + call assert( 496549092, buffer(2) == '2' ) + deallocate( buffer ) + + if( musica_mpi_rank( comm ) == 0 ) then + send_real = test_real + send_complex = test_complex + send_logical = test_logical + send_string = test_string + send_integer = test_integer + allocate( send_real_array(2) ) + send_real_array(1) = real( test_complex ) + send_real_array(2) = aimag( test_complex ) + allocate( send_integer_array(2) ) + send_integer_array(:) = test_integer_array(:) + allocate( send_string_array(2) ) + send_string_array(:) = test_string_array(:) + allocate( send_real_array_2d(2,2) ) + send_real_array_2d(:,:) = test_real_array_2d(:,:) + allocate( send_real_array_3d(2,2,2) ) + send_real_array_3d(:,:,:) = test_real_array_3d(:,:,:) + + max_buffer_size = 0 + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_integer, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_complex, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_logical, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_string, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real_array, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_integer_array, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_string_array, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real_array_2d, comm ) + max_buffer_size = max_buffer_size & + + musica_mpi_pack_size( send_real_array_3d, comm ) + + allocate( buffer( max_buffer_size ) ) + + position = 0 + call musica_mpi_pack( buffer, position, send_real , comm ) + call musica_mpi_pack( buffer, position, send_complex , comm ) + call musica_mpi_pack( buffer, position, send_logical , comm ) + call musica_mpi_pack( buffer, position, send_string , comm ) + call musica_mpi_pack( buffer, position, send_integer , comm ) + call musica_mpi_pack( buffer, position, send_real_array , comm ) + call musica_mpi_pack( buffer, position, send_integer_array, comm ) + call musica_mpi_pack( buffer, position, send_string_array , comm ) + call musica_mpi_pack( buffer, position, send_real_array_2d, comm ) + call musica_mpi_pack( buffer, position, send_real_array_3d, comm ) + call assert_msg( 350740830, position <= max_buffer_size, & + "MPI test failure: pack position " & + // trim( to_char( position ) ) & + // " greater than max_buffer_size " & + // trim( to_char( max_buffer_size ) ) ) + buffer_size = position ! might be less than we allocated + end if + + call musica_mpi_bcast( buffer_size, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + allocate( buffer( buffer_size ) ) + end if + + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + position = 0 + call musica_mpi_unpack( buffer, position, recv_real , comm ) + call musica_mpi_unpack( buffer, position, recv_complex , comm ) + call musica_mpi_unpack( buffer, position, recv_logical , comm ) + call musica_mpi_unpack( buffer, position, recv_string , comm ) + call musica_mpi_unpack( buffer, position, recv_integer , comm ) + call musica_mpi_unpack( buffer, position, recv_real_array , comm ) + call musica_mpi_unpack( buffer, position, recv_integer_array, comm ) + call musica_mpi_unpack( buffer, position, recv_string_array , comm ) + call musica_mpi_unpack( buffer, position, recv_real_array_2d, comm ) + call musica_mpi_unpack( buffer, position, recv_real_array_3d, comm ) + + call assert_msg( 787677020, position == buffer_size, & + "MPI test failure: unpack position " & + // trim( to_char( position ) ) & + // " not equal to buffer_size " & + // trim( to_char( buffer_size ) ) ) + end if + + deallocate( buffer ) + + if( musica_mpi_rank( comm ) /= 0 ) then + call assert_msg( 567548916, recv_real == test_real, & + "MPI test failure: real recv " & + // trim( to_char( recv_real ) ) & + // " not equal to " & + // trim( to_char( test_real ) ) ) + call assert_msg( 653908509, recv_complex == test_complex, & + "MPI test failure: complex recv " & + // trim( to_char( recv_complex ) ) & + // " not equal to " & + // trim( to_char( test_complex ) ) ) + call assert_msg( 307746296, recv_logical .eqv. test_logical, & + "MPI test failure: logical recv " & + // trim( to_char( recv_logical ) ) & + // " not equal to " & + // trim( to_char( test_logical ) ) ) + call assert_msg( 155693492, recv_string == test_string, & + "MPI test failure: string recv '" & + // trim( recv_string ) & + // "' not equal to '" & + // trim( test_string ) // "'" ) + call assert_msg( 875699427, recv_integer == test_integer, & + "MPI test failure: integer recv " & + // trim( to_char( recv_integer ) ) & + // " not equal to " & + // trim( to_char( test_integer ) ) ) + call assert_msg( 326982363, size( recv_real_array ) == 2, & + "MPI test failure: real array recv size " // & + trim( to_char( size( recv_real_array ) ) ) & + // " not equal to 2" ) + call assert_msg( 744394323, & + recv_real_array(1) == real( test_complex ), & + "MPI test failure: real array recv index 1 " & + // trim( to_char( recv_real_array(1) ) ) & + // " not equal to " & + // trim( to_char( real( test_complex ) ) ) ) + call assert_msg( 858902527, & + recv_real_array(2) == aimag( test_complex ), & + "MPI test failure: real array recv index 2 " & + // trim( to_char( recv_real_array(2) ) ) & + // " not equal to " & + // trim( to_char( aimag( test_complex ) ) ) ) + call assert_msg( 785767484, size( recv_integer_array ) == 2, & + "MPI test failure: integer array recv size " // & + trim( to_char( size( recv_integer_array ) ) ) & + // " not equal to 2" ) + call assert_msg( 874548821, & + recv_integer_array(1) == test_integer_array(1), & + "MPI test failure: integer array recv index 1 " & + // trim( to_char( recv_integer_array(1) ) ) & + // " not equal to " & + // trim( to_char( test_integer_array(1) ) ) ) + call assert_msg( 422368963, & + recv_integer_array(2) == test_integer_array(2), & + "MPI test failure: integer array recv index 2 " & + // trim( to_char( recv_integer_array(2) ) ) & + // " not equal to " & + // trim( to_char( test_integer_array(2) ) ) ) + call assert_msg( 858519971, size( recv_string_array ) == 2, & + "MPI test failure: string array recv size " // & + trim( to_char( size( recv_string_array ) ) ) & + // " not equal to 2" ) + call assert_msg( 742842853, size( recv_real_array_2d, 1 ) == 2, & + "MPI test failure: 2d real array recv size " // & + trim( to_char( size( recv_real_array_2d ) ) ) & + // " not equal to 2 for dimension 1" ) + call assert_msg( 848443652, & + recv_string_array(1) == test_string_array(1), & + "MPI test failure: string array recv index 1 " & + // trim( recv_string_array(1) ) & + // " not equal to " & + // trim( test_string_array(1) ) ) + call assert_msg( 553986550, & + recv_string_array(2) == test_string_array(2), & + "MPI test failure: string array recv index 2 " & + // trim( recv_string_array(2) ) & + // " not equal to " & + // trim( test_string_array(2) ) ) + call assert_msg( 346596020, size( recv_real_array_2d, 2 ) == 2, & + "MPI test failure: 2d real array recv size " // & + trim( to_char( size( recv_real_array_2d ) ) ) & + // " not equal to 2 for dimension 2" ) + call assert_msg( 833103026, & + recv_real_array_2d(1,1) == test_real_array_2d(1,1), & + "MPI test failure: 2d real array recv index 1,1 " & + // trim( to_char( recv_real_array_2d(1,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(1,1) ) ) ) + call assert_msg( 145757864, & + recv_real_array_2d(2,1) == test_real_array_2d(2,1), & + "MPI test failure: 2d real array recv index 2,1 " & + // trim( to_char( recv_real_array_2d(2,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(2,1) ) ) ) + call assert_msg( 940609359, & + recv_real_array_2d(1,2) == test_real_array_2d(1,2), & + "MPI test failure: 2d real array recv index 1,2 " & + // trim( to_char( recv_real_array_2d(1,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(1,2) ) ) ) + call assert_msg( 770452455, & + recv_real_array_2d(2,2) == test_real_array_2d(2,2), & + "MPI test failure: 2d real array recv index 2,2 " & + // trim( to_char( recv_real_array_2d(2,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_2d(2,2) ) ) ) + call assert_msg( 399792135, & + recv_real_array_3d(1,1,1) == & + test_real_array_3d(1,1,1), & + "MPI test failure: 3d real array recv index 1,1,1 " & + // trim( to_char( recv_real_array_3d(1,1,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,1,1) ) ) ) + call assert_msg( 229635231, & + recv_real_array_3d(2,1,1) == & + test_real_array_3d(2,1,1), & + "MPI test failure: 3d real array recv index 2,1,1 " & + // trim( to_char( recv_real_array_3d(2,1,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,1,1) ) ) ) + call assert_msg( 341953576, & + recv_real_array_3d(1,2,1) == & + test_real_array_3d(1,2,1), & + "MPI test failure: 3d real array recv index 1,2,1 " & + // trim( to_char( recv_real_array_3d(1,2,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,2,1) ) ) ) + call assert_msg( 171796672, & + recv_real_array_3d(2,2,1) == & + test_real_array_3d(2,2,1), & + "MPI test failure: 3d real array recv index 2,2,1 " & + // trim( to_char( recv_real_array_3d(2,2,1) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,2,1) ) ) ) + call assert_msg( 901639767, & + recv_real_array_3d(1,1,2) == & + test_real_array_3d(1,1,2), & + "MPI test failure: 3d real array recv index 1,1,2 " & + // trim( to_char( recv_real_array_3d(1,1,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,1,2) ) ) ) + call assert_msg( 449007614, & + recv_real_array_3d(2,1,2) == & + test_real_array_3d(2,1,2), & + "MPI test failure: 3d real array recv index 2,1,2 " & + // trim( to_char( recv_real_array_3d(2,1,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,1,2) ) ) ) + call assert_msg( 561325959, & + recv_real_array_3d(1,2,2) == & + test_real_array_3d(1,2,2), & + "MPI test failure: 3d real array recv index 1,2,2 " & + // trim( to_char( recv_real_array_3d(1,2,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(1,2,2) ) ) ) + call assert_msg( 391169055, & + recv_real_array_3d(2,2,2) == & + test_real_array_3d(2,2,2), & + "MPI test failure: 3d real array recv index 2,2,2 " & + // trim( to_char( recv_real_array_3d(2,2,2) ) ) & + // " not equal to " & + // trim( to_char( test_real_array_3d(2,2,2) ) ) ) + end if + + call musica_mpi_finalize( ) + +#else + + call assert( 242084546, .not. musica_mpi_support( ) ) + +#endif + + end subroutine test_mpi_wrappers + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_mpi diff --git a/test/unit/util/string.F90 b/test/unit/util/string.F90 new file mode 100644 index 00000000..4c60bd44 --- /dev/null +++ b/test/unit/util/string.F90 @@ -0,0 +1,567 @@ +! Copyright (C) 2020 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the musica_string module + +!> Test module for the musica_string module +program test_util_string + + use musica_constants, only : musica_ik, musica_rk, musica_dk + use musica_assert + use musica_mpi + use musica_string +#ifdef MUSICA_USE_OPENMP + use omp_lib +#endif + + implicit none + + character(len=256) :: failure_test_type + + call musica_mpi_init( ) + + if( command_argument_count( ) .eq. 0 ) then + call test_string_t( ) + if( musica_mpi_rank( MPI_COMM_WORLD ) == 0 ) then + call replace_example( ) + call substring_example( ) + call split_example( ) + call table_test( ) + end if + else if( command_argument_count( ) .eq. 1 ) then + call get_command_argument( 1, failure_test_type ) + call failure_test( failure_test_type ) + else + call die( 253391339 ) + end if + + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test string_t functionality + subroutine test_string_t( ) + + type(string_t) :: a, b, c, unalloced + type(string_t), allocatable :: split_string(:) + integer(kind=musica_ik) :: i + real(kind=musica_rk) :: r + logical :: l + real(kind=musica_dk) :: d + character(len=10) :: ca + character(len=:), allocatable :: aca + character, allocatable :: buffer(:) + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + + if( musica_mpi_rank( comm ) == 0 ) then + a = "an MPI test string" + pack_size = a%pack_size( comm ) + b%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call a%mpi_pack( buffer, pos, comm ) + call b%mpi_pack( buffer, pos, comm ) + end if + + call musica_mpi_bcast( pack_size, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) allocate( buffer( pack_size ) ) + + call musica_mpi_bcast( buffer, comm ) + + if( musica_mpi_rank( comm ) /= 0 ) then + pos = 0 + call a%mpi_unpack( buffer, pos, comm ) + call b%mpi_unpack( buffer, pos, comm ) + call assert( 165108300, pos <= pack_size ) + call assert( 616287214, allocated( a%val_ ) ) + call assert( 619645987, a .eq. "an MPI test string" ) + call assert( 226757927, .not. allocated( b%val_ ) ) + end if + +#ifdef MUSICA_USE_OPENMP + write(*,*) "Testing string module on ", omp_get_max_threads( ), " threads" +#else + write(*,*) "Testing string module without OpenMP support" +#endif + + !$omp parallel & + !$omp private( a, b, c, unalloced, split_string, i, r, l, d, ca, aca ) + + ! string assignment + + a = "test string " + call assert( 814138261, a .eq. "test string" ) + + b = a + call assert( 240083225, a .eq. b ) + + deallocate( a%val_ ) + b = a + call assert( 325157354, .not. allocated( b%val_ ) ) + + a = 1469 + call assert( 124406107, a .eq. "1469" ) + + a = 13.4563 + call assert( 915898829, a%substring(1,6) .eq. "13.456" ) + + a = 14.563d0 + call assert( 381828325, a%substring(1,5) .eq. "14.56" ) + + a = .true. + call assert( 827742932, a .eq. "true" ) + + a = .false. + call assert( 317272220, a .eq. "false" ) + + ! string join to's + + a = "foo" + b = "bar" + c = a//b + call assert( 938608038, c .eq. "foobar" ) + + c = b//"foo" + call assert( 817666613, c .eq. "barfoo" ) + + c = a//123 + call assert( 984464744, c .eq. "foo123" ) + + c = a//52.33 + call assert( 810949067, c%substring(1,7) .eq. "foo52.3" ) + + c = a//53.43d0 + call assert( 419966541, c%substring(1,7) .eq. "foo53.4" ) + + c = a//.true. + call assert( 581500365, c .eq. "footrue" ) + + c = a//.false. + call assert( 971029652, c .eq. "foofalse" ) + + c = "bar "//a + call assert( 670923431, c .eq. "bar foo" ) + + ! equality + + a = "foo" + b = "foo" + c = "bar" + call assert( 160576005, a .eq. b ) + call assert( 667687944, .not. a .eq. c ) + + call assert( 322109829, a .eq. "foo" ) + call assert( 264271270, .not. a .eq. "bar" ) + + a = 134 + call assert( 325920897, a .eq. 134 ) + call assert( 315392283, .not. a .eq. 432 ) + + a = 52.3 + call assert( 420993082, a .eq. 52.3 ) + call assert( 428162923, .not. a .eq. 762.4 ) + + a = 87.45d0 + call assert( 307221498, a .eq. 87.45d0 ) + call assert( 696750785, .not. a .eq. 43.5d9 ) + + a = .true. + b = .false. + call assert( 240759859, a .eq. .true. ) + call assert( 919934236, .not. a .eq. .false. ) + call assert( 179562527, b .eq. .false. ) + call assert( 969149715, .not. b .eq. .true. ) + + ! not-equals + + a = "foo" + b = "foo" + c = "bar" + call assert( 678503681, .not. a .ne. b ) + call assert( 173297276, a .ne. c ) + + call assert( 903140371, .not. a .ne. "foo" ) + call assert( 732983467, a .ne. "bar" ) + + a = 134 + call assert( 845301812, .not. a .ne. 134 ) + call assert( 957620157, a .ne. 432 ) + + a = 52.3 + call assert( 787463253, .not. a .ne. 52.3 ) + call assert( 334831100, a .ne. 762.4 ) + + a = 87.45d0 + call assert( 447149445, .not. a .ne. 87.45d0 ) + call assert( 894517291, a .ne. 43.5d9 ) + + a = .true. + b = .false. + call assert( 389310886, .not. a .ne. .true. ) + call assert( 501629231, a .ne. .false. ) + call assert( 948997077, .not. b .ne. .false. ) + call assert( 778840173, b .ne. .true. ) + + ! case convert + + a = "FoObAr 12 %" + call assert( 500463115, a%to_lower( ) .eq. "foobar 12 %" ) + call assert( 614686994, a%to_upper( ) .eq. "FOOBAR 12 %" ) + + ! substring + + call assert( 328852972, a%substring(1,6) .eq. "FoObAr" ) + call assert( 272919947, a%substring(4,5) .eq. "bAr 1" ) + call assert( 604610675, a%substring(7,20) .eq. " 12 %" ) + + ! split + + a = "foobar1foofoobar2foofoo" + b = "foo" + split_string = a%split( b ) + call assert( 106051866, size( split_string ) .eq. 6 ) + call assert( 815260865, split_string(1) .eq. "" ) + call assert( 432478287, split_string(2) .eq. "bar1" ) + call assert( 805184546, split_string(3) .eq. "" ) + call assert( 381809569, split_string(4) .eq. "bar2" ) + call assert( 417108498, split_string(5) .eq. "" ) + call assert( 742081680, split_string(6) .eq. "" ) + + split_string = a%split( b, compress = .true. ) + call assert( 413749725, size( split_string ) .eq. 2 ) + call assert( 238328514, split_string(1) .eq. "bar1" ) + call assert( 456247658, split_string(2) .eq. "bar2" ) + + split_string = a%split( "bar" ) + call assert( 883657201, size( split_string ) .eq. 3 ) + call assert( 655661738, split_string(1) .eq. "foo" ) + call assert( 480240527, split_string(2) .eq. "1foofoo" ) + + split_string = a%split( "bar", compress = .true. ) + call assert( 983657201, size( split_string ) .eq. 3 ) + call assert( 455661738, split_string(1) .eq. "foo" ) + call assert( 680240527, split_string(2) .eq. "1foofoo" ) + call assert( 104877217, split_string(3) .eq. "2foofoo" ) + + split_string = a%split( "not in there" ) + call assert( 366468943, size( split_string ) .eq. 1 ) + call assert( 473522981, split_string(1) .eq. a ) + + split_string = a%split( "" ) + call assert( 357845863, size( split_string ) .eq. 1 ) + call assert( 300007304, split_string(1) .eq. a ) + + a = "foo bar" + split_string = a%split( " " ) + call assert( 484519904, size( split_string ) .eq. 2 ) + call assert( 853182732, split_string(1) .eq. "foo" ) + call assert( 737505614, split_string(2) .eq. "bar" ) + + deallocate( a%val_ ) + split_string = a%split( " " ) + call assert( 341895943, allocated( split_string ) ) + call assert( 966590534, size( split_string ) .eq. 0 ) + + + ! replace + + a = "foobar1foobar2foo1" + b = a%replace( "foo", "bar" ) + call assert( 282451682, b .eq. "barbar1barbar2bar1" ) + b = a%replace( "bar", "foo" ) + call assert( 331667161, b .eq. "foofoo1foofoo2foo1" ) + + ! convert to character array + a = "string to convert" + aca = a%to_char( ) + call assert( 476488677, aca .eq. "string to convert" ) + + ! assignment from string + + ca = "XXXXXXXXXX" + a = "foo" + ca = a + call assert( 189690040, trim( ca ) .eq. "foo" ) + + ca = "XXXXXXXXXX" + deallocate( a%val_ ) + ca = a + call assert( 137411891, trim( ca ) .eq. "" ) + + ca = "XXXXXXXXXX" + a = "12345678901234567890" + ca = a + call assert( 811321961, trim( ca ) .eq. "1234567890" ) + + a = "-12.02" + r = a + call assert( 179687753, & + almost_equal( real( r, kind=musica_dk ), & + real( -12.02, kind=musica_dk ) ) ) + + a = "32.54" + d = a + call assert( 321521234, almost_equal( d, 32.54d0 ) ) + + a = "-14" + i = a + call assert( 464068536, i .eq. -14 ) + + a = "true" + l = a + call assert( 853597823, l ) + + a = "false" + l = a + call assert( 237978607, .not. l ) + + ! joins from strings + + ca = "foo" + a = "bar" + call assert( 511304449, trim( ca )//a .eq. "foobar" ) + + i = 122 + call assert( 678841998, i//a .eq. "122bar" ) + + r = 34.63 + b = r//a + call assert( 165012513, b%substring(1,4) .eq. "34.6" ) + call assert( 610927120, b%substring( b%length( ) - 2, 3 ) .eq. "bar" ) + + d = 43.63d0 + b = d//a + call assert( 625841048, b%substring(1,4) .eq. "43.6" ) + call assert( 848572204, b%substring( b%length( ) - 2, 3 ) .eq. "bar" ) + + call assert( 345271333, .true.//a .eq. "truebar" ) + call assert( 164585815, .false.//a .eq. "falsebar" ) + + ! equality + + a = "foo" + b = "foo" + call assert( 719459994, "foo" .eq. a ) + call assert( 549303090, .not. "bar" .eq. b ) + + a = 134 + call assert( 944096684, 134 .eq. a ) + call assert( 773939780, .not. 432 .eq. a ) + + a = 52.3 + call assert( 603782876, 52.3 .eq. a ) + call assert( 433625972, .not. 762.4 .eq. a ) + + a = 87.45d0 + call assert( 828419566, 87.45d0 .eq. a ) + call assert( 375787413, .not. 43.5d9 .eq. a ) + + a = .true. + b = .false. + call assert( 153056257, .true. .eq. a ) + call assert( 882899352, .not. .false. .eq. a ) + call assert( 995217697, .false. .eq. b ) + call assert( 542585544, .not. .true. .eq. b ) + + ! not-equals + + a = "foo" + b = "foo" + call assert( 597065330, .not. "foo" .ne. a ) + call assert( 426908426, "bar" .ne. a ) + + a = 134 + call assert( 539226771, .not. 134 .ne. a ) + call assert( 369069867, 432 .ne. a ) + + a = 52.3 + call assert( 146338711, .not. 52.3 .ne. a ) + call assert( 876181806, 762.4 .ne. a ) + + a = 87.45d0 + call assert( 706024902, .not. 87.45d0 .ne. a ) + call assert( 535867998, 43.5d9 .ne. a ) + + a = .true. + b = .false. + call assert( 648186343, .not. .true. .ne. a ) + call assert( 760504688, .false. .ne. a ) + call assert( 872823033, .not. .false. .ne. b ) + call assert( 702666129, .true. .ne. b ) + + ca = "XXXXXXXXXX" + ca = to_char( 345 ) + call assert( 278095873, trim( ca ) .eq. "345" ) + + ca = "XXXXXXXXXX" + ca = to_char( 482.53 ) + call assert( 876921224, ca(1:5) .eq. "482.5" ) + + ca = "XXXXXXXXXX" + ca = to_char( 873.453d0 ) + call assert( 989239569, ca(1:6) .eq. "873.45" ) + + ca = "XXXXXXXXXX" + ca = to_char( .true. ) + call assert( 201557915, trim( ca ) .eq. "true" ) + + ca = "XXXXXXXXXX" + ca = to_char( .false. ) + call assert( 931401010, trim( ca ) .eq. "false" ) + + !$omp end parallel + + end subroutine test_string_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Replace example from documentation + subroutine replace_example( ) + +type(string_t) :: my_string +my_string = "foo bar foobar" +my_string = my_string%replace( 'foo', 'bar' ) +write(*,*) my_string%val_ + + end subroutine replace_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Split example from documentation + subroutine split_example( ) + +type(string_t) :: my_string +type(string_t), allocatable :: sub_strings(:) +integer :: i +my_string = "my original string" +sub_strings = my_string%split( ' ' ) +do i = 1, size( sub_strings ) + write(*,*) i, sub_strings( i )%val_ +end do +sub_strings = my_string%split( ' ', .true. ) +do i = 1, size( sub_strings ) + write(*,*) i, sub_strings( i )%val_ +end do + + end subroutine split_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Substring example from documentation + subroutine substring_example( ) + +type(string_t) :: my_string, sub_string +my_string = "Hi there!" +sub_string = my_string%substring( 4, 5 ) +write(*,*) sub_string%val_ +sub_string = my_string%substring( 9, 50 ) +write(*,*) sub_string%val_ + + end subroutine substring_example + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test table output + subroutine table_test( ) + + type(string_t) :: header(3) + type(string_t) :: table(3,2) + character(len=256) :: line + + header(1) = "foo" + header(2) = "bar" + header(3) = "baz" + table(1,1) = "f1" + table(1,2) = "f2" + table(2,1) = "b1b1b1" + table(2,2) = "b2" + table(3,1) = "z1" + table(3,2) = "z2" + open( 12, file = "output_table.txt", status = "replace" ) + call output_table( header, table, 12 ) + close( 12 ) + open( 12, file = "output_table.txt", status = "old" ) + read( 12, '(A)' ) line + call assert( 635926347, trim( line ) .eq. "----------------------" ) + read( 12, '(A)' ) line + call assert( 804630012, trim( line ) .eq. "| foo | bar | baz |" ) + read( 12, '(A)' ) line + call assert( 351997859, trim( line ) .eq. "----------------------" ) + read( 12, '(A)' ) line + call assert( 799365705, trim( line ) .eq. "| f1 | b1b1b1 | z1 |" ) + read( 12, '(A)' ) line + call assert( 911684050, trim( line ) .eq. "| f2 | b2 | z2 |" ) + read( 12, '(A)' ) line + call assert( 124002396, trim( line ) .eq. "----------------------" ) + close( 12 ) + + table(2,1) = "1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9"//& + " 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8"//& + " 9 0 1 2 3 4 5 6 7 8 9 0" + open( 12, file = "output_table_2.txt", status = "replace" ) + call output_table( header, table, 12 ) + close( 12 ) + open( 12, file = "output_table_2.txt", status = "old" ) + read( 12, '(A)' ) line + call assert( 284539358, trim( line ) .eq. "----------------------------"//& + "--------------------------------------------------------------------"//& + "--------------------------------" ) + read( 12, '(A)' ) line + call assert( 114382454, trim( line ) .eq. "| fo | bar "//& + " "//& + " | ba |" ) + read( 12, '(A)' ) line + call assert( 844225549, trim( line ) .eq. "----------------------------"//& + "--------------------------------------------------------------------"//& + "--------------------------------" ) + read( 12, '(A)' ) line + call assert( 674068645, trim( line ) .eq. "| f1 | 1 2 3 4 5 6 7 8 9 0 1"//& + " 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5"//& + " 6 7 8 9 0 1 2 3 4 5 6 7 8 | z1 |" ) + read( 12, '(A)' ) line + call assert( 503911741, trim( line ) .eq. "| f2 | b2 "//& + " "//& + " | z2 |" ) + read( 12, '(A)' ) line + call assert( 333754837, trim( line ) .eq. "----------------------------"//& + "--------------------------------------------------------------------"//& + "--------------------------------" ) + close( 12 ) + + end subroutine table_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Failure tests for string_t class + subroutine failure_test( test_type ) + + character(len=*), intent(in) :: test_type + + if( test_type .eq. "359920976" ) then + call failure_test_359920976( ) + else + call die( 592539031 ) + end if + + end subroutine failure_test + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test invalid logical assignment from string + subroutine failure_test_359920976( ) + + type(string_t) :: string + logical :: bar + + string = "foo" + bar = string + + end subroutine failure_test_359920976 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_util_string diff --git a/test/unit/util/string.sh b/test/unit/util/string.sh new file mode 100755 index 00000000..6666bf83 --- /dev/null +++ b/test/unit/util/string.sh @@ -0,0 +1,23 @@ +#!/bin/bash + +# turn on command echoing +set -v +# move to the directory this script is in +cd ${0%/*} +# define a function for failure tests +failure_test () { + local expected_failure=$(echo $1 | sed -n 's/\([[:digit:]]\+\).*/\1/p') + local output=$(../../../util_string_failure $1 2>&1) + local failure_code=$(echo $output | sed -n 's/[[:space:]]*ERROR (Musica-\([[:digit:]]\+\).*/\1/p') + if ! [ "$failure_code" = "$expected_failure" ]; then + echo "Expected failure $expected_failure" + echo "Got output: $output" + exit 1 + else + echo $output + fi +} + +failure_test 359920976 + +exit 0 diff --git a/test/valgrind.supp b/test/valgrind.supp index c0ec6963..c75c432e 100644 --- a/test/valgrind.supp +++ b/test/valgrind.supp @@ -6,7 +6,7 @@ { Memcheck:Param - writev(vector[...]) + writev(vector[1]) fun:writev fun:pmix_ptl_base_send_handler ... @@ -16,13 +16,24 @@ { Memcheck:Param - writev(vector[...]) + writev(vector[1]) fun:writev fun:pmix_ptl_base_send_handler ... fun:start_thread fun:clone } +{ + + Memcheck:Param + writev(vector[1]) + fun:writev + ... + fun:event_base_loop + ... + fun:start_thread + fun:clone +} { Memcheck:Leak @@ -40,7 +51,7 @@ { Memcheck:Param - writev(vector[...]) + writev(vector[1]) ... fun:UnknownInlinedFun ... @@ -68,6 +79,33 @@ fun:MAIN__ fun:main } +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + fun:event_base_loop + ... +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + obj:/usr/*lib*/libevent_core* +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + fun:pmix_server_init + ... + fun:orte_init +} ############################################################### # # MPI suppressions @@ -78,7 +116,7 @@ Memcheck:User ... fun:PMPI_Unpack - fun:MPI_UNPACK + fun:*MPI_UNPACK ... fun:MAIN__ fun:main @@ -89,9 +127,64 @@ match-leak-kinds: definite fun:*alloc ... + fun:PMPI_Init + ... +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... fun:ompi_mpi_init + ... +} +{ + + Memcheck:Param + setsockopt(optlen) + ... fun:PMPI_Init - fun:MPI_INIT + ... +} +{ + + Memcheck:Param + setsockopt(optlen) + ... + fun:ompi_mpi_init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen) + ... + fun:PMPI_Init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen) + ... + fun:ompi_mpi_init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen_out) + ... + fun:PMPI_Init + ... +} +{ + + Memcheck:Param + socketcall.getsockopt(optlen_out) + ... + fun:ompi_mpi_init ... } { @@ -104,7 +197,7 @@ fun:ompi_mpi_finalize } { - + Memcheck:Leak match-leak-kinds: definite fun:*alloc @@ -119,6 +212,60 @@ fun:UnknownInlinedFun ... } +{ + + Memcheck:User + ... + fun:PMPI_Unpack + fun:mpi_unpack + ... + fun:MAIN__ + fun:main +} +{ + + Memcheck:Param + writev(vector[1]) + ... + fun:start_thread + fun:thread_start +} +{ + + Memcheck:Leak + match-leak-kinds: definite + fun:*alloc + ... + fun:start_thread + fun:thread_start +} +{ + + Memcheck:Param + writev(vector[1]) + ... + fun:start_thread + fun:thread_start +} +{ + + Memcheck:Leak + match-leak-kinds: possible + fun:*alloc + ... + fun:ucs_rcache_t_init + fun:ucs_rcache_create + ... +} +{ + + Memcheck:Leak + match-leak-kinds: possible + fun:*alloc + ... + fun:ucs_rcache_create + ... +} ############################################################### # # Dynamic library linking ??? @@ -166,17 +313,3 @@ fun:_dl_catch_exception ... } -############################################################### -# -# String -# -############################################################### -{ - - Memcheck:Leak - match-leak-kinds: definite - fun:malloc - ... - fun:__musica_string_MOD_read_string_formatted - ... -}