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/docker.yml b/.github/workflows/docker.yml new file mode 100644 index 00000000..be54d833 --- /dev/null +++ b/.github/workflows/docker.yml @@ -0,0 +1,50 @@ +name: Docker + +on: [push, pull_request] + +concurrency: + group: ${{ github.workflow }}-${{ github.ref || github.run_id }} + cancel-in-progress: true + +jobs: + docker-build-and-test: + if: github.event_name != 'pull_request' || github.event.pull_request.head.repo.full_name != github.event.pull_request.base.repo.full_name + name: Build and Test - ${{ matrix.dockerfile }} + runs-on: ubuntu-latest + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + dockerfile: + - Dockerfile + - Dockerfile.coverage + - Dockerfile.memcheck + - Dockerfile.mpi + - Dockerfile.mpi.memcheck + steps: + - name: Checkout code + uses: actions/checkout@v3 + with: + submodules: recursive + + - name: Build Docker image + run: docker build -t tuvx -f docker/${{ matrix.dockerfile }} . + + - name: Run tests in container + if: matrix.dockerfile != 'Dockerfile.coverage' + run: docker run --name test-container -t tuvx bash -c 'make test ARGS="--rerun-failed --output-on-failure"' + + - name: Run coverage tests in container + if: matrix.dockerfile == 'Dockerfile.coverage' + run: docker run --name test-container -t tuvx bash -c 'make coverage ARGS="--rerun-failed --output-on-failure"' + + - name: Copy coverage from container + if: matrix.dockerfile == 'Dockerfile.coverage' + run: docker cp test-container:build/coverage.info . + + - name: Upload coverage report + if: matrix.dockerfile == 'Dockerfile.coverage' + uses: codecov/codecov-action@v3 + with: + token: ${{ secrets.CODECOV_TOKEN }} + files: coverage.info \ No newline at end of file diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index ed377e74..9ef87037 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -54,7 +54,7 @@ jobs: # create two copies of the documentaiton # 1. the frozen version, represented as vX.X in the version switcher - docker build -t tuvx -f Dockerfile.docs . + docker build -t tuvx -f docker/Dockerfile.docs . id=$(docker create tuvx) docker cp $id:/build/docs/sphinx tmpdocs docker rm -v $id @@ -63,7 +63,7 @@ jobs: # 2. stable, represented as vX.X (stable) in the version switcher # edit conf.py to produce a version string that looks like vX.X (stable) - docker build -t tuvx -f Dockerfile.docs --build-arg SUFFIX=" (stable)" . + docker build -t tuvx -f docker/Dockerfile.docs --build-arg SUFFIX=" (stable)" . id=$(docker create tuvx) docker cp $id:/build/docs/sphinx tmpdocs docker rm -v $id @@ -84,7 +84,7 @@ jobs: !contains(github.ref, env.DEFAULT_BRANCH) run: | set -x - docker build -t tuvx -f Dockerfile.docs . + docker build -t tuvx -f docker/Dockerfile.docs . id=$(docker create tuvx) docker cp $id:/build/docs/sphinx tmpdocs docker rm -v $id diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml deleted file mode 100644 index 37e0cb90..00000000 --- a/.github/workflows/test.yml +++ /dev/null @@ -1,59 +0,0 @@ -name: build - -on: [ push, pull_request ] - -concurrency: - group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} - cancel-in-progress: true - -jobs: - build_test_no_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 - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - 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"' - 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 - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - 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"' - 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 - steps: - - uses: actions/checkout@v3 - with: - submodules: recursive - - 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"' - - 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_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 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"' diff --git a/.github/workflows/ubuntu.yml b/.github/workflows/ubuntu.yml new file mode 100644 index 00000000..8610eb18 --- /dev/null +++ b/.github/workflows/ubuntu.yml @@ -0,0 +1,35 @@ +name: Ubuntu + +on: [ push, pull_request ] + +concurrency: + group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + +jobs: + gcc: + 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 + strategy: + matrix: + gcc_version: [11, 12, 13] + env: + FC: gfortran-${{ matrix.gcc_version }} + steps: + - uses: actions/checkout@v3 + with: + submodules: recursive + - name: Install dependencies + run: | + sudo apt-get update + sudo apt-get install -y libnetcdf-dev netcdf-bin libnetcdff-dev + - name: Install python dependencies + run: pip install numpy scipy + - name: Run Cmake + run: cmake -S . -B build + - name: Build + run: cmake --build build --parallel + - name: Run tests + run: | + cd build + ctest --rerun-failed --output-on-failure . --verbose \ No newline at end of file diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 00000000..38686111 --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,15 @@ +cff-version: 1.2.0 +message: "If you use this software, please cite it as below." +authors: + - family-names: Dawson + given-names: Matt + - family-names: Shores + given-names: Kyle + - family-names: Walters + given-names: Stacy +title: "NCAR/tuv-x: Version 0.8.0" +version: 0.8.0 +doi: 10.5281/zenodo.7126039 +url: "https://github.com/NCAR/tuv-x" +year: 2024 +publisher: Zenodo \ No newline at end of file diff --git a/CMakeLists.txt b/CMakeLists.txt index 5715ce5a..ee0159b0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -6,8 +6,8 @@ set(CMAKE_USER_MAKE_RULES_OVERRIDE "cmake/set_defaults.cmake") project( tuv-x - VERSION 0.7.0 - LANGUAGES Fortran + VERSION 0.8.0 + LANGUAGES Fortran CXX C ) set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}) @@ -31,7 +31,7 @@ option(ENABLE_MPI "Enable MPI parallel support" OFF) cmake_dependent_option(ENABLE_OPENMP "Enable OpenMP support" OFF "ENABLE_MPI" OFF) option(ENABLE_TESTS "Build tests" ON) option(ENABLE_COVERAGE "Enable code coverage output" OFF) -option(ENABLE_MEMCHECK "Enable memory checking in tests" ON) +option(ENABLE_MEMCHECK "Enable memory checking in tests" OFF) option(ENABLE_NC_CONFIG "Use nc-config to determine NetCDF libraries" OFF) option(BUILD_DOCS "Build the documentation" OFF) @@ -78,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 deleted file mode 100644 index 8f225029..00000000 --- a/Dockerfile +++ /dev/null @@ -1,51 +0,0 @@ -FROM fedora:35 - -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 \ - && 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 \ - && make install -j 8 - -WORKDIR /build diff --git a/README.md b/README.md index 28eb9c4a..d2852982 100644 --- a/README.md +++ b/README.md @@ -5,12 +5,13 @@ Tropospheric ultraviolet-extended (TUV-x): A photolysis rate calculator [![License](https://img.shields.io/github/license/NCAR/tuv-x.svg)](https://github.com/NCAR/tuv-x/blob/main/LICENSE) -[![CI Status](https://github.com/NCAR/tuv-x/actions/workflows/test.yml/badge.svg)](https://github.com/NCAR/tuv-x/actions/workflows/test.yml) +[![Ubuntu](https://github.com/NCAR/tuv-x/actions/workflows/ubuntu.yml/badge.svg)](https://github.com/NCAR/tuv-x/actions/workflows/ubuntu.yml) +[![Docker](https://github.com/NCAR/tuv-x/actions/workflows/docker.yml/badge.svg)](https://github.com/NCAR/tuv-x/actions/workflows/docker.yml) [![codecov](https://codecov.io/gh/NCAR/tuv-x/branch/main/graph/badge.svg?token=H46AAEAQF9)](https://codecov.io/gh/NCAR/tuv-x) [![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 +23,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. @@ -143,13 +144,13 @@ The TUV-x software can be cited with author = {Matt Dawson and Kyle Shores and Stacy Walters}, - title = {NCAR/tuv-x: Version 0.2.0}, - month = sep, - year = 2022, + title = {NCAR/tuv-x: Version 0.5.0}, + month = dec, + year = 2023, publisher = {Zenodo}, version = {v0.2.0}, - doi = {10.5281/zenodo.7126040}, - url = {https://doi.org/10.5281/zenodo.7126040} + doi = {10.5281/zenodo.8110063}, + url = {https://doi.org/10.5281/zenodo.8110063} } ``` @@ -185,4 +186,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 931b5223..23e8a8cd 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -1,3 +1,6 @@ +find_package(PkgConfig REQUIRED) +include(FetchContent) + ################################################################################ # LAPACK @@ -36,25 +39,6 @@ if(ENABLE_OPENMP) endif() endif() -################################################################################ -# json-fortran library - -find_path(JSON_INCLUDE_DIR json_module.mod - DOC "json-fortran include directory (must include json_*.mod files)" - PATHS - $ENV{JSON_FORTRAN_HOME}/lib - /opt/local/lib - /usr/local/lib - /usr/local/lib64) -find_library(JSON_LIB jsonfortran - DOC "json-fortran library" - PATHS - $ENV{JSON_FORTRAN_HOME}/lib - /opt/local/lib - /usr/local/lib - /usr/local/lib64) -include_directories(${JSON_INCLUDE_DIR}) - ################################################################################ # NetCDF library @@ -62,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) - - set(ENABLE_UTIL_ONLY ON) - - FetchContent_Declare(musicacore - GIT_REPOSITORY https://github.com/NCAR/musica-core.git - GIT_TAG v0.4.1 - FIND_PACKAGE_ARGS NAMES musicacore - ) - - FetchContent_MakeAvailable(musicacore) -endif() +# yaml-cpp + +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/data/cross_sections/ACETONE_JPL06.nc b/data/cross_sections/ACETONE_JPL06.nc new file mode 100644 index 00000000..ee1e2d29 Binary files /dev/null and b/data/cross_sections/ACETONE_JPL06.nc differ diff --git a/data/cross_sections/BRONO2_JPL06.nc b/data/cross_sections/BRONO2_JPL06.nc new file mode 100644 index 00000000..2da2063b Binary files /dev/null and b/data/cross_sections/BRONO2_JPL06.nc differ diff --git a/data/cross_sections/BRO_JPL06.nc b/data/cross_sections/BRO_JPL06.nc new file mode 100644 index 00000000..5ad156c8 Binary files /dev/null and b/data/cross_sections/BRO_JPL06.nc differ diff --git a/data/cross_sections/CF2CL2_JPL06.nc b/data/cross_sections/CF2CL2_JPL06.nc new file mode 100644 index 00000000..f84b84a8 Binary files /dev/null and b/data/cross_sections/CF2CL2_JPL06.nc differ diff --git a/data/cross_sections/CFC113_JPL06.nc b/data/cross_sections/CFC113_JPL06.nc new file mode 100644 index 00000000..4889f8e5 Binary files /dev/null and b/data/cross_sections/CFC113_JPL06.nc differ diff --git a/data/cross_sections/CFC114_JPL10.nc b/data/cross_sections/CFC114_JPL10.nc new file mode 100644 index 00000000..ed2bdeac Binary files /dev/null and b/data/cross_sections/CFC114_JPL10.nc differ diff --git a/data/cross_sections/CFC115_JPL10.nc b/data/cross_sections/CFC115_JPL10.nc new file mode 100644 index 00000000..4fd20caf Binary files /dev/null and b/data/cross_sections/CFC115_JPL10.nc differ diff --git a/data/cross_sections/CFCL3_JPL06.nc b/data/cross_sections/CFCL3_JPL06.nc new file mode 100644 index 00000000..9f3dd180 Binary files /dev/null and b/data/cross_sections/CFCL3_JPL06.nc differ diff --git a/data/cross_sections/CH3BR_JPL06.nc b/data/cross_sections/CH3BR_JPL06.nc new file mode 100644 index 00000000..0d6beec2 Binary files /dev/null and b/data/cross_sections/CH3BR_JPL06.nc differ diff --git a/data/cross_sections/CH3CL_JPL06.nc b/data/cross_sections/CH3CL_JPL06.nc new file mode 100644 index 00000000..823cff31 Binary files /dev/null and b/data/cross_sections/CH3CL_JPL06.nc differ diff --git a/data/cross_sections/CHBR3_JPL10.nc b/data/cross_sections/CHBR3_JPL10.nc new file mode 100644 index 00000000..cf8240a8 Binary files /dev/null and b/data/cross_sections/CHBR3_JPL10.nc differ diff --git a/data/cross_sections/CL2O2_JPL10.nc b/data/cross_sections/CL2O2_JPL10.nc new file mode 100644 index 00000000..1656cee4 Binary files /dev/null and b/data/cross_sections/CL2O2_JPL10.nc differ diff --git a/data/cross_sections/CLO_JPL06.nc b/data/cross_sections/CLO_JPL06.nc new file mode 100644 index 00000000..9b0c4281 Binary files /dev/null and b/data/cross_sections/CLO_JPL06.nc differ diff --git a/data/cross_sections/H1301_JPL06.nc b/data/cross_sections/H1301_JPL06.nc new file mode 100644 index 00000000..e9fc0ec1 Binary files /dev/null and b/data/cross_sections/H1301_JPL06.nc differ diff --git a/data/cross_sections/H2402_JPL06.nc b/data/cross_sections/H2402_JPL06.nc new file mode 100644 index 00000000..6293b891 Binary files /dev/null and b/data/cross_sections/H2402_JPL06.nc differ diff --git a/data/cross_sections/HCFC141b_JPL10.nc b/data/cross_sections/HCFC141b_JPL10.nc new file mode 100644 index 00000000..513c23c6 Binary files /dev/null and b/data/cross_sections/HCFC141b_JPL10.nc differ diff --git a/data/cross_sections/HCFC142b_JPL10.nc b/data/cross_sections/HCFC142b_JPL10.nc new file mode 100644 index 00000000..6ac72f1e Binary files /dev/null and b/data/cross_sections/HCFC142b_JPL10.nc differ diff --git a/data/cross_sections/HCFC22_JPL06.nc b/data/cross_sections/HCFC22_JPL06.nc new file mode 100644 index 00000000..22a9c384 Binary files /dev/null and b/data/cross_sections/HCFC22_JPL06.nc differ diff --git a/data/cross_sections/HNO3_JPL06.nc b/data/cross_sections/HNO3_JPL06.nc new file mode 100644 index 00000000..f56b8dd4 Binary files /dev/null and b/data/cross_sections/HNO3_JPL06.nc differ diff --git a/data/cross_sections/HO2NO2_JPL06.nc b/data/cross_sections/HO2NO2_JPL06.nc new file mode 100644 index 00000000..e1a767e9 Binary files /dev/null and b/data/cross_sections/HO2NO2_JPL06.nc differ diff --git a/data/cross_sections/HO2NO2_temp_JPL06.nc b/data/cross_sections/HO2NO2_temp_JPL06.nc new file mode 100644 index 00000000..6ae279c3 Binary files /dev/null and b/data/cross_sections/HO2NO2_temp_JPL06.nc differ diff --git a/data/cross_sections/N2O5_JPL06.nc b/data/cross_sections/N2O5_JPL06.nc index b7a81498..abec5694 100644 Binary files a/data/cross_sections/N2O5_JPL06.nc and b/data/cross_sections/N2O5_JPL06.nc differ diff --git a/data/cross_sections/SO2_Mills.nc b/data/cross_sections/SO2_Mills.nc new file mode 100644 index 00000000..455770ec Binary files /dev/null and b/data/cross_sections/SO2_Mills.nc differ diff --git a/data/dose_rates.json b/data/dose_rates.json index 1b71093e..f7f277b6 100644 --- a/data/dose_rates.json +++ b/data/dose_rates.json @@ -1,4 +1,7 @@ - "__description": "This file contains all the dose rates that can be calculated using data in this folder", + "__description": [ + "This file contains all the dose rates that can be calculated using data in this folder", + "The original TUV 5.4 source code and data sets can be found here: https://www2.acom.ucar.edu/modeling/tuv-download" + ], "dose rates": { "enable diagnostics": true, "rates": [ diff --git a/data/photolysis_rate_constants.json b/data/photolysis_rate_constants.json index 8cbb47f7..2f89aa75 100644 --- a/data/photolysis_rate_constants.json +++ b/data/photolysis_rate_constants.json @@ -1,4 +1,7 @@ - "__description": "This file contains configurations for each of the photolysis rate constants that can be calculated using data from this folder", + "__description": [ + "This file contains configurations for each of the TUV 5.4 photolysis rate constants that can be calculated using data from this folder", + "The original TUV 5.4 source code and data sets can be found here: https://www2.acom.ucar.edu/modeling/tuv-download" + ], "photolysis": { "enable diagnostics" : true, "reactions": [ diff --git a/data/quantum_yields/H2SO4_mills.nc b/data/quantum_yields/H2SO4_mills.nc new file mode 100644 index 00000000..6b55ee87 Binary files /dev/null and b/data/quantum_yields/H2SO4_mills.nc differ diff --git a/data/quantum_yields/N2O5_NO3_NO2.nc b/data/quantum_yields/N2O5_NO3_NO2.nc deleted file mode 100644 index cd7edee1..00000000 Binary files a/data/quantum_yields/N2O5_NO3_NO2.nc and /dev/null differ diff --git a/data/quantum_yields/N2O5_NO3_NO_O.nc b/data/quantum_yields/N2O5_NO3_NO_O.nc deleted file mode 100644 index 29224c1b..00000000 Binary files a/data/quantum_yields/N2O5_NO3_NO_O.nc and /dev/null differ diff --git a/docker/Dockerfile b/docker/Dockerfile new file mode 100644 index 00000000..6baec36b --- /dev/null +++ b/docker/Dockerfile @@ -0,0 +1,33 @@ +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 + +ENV LD_LIBRARY_PATH=/usr/local/lib64 + +# build the tuv-x tool +COPY . /tuv-x/ +RUN mkdir /build \ + && cd /build \ + && cmake -D CMAKE_BUILD_TYPE=release \ + /tuv-x \ + && make install -j 8 + +WORKDIR /build diff --git a/Dockerfile.memcheck b/docker/Dockerfile.coverage similarity index 59% rename from Dockerfile.memcheck rename to docker/Dockerfile.coverage index 18187aab..26c827f4 100644 --- a/Dockerfile.memcheck +++ b/docker/Dockerfile.coverage @@ -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.docs b/docker/Dockerfile.docs similarity index 63% rename from Dockerfile.docs rename to docker/Dockerfile.docs index 51dd6d18..4868ebd1 100644 --- a/Dockerfile.docs +++ b/docker/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/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck new file mode 100644 index 00000000..ebcbec3e --- /dev/null +++ b/docker/Dockerfile.memcheck @@ -0,0 +1,32 @@ +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 +COPY . /tuv-x/ +RUN mkdir /build \ + && cd /build \ + && cmake \ + -DENABLE_MEMCHECK:BOOL=TRUE \ + /tuv-x \ + && make -j 8 + +WORKDIR /build diff --git a/Dockerfile.mpi b/docker/Dockerfile.mpi similarity index 69% rename from Dockerfile.mpi rename to docker/Dockerfile.mpi index 79065e3e..c04e987c 100644 --- a/Dockerfile.mpi +++ b/docker/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,27 +32,16 @@ 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 \ ../tuv-x \ && make -j 8 diff --git a/Dockerfile.mpi.memcheck b/docker/Dockerfile.mpi.memcheck similarity index 73% rename from Dockerfile.mpi.memcheck rename to docker/Dockerfile.mpi.memcheck index 6856fa4c..7d1eb662 100644 --- a/Dockerfile.mpi.memcheck +++ b/docker/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/docs/source/conf.py b/docs/source/conf.py index 7ac7dd1f..42db23e8 100644 --- a/docs/source/conf.py +++ b/docs/source/conf.py @@ -26,7 +26,7 @@ suffix = os.getenv("SWITCHER_SUFFIX", "") # The full version, including alpha/beta/rc tags -release = f'v0.7{suffix}' +release = f'v0.8{suffix}' # -- General configuration --------------------------------------------------- diff --git a/docs/switcher.json b/docs/switcher.json index 4b19298e..0aaa0b03 100644 --- a/docs/switcher.json +++ b/docs/switcher.json @@ -1,6 +1,6 @@ [ { - "name": "v0.7 (stable)", + "name": "v0.8 (stable)", "version": "stable", "url": "https://ncar.github.io/tuv-x/versions/stable/" }, @@ -18,5 +18,10 @@ "name": "v0.7", "version": "0.7", "url": "https://ncar.github.io/tuv-x/versions/0.7/" + }, + { + "name": "v0.8", + "version": "0.8", + "url": "https://ncar.github.io/tuv-x/versions/0.8/" } -] +] \ No newline at end of file diff --git a/examples/ts1_tsmlt.json b/examples/ts1_tsmlt.json new file mode 100644 index 00000000..7ea1806e --- /dev/null +++ b/examples/ts1_tsmlt.json @@ -0,0 +1,2095 @@ +{ + "__description": "TUV-x configuration for the MOZART-TS1 and MOZART-TSMLT chemical mechanisms", + "O2 absorption" : { + "cross section parameters file": "data/cross_sections/O2_parameters.txt" + }, + "grids": [ + { + "name": "height", + "type": "equal interval", + "units": "km", + "begins at" : 0.0, + "ends at" : 120.0, + "cell delta" : 1.0 + }, + { + "name": "wavelength", + "type": "from csv file", + "units": "nm", + "file path": "data/grids/wavelength/cam.csv" + }, + { + "name": "time", + "type": "from config file", + "units": "hours", + "values": [ 12.0, 14.0 ] + } + ], + "profiles": [ + { + "name": "O3", + "type": "O3", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.ozone" + }, + { + "name": "air", + "type": "air", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" + }, + { + "name": "O2", + "type": "O2", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" + }, + { + "name": "temperature", + "type": "from csv file", + "units": "K", + "file path": "data/profiles/atmosphere/ussa.temp", + "grid": { + "name": "height", + "units": "km" + } + }, + { + "name": "solar zenith angle", + "type": "solar zenith angle", + "units": "degrees", + "year" : 2002, + "month": 3, + "day": 21, + "longitude": 0.0, + "latitude": 0.0 + }, + { + "name": "Earth-Sun distance", + "type": "Earth-Sun distance", + "units": "AU", + "year" : 2002, + "month": 3, + "day": 21 + }, + { + "name": "surface albedo", + "type": "from config file", + "units": "none", + "uniform value": 0.10, + "grid": { + "name": "wavelength", + "units": "nm" + } + }, + { + "name": "extraterrestrial flux", + "enable diagnostics" : true, + "type": "extraterrestrial flux", + "units": "photon cm-2 s-1", + "file path": ["data/profiles/solar/susim_hi.flx", + "data/profiles/solar/atlas3_1994_317_a.dat", + "data/profiles/solar/sao2010.solref.converted", + "data/profiles/solar/neckel.flx"], + "interpolator": ["","","","fractional target"] + } + ], + "radiative transfer": { + "__output": true, + "solver" : { + "type" : "delta eddington" + }, + "cross sections": [ + { + "name": "air", + "type": "air" + }, + { + "name": "O3", + "netcdf files": [ + { "file path": "data/cross_sections/O3_1.nc" }, + { "file path": "data/cross_sections/O3_2.nc" }, + { "file path": "data/cross_sections/O3_3.nc" }, + { "file path": "data/cross_sections/O3_4.nc" } + ], + "type": "O3" + }, + { + "name": "O2", + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" } + } + ], + "type": "base" + } + ], + "radiators": [ + { + "enable diagnostics" : true, + "name": "air", + "type": "base", + "treat as air": true, + "cross section": "air", + "vertical profile": "air", + "vertical profile units": "molecule cm-3" + }, + { + "enable diagnostics" : true, + "name": "O2", + "type": "base", + "cross section": "O2", + "vertical profile": "O2", + "vertical profile units": "molecule cm-3" + }, + { + "enable diagnostics" : true, + "name": "O3", + "type": "base", + "cross section": "O3", + "vertical profile": "O3", + "vertical profile units": "molecule cm-3" + }, + { + "enable diagnostics" : true, + "name": "aerosols", + "type": "aerosol", + "optical depths": [2.40e-01, 1.06e-01, 4.56e-02, 1.91e-02, 1.01e-02, 7.63e-03, + 5.38e-03, 5.00e-03, 5.15e-03, 4.94e-03, 4.82e-03, 4.51e-03, + 4.74e-03, 4.37e-03, 4.28e-03, 4.03e-03, 3.83e-03, 3.78e-03, + 3.88e-03, 3.08e-03, 2.26e-03, 1.64e-03, 1.23e-03, 9.45e-04, + 7.49e-04, 6.30e-04, 5.50e-04, 4.21e-04, 3.22e-04, 2.48e-04, + 1.90e-04, 1.45e-04, 1.11e-04, 8.51e-05, 6.52e-05, 5.00e-05, + 3.83e-05, 2.93e-05, 2.25e-05, 1.72e-05, 1.32e-05, 1.01e-05, + 7.72e-06, 5.91e-06, 4.53e-06, 3.46e-06, 2.66e-06, 2.04e-06, + 1.56e-06, 1.19e-06, 9.14e-07], + "single scattering albedo": 0.99, + "asymmetry factor": 0.61, + "550 nm optical depth": 0.235 + } + ] + }, + "photolysis": { + "reactions": [ + { + "name": "jo2_a", + "__reaction": "O2 + hv -> O + O1D", + "cross section": { + "apply O2 bands": true, + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" }, + "interpolator": { "type": "fractional target" } + } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0, + "override bands": [ + { + "band": "lyman-alpha", + "value": 0.53 + }, + { + "band": "schumann-runge continuum", + "value": 1.0 + } + ] + }, + "heating" : { + "energy term": 175.05 + } + }, + { + "name": "jo2_b", + "__reaction": "O2 + hv -> O + O", + "cross section": { + "apply O2 bands": true, + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" }, + "interpolator": { "type": "fractional target" } + } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0, + "override bands": [ + { + "band": "lyman-alpha", + "value": 0.47 + }, + { + "band": "schumann-runge continuum", + "value": 0.0 + } + ] + }, + "heating" : { + "energy term": 242.37 + } + }, + { + "name": "jo3_a", + "__reaction": "O3 + hv -> O2 + O(1D)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/O3_1.nc" }, + { "file path": "data/cross_sections/O3_2.nc" }, + { "file path": "data/cross_sections/O3_3.nc" }, + { "file path": "data/cross_sections/O3_4.nc" } + ], + "type": "O3" + }, + "quantum yield": { + "type": "O3+hv->O2+O(1D)" + }, + "heating" : { + "energy term": 310.32 + } + }, + { + "name": "jo3_b", + "__reaction": "O3 + hv -> O2 + O(3P)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/O3_1.nc" }, + { "file path": "data/cross_sections/O3_2.nc" }, + { "file path": "data/cross_sections/O3_3.nc" }, + { "file path": "data/cross_sections/O3_4.nc" } + ], + "type": "O3" + }, + "quantum yield": { + "type": "O3+hv->O2+O(3P)" + }, + "heating" : { + "energy term": 1179.87 + } + }, + { + "name": "jn2o", + "__reaction": "N2O + hv -> N2 + O(1D)", + "cross section": { + "type": "N2O+hv->N2+O(1D)" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jno2", + "__reaction": "NO2 + hv -> NO + O(3P)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/NO2_1.nc" } + ], + "type": "NO2 tint" + }, + "quantum yield": { + "netcdf files": ["data/quantum_yields/NO2_1.nc"], + "type": "NO2 tint", + "lower extrapolation": { "type": "boundary" } + } + }, + { + "name": "jn2o5_a", + "__reaction": "N2O5 + hv -> NO2 + NO3", + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ -2.832441, 0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 1.0 + } + ] + } + }, + { + "name": "jn2o5_b", + "__reaction": "N2O5 + hv -> NO + O + NO3", + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ 3.832441, -0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 0.0 + } + ] + } + }, + { + "name": "jhno3", + "__reaction": "HNO3 + hv -> OH + NO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HNO3_JPL06.nc" } + ], + "type": "HNO3+hv->OH+NO2" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jno3_a", + "__reaction": "NO3 + hv -> NO2 + O(3P)", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/NO3_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/NO3-NO2+O(3P)_1.nc" + ], + "type": "tint", + "lower extrapolation": { + "type": "constant", + "value": 1.0 + } + } + }, + { + "name": "jno3_b", + "__reaction": "NO3 + hv -> NO + O2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/NO3_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/NO3-NO+O2_1.nc" + ], + "type": "tint" + } + }, + { + "name": "jch3ooh", + "__reaction": "CH3OOH + hv -> CH3O + OH", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3OOH_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch2o_a", + "__reaction": "CH2O + hv -> H + HCO", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH2O_1.nc" } + ], + "type": "CH2O" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/CH2O_1.nc" + ], + "type": "base", + "lower extrapolation": { + "type": "boundary" + } + } + }, + { + "name": "jch2o_b", + "__reaction": "CH2O + hv -> H2 + CO", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH2O_1.nc" } + ], + "type": "CH2O" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/CH2O_1.nc" + ], + "type": "CH2O", + "lower extrapolation": { + "type": "boundary" + } + } + }, + { + "name": "jh2o2", + "__reaction": "H2O2 + hv -> OH + OH", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/H2O2_1.nc" } + ], + "type": "H2O2+hv->OH+OH" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3cho", + "__reaction": "CH3CHO + hv -> CH3 + HCO", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3CHO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "netcdf files": [ + "data/quantum_yields/CH3CHO_1.nc" + ], + "type": "CH3CHO+hv->CH3+HCO" + } + }, + { + "name": "jpan", + "__reaction": "PAN + hv -> 0.6*CH3CO3 + 0.6*NO2 + 0.4*CH3O2 + 0.4*NO3 + 0.4*CO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/PAN_1.nc" } + ], + "type": "CH3ONO2+hv->CH3O+NO2" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jmvk", + "__reaction": "MVK + hv -> 0.7*C3H6 + 0.7*CO + 0.3*CH3O2 + 0.3*CH3CO3", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/MVK_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "MVK+hv->Products" + } + }, + { + "name": "jacet", + "__reaction": "CH3COCH3 + hv -> CH3CO + CH3", + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/ACETONE_JPL06.nc" + }, + "base temperature": 0.0, + "temperature ranges": [ + { + "maximum": 234.999999999999, + "fixed value": 235.0 + }, + { + "minimum": 235.0, + "maximum": 298.0 + }, + { + "minimum": 298.00000000001, + "fixed value": 298.0 + } + ] + } + }, + "quantum yield": { + "type": "CH3COCH3+hv->CH3CO+CH3", + "branch": "CO+CH3CO", + "low wavelength value": 1, + "minimum temperature": 218, + "maximum temperature": 295 + } + }, + { + "name": "jmgly", + "__reaction": "CH3COCHO + hv -> CH3CO3 + CO + HO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3COCHO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "CH3COCHO+hv->CH3CO+HCO" + } + }, + { + "name": "jglyald", + "__reaction": "GLYALD + hv -> 2*HO2 + CO + CH2O", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HOCH2CHO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.5 + } + }, + { + "name": "jbrcl", + "__reaction": "BrCl + hv -> Br + Cl", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/BrCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jbro", + "__reaction": "BrO + hv -> Br + O", + "cross section": { + "netcdf files": [ + { + "file path": "data/cross_sections/BRO_JPL06.nc" + } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jbrono2_a", + "__reaction": "BrONO2 + hv -> Br + NO3", + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.85 + } + }, + { + "name": "jbrono2_b", + "__reaction": "BrONO2 + hv -> BrO + NO2", + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.15 + } + }, + { + "name": "jccl4", + "__reaction": "CCl4 + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CCl4_1.nc" } + ], + "type": "CCl4+hv->Products" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcf2clbr", + "__reaction": "CF2BrCl + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CF2BrCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcf3br", + "__reaction": "CF3Br + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H1301_JPL06.nc", + "parameterization": { + "AA": [ 62.563, -2.0068, 1.6592e-2, -5.6465e-5, 6.7459e-8 ], + "BB": [ -9.1755e-1, 1.8575e-2, -1.3857e-4, 4.5066e-7, -5.3803e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 178.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfcl3", + "__reaction": "CCl3F + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFCL3_JPL06.nc", + "parameterization": { + "AA": [ -84.611, 7.9551e-1, -2.0550e-3, -4.4812e-6, 1.5838e-8 ], + "BB": [ -5.7912, 1.1689e-1, -8.8069e-4, 2.9335e-6, -3.6421e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfc113", + "__reaction": "CFC-113 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC113_JPL06.nc", + "parameterization": { + "AA": [ -1087.9, 20.004, -1.3920e-1, 4.2828e-4, -4.9384e-7 ], + "BB": [ 12.493, -2.3937e-1, 1.7142e-3, -5.4393e-6, 6.4548e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 182.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfc114", + "__reaction": "CFC-114 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC114_JPL10.nc", + "parameterization": { + "AA": [ -160.50, 2.4807, -1.5202e-2, 3.8412e-5, -3.4373e-8 ], + "BB": [ -1.5296, 3.5248e-2, -2.9951e-4, 1.1129e-6, -1.5259e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 220.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcfc115", + "__reaction": "CFC-115 + hv -> Products", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CFC115_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcf2cl2", + "__reaction": "CCl2F2 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CF2CL2_JPL06.nc", + "parameterization": { + "AA": [ -43.8954569, -2.403597e-1, -4.2619e-4, 9.8743e-6, 0.0 ], + "BB": [ 4.8438e-3, 4.96145e-4, -5.6953e-6, 0.0, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 231.0, + "base temperature": 296.0, + "base wavelength": 200.0, + "logarithm": "natural", + "temperature ranges": [ + { + "maximum": 219.999999999999, + "fixed value": 220.0 + }, + { + "minimum": 220, + "maximum": 296 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch2br2", + "__reaction": "CH2BR2 + hv -> 2*BR", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH2BR2_1.nc", + "parameterization": { + "AA": [ -70.211776, 1.940326e-1, 2.726152e-3, -1.695472e-5, 2.500066e-8 ], + "BB": [ 2.899280, -4.327724e-2, 2.391599e-4, -5.807506e-7, 5.244883e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 210.0, + "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3br", + "__reaction": "CH3Br + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3BR_JPL06.nc", + "parameterization": { + "AA": [ 46.520, -1.4580, 1.1469e-2, -3.7627e-5, 4.3264e-8 ], + "BB": [ 9.3408e-1, -1.6887e-2, 1.1487e-4, -3.4881e-7, 3.9945e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3ccl3", + "__reaction": "CH3CCl3+hv->Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CH3CCl3_1.nc" } + ], + "type": "tint" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jch3cl", + "__reaction": "CH3Cl + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3CL_JPL06.nc", + "parameterization": { + "AA": [ -299.80, 5.1047, -3.3630e-2, 9.5805e-5, -1.0135e-7 ], + "BB": [ -7.1727, 1.4837e-1, -1.1463e-3, 3.9188e-6, -4.9994e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 216.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jchbr3", + "__reaction": "CHBr3 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CHBR3_JPL10.nc", + "parameterization": { + "AA": [ -32.6067, 0.10308, 6.39e-5, -7.7392e-7, -2.2513e-9, 6.1376e-12 ], + "BB": [ 0.1582, -0.0014758, 3.8058e-6, 9.187e-10, -1.0772e-11, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0 ], + "minimum wavelength": 260.0, + "maximum wavelength": 362.0, + "base temperature": 296.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "invert temperature offset": true, + "temperature ranges": [ + { + "maximum": 259.999999999999, + "fixed value": 260.0 + }, + { + "minimum": 260.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcl2", + "__reaction": "Cl2 + hv -> Cl + Cl", + "cross section": { + "type": "Cl2+hv->Cl+Cl" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcl2o2", + "__reaction": "ClOOCl + hv -> Cl + ClOO", + "__comments": "TODO - this doesn't exactly match the products in TS1", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CL2O2_JPL10.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jclo", + "__reaction": "ClO + hv -> Cl + O", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CLO_JPL06.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jclono2_a", + "__reaction": "ClONO2 + hv -> Cl + NO3", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/ClONO2_1.nc" } + ], + "type": "ClONO2" + }, + "quantum yield": { + "type": "ClONO2+hv->Cl+NO3" + } + }, + { + "name": "jclono2_b", + "__reaction": "ClONO2 + hv -> ClO + NO2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/ClONO2_1.nc" } + ], + "type": "ClONO2" + }, + "quantum yield": { + "type": "ClONO2+hv->ClO+NO2" + } + }, + { + "name": "jcof2", + "__reaction": "CF2O + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CF2O_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jcofcl", + "__reaction": "CClFO + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/CClFO_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jh2402", + "__reaction": "H2402 + hv -> 2*BR + 2*COF2", + "__comments": "TUV data set name CF2BrCF2Br", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H2402_JPL06.nc", + "parameterization": { + "AA": [ 34.026, -1.152616, 8.959798e-3, -2.9089e-5, 3.307212e-8 ], + "BB": [ 4.010664e-1, -8.358968e-3, 6.415741e-5, -2.157554e-7, 2.691871e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 190.0, + "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcfc141b", + "__reaction": "HCFC-141b + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC141b_JPL10.nc", + "parameterization": { + "AA": [ -682.913042, 12.122290, -8.187699e-2, 2.437244e-4, -2.719103e-7 ], + "BB": [ 4.074747, -8.053899e-2, 5.946552e-4, -1.945048e-6, 2.380143e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 240.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcfc142b", + "__reaction": "HCFC-142b + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC142b_JPL10.nc", + "parameterization": { + "AA": [ -328.092008, 6.342799, -4.810362e-2, 1.611991e-4, -2.042613e-7 ], + "BB": [ 4.289533e-1, -9.042817e-3, 7.018009e-5, -2.389064e-7, 3.039799e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcfc22", + "__reaction": "HCFC-22 + hv -> Products", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC22_JPL06.nc", + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 169.0, 171.0, 173.0, 175.0, 177.0, 179.0, 181.0, 183.0, 185.0, + 187.0, 189.0, 191.0, 193.0, 195.0, 197.0, 199.0, 201.0, 203.0, + 205.0, 207.0, 209.0, 211.0, 213.0, 215.0, 217.0, 219.0, 221.0 + ] + }, + "parameterization": { + "AA": [ -106.029, 1.5038, -8.2476e-3, 1.4206e-5 ], + "BB": [ -1.3399e-1, 2.7405e-3, -1.8028e-5, 3.8504e-8 ], + "lp": [ 0.0, 1.0, 2.0, 3.0 ], + "minimum wavelength": 174.0, + "maximum wavelength": 204.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhcl", + "__reaction": "HCl + hv -> H + Cl", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhobr", + "__reaction": "HOBr + hv -> OH + Br", + "cross section": { + "type": "HOBr+hv->OH+Br" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhocl", + "__reaction": "HOCl + hv -> HO + Cl", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/HOCl_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "joclo", + "__reaction": "OClO + hv -> Products", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/OClO_1.nc" }, + { "file path": "data/cross_sections/OClO_2.nc" }, + { "file path": "data/cross_sections/OClO_3.nc" } + ], + "type": "OClO+hv->Products" + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jho2no2_a", + "__reaction": "HNO4 + hv -> OH + NO3", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.30, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.20 + } + ] + } + }, + { + "name": "jho2no2_b", + "__reaction": "HNO4 + hv -> HO2 + NO2", + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.70, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.80 + } + ] + } + }, + { + "name": "jmacr_a", + "__reaction": "CH2=C(CH3)CHO->1.34HO2+0.66MCO3+1.34CH2O+CH3CO3", + "__comments": "Methacrolein photolysis channel 1", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/Methacrolein_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.005 + } + }, + { + "name": "jmacr_b", + "__reaction": "CH2=C(CH3)CHO->0.66OH+1.34CO", + "__comments": "Methacrolein photolysis channel 2", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/Methacrolein_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.005 + } + }, + { + "name": "jhyac", + "__reaction": "CH2(OH)COCH3->CH3CO3+HO2+CH2O", + "__comments": "hydroxy acetone TODO: the products of this reaction differ from standalone TUV-x", + "cross section": { + "netcdf files": [ + { "file path": "data/cross_sections/Hydroxyacetone_1.nc" } + ], + "type": "base" + }, + "quantum yield": { + "type": "base", + "constant value": 0.65 + } + }, + { + "name": "jh2o_a", + "__reaction": "H2O + hv -> OH + H", + "cross section": { + "type": "base", + "merge data": true, + "netcdf files": [ + { + "file path": "data/cross_sections/H2O_1.nc", + "zero above": 183.0 + }, + { + "file path": "data/cross_sections/H2O_2.nc", + "zero below": 183.00000000001, + "zero above": 190.0 + }, + { + "file path": "data/cross_sections/H2O_3.nc", + "zero below": 190.00000000001 + } + ] + }, + "quantum yield" : { + "type": "base", + "netcdf files": [ "data/quantum_yields/H2O_H_OH.nc" ] + } + }, + { + "name": "jh2o_b", + "__reaction": "H2O + hv -> H2 + O1D", + "cross section": { + "type": "base", + "merge data": true, + "netcdf files": [ + { + "file path": "data/cross_sections/H2O_1.nc", + "zero above": 183.0 + }, + { + "file path": "data/cross_sections/H2O_2.nc", + "zero below": 183.00000000001, + "zero above": 190.0 + }, + { + "file path": "data/cross_sections/H2O_3.nc", + "zero below": 190.00000000001 + } + ] + }, + "quantum yield" : { + "type": "base", + "netcdf files": [ "data/quantum_yields/H2O_H2_O1D.nc" ] + } + }, + { + "name": "jh2o_c", + "__reaction": "H2O + hv -> 2*H + O", + "cross section": { + "type": "base", + "merge data": true, + "netcdf files": [ + { + "file path": "data/cross_sections/H2O_1.nc", + "zero above": 183.0 + }, + { + "file path": "data/cross_sections/H2O_2.nc", + "zero below": 183.00000000001, + "zero above": 190.0 + }, + { + "file path": "data/cross_sections/H2O_3.nc", + "zero below": 190.00000000001 + } + ] + }, + "quantum yield" : { + "type": "base", + "netcdf files": [ "data/quantum_yields/H2O_2H_O3P.nc" ] + } + }, + { + "name": "jch4_a", + "__reaction": "CH4 + hv -> H + CH3O2", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CH4_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 0.45 + } + }, + { + "name": "jch4_b", + "__reaction": "CH4 + hv -> 1.44*H2 + 0.18*CH2O + 0.18*O + 0.33*OH + 0.33*H + 0.44*CO2 + 0.38*CO + 0.05*H2O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CH4_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 0.55 + } + }, + { + "name": "jco2", + "__reaction": "CO2 + hv -> CO + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CO2_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhbr", + "__reaction": "HBR + hv -> BR + H", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/HBr_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jhf", + "__reaction": "HF + hv -> H + F", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/HF_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jsf6", + "__reaction": "SF6 + hv -> sink", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SF6_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jh2so4", + "__reaction": "H2SO4 + hv -> SO3 + H2O", + "cross section": { + "type": "base", + "data": { + "default value": 0.0, + "point values": [ + { "wavelength": 121.65, "value": 6.3e-17 }, + { "wavelength": 525.0, "value": 1.43e-26 }, + { "wavelength": 625.0, "value": 1.8564e-25 }, + { "wavelength": 725.0, "value": 3.086999e-24 } + ] + } + }, + "quantum yield": { + "type": "H2SO4 Mills", + "netcdf files": [ + "data/quantum_yields/H2SO4_mills.nc" + ], + "parameterized wavelengths": [ + 525, + 625, + 725 + ], + "collision interval s": [ + 1.1e-9, + 8.9e-9, + 1.7e-7 + ], + "molecular diameter m": 4.18e-10, + "molecular weight kg mol-1": 98.078479e-3 + } + }, + { + "name": "jocs", + "__reaction": "OCS + hv -> S + CO", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/OCS_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jso", + "__reaction": "SO + hv -> S + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jso2", + "__reaction": "SO2 + hv -> SO + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO2_Mills.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jso3", + "__reaction": "SO3 + hv -> SO2 + O", + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO3_1.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + }, + { + "name": "jno_i", + "__reaction": "NO + hv -> NOp + e", + "cross section": { + "type": "base", + "data": { + "default value": 0.0, + "point values": [ + { "wavelength": 121.65, "value": 2.0e-18 } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + } + } + ] + }, + "__CAM options": { + "aliasing": { + "default matching": "backup", + "pairs": [ + { + "to": "jalknit", + "__reaction": "ALKNIT + hv -> NO2 + 0.4*CH3CHO + 0.1*CH2O + 0.25*CH3COCH3 + HO2 + 0.8*MEK", + "from": "jch3ooh" + }, + { + "to": "jpooh", + "__reaction": "POOH (C3H6OHOOH) + hv -> CH3CHO + CH2O + HO2 + OH", + "from": "jch3ooh" + }, + { + "to": "jch3co3h", + "__reaction": "CH3COOOH + hv -> CH3O2 + OH + CO2", + "from": "jh2o2", + "scale by": 0.28 + }, + { + "to": "jmpan", + "__reaction": "MPAN + hv -> MCO3 + NO2", + "from": "jpan" + }, + { + "to": "jc2h5ooh", + "__reaction": "C2H5OOH + hv -> CH3CHO + HO2 + OH", + "from": "jch3ooh" + }, + { + "to": "jc3h7ooh", + "__reaction": "C3H7OOH + hv -> 0.82*CH3COCH3 + OH + HO2", + "from": "jch3ooh" + }, + { + "to": "jc6h5ooh", + "__reaction": "C6H5OOH + hv -> PHENO + OH", + "from": "jch3ooh" + }, + { + "to": "jeooh", + "__reaction": "EOOH + hv -> EO + OH", + "from": "jch3ooh" + }, + { + "to": "jrooh", + "__reaction": "ROOH + hv -> CH3CO3 + CH2O + OH", + "from": "jch3ooh" + }, + { + "to": "jxooh", + "__reaction": "XOOH + hv -> OH", + "from": "jch3ooh" + }, + { + "to": "jonitr", + "__reaction": "ONITR + hv -> NO2", + "from": "jch3cho" + }, + { + "to": "jisopooh", + "__reaction": "ISOPOOH + hv -> 0.402*MVK + 0.288*MACR + 0.69*CH2O + HO2", + "from": "jch3ooh" + }, + { + "to": "jmek", + "__reaction": "MEK + hv -> CH3CO3 + C2H5O2", + "from": "jacet" + }, + { + "to": "jalkooh", + "__reaction": "ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH", + "from": "jch3ooh" + }, + { + "to": "jbenzooh", + "__reaction": "BENZOOH + hv -> OH + GLYOXAL + 0.5*BIGALD1 + HO2", + "from": "jch3ooh" + }, + { + "to": "jbepomuc", + "__reaction": "BEPOMUC + hv -> BIGALD1 + 1.5*HO2 + 1.5*CO", + "from": "jno2", + "scale by": 0.1 + }, + { + "to": "jbigald", + "__reaction": "BIGALD + hv -> 0.45*CO + 0.13*GLYOXAL + 0.56*HO2 + 0.13*CH3CO3 + 0.18*CH3COCHO", + "from": "jno2", + "scale by": 0.2 + }, + { + "to": "jbigald1", + "__reaction": "BIGALD1 + hv -> 0.6*MALO2 + HO2", + "from": "jno2", + "scale by": 0.14 + }, + { + "to": "jbigald2", + "__reaction": "BIGALD2 + hv -> 0.6*HO2 + 0.6*DICARBO2", + "from": "jno2", + "scale by": 0.2 + }, + { + "to": "jbigald3", + "__reaction": "BIGALD3 + hv -> 0.6*HO2 + 0.6*CO + 0.6*MDIALO2", + "from": "jno2", + "scale by": 0.2 + }, + { + "to": "jbigald4", + "__reaction": "BIGALD4 + hv -> HO2 + CO + CH3COCHO + CH3CO3", + "from": "jno2", + "scale by": 0.006 + }, + { + "to": "jbzooh", + "__reaction": "BZOOH + hv -> BZALD + OH + HO2", + "from": "jch3ooh" + }, + { + "to": "jmekooh", + "__reaction": "MEKOOH + hv -> OH + CH3CO3 + CH3CHO", + "from": "jch3ooh" + }, + { + "to": "jtolooh", + "__reaction": "TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD", + "from": "jch3ooh" + }, + { + "to": "jterpooh", + "__reaction": "TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR", + "from": "jch3ooh" + }, + { + "to": "jhonitr", + "__reaction": "HONITR + hv -> NO2 + 0.67*HO2 + 0.33*CH3CHO + 0.33*CH2O + 0.33*CO + 0.33*GLYALD + 0.33*CH3CO3 + 0.17*HYAC + 0.17*CH3COCH3", + "from": "jch2o_a" + }, + { + "to": "jhpald", + "__reaction": "HPALD + hv -> BIGALD3 + OH + HO2", + "from": "jno2", + "scale by": 0.006 + }, + { + "to": "jisopnooh", + "__reaction": "ISOPNOOH + hv -> NO2 + HO2 + ISOPOOH", + "from": "jch3ooh" + }, + { + "to": "jnc4cho", + "__reaction": "NC4CHO + hv -> BIGALD3 + NO2 + HO2", + "from": "jch2o_a" + }, + { + "to": "jnoa", + "__reaction": "NOA + hv -> NO2 + CH2O + CH3CO3", + "from": "jch2o_a" + }, + { + "to": "jnterpooh", + "__reaction": "NTERPOOH + hv -> TERPROD1 + NO2 + OH", + "from": "jch3ooh" + }, + { + "to": "jphenooh", + "__reaction": "PHENOOH + hv -> OH + HO2 + 0.7*GLYOXAL", + "from": "jch3ooh" + }, + { + "to": "jtepomuc", + "__reaction": "TEPOMUC + hv -> 0.5*CH3CO3 + HO2 + 1.5*CO", + "from": "jno2", + "scale by": 0.1 + }, + { + "to": "jterp2ooh", + "__reaction": "TERP2OOH + hv -> OH + 0.375*CH2O + 0.3*CH3COCH3 + 0.25*CO + CO2 + TERPROD2 + HO2 + 0.25*GLYALD", + "from": "jch3ooh" + }, + { + "to": "jterpnit", + "__reaction": "TERPNIT + hv -> TERPROD1 + NO2 + HO2", + "from": "jch3ooh" + }, + { + "to": "jterprd1", + "__reaction": "TERPROD1 + hv -> HO2 + CO + TERPROD2", + "from": "jch3cho" + }, + { + "to": "jterprd2", + "__reaction": "TERPROD2 + hv -> 0.15*RO2 + 0.68*CH2O + 0.8*CO2 + 0.5*CH3COCH3 + 0.65*CH3CO3 + 1.2*HO2 + 1.7*CO", + "from": "jch3cho" + }, + { + "to": "jxylenooh", + "__reaction": "XYLENOOH + hv -> OH + HO2 + 0.34*GLYOXAL + 0.54*CH3COCHO + 0.06*BIGALD1 + 0.2*BIGALD2 + 0.15*BIGALD3 + 0.21*BIGALD4", + "from": "jch3ooh" + }, + { + "to": "jxylolooh", + "__reaction": "XYLOLOOH + hv -> OH + 0.17*GLYOXAL + 0.51*CH3COCHO + HO2", + "from": "jch3ooh" + }, + { + "to": "jsoa1_a1", + "__reaction": "soa1_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa1_a2", + "__reaction": "soa1_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa2_a1", + "__reaction": "soa2_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa2_a2", + "__reaction": "soa2_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa3_a1", + "__reaction": "soa3_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa3_a2", + "__reaction": "soa3_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa4_a1", + "__reaction": "soa4_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa4_a2", + "__reaction": "soa4_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa5_a1", + "__reaction": "soa5_a1 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jsoa5_a2", + "__reaction": "soa5_a2 + hv -> Products", + "from": "jno2", + "scale by": 0.0004 + }, + { + "to": "jglyoxal", + "__reaction": "GLYOXAL + hv -> 2*CO + 2*HO2", + "from": "jmgly" + } + ] + } + } +} diff --git a/examples/ts1_tsmlt.yml b/examples/ts1_tsmlt.yml new file mode 100644 index 00000000..c6d1e4e8 --- /dev/null +++ b/examples/ts1_tsmlt.yml @@ -0,0 +1,1742 @@ +O2 absorption: + cross section parameters file: data/cross_sections/O2_parameters.txt +__CAM options: + aliasing: + default matching: backup + pairs: + - __reaction: ALKNIT + hv -> NO2 + 0.4*CH3CHO + 0.1*CH2O + 0.25*CH3COCH3 + HO2 + + 0.8*MEK + from: jch3ooh + to: jalknit + - __reaction: POOH (C3H6OHOOH) + hv -> CH3CHO + CH2O + HO2 + OH + from: jch3ooh + to: jpooh + - __reaction: CH3COOOH + hv -> CH3O2 + OH + CO2 + from: jh2o2 + scale by: 0.28 + to: jch3co3h + - __reaction: MPAN + hv -> MCO3 + NO2 + from: jpan + to: jmpan + - __reaction: C2H5OOH + hv -> CH3CHO + HO2 + OH + from: jch3ooh + to: jc2h5ooh + - __reaction: C3H7OOH + hv -> 0.82*CH3COCH3 + OH + HO2 + from: jch3ooh + to: jc3h7ooh + - __reaction: C6H5OOH + hv -> PHENO + OH + from: jch3ooh + to: jc6h5ooh + - __reaction: EOOH + hv -> EO + OH + from: jch3ooh + to: jeooh + - __reaction: ROOH + hv -> CH3CO3 + CH2O + OH + from: jch3ooh + to: jrooh + - __reaction: XOOH + hv -> OH + from: jch3ooh + to: jxooh + - __reaction: ONITR + hv -> NO2 + from: jch3cho + to: jonitr + - __reaction: ISOPOOH + hv -> 0.402*MVK + 0.288*MACR + 0.69*CH2O + HO2 + from: jch3ooh + to: jisopooh + - __reaction: MEK + hv -> CH3CO3 + C2H5O2 + from: jacet + to: jmek + - __reaction: ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + + OH + from: jch3ooh + to: jalkooh + - __reaction: BENZOOH + hv -> OH + GLYOXAL + 0.5*BIGALD1 + HO2 + from: jch3ooh + to: jbenzooh + - __reaction: BEPOMUC + hv -> BIGALD1 + 1.5*HO2 + 1.5*CO + from: jno2 + scale by: 0.1 + to: jbepomuc + - __reaction: BIGALD + hv -> 0.45*CO + 0.13*GLYOXAL + 0.56*HO2 + 0.13*CH3CO3 + + 0.18*CH3COCHO + from: jno2 + scale by: 0.2 + to: jbigald + - __reaction: BIGALD1 + hv -> 0.6*MALO2 + HO2 + from: jno2 + scale by: 0.14 + to: jbigald1 + - __reaction: BIGALD2 + hv -> 0.6*HO2 + 0.6*DICARBO2 + from: jno2 + scale by: 0.2 + to: jbigald2 + - __reaction: BIGALD3 + hv -> 0.6*HO2 + 0.6*CO + 0.6*MDIALO2 + from: jno2 + scale by: 0.2 + to: jbigald3 + - __reaction: BIGALD4 + hv -> HO2 + CO + CH3COCHO + CH3CO3 + from: jno2 + scale by: 0.006 + to: jbigald4 + - __reaction: BZOOH + hv -> BZALD + OH + HO2 + from: jch3ooh + to: jbzooh + - __reaction: MEKOOH + hv -> OH + CH3CO3 + CH3CHO + from: jch3ooh + to: jmekooh + - __reaction: TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + from: jch3ooh + to: jtolooh + - __reaction: TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + from: jch3ooh + to: jterpooh + - __reaction: HONITR + hv -> NO2 + 0.67*HO2 + 0.33*CH3CHO + 0.33*CH2O + 0.33*CO + + 0.33*GLYALD + 0.33*CH3CO3 + 0.17*HYAC + 0.17*CH3COCH3 + from: jch2o_a + to: jhonitr + - __reaction: HPALD + hv -> BIGALD3 + OH + HO2 + from: jno2 + scale by: 0.006 + to: jhpald + - __reaction: ISOPNOOH + hv -> NO2 + HO2 + ISOPOOH + from: jch3ooh + to: jisopnooh + - __reaction: NC4CHO + hv -> BIGALD3 + NO2 + HO2 + from: jch2o_a + to: jnc4cho + - __reaction: NOA + hv -> NO2 + CH2O + CH3CO3 + from: jch2o_a + to: jnoa + - __reaction: NTERPOOH + hv -> TERPROD1 + NO2 + OH + from: jch3ooh + to: jnterpooh + - __reaction: PHENOOH + hv -> OH + HO2 + 0.7*GLYOXAL + from: jch3ooh + to: jphenooh + - __reaction: TEPOMUC + hv -> 0.5*CH3CO3 + HO2 + 1.5*CO + from: jno2 + scale by: 0.1 + to: jtepomuc + - __reaction: TERP2OOH + hv -> OH + 0.375*CH2O + 0.3*CH3COCH3 + 0.25*CO + CO2 + + TERPROD2 + HO2 + 0.25*GLYALD + from: jch3ooh + to: jterp2ooh + - __reaction: TERPNIT + hv -> TERPROD1 + NO2 + HO2 + from: jch3ooh + to: jterpnit + - __reaction: TERPROD1 + hv -> HO2 + CO + TERPROD2 + from: jch3cho + to: jterprd1 + - __reaction: TERPROD2 + hv -> 0.15*RO2 + 0.68*CH2O + 0.8*CO2 + 0.5*CH3COCH3 + + 0.65*CH3CO3 + 1.2*HO2 + 1.7*CO + from: jch3cho + to: jterprd2 + - __reaction: XYLENOOH + hv -> OH + HO2 + 0.34*GLYOXAL + 0.54*CH3COCHO + 0.06*BIGALD1 + + 0.2*BIGALD2 + 0.15*BIGALD3 + 0.21*BIGALD4 + from: jch3ooh + to: jxylenooh + - __reaction: XYLOLOOH + hv -> OH + 0.17*GLYOXAL + 0.51*CH3COCHO + HO2 + from: jch3ooh + to: jxylolooh + - __reaction: soa1_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa1_a1 + - __reaction: soa1_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa1_a2 + - __reaction: soa2_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa2_a1 + - __reaction: soa2_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa2_a2 + - __reaction: soa3_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa3_a1 + - __reaction: soa3_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa3_a2 + - __reaction: soa4_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa4_a1 + - __reaction: soa4_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa4_a2 + - __reaction: soa5_a1 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa5_a1 + - __reaction: soa5_a2 + hv -> Products + from: jno2 + scale by: 0.0004 + to: jsoa5_a2 + - __reaction: GLYOXAL + hv -> 2*CO + 2*HO2 + from: jmgly + to: jglyoxal +__description: TUV-x configuration for the MOZART-TS1 and MOZART-TSMLT chemical mechanisms +grids: +- begins at: 0.0 + cell delta: 1.0 + ends at: 120.0 + name: height + type: equal interval + units: km +- file path: data/grids/wavelength/cam.csv + name: wavelength + type: from csv file + units: nm +- name: time + type: from config file + units: hours + values: + - 12.0 + - 14.0 +photolysis: + reactions: + - __reaction: O2 + hv -> O + O1D + cross section: + apply O2 bands: true + netcdf files: + - file path: data/cross_sections/O2_1.nc + interpolator: + type: fractional target + lower extrapolation: + type: boundary + type: base + heating: + energy term: 175.05 + name: jo2_a + quantum yield: + constant value: 0 + override bands: + - band: lyman-alpha + value: 0.53 + - band: schumann-runge continuum + value: 1.0 + type: base + - __reaction: O2 + hv -> O + O + cross section: + apply O2 bands: true + netcdf files: + - file path: data/cross_sections/O2_1.nc + interpolator: + type: fractional target + lower extrapolation: + type: boundary + type: base + heating: + energy term: 242.37 + name: jo2_b + quantum yield: + constant value: 1.0 + override bands: + - band: lyman-alpha + value: 0.47 + - band: schumann-runge continuum + value: 0.0 + type: base + - __reaction: O3 + hv -> O2 + O(1D) + cross section: + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + heating: + energy term: 310.32 + name: jo3_a + quantum yield: + type: O3+hv->O2+O(1D) + - __reaction: O3 + hv -> O2 + O(3P) + cross section: + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + heating: + energy term: 1179.87 + name: jo3_b + quantum yield: + type: O3+hv->O2+O(3P) + - __reaction: N2O + hv -> N2 + O(1D) + cross section: + type: N2O+hv->N2+O(1D) + name: jn2o + quantum yield: + constant value: 1.0 + type: base + - __reaction: NO2 + hv -> NO + O(3P) + cross section: + netcdf files: + - file path: data/cross_sections/NO2_1.nc + type: NO2 tint + name: jno2 + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/NO2_1.nc + type: NO2 tint + - __reaction: N2O5 + hv -> NO2 + NO3 + cross section: + netcdf file: data/cross_sections/N2O5_JPL06.nc + parameterization: + aa: + - -18.27 + - -18.42 + - -18.59 + - -18.72 + - -18.84 + - -18.9 + - -18.93 + - -18.87 + - -18.77 + - -18.71 + - -18.31 + - -18.14 + - -18.01 + - -18.42 + - -18.59 + - -18.13 + base temperature: 0.0 + base wavelength: 0.0 + bb: + - -91.0 + - -104.0 + - -112.0 + - -135.0 + - -170.0 + - -226.0 + - -294.0 + - -388.0 + - -492.0 + - -583.0 + - -770.0 + - -885.0 + - -992.0 + - -949.0 + - -966.0 + - -1160.0 + logarithm: base 10 + maximum wavelength: 410.0 + minimum wavelength: 260.0 + temperature ranges: + - fixed value: 200 + maximum: 199.999999999999 + - maximum: 295 + minimum: 200 + - fixed value: 295.0 + minimum: 295.00000000001 + type: HARWOOD + parameterization wavelength grid: + name: custom wavelengths + type: from config file + units: nm + values: + - 255.0 + - 265.0 + - 275.0 + - 285.0 + - 295.0 + - 305.0 + - 315.0 + - 325.0 + - 335.0 + - 345.0 + - 355.0 + - 365.0 + - 375.0 + - 385.0 + - 395.0 + - 405.0 + - 415.0 + type: temperature based + name: jn2o5_a + quantum yield: + coefficients: + - -2.832441 + - 0.012809638 + constant value: 0.0 + override bands: + - band: range + minimum wavelength: 300.0 + value: 1.0 + type: Taylor series + - __reaction: N2O5 + hv -> NO + O + NO3 + cross section: + netcdf file: data/cross_sections/N2O5_JPL06.nc + parameterization: + aa: + - -18.27 + - -18.42 + - -18.59 + - -18.72 + - -18.84 + - -18.9 + - -18.93 + - -18.87 + - -18.77 + - -18.71 + - -18.31 + - -18.14 + - -18.01 + - -18.42 + - -18.59 + - -18.13 + base temperature: 0.0 + base wavelength: 0.0 + bb: + - -91.0 + - -104.0 + - -112.0 + - -135.0 + - -170.0 + - -226.0 + - -294.0 + - -388.0 + - -492.0 + - -583.0 + - -770.0 + - -885.0 + - -992.0 + - -949.0 + - -966.0 + - -1160.0 + logarithm: base 10 + maximum wavelength: 410.0 + minimum wavelength: 260.0 + temperature ranges: + - fixed value: 200 + maximum: 199.999999999999 + - maximum: 295 + minimum: 200 + - fixed value: 295.0 + minimum: 295.00000000001 + type: HARWOOD + parameterization wavelength grid: + name: custom wavelengths + type: from config file + units: nm + values: + - 255.0 + - 265.0 + - 275.0 + - 285.0 + - 295.0 + - 305.0 + - 315.0 + - 325.0 + - 335.0 + - 345.0 + - 355.0 + - 365.0 + - 375.0 + - 385.0 + - 395.0 + - 405.0 + - 415.0 + type: temperature based + name: jn2o5_b + quantum yield: + coefficients: + - 3.832441 + - -0.012809638 + constant value: 0.0 + override bands: + - band: range + minimum wavelength: 300.0 + value: 0.0 + type: Taylor series + - __reaction: HNO3 + hv -> OH + NO2 + cross section: + netcdf files: + - file path: data/cross_sections/HNO3_JPL06.nc + type: HNO3+hv->OH+NO2 + name: jhno3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: NO3 + hv -> NO2 + O(3P) + cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: jno3_a + quantum yield: + lower extrapolation: + type: constant + value: 1.0 + netcdf files: + - data/quantum_yields/NO3-NO2+O(3P)_1.nc + type: tint + - __reaction: NO3 + hv -> NO + O2 + cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: jno3_b + quantum yield: + netcdf files: + - data/quantum_yields/NO3-NO+O2_1.nc + type: tint + - __reaction: CH3OOH + hv -> CH3O + OH + cross section: + netcdf files: + - file path: data/cross_sections/CH3OOH_1.nc + type: base + name: jch3ooh + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH2O + hv -> H + HCO + cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: jch2o_a + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: base + - __reaction: CH2O + hv -> H2 + CO + cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: jch2o_b + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: CH2O + - __reaction: H2O2 + hv -> OH + OH + cross section: + netcdf files: + - file path: data/cross_sections/H2O2_1.nc + type: H2O2+hv->OH+OH + name: jh2o2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3CHO + hv -> CH3 + HCO + cross section: + netcdf files: + - file path: data/cross_sections/CH3CHO_1.nc + type: base + name: jch3cho + quantum yield: + netcdf files: + - data/quantum_yields/CH3CHO_1.nc + type: CH3CHO+hv->CH3+HCO + - __reaction: PAN + hv -> 0.6*CH3CO3 + 0.6*NO2 + 0.4*CH3O2 + 0.4*NO3 + 0.4*CO2 + cross section: + netcdf files: + - file path: data/cross_sections/PAN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: jpan + quantum yield: + constant value: 1.0 + type: base + - __reaction: MVK + hv -> 0.7*C3H6 + 0.7*CO + 0.3*CH3O2 + 0.3*CH3CO3 + cross section: + netcdf files: + - file path: data/cross_sections/MVK_1.nc + type: base + name: jmvk + quantum yield: + type: MVK+hv->Products + - __reaction: CH3COCH3 + hv -> CH3CO + CH3 + cross section: + parameterization: + base temperature: 0.0 + netcdf file: + file path: data/cross_sections/ACETONE_JPL06.nc + temperature ranges: + - fixed value: 235.0 + maximum: 234.999999999999 + - maximum: 298.0 + minimum: 235.0 + - fixed value: 298.0 + minimum: 298.00000000001 + type: TAYLOR_SERIES + type: temperature based + name: jacet + quantum yield: + branch: CO+CH3CO + low wavelength value: 1 + maximum temperature: 295 + minimum temperature: 218 + type: CH3COCH3+hv->CH3CO+CH3 + - __reaction: CH3COCHO + hv -> CH3CO3 + CO + HO2 + cross section: + netcdf files: + - file path: data/cross_sections/CH3COCHO_1.nc + type: base + name: jmgly + quantum yield: + type: CH3COCHO+hv->CH3CO+HCO + - __reaction: GLYALD + hv -> 2*HO2 + CO + CH2O + cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: jglyald + quantum yield: + constant value: 0.5 + type: base + - __reaction: BrCl + hv -> Br + Cl + cross section: + netcdf files: + - file path: data/cross_sections/BrCl_1.nc + type: base + name: jbrcl + quantum yield: + constant value: 1.0 + type: base + - __reaction: BrO + hv -> Br + O + cross section: + netcdf files: + - file path: data/cross_sections/BRO_JPL06.nc + type: base + name: jbro + quantum yield: + constant value: 1.0 + type: base + - __reaction: BrONO2 + hv -> Br + NO3 + cross section: + parameterization: + base temperature: 296.0 + netcdf file: + file path: data/cross_sections/BRONO2_JPL06.nc + temperature ranges: + - fixed value: 200.0 + maximum: 199.999999999999 + - maximum: 296.0 + minimum: 200.0 + - fixed value: 296.0 + minimum: 296.00000000001 + type: TAYLOR_SERIES + type: temperature based + name: jbrono2_a + quantum yield: + constant value: 0.85 + type: base + - __reaction: BrONO2 + hv -> BrO + NO2 + cross section: + parameterization: + base temperature: 296.0 + netcdf file: + file path: data/cross_sections/BRONO2_JPL06.nc + temperature ranges: + - fixed value: 200.0 + maximum: 199.999999999999 + - maximum: 296.0 + minimum: 200.0 + - fixed value: 296.0 + minimum: 296.00000000001 + type: TAYLOR_SERIES + type: temperature based + name: jbrono2_b + quantum yield: + constant value: 0.15 + type: base + - __reaction: CCl4 + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CCl4_1.nc + type: CCl4+hv->Products + name: jccl4 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CF2BrCl + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CF2BrCl_1.nc + type: base + name: jcf2clbr + quantum yield: + constant value: 1.0 + type: base + - __reaction: CF3Br + hv -> Products + cross section: + netcdf file: data/cross_sections/H1301_JPL06.nc + parameterization: + AA: + - 62.563 + - -2.0068 + - 0.016592 + - -5.6465e-05 + - 6.7459e-08 + BB: + - -0.91755 + - 0.018575 + - -0.00013857 + - 4.5066e-07 + - -5.3803e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 280.0 + minimum wavelength: 178.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcf3br + quantum yield: + constant value: 1.0 + type: base + - __reaction: CCl3F + hv -> Products + cross section: + netcdf file: data/cross_sections/CFCL3_JPL06.nc + parameterization: + AA: + - -84.611 + - 0.79551 + - -0.002055 + - -4.4812e-06 + - 1.5838e-08 + BB: + - -5.7912 + - 0.11689 + - -0.00088069 + - 2.9335e-06 + - -3.6421e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 230.0 + minimum wavelength: 174.1 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcfcl3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CFC-113 + hv -> Products + cross section: + netcdf file: data/cross_sections/CFC113_JPL06.nc + parameterization: + AA: + - -1087.9 + - 20.004 + - -0.1392 + - 0.00042828 + - -4.9384e-07 + BB: + - 12.493 + - -0.23937 + - 0.0017142 + - -5.4393e-06 + - 6.4548e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 230.0 + minimum wavelength: 182.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcfc113 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CFC-114 + hv -> Products + cross section: + netcdf file: data/cross_sections/CFC114_JPL10.nc + parameterization: + AA: + - -160.5 + - 2.4807 + - -0.015202 + - 3.8412e-05 + - -3.4373e-08 + BB: + - -1.5296 + - 0.035248 + - -0.00029951 + - 1.1129e-06 + - -1.5259e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 220.0 + minimum wavelength: 172.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jcfc114 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CFC-115 + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CFC115_JPL10.nc + type: base + name: jcfc115 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CCl2F2 + hv -> Products + cross section: + netcdf file: data/cross_sections/CF2CL2_JPL06.nc + parameterization: + AA: + - -43.8954569 + - -0.2403597 + - -0.00042619 + - 9.8743e-06 + - 0.0 + BB: + - 0.0048438 + - 0.000496145 + - -5.6953e-06 + - 0.0 + - 0.0 + base temperature: 296.0 + base wavelength: 200.0 + logarithm: natural + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 231.0 + minimum wavelength: 200.0 + temperature ranges: + - fixed value: 220.0 + maximum: 219.999999999999 + - maximum: 296 + minimum: 220 + - fixed value: 296.0 + minimum: 296.00000000001 + type: temperature based + name: jcf2cl2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH2BR2 + hv -> 2*BR + cross section: + netcdf file: data/cross_sections/CH2BR2_1.nc + parameterization: + AA: + - -70.211776 + - 0.1940326 + - 0.002726152 + - -1.695472e-05 + - 2.500066e-08 + BB: + - 2.89928 + - -0.04327724 + - 0.0002391599 + - -5.807506e-07 + - 5.244883e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 290.0 + minimum wavelength: 210.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jch2br2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3Br + hv -> Products + cross section: + netcdf file: data/cross_sections/CH3BR_JPL06.nc + parameterization: + AA: + - 46.52 + - -1.458 + - 0.011469 + - -3.7627e-05 + - 4.3264e-08 + BB: + - 0.93408 + - -0.016887 + - 0.00011487 + - -3.4881e-07 + - 3.9945e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 280.0 + minimum wavelength: 200.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jch3br + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3CCl3+hv->Products + cross section: + netcdf files: + - file path: data/cross_sections/CH3CCl3_1.nc + type: tint + name: jch3ccl3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CH3Cl + hv -> Products + cross section: + netcdf file: data/cross_sections/CH3CL_JPL06.nc + parameterization: + AA: + - -299.8 + - 5.1047 + - -0.03363 + - 9.5805e-05 + - -1.0135e-07 + BB: + - -7.1727 + - 0.14837 + - -0.0011463 + - 3.9188e-06 + - -4.9994e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 216.0 + minimum wavelength: 174.1 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300 + minimum: 210 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jch3cl + quantum yield: + constant value: 1.0 + type: base + - __reaction: CHBr3 + hv -> Products + cross section: + netcdf file: data/cross_sections/CHBR3_JPL10.nc + parameterization: + AA: + - -32.6067 + - 0.10308 + - 6.39e-05 + - -7.7392e-07 + - -2.2513e-09 + - 6.1376e-12 + BB: + - 0.1582 + - -0.0014758 + - 3.8058e-06 + - 9.187e-10 + - -1.0772e-11 + - 0.0 + base temperature: 296.0 + base wavelength: 0.0 + invert temperature offset: true + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + - 5.0 + maximum wavelength: 362.0 + minimum wavelength: 260.0 + temperature ranges: + - fixed value: 260.0 + maximum: 259.999999999999 + - minimum: 260.0 + type: temperature based + name: jchbr3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: Cl2 + hv -> Cl + Cl + cross section: + type: Cl2+hv->Cl+Cl + name: jcl2 + quantum yield: + constant value: 1.0 + type: base + - __comments: TODO - this doesn't exactly match the products in TS1 + __reaction: ClOOCl + hv -> Cl + ClOO + cross section: + netcdf files: + - file path: data/cross_sections/CL2O2_JPL10.nc + type: base + name: jcl2o2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: ClO + hv -> Cl + O + cross section: + netcdf files: + - file path: data/cross_sections/CLO_JPL06.nc + type: base + name: jclo + quantum yield: + constant value: 1.0 + type: base + - __reaction: ClONO2 + hv -> Cl + NO3 + cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: jclono2_a + quantum yield: + type: ClONO2+hv->Cl+NO3 + - __reaction: ClONO2 + hv -> ClO + NO2 + cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: jclono2_b + quantum yield: + type: ClONO2+hv->ClO+NO2 + - __reaction: CF2O + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CF2O_1.nc + type: base + name: jcof2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: CClFO + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/CClFO_1.nc + type: base + name: jcofcl + quantum yield: + constant value: 1.0 + type: base + - __comments: TUV data set name CF2BrCF2Br + __reaction: H2402 + hv -> 2*BR + 2*COF2 + cross section: + netcdf file: data/cross_sections/H2402_JPL06.nc + parameterization: + AA: + - 34.026 + - -1.152616 + - 0.008959798 + - -2.9089e-05 + - 3.307212e-08 + BB: + - 0.4010664 + - -0.008358968 + - 6.415741e-05 + - -2.157554e-07 + - 2.691871e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 290.0 + minimum wavelength: 190.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jh2402 + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCFC-141b + hv -> Products + cross section: + netcdf file: data/cross_sections/HCFC141b_JPL10.nc + parameterization: + AA: + - -682.913042 + - 12.12229 + - -0.08187699 + - 0.0002437244 + - -2.719103e-07 + BB: + - 4.074747 + - -0.08053899 + - 0.0005946552 + - -1.945048e-06 + - 2.380143e-09 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 240.0 + minimum wavelength: 172.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jhcfc141b + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCFC-142b + hv -> Products + cross section: + netcdf file: data/cross_sections/HCFC142b_JPL10.nc + parameterization: + AA: + - -328.092008 + - 6.342799 + - -0.04810362 + - 0.0001611991 + - -2.042613e-07 + BB: + - 0.4289533 + - -0.009042817 + - 7.018009e-05 + - -2.389064e-07 + - 3.039799e-10 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + - 4.0 + maximum wavelength: 230.0 + minimum wavelength: 172.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + type: temperature based + name: jhcfc142b + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCFC-22 + hv -> Products + cross section: + netcdf file: data/cross_sections/HCFC22_JPL06.nc + parameterization: + AA: + - -106.029 + - 1.5038 + - -0.0082476 + - 1.4206e-05 + BB: + - -0.13399 + - 0.0027405 + - -1.8028e-05 + - 3.8504e-08 + base temperature: 273.0 + base wavelength: 0.0 + logarithm: base 10 + lp: + - 0.0 + - 1.0 + - 2.0 + - 3.0 + maximum wavelength: 204.0 + minimum wavelength: 174.0 + temperature ranges: + - fixed value: 210.0 + maximum: 209.999999999999 + - maximum: 300.0 + minimum: 210.0 + - fixed value: 300.0 + minimum: 300.00000000001 + parameterization wavelength grid: + name: custom wavelengths + type: from config file + units: nm + values: + - 169.0 + - 171.0 + - 173.0 + - 175.0 + - 177.0 + - 179.0 + - 181.0 + - 183.0 + - 185.0 + - 187.0 + - 189.0 + - 191.0 + - 193.0 + - 195.0 + - 197.0 + - 199.0 + - 201.0 + - 203.0 + - 205.0 + - 207.0 + - 209.0 + - 211.0 + - 213.0 + - 215.0 + - 217.0 + - 219.0 + - 221.0 + type: temperature based + name: jhcfc22 + quantum yield: + constant value: 1.0 + type: base + - __reaction: HCl + hv -> H + Cl + cross section: + netcdf files: + - file path: data/cross_sections/HCl_1.nc + type: base + name: jhcl + quantum yield: + constant value: 1.0 + type: base + - __reaction: HOBr + hv -> OH + Br + cross section: + type: HOBr+hv->OH+Br + name: jhobr + quantum yield: + constant value: 1.0 + type: base + - __reaction: HOCl + hv -> HO + Cl + cross section: + netcdf files: + - file path: data/cross_sections/HOCl_1.nc + type: base + name: jhocl + quantum yield: + constant value: 1.0 + type: base + - __reaction: OClO + hv -> Products + cross section: + netcdf files: + - file path: data/cross_sections/OClO_1.nc + - file path: data/cross_sections/OClO_2.nc + - file path: data/cross_sections/OClO_3.nc + type: OClO+hv->Products + name: joclo + quantum yield: + constant value: 1.0 + type: base + - __reaction: HNO4 + hv -> OH + NO3 + cross section: + netcdf file: data/cross_sections/HO2NO2_JPL06.nc + parameterization: + A: -988.0 + B: 0.69 + netcdf file: + file path: data/cross_sections/HO2NO2_temp_JPL06.nc + temperature ranges: + - fixed value: 280.0 + maximum: 279.999999999999 + - maximum: 350.0 + minimum: 280.0 + - fixed value: 350.0 + minimum: 350.00000000001 + type: BURKHOLDER + type: temperature based + name: jho2no2_a + quantum yield: + constant value: 0.3 + override bands: + - band: range + minimum wavelength: 200.0 + value: 0.2 + type: base + - __reaction: HNO4 + hv -> HO2 + NO2 + cross section: + netcdf file: data/cross_sections/HO2NO2_JPL06.nc + parameterization: + A: -988.0 + B: 0.69 + netcdf file: + file path: data/cross_sections/HO2NO2_temp_JPL06.nc + temperature ranges: + - fixed value: 280.0 + maximum: 279.999999999999 + - maximum: 350.0 + minimum: 280.0 + - fixed value: 350.0 + minimum: 350.00000000001 + type: BURKHOLDER + type: temperature based + name: jho2no2_b + quantum yield: + constant value: 0.7 + override bands: + - band: range + minimum wavelength: 200.0 + value: 0.8 + type: base + - __comments: Methacrolein photolysis channel 1 + __reaction: CH2=C(CH3)CHO->1.34HO2+0.66MCO3+1.34CH2O+CH3CO3 + cross section: + netcdf files: + - file path: data/cross_sections/Methacrolein_1.nc + type: base + name: jmacr_a + quantum yield: + constant value: 0.005 + type: base + - __comments: Methacrolein photolysis channel 2 + __reaction: CH2=C(CH3)CHO->0.66OH+1.34CO + cross section: + netcdf files: + - file path: data/cross_sections/Methacrolein_1.nc + type: base + name: jmacr_b + quantum yield: + constant value: 0.005 + type: base + - __comments: 'hydroxy acetone TODO: the products of this reaction differ from standalone + TUV-x' + __reaction: CH2(OH)COCH3->CH3CO3+HO2+CH2O + cross section: + netcdf files: + - file path: data/cross_sections/Hydroxyacetone_1.nc + type: base + name: jhyac + quantum yield: + constant value: 0.65 + type: base + - __reaction: H2O + hv -> OH + H + cross section: + merge data: true + netcdf files: + - file path: data/cross_sections/H2O_1.nc + zero above: 183.0 + - file path: data/cross_sections/H2O_2.nc + zero above: 190.0 + zero below: 183.00000000001 + - file path: data/cross_sections/H2O_3.nc + zero below: 190.00000000001 + type: base + name: jh2o_a + quantum yield: + netcdf files: + - data/quantum_yields/H2O_H_OH.nc + type: base + - __reaction: H2O + hv -> H2 + O1D + cross section: + merge data: true + netcdf files: + - file path: data/cross_sections/H2O_1.nc + zero above: 183.0 + - file path: data/cross_sections/H2O_2.nc + zero above: 190.0 + zero below: 183.00000000001 + - file path: data/cross_sections/H2O_3.nc + zero below: 190.00000000001 + type: base + name: jh2o_b + quantum yield: + netcdf files: + - data/quantum_yields/H2O_H2_O1D.nc + type: base + - __reaction: H2O + hv -> 2*H + O + cross section: + merge data: true + netcdf files: + - file path: data/cross_sections/H2O_1.nc + zero above: 183.0 + - file path: data/cross_sections/H2O_2.nc + zero above: 190.0 + zero below: 183.00000000001 + - file path: data/cross_sections/H2O_3.nc + zero below: 190.00000000001 + type: base + name: jh2o_c + quantum yield: + netcdf files: + - data/quantum_yields/H2O_2H_O3P.nc + type: base + - __reaction: CH4 + hv -> H + CH3O2 + cross section: + netcdf files: + - file path: data/cross_sections/CH4_1.nc + type: base + name: jch4_a + quantum yield: + constant value: 0.45 + type: base + - __reaction: CH4 + hv -> 1.44*H2 + 0.18*CH2O + 0.18*O + 0.33*OH + 0.33*H + 0.44*CO2 + + 0.38*CO + 0.05*H2O + cross section: + netcdf files: + - file path: data/cross_sections/CH4_1.nc + type: base + name: jch4_b + quantum yield: + constant value: 0.55 + type: base + - __reaction: CO2 + hv -> CO + O + cross section: + netcdf files: + - file path: data/cross_sections/CO2_1.nc + type: base + name: jco2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: HBR + hv -> BR + H + cross section: + netcdf files: + - file path: data/cross_sections/HBr_1.nc + type: base + name: jhbr + quantum yield: + constant value: 1.0 + type: base + - __reaction: HF + hv -> H + F + cross section: + netcdf files: + - file path: data/cross_sections/HF_1.nc + type: base + name: jhf + quantum yield: + constant value: 1.0 + type: base + - __reaction: SF6 + hv -> sink + cross section: + netcdf files: + - file path: data/cross_sections/SF6_1.nc + type: base + name: jsf6 + quantum yield: + constant value: 1.0 + type: base + - __reaction: H2SO4 + hv -> SO3 + H2O + cross section: + data: + default value: 0.0 + point values: + - value: 6.3e-17 + wavelength: 121.65 + - value: 1.43e-26 + wavelength: 525.0 + - value: 1.8564e-25 + wavelength: 625.0 + - value: 3.086999e-24 + wavelength: 725.0 + type: base + name: jh2so4 + quantum yield: + collision interval s: + - 1.1e-09 + - 8.9e-09 + - 1.7e-07 + molecular diameter m: 4.18e-10 + molecular weight kg mol-1: 0.098078479 + netcdf files: + - data/quantum_yields/H2SO4_mills.nc + parameterized wavelengths: + - 525 + - 625 + - 725 + type: H2SO4 Mills + - __reaction: OCS + hv -> S + CO + cross section: + netcdf files: + - file path: data/cross_sections/OCS_1.nc + type: base + name: jocs + quantum yield: + constant value: 1.0 + type: base + - __reaction: SO + hv -> S + O + cross section: + netcdf files: + - file path: data/cross_sections/SO_1.nc + type: base + name: jso + quantum yield: + constant value: 1.0 + type: base + - __reaction: SO2 + hv -> SO + O + cross section: + netcdf files: + - file path: data/cross_sections/SO2_Mills.nc + type: base + name: jso2 + quantum yield: + constant value: 1.0 + type: base + - __reaction: SO3 + hv -> SO2 + O + cross section: + netcdf files: + - file path: data/cross_sections/SO3_1.nc + type: base + name: jso3 + quantum yield: + constant value: 1.0 + type: base + - __reaction: NO + hv -> NOp + e + cross section: + data: + default value: 0.0 + point values: + - value: 2.0e-18 + wavelength: 121.65 + type: base + name: jno_i + quantum yield: + constant value: 1.0 + type: base +profiles: +- file path: data/profiles/atmosphere/ussa.ozone + name: O3 + type: O3 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: air + type: air + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: O2 + type: O2 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.temp + grid: + name: height + units: km + name: temperature + type: from csv file + units: K +- day: 21 + latitude: 0.0 + longitude: 0.0 + month: 3 + name: solar zenith angle + type: solar zenith angle + units: degrees + year: 2002 +- day: 21 + month: 3 + name: Earth-Sun distance + type: Earth-Sun distance + units: AU + year: 2002 +- grid: + name: wavelength + units: nm + name: surface albedo + type: from config file + uniform value: 0.1 + units: none +- enable diagnostics: true + file path: + - data/profiles/solar/susim_hi.flx + - data/profiles/solar/atlas3_1994_317_a.dat + - data/profiles/solar/sao2010.solref.converted + - data/profiles/solar/neckel.flx + interpolator: + - '' + - '' + - '' + - fractional target + name: extraterrestrial flux + type: extraterrestrial flux + units: photon cm-2 s-1 +radiative transfer: + __output: true + cross sections: + - name: air + type: air + - name: O3 + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + - name: O2 + netcdf files: + - file path: data/cross_sections/O2_1.nc + lower extrapolation: + type: boundary + type: base + radiators: + - cross section: air + enable diagnostics: true + name: air + treat as air: true + type: base + vertical profile: air + vertical profile units: molecule cm-3 + - cross section: O2 + enable diagnostics: true + name: O2 + type: base + vertical profile: O2 + vertical profile units: molecule cm-3 + - cross section: O3 + enable diagnostics: true + name: O3 + type: base + vertical profile: O3 + vertical profile units: molecule cm-3 + - 550 nm optical depth: 0.235 + asymmetry factor: 0.61 + enable diagnostics: true + name: aerosols + optical depths: + - 0.24 + - 0.106 + - 0.0456 + - 0.0191 + - 0.0101 + - 0.00763 + - 0.00538 + - 0.005 + - 0.00515 + - 0.00494 + - 0.00482 + - 0.00451 + - 0.00474 + - 0.00437 + - 0.00428 + - 0.00403 + - 0.00383 + - 0.00378 + - 0.00388 + - 0.00308 + - 0.00226 + - 0.00164 + - 0.00123 + - 0.000945 + - 0.000749 + - 0.00063 + - 0.00055 + - 0.000421 + - 0.000322 + - 0.000248 + - 0.00019 + - 0.000145 + - 0.000111 + - 8.51e-05 + - 6.52e-05 + - 5.0e-05 + - 3.83e-05 + - 2.93e-05 + - 2.25e-05 + - 1.72e-05 + - 1.32e-05 + - 1.01e-05 + - 7.72e-06 + - 5.91e-06 + - 4.53e-06 + - 3.46e-06 + - 2.66e-06 + - 2.04e-06 + - 1.56e-06 + - 1.19e-06 + - 9.14e-07 + single scattering albedo: 0.99 + type: aerosol + solver: + type: delta eddington diff --git a/examples/full_config.json b/examples/tuv_5_4.json similarity index 99% rename from examples/full_config.json rename to examples/tuv_5_4.json index d79d2628..861236cf 100644 --- a/examples/full_config.json +++ b/examples/tuv_5_4.json @@ -1,4 +1,8 @@ { + "__description": [ + "TUV-x configuration that reporoduces photolysis rate constants of the TUV 5.4 calculator", + "The original TUV 5.4 source code and data sets can be found here: https://www2.acom.ucar.edu/modeling/tuv-download" + ], "O2 absorption" : { "cross section parameters file": "data/cross_sections/O2_parameters.txt" }, @@ -169,7 +173,6 @@ } ] }, - "__description": "This file contains configurations for each of the photolysis rate constants that can be calculated using data from this folder", "photolysis": { "enable diagnostics" : true, "reactions": [ diff --git a/examples/tuv_5_4.yml b/examples/tuv_5_4.yml new file mode 100644 index 00000000..ca2b53ba --- /dev/null +++ b/examples/tuv_5_4.yml @@ -0,0 +1,1218 @@ +O2 absorption: + cross section parameters file: data/cross_sections/O2_parameters.txt +__description: +- TUV-x configuration that reporoduces photolysis rate constants of the TUV 5.4 calculator +- 'The original TUV 5.4 source code and data sets can be found here: https://www2.acom.ucar.edu/modeling/tuv-download' +dose rates: + enable diagnostics: true + rates: + - name: RB Meter, model 501 + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/RB-Meter,model_501_spectral_wght_1.nc + type: base + - name: Eppley UV Photometer + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Eppley-UV-Photometer_spectral_wght_1.nc + type: Eppley UV Photometer + - name: UV-A, 315-400 nm + weights: + notch filter begin: 315.0 + notch filter end: 400.0 + type: Notch Filter + - name: UV-B, 280-315 nm + weights: + notch filter begin: 280.0 + notch filter end: 315.0 + type: Notch Filter + - name: UV-B*, 280-320 nm + weights: + notch filter begin: 280.0 + notch filter end: 320.0 + type: Notch Filter + - name: vis+, > 400 nm + weights: + notch filter begin: 400.0 + notch filter end: 700.0 + type: Notch Filter + - name: Gaussian, 305 nm, 10 nm FWHM + weights: + centroid: 305.0 + type: Gaussian + - name: Gaussian, 320 nm, 10 nm FWHM + weights: + centroid: 320.0 + type: Gaussian + - name: Gaussian, 340 nm, 10 nm FWHM + weights: + centroid: 340.0 + type: Gaussian + - name: Gaussian, 380 nm, 10 nm FWHM + weights: + centroid: 380.0 + type: Gaussian + - name: SCUP-human (de Gruijl and van der Leun, 1994) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/SCUP-human(de Gruijl and van der Leun,1994)_spectral_wght_1.nc + type: base + - name: PAR, 400-700 nm, umol m-2 s-1 + weights: + type: PAR, 400-700 nm, umol m-2 s-1 + - name: Exponential decay, 14 nm/10 + weights: + type: Exponential decay, 14 nm/10 + - name: SCUP-mice (de Gruijl et al., 1993) + weights: + type: SCUP-mice (de Gruijl et al., 1993) + - name: Standard human erythema (Webb et al., 2011) + weights: + type: Standard human erythema (Webb et al., 2011) + - name: UV index (WMO, 1994; Webb et al., 2011) + weights: + type: UV index (WMO, 1994; Webb et al., 2011) + - name: Phytoplankton (Boucher et al., 1994) + weights: + type: Phytoplankton (Boucher et al., 1994) + - name: Plant damage (Caldwell, 1971) + weights: + type: Plant damage (Caldwell, 1971) + - name: Plant damage,Flint&Caldwell,2003,orig. + weights: + type: Plant damage,Flint&Caldwell,2003,orig. + - name: Plant damage,Flint&Caldwell,2003,ext390 + weights: + type: Plant damage,Flint&Caldwell,2003,ext390 + - name: Occupational TLV (ACGIH, 1992) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Occupational TLV (ACGIH,1992)_spectral_wght_1.nc + type: base + - name: Phytoplankton, phaeo (Cullen et al., 1992) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Phytoplankton, phaeo(Cullen et al. 1992)_spectral_wght_1.nc + type: base + - name: Phytoplankton, proro (Cullen et al., 1992) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Phytoplankton, proro(Cullen et al. 1992)_spectral_wght_1.nc + type: base + - name: Cataract, pig (Oriowo et al., 2001) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Cataract, pig(Oriowo et al.,2001)_spectral_wght_1.nc + type: base + - name: Previtamin-D3 (CIE 2006) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Previtamin-D3 (CIE 2006)_spectral_wght_1.nc + type: base + - name: NMSC (CIE 2006) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/NMSC (CIE 2006)_spectral_wght_1.nc + type: base + - name: DNA damage, in vitro (Setlow, 1974) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/DNA_damage_in_vitro(Setlow,1974)_spectral_wght_1.nc + type: base + - name: Erythema, humans (Anders et al., 1995) + weights: + lower extrapolation: + type: boundary + netcdf files: + - data/spectral_weights/Erythema,humans(Anders et al.,1995)_spectral_wght_1.nc + type: base +grids: +- begins at: 0.0 + cell delta: 1.0 + ends at: 120.0 + name: height + type: equal interval + units: km +- file path: data/grids/wavelength/combined.grid + name: wavelength + type: from csv file + units: nm +- name: time + type: from config file + units: hours + values: + - 12.0 + - 14.0 +photolysis: + enable diagnostics: true + reactions: + - cross section: + apply O2 bands: true + netcdf files: + - file path: data/cross_sections/O2_1.nc + lower extrapolation: + type: boundary + type: base + name: O2+hv->O+O + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HNO4_1.nc + type: base + name: HNO4+hv->HO2+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + __output: true + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + name: O3+hv->O2+O(1D) + quantum yield: + type: O3+hv->O2+O(1D) + - cross section: + __output: true + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + name: O3+hv->O2+O(3P) + quantum yield: + __output: true + type: O3+hv->O2+O(3P) + - cross section: + netcdf files: + - file path: data/cross_sections/NO3-(aq)_1.nc + type: base + name: NO3-(aq)+hv->NO2(aq)+O- + quantum yield: + type: NO3-_(aq)+hv->NO2(aq)+O- + - cross section: + netcdf files: + - file path: data/cross_sections/NO3-(aq)_1.nc + type: base + name: NO3-(aq)+hv->NO2-(aq)+O(3P) + quantum yield: + __output: true + constant value: 0.0011 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/NOCl_1.nc + type: tint + name: NOCl+hv->NO+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3Cl_1.nc + type: tint + name: CH3Cl+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CCl3_1.nc + type: tint + name: CH3CCl3+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CCl2O_1.nc + type: base + name: CCl2O+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CClFO_1.nc + type: base + name: CClFO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3OOH_1.nc + type: base + name: CH3OOH+hv->CH3O+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2OOH_1.nc + type: base + name: HOCH2OOH+hv->CH2(OH)O+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HO2_1.nc + type: base + name: HO2+hv->OH+O + quantum yield: + type: HO2 + - cross section: + netcdf files: + - file path: data/cross_sections/H2O2_1.nc + type: H2O2+hv->OH+OH + name: H2O2+hv->OH+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: NO3+hv->NO+O2 + quantum yield: + netcdf files: + - data/quantum_yields/NO3-NO+O2_1.nc + type: tint + - cross section: + netcdf files: + - file path: data/cross_sections/NO3_1.nc + type: base + name: NO3+hv->NO2+O(3P) + quantum yield: + lower extrapolation: + type: constant + value: 1.0 + netcdf files: + - data/quantum_yields/NO3-NO2+O(3P)_1.nc + type: tint + - cross section: + netcdf files: + - file path: data/cross_sections/HNO3_1.nc + type: HNO3+hv->OH+NO2 + name: HNO3+hv->OH+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: N2O+hv->N2+O(1D) + name: N2O+hv->N2+O(1D) + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/N2O5_1.nc + - file path: data/cross_sections/N2O5_2.nc + type: N2O5+hv->NO2+NO3 + name: N2O5+hv->NO2+NO3 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/NO2_1.nc + type: NO2 tint + name: NO2+hv->NO+O(3P) + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/NO2_1.nc + type: NO2 tint + - cross section: + netcdf files: + - file path: data/cross_sections/C2H5CHO_1.nc + type: base + name: C2H5CHO+hv->C2H5+HCO + quantum yield: + netcdf files: + - data/quantum_yields/C2H5CHO_1.nc + type: C2H5CHO + - cross section: + netcdf files: + - file path: data/cross_sections/CH2CHCHO_1.nc + type: base + name: CH2CHCHO+hv->Products + quantum yield: + type: CH2CHCHO+hv->Products + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CHO_1.nc + type: base + name: CH3CHO+hv->CH3+HCO + quantum yield: + netcdf files: + - data/quantum_yields/CH3CHO_1.nc + type: CH3CHO+hv->CH3+HCO + - cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: CH2O+hv->H+HCO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH2O_1.nc + type: CH2O + name: CH2O+hv->H2+CO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CH2O_1.nc + type: CH2O + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCH2CH3_1.nc + type: base + name: CH3COCH2CH3+hv->CH3CO+CH2CH3 + quantum yield: + type: CH3COCH2CH3+hv->CH3CO+CH2CH3 + - cross section: + netcdf files: + - file path: data/cross_sections/HNO2_1.nc + type: base + name: HNO2+hv->OH+NO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHBr3_1.nc + lower extrapolation: + type: boundary + type: CHBr3+hv->Products + name: CHBr3+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2Br2_1.nc + type: base + name: CF2Br2+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2BrCl_1.nc + type: base + name: CF2BrCl+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3Br_1.nc + type: base + name: CF3Br+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2BrCF2Br_1.nc + type: base + name: CF2BrCF2Br+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/I2_1.nc + type: base + name: I2+hv->I+I + quantum yield: + lower extrapolation: + type: constant + value: 1.0 + netcdf files: + - data/quantum_yields/I2_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/IO_1.nc + type: base + name: IO+hv->I+O + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/IOH_1.nc + type: base + name: IOH+hv->I+OH + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/perfluoro 1-iodopropane_1.nc + type: base + name: perfluoro-1-iodopropane+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3OCl_1.nc + type: base + name: CH3OCl+hv->CH3O+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHCl3_1.nc + type: CHCl3+hv->Products + name: CHCl3+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: Cl2+hv->Cl+Cl + name: Cl2+hv->Cl+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CCl4_1.nc + type: CCl4+hv->Products + name: CCl4+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClO_1.nc + type: tint + name: ClO+hv->Cl+O(1D) + quantum yield: + type: ClO+hv->Cl+O(1D) + - cross section: + netcdf files: + - file path: data/cross_sections/ClO_1.nc + type: tint + name: ClO+hv->Cl+O(3P) + quantum yield: + type: ClO+hv->Cl+O(3P) + - cross section: + netcdf files: + - file path: data/cross_sections/ClOO_1.nc + type: base + name: ClOO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClOOCl_1.nc + type: base + name: ClOOCl+hv->Cl+ClOO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HCl_1.nc + type: base + name: HCl+hv->H+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCl_1.nc + type: base + name: HOCl+hv->HO+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClNO2_1.nc + type: base + name: ClNO2+hv->Cl+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClONO_1.nc + type: base + name: ClONO+hv->Cl+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: ClONO2+hv->Cl+NO3 + quantum yield: + type: ClONO2+hv->Cl+NO3 + - cross section: + netcdf files: + - file path: data/cross_sections/ClONO2_1.nc + type: ClONO2 + name: ClONO2+hv->ClO+NO2 + quantum yield: + type: ClONO2+hv->ClO+NO2 + - cross section: + netcdf files: + - file path: data/cross_sections/OClO_1.nc + - file path: data/cross_sections/OClO_2.nc + - file path: data/cross_sections/OClO_3.nc + type: OClO+hv->Products + name: OClO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Br2_1.nc + type: base + name: Br2+hv->Br+Br + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrO_1.nc + interpolator: + fold in: true + type: fractional target + type: base + name: BrO+hv->Br+O + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: HOBr+hv->OH+Br + name: HOBr+hv->OH+Br + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrNO_1.nc + type: base + name: BrNO+hv->Br+NO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO_1.nc + type: base + name: BrONO+hv->Br+NO2 + quantum yield: + constant value: 0.5 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO_1.nc + type: base + name: BrONO+hv->BrO+NO + quantum yield: + constant value: 0.5 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrNO2_1.nc + type: base + name: BrNO2+hv->Br+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO2_1.nc + type: base + name: BrONO2+hv->BrO+NO2 + quantum yield: + constant value: 0.15 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrONO2_1.nc + type: base + name: BrONO2+hv->Br+NO3 + quantum yield: + constant value: 0.85 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/BrCl_1.nc + type: base + name: BrCl+hv->Br+Cl + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3Br_1.nc + type: base + name: CH3Br+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3ONO2_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: CH3ONO2+hv->CH3O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3OONO2_1.nc + type: base + name: CH3(OONO2)+hv->CH3OO+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/C2H5ONO2_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: C2H5ONO2+hv->C2H5O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/nC3H7ONO2_1.nc + type: base + name: nC3H7ONO2+hv->C3H7O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/1-C4H9ONO2_1.nc + type: base + name: 1-C4H9ONO2+hv->1-C4H9O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/2-C4H9ONO2_1.nc + type: base + name: 2-C4H9ONO2+hv->2-C4H9O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: CH3COCH2(ONO2)+hv->CH3COCH2(O.)+NO2 + name: nitro_acetone+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: CH2(OH)CH2(ONO2)+hv->CH2(OH)CH2(O.)+NO2 + name: nitro_ethanol+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CH2ONO2_1.nc + type: RONO2 + name: CH3CH2ONO2+hv->CH3CH2O+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CHONO2CH3_1.nc + type: RONO2 + name: CH3CHONO2CH3+hv->CH3CHOCH3+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCH3_1.nc + type: CH3COCH3+hv->CH3CO+CH3 + name: CH3COCH3+hv->CH3CO+CH3 + quantum yield: + type: CH3COCH3+hv->CH3CO+CH3 + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-11_1.nc + type: CCl3F+hv->Products + name: CCl3F+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-12_1.nc + type: CCl3F+hv->Products + name: CCl2F2+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-113_1.nc + type: tint + name: CFC-113+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-114_1.nc + type: tint + name: CFC-114+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CFC-115_1.nc + type: base + name: CFC-115+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHClF2_1.nc + type: tint + name: HCFC-22+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3CHCl2_1.nc + type: HCFC+hv->Products + name: CF3CHCl2+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3CHFCl_1.nc + type: HCFC+hv->Products + name: CF3CHFCl+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CFCl2_1.nc + type: base + name: HCFC-141b+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CF2Cl_1.nc + type: HCFC+hv->Products + name: HCFC-142b+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF3CF2CHCl2_1.nc + type: base + name: HCFC-225ca+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2ClCF2CHFCl_1.nc + type: base + name: HCFC-225cb+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + type: t_butyl_nitrate+hv->Products + name: C(CH3)3(ONO2)+hv->C(CH3)(O.)+NO2 + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/t-butyl-nitrite_1.nc + type: base + name: C(CH3)3(ONO)+hv->C(CH3)3(O)+NO + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PAN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PAN+hv->CH3CO(OO)+NO2 + quantum yield: + constant value: 0.7 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PAN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PAN+hv->CH3CO(O)+NO3 + quantum yield: + constant value: 0.3 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PPN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PPN+hv->CH3CH2CO(OO)+NO2 + quantum yield: + constant value: 0.61 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/PPN_1.nc + type: CH3ONO2+hv->CH3O+NO2 + name: PPN+hv->CH3CH2CO(O)+NO3 + quantum yield: + constant value: 0.39 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Methacrolein_1.nc + type: base + name: CH2=C(CH3)CHO+hv->Products + quantum yield: + constant value: 0.01 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/MVK_1.nc + type: base + name: MVK+hv->Products + quantum yield: + type: MVK+hv->Products + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: HOCH2CHO+hv->CH2OH+HCO + quantum yield: + constant value: 0.83 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: HOCH2CHO+hv->CH3OH+CO + quantum yield: + constant value: 0.1 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/HOCH2CHO_1.nc + type: base + name: HOCH2CHO+hv->CH2CHO+OH + quantum yield: + constant value: 0.07 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Hydroxyacetone_1.nc + type: base + name: CH2(OH)COCH3+hv->CH3CO+CH2(OH) + quantum yield: + constant value: 0.325 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/Hydroxyacetone_1.nc + type: base + name: CH2(OH)COCH3+hv->CH2(OH)CO+CH3 + quantum yield: + constant value: 0.325 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHOCHO_1.nc + type: base + name: CHOCHO+hv->HCO+HCO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CHOCHO-HCO_HCO_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHOCHO_1.nc + type: base + name: CHOCHO+hv->H2+CO+CO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CHOCHO-H2_CO_CO_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CHOCHO_1.nc + type: base + name: CHOCHO+hv->CH2O+CO + quantum yield: + lower extrapolation: + type: boundary + netcdf files: + - data/quantum_yields/CHOCHO-CH2O_CO_1.nc + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCHO_1.nc + type: base + name: CH3COCHO+hv->CH3CO+HCO + quantum yield: + type: CH3COCHO+hv->CH3CO+HCO + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCOCH3_1.nc + type: base + name: CH3COCOCH3+hv->Products + quantum yield: + constant value: 0.158 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COOH_1.nc + type: base + name: CH3COOH+hv->CH3+COOH + quantum yield: + constant value: 0.55 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COOOH_1.nc + type: base + name: CH3COOOH+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3COCOOH_1.nc + type: base + name: CH3COCOOH+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CH3CH3NNO_1.nc + type: base + name: CH3CH3NNO+hv->Products + quantum yield: + constant value: 1.0 + type: base + - cross section: + netcdf files: + - file path: data/cross_sections/CF2O_1.nc + type: base + name: CF2O+hv->Products + quantum yield: + constant value: 1.0 + type: base +profiles: +- file path: data/profiles/atmosphere/ussa.ozone + name: O3 + type: O3 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: air + type: air + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.dens + name: O2 + type: O2 + units: molecule cm-3 +- file path: data/profiles/atmosphere/ussa.temp + grid: + name: height + units: km + name: temperature + type: from csv file + units: K +- day: 21 + latitude: 0.0 + longitude: 0.0 + month: 3 + name: solar zenith angle + type: solar zenith angle + units: degrees + year: 2002 +- day: 21 + month: 3 + name: Earth-Sun distance + type: Earth-Sun distance + units: AU + year: 2002 +- grid: + name: wavelength + units: nm + name: surface albedo + type: from config file + uniform value: 0.1 + units: none +- enable diagnostics: true + file path: + - data/profiles/solar/susim_hi.flx + - data/profiles/solar/atlas3_1994_317_a.dat + - data/profiles/solar/sao2010.solref.converted + - data/profiles/solar/neckel.flx + interpolator: + - '' + - '' + - '' + - fractional target + name: extraterrestrial flux + type: extraterrestrial flux + units: photon cm-2 s-1 +radiative transfer: + __output: true + cross sections: + - name: air + type: air + - name: O3 + netcdf files: + - file path: data/cross_sections/O3_1.nc + - file path: data/cross_sections/O3_2.nc + - file path: data/cross_sections/O3_3.nc + - file path: data/cross_sections/O3_4.nc + type: O3 + - name: O2 + netcdf files: + - file path: data/cross_sections/O2_1.nc + lower extrapolation: + type: boundary + type: base + radiators: + - cross section: air + enable diagnostics: true + name: air + treat as air: true + type: base + vertical profile: air + vertical profile units: molecule cm-3 + - cross section: O2 + enable diagnostics: true + name: O2 + type: base + vertical profile: O2 + vertical profile units: molecule cm-3 + - cross section: O3 + enable diagnostics: true + name: O3 + type: base + vertical profile: O3 + vertical profile units: molecule cm-3 + - 550 nm optical depth: 0.235 + asymmetry factor: 0.61 + enable diagnostics: true + name: aerosols + optical depths: + - 0.24 + - 0.106 + - 0.0456 + - 0.0191 + - 0.0101 + - 0.00763 + - 0.00538 + - 0.005 + - 0.00515 + - 0.00494 + - 0.00482 + - 0.00451 + - 0.00474 + - 0.00437 + - 0.00428 + - 0.00403 + - 0.00383 + - 0.00378 + - 0.00388 + - 0.00308 + - 0.00226 + - 0.00164 + - 0.00123 + - 0.000945 + - 0.000749 + - 0.00063 + - 0.00055 + - 0.000421 + - 0.000322 + - 0.000248 + - 0.00019 + - 0.000145 + - 0.000111 + - 8.51e-05 + - 6.52e-05 + - 5.0e-05 + - 3.83e-05 + - 2.93e-05 + - 2.25e-05 + - 1.72e-05 + - 1.32e-05 + - 1.01e-05 + - 7.72e-06 + - 5.91e-06 + - 4.53e-06 + - 3.46e-06 + - 2.66e-06 + - 2.04e-06 + - 1.56e-06 + - 1.19e-06 + - 9.14e-07 + single scattering albedo: 0.99 + type: aerosol + solver: + type: delta eddington 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 37b64f99..c147d1cd 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -3,19 +3,27 @@ # object library add_library(tuvx_object OBJECT) + +target_compile_features(tuvx_object INTERFACE cxx_std_11) + 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 +36,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 @@ -46,6 +64,7 @@ target_sources(tuvx_object grid.F90 grid_factory.F90 grid_warehouse.F90 + heating_rates.F90 interpolate.F90 la_sr_bands.F90 linear_algebra.F90 @@ -70,6 +89,6 @@ add_subdirectory(profiles) add_subdirectory(quantum_yields) add_subdirectory(radiative_transfer) add_subdirectory(spectral_weights) - +add_subdirectory(util) ################################################################################ diff --git a/src/constants.F90 b/src/constants.F90 index 42d88026..43829d33 100644 --- a/src/constants.F90 +++ b/src/constants.F90 @@ -22,5 +22,7 @@ module tuvx_constants real(dk), parameter :: pi = 3.1415926535898_dk ! Pi real(dk), parameter :: radius = 6.371E+3_dk ! Radius of the Earth [km] real(dk), parameter :: hc = 6.626068e-34_dk * 2.99792458e8_dk ! Plank's constants x speed of light [J m] - + real(dk), parameter :: Avogadro = 6.02214076e23_dk ! Avogadro's number [mol-1] + real(dk), parameter :: gas_constant = 8.31446261815324_dk ! Ideal gas constant [J K-1 mol-1] + end module tuvx_constants diff --git a/src/core.F90 b/src/core.F90 index 43c7e482..72828dda 100644 --- a/src/core.F90 +++ b/src/core.F90 @@ -9,6 +9,7 @@ module tuvx_core use musica_constants, only : dk => musica_dk use tuvx_dose_rates, only : dose_rates_t use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_heating_rates, only : heating_rates_t use tuvx_la_sr_bands, only : la_sr_bands_t use tuvx_photolysis_rates, only : photolysis_rates_t use tuvx_profile_warehouse, only : profile_warehouse_t @@ -32,10 +33,11 @@ module tuvx_core type(radiative_transfer_t), pointer :: radiative_transfer_ => null() type(photolysis_rates_t), pointer :: photolysis_rates_ => null() type(dose_rates_t), pointer :: dose_rates_ => null() + type(heating_rates_t), pointer :: heating_rates_ => null() type(radiation_field_t), pointer :: radiation_field_ => null() logical :: enable_diagnostics_ ! determines if diagnostic output is written or not contains - ! Calculate photolysis rate constants and dose rates + ! Calculate photolysis rate constants, dose rates, and heating rates procedure :: run ! Returns a grid from the warehouse procedure :: get_grid @@ -50,10 +52,14 @@ module tuvx_core procedure :: number_of_photolysis_reactions ! Returns the number of dose rates procedure :: number_of_dose_rates + ! Returns the number of heating rates + procedure :: number_of_heating_rates ! Returns the set of photolysis reaction labels procedure :: photolysis_reaction_labels ! Returns the set of dose rate labels procedure :: dose_rate_labels + ! Returns the set of heating rate labels + procedure :: heating_rate_labels ! Returns the photolysis reaction cross section for the current conditions procedure :: get_photolysis_cross_section ! Returns the photolysis reaction quantum yield for the current conditions @@ -165,6 +171,9 @@ function constructor( config, grids, profiles, radiators ) result( new_core ) photolysis_rates_t( child_config, & new_core%grid_warehouse_, & new_core%profile_warehouse_ ) + new_core%heating_rates_ => heating_rates_t( child_config, & + new_core%grid_warehouse_, & + new_core%profile_warehouse_ ) end if ! dose rates @@ -191,7 +200,7 @@ end function constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine run( this, solar_zenith_angle, earth_sun_distance, & - photolysis_rate_constants, dose_rates, diagnostic_label ) + photolysis_rate_constants, dose_rates, heating_rates, diagnostic_label ) ! Performs calculations for specified photolysis and dose rates for a ! given set of conditions @@ -205,6 +214,7 @@ subroutine run( this, solar_zenith_angle, earth_sun_distance, & real(dk), intent(in) :: earth_sun_distance ! [AU] real(dk), optional, intent(out) :: photolysis_rate_constants(:,:) ! (vertical level, reaction) [s-1] real(dk), optional, intent(out) :: dose_rates(:,:) ! (vertical level, reaction) [s-1] + real(dk), optional, intent(out) :: heating_rates(:,:) ! (vertical level, reaction) [J s-1] character(len=*), optional, intent(in) :: diagnostic_label ! label used in diagnostic file names ! Local variables @@ -247,6 +257,14 @@ subroutine run( this, solar_zenith_angle, earth_sun_distance, & photolysis_rate_constants, & diag_label ) end if + if( associated( this%heating_rates_ ) .and. present( heating_rates ) ) then + call this%heating_rates_%get( this%la_sr_bands_, & + this%spherical_geometry_, & + this%grid_warehouse_, & + this%profile_warehouse_, & + this%radiation_field_, & + heating_rates ) + end if if( associated( this%dose_rates_ ) .and. present( dose_rates ) ) then call this%dose_rates_%get( this%grid_warehouse_, & this%profile_warehouse_, & @@ -410,6 +428,20 @@ integer function number_of_dose_rates( this ) end function number_of_dose_rates +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function number_of_heating_rates( this ) + ! Returns the number of heating rates + + class(core_t), intent(in) :: this + + number_of_heating_rates = 0 + if( associated( this%heating_rates_ ) ) then + number_of_heating_rates = this%heating_rates_%size( ) + end if + + end function number_of_heating_rates + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function photolysis_reaction_labels( this ) result( labels ) @@ -442,6 +474,22 @@ function dose_rate_labels( this ) result( labels ) end function dose_rate_labels +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function heating_rate_labels( this ) result( labels ) + ! Returns the set of heating rate labels + + class(core_t), intent(in) :: this + type(string_t), allocatable :: labels(:) + + if( associated( this%heating_rates_ ) ) then + labels = this%heating_rates_%labels( ) + else + allocate( labels( 0 ) ) + end if + + end function heating_rate_labels + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function get_photolysis_cross_section( this, reaction_label, found ) & @@ -558,6 +606,11 @@ integer function pack_size( this, comm ) if( associated( this%dose_rates_ ) ) then pack_size = pack_size + this%dose_rates_%pack_size( comm ) end if + pack_size = pack_size + & + musica_mpi_pack_size( associated( this%heating_rates_ ), comm ) + if( associated( this%heating_rates_ ) ) then + pack_size = pack_size + this%heating_rates_%pack_size( comm ) + end if #else pack_size = 0 #endif @@ -617,6 +670,11 @@ subroutine mpi_pack( this, buffer, position, comm ) if( associated( this%dose_rates_ ) ) then call this%dose_rates_%mpi_pack( buffer, position, comm ) end if + call musica_mpi_pack( buffer, position, & + associated( this%heating_rates_ ), comm ) + if( associated( this%heating_rates_ ) ) then + call this%heating_rates_%mpi_pack( buffer, position, comm ) + end if call assert( 332208077, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -676,6 +734,11 @@ subroutine mpi_unpack( this, buffer, position, comm ) allocate( this%dose_rates_ ) call this%dose_rates_%mpi_unpack( buffer, position, comm ) end if + call musica_mpi_unpack( buffer, position, alloced, comm ) + if( alloced ) then + allocate( this%heating_rates_ ) + call this%heating_rates_%mpi_unpack( buffer, position, comm ) + end if call assert( 332208077, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -713,6 +776,9 @@ subroutine finalize( this ) if( associated( this%radiation_field_ ) ) then deallocate( this%radiation_field_ ) end if + if( associated( this%heating_rates_ ) ) then + deallocate( this%heating_rates_ ) + end if end subroutine finalize diff --git a/src/cross_section.F90 b/src/cross_section.F90 index 5c06d10f..f7750317 100644 --- a/src/cross_section.F90 +++ b/src/cross_section.F90 @@ -75,6 +75,8 @@ module tuvx_cross_section procedure :: mpi_unpack ! Processes a NetCDF input file procedure :: process_file + ! Apply cross section profile from configuration file + procedure :: cross_section_from_config end type cross_section_t interface cross_section_t @@ -108,7 +110,7 @@ function constructor( config, grid_warehouse, profile_warehouse ) & type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` - type(string_t) :: required_keys(1), optional_keys(5) + type(string_t) :: required_keys(1), optional_keys(6) required_keys(1) = "type" optional_keys(1) = "netcdf files" @@ -116,6 +118,7 @@ function constructor( config, grid_warehouse, profile_warehouse ) & optional_keys(3) = "merge data" optional_keys(4) = "override bands" optional_keys(5) = "apply O2 bands" + optional_keys(6) = "data" call assert_msg( 124969900, & config%validate( required_keys, optional_keys ), & "Bad configuration data format for "// & @@ -147,7 +150,8 @@ subroutine base_constructor( this, config, grid_warehouse, & character(len=*), parameter :: Iam = 'base cross section initialize' integer :: i_param, i_file, i_override logical :: found - type(config_t) :: netcdf_files, netcdf_file, overrides, override + type(config_t) :: netcdf_files, netcdf_file, overrides, override, & + data_config class(iterator_t), pointer :: iter logical :: merge_data class(grid_t), pointer :: wavelengths @@ -157,7 +161,7 @@ subroutine base_constructor( this, config, grid_warehouse, & this%height_grid_ = grid_warehouse%get_ptr( "height", "km" ) this%temperature_profile_ = profile_warehouse%get_ptr( "temperature", "K" ) - ! get cross section netcdf filespec + ! get cross section netcdf data or data specified in config file call config%get( 'netcdf files', netcdf_files, Iam, found = found ) if( found ) then iter => netcdf_files%get_iterator( ) @@ -174,6 +178,12 @@ subroutine base_constructor( this, config, grid_warehouse, & deallocate( iter ) end if + ! get cross section data points specified in configuration + call config%get( 'data', data_config, Iam, found = found ) + if( found ) then + call this%cross_section_from_config( data_config, grid_warehouse ) + end if + ! get values to overlay for specific bands call config%get( "override bands", overrides, Iam, found = found ) if( found ) then @@ -311,6 +321,74 @@ subroutine process_file( this, config, grid_warehouse, parameters ) end subroutine process_file +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Apply cross section data points specified in configuration + subroutine cross_section_from_config( this, config, grid_warehouse ) + + use musica_assert, only : assert_msg, almost_equal + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t, to_char + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + + !> Cross section calculator + class(cross_section_t), intent(inout) :: this + !> Configuration data + type(config_t), intent(inout) :: config + !> Grids + type(grid_warehouse_t), intent(inout) :: grid_warehouse + + character(len=*), parameter :: Iam = 'base cross section data' + class(grid_t), pointer :: wavelengths + type(config_t) :: points, point + class(iterator_t), pointer :: iter + real(kind=dk) :: value, wl + integer :: i_wl + logical :: found + type(string_t) :: required_keys(0), optional_keys(2) + + optional_keys(1) = "default value" + optional_keys(2) = "point values" + call assert_msg( 246462484, & + config%validate( required_keys, optional_keys ), & + "Invalid configuration for cross section data" ) + + wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) + call config%get( "default value", value, Iam, default = 0.0_dk ) + if( .not. allocated( this%cross_section_parms ) ) then + allocate( this%cross_section_parms( 1 ) ) + allocate( this%cross_section_parms( 1 )%array( wavelengths%ncells_, 1 ) ) + this%cross_section_parms( 1 )%array(:,:) = value + end if + call assert_msg( 952054750, size( this%cross_section_parms ) .eq. 1, & + "Cross section data points cannot be specified when "// & + "multiple input files are being used." ) + call config%get( "point values", points, Iam, found = found ) + if( found ) then + iter => points%get_iterator( ) + do while( iter%next( ) ) + call points%get( iter, point, Iam ) + call point%get( "wavelength", wl, Iam ) + call point%get( "value", value, Iam ) + do i_wl = 1, wavelengths%ncells_ + if( almost_equal( wl, wavelengths%mid_( i_wl ) ) ) then + this%cross_section_parms( 1 )%array( i_wl, 1 ) = value + exit + end if + call assert_msg( 534489163, i_wl .ne. wavelengths%ncells_, & + "Cross section wavelength point "// & + trim( to_char( wl ) )// & + " does not exist on wavelength grid." ) + end do + end do + deallocate( iter ) + end if + deallocate( wavelengths ) + + end subroutine cross_section_from_config + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & diff --git a/src/cross_sections/CMakeLists.txt b/src/cross_sections/CMakeLists.txt index 64db6ead..66ab8245 100644 --- a/src/cross_sections/CMakeLists.txt +++ b/src/cross_sections/CMakeLists.txt @@ -31,4 +31,6 @@ target_sources(tuvx_object rayliegh.F90 ) +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/cross_sections/temperature_based.F90 b/src/cross_sections/temperature_based.F90 index 13aaf6ed..882495ca 100644 --- a/src/cross_sections/temperature_based.F90 +++ b/src/cross_sections/temperature_based.F90 @@ -1,4 +1,4 @@ -! Copyright (C) 2020 National Center for Atmospheric Research +! Copyright (C) 2020-4 National Center for Atmospheric Research ! SPDX-License-Identifier: Apache-2.0 module tuvx_cross_section_temperature_based @@ -10,92 +10,25 @@ module tuvx_cross_section_temperature_based use musica_constants, only : dk => musica_dk use tuvx_cross_section, only : cross_section_t use tuvx_interpolate, only : interpolator_conserving_t + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t implicit none private public :: cross_section_temperature_based_t - !> Range for temperature-based calculations - type :: temperature_range_t - !> Minimum temperature [K] for inclusion in range - real(kind=dk) :: min_temperature_ = 0.0_dk - !> Maximum temperature [K] for include in range - real(kind=dk) :: max_temperature_ = huge(1.0_dk) - !> Indicates whether to use a fixed temperature for the - !! parameterization calculation. If FALSE, the actual - !! temperature is used. - logical :: is_fixed_ = .false. - !> Fixed temperature [K] to use in paramterization calculation - !! - !! Is only used if is_fixed == TRUE - real(kind=dk) :: fixed_temperature_ = 0.0_dk - contains - !> Returns the number of bytes required to pack the range onto a - !! character buffer - procedure :: pack_size => temperature_range_pack_size - !> Packs the range onto a character buffer - procedure :: mpi_pack => temperature_range_mpi_pack - !> Unpacks a range from a character buffer - procedure :: mpi_unpack => temperature_range_mpi_unpack - end type temperature_range_t - - !> Constructor for temperature_range_t - interface temperature_range_t - module procedure :: temperature_range_constructor - end interface temperature_range_t - - !> Parameters for calculating cross section values based on - !! temperature - !! - !! Cross section elements are calculated as: - !! - !! \f[ - !! 10^{\sum_i{(AA_i + (T-273)*BB_i)*\lambda^{lp_i}}} - !! \f] - !! - !! where \f$\lambda\f$ is the wavelength [nm] and - !! \f$T\f$ is the temperature [K]. - type :: temperature_parameterization_t - integer :: n_sets_ = 0 - real(kind=dk), allocatable :: AA_(:) - real(kind=dk), allocatable :: BB_(:) - real(kind=dk), allocatable :: lp_(:) - !> Minimum wavelength [nm] to calculate values for - real(kind=dk) :: min_wavelength_ - !> Maximum wavelength [nm] to calculate values for - real(kind=dk) :: max_wavelength_ - !> Index of minimum wavelength [nm] to calculate values for - integer :: min_wavelength_index_ - !> Index of maximum wavelength to calculate values for - integer :: max_wavelength_index_ - !> Temperature ranges used in parameterization - type(temperature_range_t), allocatable :: ranges_(:) - contains - !> Merges NetCDF wavelength grid with parameterization grid - procedure :: merge_wavelength_grids - !> Calculate the cross section value for a specific temperature - !! and wavelength - procedure :: calculate => temperature_parameterization_calculate - !> Returns the number of bytes required to pack the parameterization - !! onto a character buffer - procedure :: pack_size => temperature_parameterization_pack_size - !> Packs the parameterization onto a character buffer - procedure :: mpi_pack => temperature_parameterization_mpi_pack - !> Unpacks the parameterization from a character buffer - procedure :: mpi_unpack => temperature_parameterization_mpi_unpack - end type temperature_parameterization_t - - !> Constructor for temperature_parameterization_t - interface temperature_parameterization_t - module procedure :: temperature_parameterization_constructor - end interface temperature_parameterization_t + integer, parameter :: PARAM_BASE = 1 + integer, parameter :: PARAM_TAYLOR_SERIES = 2 + integer, parameter :: PARAM_BURKHOLDER = 3 + integer, parameter :: PARAM_HARWOOD = 4 !> Calculator for temperature-based cross sections type, extends(cross_section_t) :: cross_section_temperature_based_t real(kind=dk), allocatable :: raw_wavelengths_(:) ! [nm] real(kind=dk), allocatable :: raw_data_(:) - type(temperature_parameterization_t) :: parameterization_ + class(temperature_parameterization_t), pointer :: parameterization_ => & + null( ) type(interpolator_conserving_t) :: interpolator_ contains !> Calculate the cross section @@ -107,6 +40,8 @@ module tuvx_cross_section_temperature_based procedure :: mpi_pack !> Unpacks a cross section from a character buffer procedure :: mpi_unpack + !> Clean up memory + final :: finalize end type cross_section_temperature_based_t !> Constructor @@ -122,14 +57,20 @@ function constructor( config, grid_warehouse, profile_warehouse ) & result( this ) ! Constructs cross_section_temperature_based_t objects - use musica_assert, only : assert, assert_msg + use musica_assert, only : assert, assert_msg, die_msg use musica_string, only : string_t use tuvx_cross_section, only : base_constructor use tuvx_grid, only : grid_t + use tuvx_grid_factory, only : grid_builder use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_netcdf, only : netcdf_t use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_util, only : add_point + use tuvx_temperature_parameterization_burkholder, & + only : temperature_parameterization_burkholder_t + use tuvx_temperature_parameterization_harwood, & + only : temperature_parameterization_harwood_t + use tuvx_temperature_parameterization_taylor_series, & + only : temperature_parameterization_taylor_series_t class(cross_section_t), pointer :: this type(config_t), intent(inout) :: config @@ -139,11 +80,10 @@ function constructor( config, grid_warehouse, profile_warehouse ) & ! local variables character(len=*), parameter :: my_name = & 'Temperature-based cross section constructor' - real(kind=dk), parameter :: deltax = 1.0e-5 - type(string_t) :: required_keys(3), optional_keys(1) + type(string_t) :: required_keys(2), optional_keys(3) class(grid_t), pointer :: wavelengths - type(config_t) :: param_config, interpolator_config - type(string_t) :: file_path + type(config_t) :: param_config, interpolator_config, grid_config + type(string_t) :: file_path, param_type type(netcdf_t) :: netcdf real(kind=dk), allocatable :: file_data(:), file_wl(:) logical :: found @@ -151,8 +91,9 @@ function constructor( config, grid_warehouse, profile_warehouse ) & required_keys(1) = "type" required_keys(2) = "parameterization" - required_keys(3) = "netcdf file" optional_keys(1) = "name" + optional_keys(2) = "parameterization wavelength grid" + optional_keys(3) = "netcdf file" call assert_msg( 483410000, & config%validate( required_keys, optional_keys ), & "Bad configuration for temperature-based cross section" ) @@ -166,31 +107,57 @@ function constructor( config, grid_warehouse, profile_warehouse ) & ! Load NetCDF files call config%get( "netcdf file", file_path, my_name, found = found ) - call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & - variable_name = "cross_section_" ) - call assert_msg( 793476078, size( netcdf%parameters, dim = 2 ) == 1, & - "File: "//file_path//" should contain 1 parameter" ) - file_data = netcdf%parameters(:,1) - file_wl = netcdf%wavelength(:) - call add_point( x = file_wl, y = file_data, & - xnew = ( 1.0_dk - deltax ) * file_wl(1), ynew = 0.0_dk ) - call add_point( x = file_wl, y = file_data, & - xnew = 0.0_dk, ynew = 0.0_dk ) - call add_point( x = file_wl, y = file_data, & - xnew = ( 1.0_dk + deltax ) * file_wl( size( file_wl ) ), & - ynew = 0.0_dk ) - call add_point( x = file_wl, y = file_data, & - xnew = 1.0e38_dk, ynew = 0.0_dk ) + if( found ) then + call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & + variable_name = "cross_section_" ) + call assert_msg( 793476078, size( netcdf%parameters, dim = 2 ) == 1, & + "File: "//file_path//" should contain 1 parameter" ) + file_data = netcdf%parameters(:,1) + file_wl = netcdf%wavelength(:) + else + allocate( file_data(0) ) + allocate( file_wl(0) ) + end if + + ! Check for custom wavelength grid for parameterization + call config%get( "parameterization wavelength grid", grid_config, my_name,& + found = found) + if( found ) then + wavelengths => grid_builder( grid_config ) + call assert_msg( 993335233, wavelengths%units( ) .eq. "nm", & + "Invalid units for custom wavelength grid in "// & + "temperature-based cross section. Expected 'nm' "// & + "but got '"//wavelengths%units( )//"'" ) + else + wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) + end if ! Load parameters select type( this ) type is( cross_section_temperature_based_t ) - wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) call config%get( "parameterization", param_config, my_name ) - this%parameterization_ = & - temperature_parameterization_t( param_config, wavelengths ) + call param_config%get( "type", param_type, my_name, found = found ) + if( found ) then + if( param_type == "TAYLOR_SERIES" ) then + allocate( this%parameterization_, source = & + temperature_parameterization_taylor_series_t( param_config ) ) + else if( param_type == "BURKHOLDER" ) then + allocate( this%parameterization_, source = & + temperature_parameterization_burkholder_t( param_config ) ) + else if( param_type == "HARWOOD" ) then + allocate( this%parameterization_, source = & + temperature_parameterization_harwood_t( param_config, & + wavelengths ) ) + else + call die_msg( 370773773, "Invalid temperature-based "// & + "parameterization type: '"//param_type//"'" ) + end if + else + allocate( this%parameterization_, source = & + temperature_parameterization_t( param_config, wavelengths ) ) + end if this%raw_wavelengths_ = & - this%parameterization_%merge_wavelength_grids( file_wl, wavelengths ) + this%parameterization_%merge_wavelength_grids( file_wl ) allocate( this%raw_data_( size( this%raw_wavelengths_ ) ) ) i_file = 1 do i_wl = 1, size( this%raw_wavelengths_ ) @@ -205,9 +172,9 @@ function constructor( config, grid_warehouse, profile_warehouse ) & this%raw_data_( i_wl ) = file_data( i_file ) i_file = i_file + 1 end do - call assert( 950874524, i_file == size( file_data ) + 1 ) - deallocate( wavelengths ) + call assert( 950874524, i_file <= size( file_data ) + 1 ) end select + deallocate( wavelengths ) end function constructor @@ -222,6 +189,7 @@ function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_profile_warehouse, only : profile_warehouse_t use tuvx_profile, only : profile_t + use tuvx_util, only : add_point real(kind=dk), allocatable :: cross_section(:,:) class(cross_section_temperature_based_t), intent(in) :: this @@ -232,11 +200,12 @@ function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & ! local variables character(len=*), parameter :: Iam = & 'Temperature-based cross section calculate' + real(kind=dk), parameter :: deltax = 1.0e-5 class(grid_t), pointer :: heights class(grid_t), pointer :: wavelengths class(profile_t), pointer :: temperatures real(kind=dk) :: temperature - real(kind=dk), allocatable :: raw_data(:) + real(kind=dk), allocatable :: raw_data(:), raw_wl(:) logical :: l_at_mid_point integer :: i_wl, i_height @@ -261,11 +230,20 @@ function calculate( this, grid_warehouse, profile_warehouse, at_mid_point ) & temperature = temperatures%edge_val_( i_height ) end if raw_data = this%raw_data_ - call this%parameterization_%calculate( temperature, & - this%raw_wavelengths_, raw_data ) + raw_wl = this%raw_wavelengths_ + call this%parameterization_%calculate( temperature, raw_wl, raw_data ) + call add_point( x = raw_wl, y = raw_data, & + xnew = ( 1.0_dk - deltax ) * raw_wl(1), ynew = 0.0_dk ) + call add_point( x = raw_wl, y = raw_data, & + xnew = 0.0_dk, ynew = 0.0_dk ) + call add_point( x = raw_wl, y = raw_data, & + xnew = ( 1.0_dk + deltax ) * raw_wl( size( raw_wl ) ), & + ynew = 0.0_dk ) + call add_point( x = raw_wl, y = raw_data, & + xnew = 1.0e38_dk, ynew = 0.0_dk ) cross_section( i_height, : ) = & this%interpolator_%interpolate( x_target = wavelengths%edge_, & - x_source = this%raw_wavelengths_, & + x_source = raw_wl, & y_source = raw_data, & requested_by = & "temperature based cross section wavelength grid" ) @@ -289,8 +267,13 @@ integer function pack_size( this, comm ) #ifdef MUSICA_USE_MPI pack_size = this%cross_section_t%pack_size( comm ) + & musica_mpi_pack_size( this%raw_wavelengths_, comm ) + & - musica_mpi_pack_size( this%raw_data_, comm ) + & - this%parameterization_%pack_size( comm ) + musica_mpi_pack_size( this%raw_data_, comm ) + & + musica_mpi_pack_size( .false., comm ) + if( associated( this%parameterization_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( 1, comm ) + & + this%parameterization_%pack_size( comm ) + end if #else pack_size = this%cross_section_t%pack_size( comm ) #endif @@ -302,8 +285,14 @@ end function pack_size subroutine mpi_pack( this, buffer, position, comm ) ! Packs the cross section onto a character buffer - use musica_assert, only : assert + use musica_assert, only : assert, die use musica_mpi, only : musica_mpi_pack + use tuvx_temperature_parameterization_burkholder, & + only : temperature_parameterization_burkholder_t + use tuvx_temperature_parameterization_harwood, & + only : temperature_parameterization_harwood_t + use tuvx_temperature_parameterization_taylor_series, & + only : temperature_parameterization_taylor_series_t class(cross_section_temperature_based_t), intent(in) :: this ! cross section to be packed character, intent(inout) :: buffer(:) ! memory buffer @@ -311,13 +300,32 @@ subroutine mpi_pack( this, buffer, position, comm ) integer, intent(in) :: comm ! MPI communicator #ifdef MUSICA_USE_MPI - integer :: prev_pos + integer :: prev_pos, param_type + logical :: is_alloced + + is_alloced = associated( this%parameterization_ ) prev_pos = position call this%cross_section_t%mpi_pack( buffer, position, comm ) call musica_mpi_pack( buffer, position, this%raw_wavelengths_, comm ) - call musica_mpi_pack( buffer, position, this%raw_data_, comm ) - call this%parameterization_%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%raw_data_, comm ) + call musica_mpi_pack( buffer, position, is_alloced, comm ) + if( is_alloced ) then + select type( param => this%parameterization_ ) + type is( temperature_parameterization_t ) + param_type = PARAM_BASE + type is( temperature_parameterization_taylor_series_t ) + param_type = PARAM_TAYLOR_SERIES + type is( temperature_parameterization_burkholder_t ) + param_type = PARAM_BURKHOLDER + type is( temperature_parameterization_harwood_t ) + param_type = PARAM_HARWOOD + class default + call die( 424852458 ) + end select + call musica_mpi_pack( buffer, position, param_type, comm ) + call this%parameterization_%mpi_pack( buffer, position, comm ) + end if call assert( 322345685, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -328,8 +336,14 @@ end subroutine mpi_pack subroutine mpi_unpack( this, buffer, position, comm ) ! Unpacks a cross section from a character buffer - use musica_assert, only : assert + use musica_assert, only : assert, die use musica_mpi, only : musica_mpi_unpack + use tuvx_temperature_parameterization_burkholder, & + only : temperature_parameterization_burkholder_t + use tuvx_temperature_parameterization_harwood, & + only : temperature_parameterization_harwood_t + use tuvx_temperature_parameterization_taylor_series, & + only : temperature_parameterization_taylor_series_t class(cross_section_temperature_based_t), intent(out) :: this ! cross section to be unpacked character, intent(inout) :: buffer(:) ! memory buffer @@ -337,13 +351,33 @@ subroutine mpi_unpack( this, buffer, position, comm ) integer, intent(in) :: comm ! MPI communicator #ifdef MUSICA_USE_MPI - integer :: prev_pos + integer :: prev_pos, param_type + logical :: is_alloced prev_pos = position call this%cross_section_t%mpi_unpack( buffer, position, comm ) call musica_mpi_unpack( buffer, position, this%raw_wavelengths_, comm ) - call musica_mpi_unpack( buffer, position, this%raw_data_, comm ) - call this%parameterization_%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%raw_data_, comm ) + call musica_mpi_unpack( buffer, position, is_alloced, comm ) + if( is_alloced ) then + call musica_mpi_unpack( buffer, position, param_type, comm ) + select case( param_type ) + case( PARAM_BASE ) + allocate( temperature_parameterization_t :: this%parameterization_ ) + case( PARAM_TAYLOR_SERIES ) + allocate( temperature_parameterization_taylor_series_t :: & + this%parameterization_ ) + case( PARAM_BURKHOLDER ) + allocate( temperature_parameterization_burkholder_t :: & + this%parameterization_ ) + case( PARAM_HARWOOD ) + allocate( temperature_parameterization_harwood_t :: & + this%parameterization_ ) + case default + call die( 324803089 ) + end select + call this%parameterization_%mpi_unpack( buffer, position, comm ) + end if call assert( 820834544, position - prev_pos <= this%pack_size( comm ) ) #endif @@ -351,427 +385,16 @@ end subroutine mpi_unpack !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function temperature_range_constructor( config ) result( this ) - ! Constructs temperature range objects - - use musica_assert, only : assert_msg - use musica_config, only : config_t - use musica_string, only : string_t - - type(temperature_range_t) :: this - type(config_t), intent(inout) :: config - - character(len=*), parameter :: my_name = "temperature range constructor" - type(string_t) :: required_keys(0), optional_keys(3) - logical :: found - - optional_keys(1) = "minimum" - optional_keys(2) = "maximum" - optional_keys(3) = "fixed value" - call assert_msg( 355912601, & - config%validate( required_keys, optional_keys ), & - "Bad configuration for temperature range" ) - - call config%get( "minimum", this%min_temperature_, my_name, & - default = 0.0_dk ) - call config%get( "maximum", this%max_temperature_, my_name, & - default = huge(1.0_dk) ) - call config%get( "fixed value", this%fixed_temperature_, my_name, & - found = found ) - this%is_fixed_ = found - - end function temperature_range_constructor - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer function temperature_range_pack_size( this, comm ) & - result( pack_size ) - ! Returns the size of a character buffer required to pack the range - - use musica_mpi, only : musica_mpi_pack_size - - class(temperature_range_t), intent(in) :: this ! temperature range to be packed - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - pack_size = musica_mpi_pack_size( this%min_temperature_, comm ) + & - musica_mpi_pack_size( this%max_temperature_, comm ) + & - musica_mpi_pack_size( this%is_fixed_, comm ) + & - musica_mpi_pack_size( this%fixed_temperature_, comm ) -#else - pack_size = 0 -#endif - - end function temperature_range_pack_size - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_range_mpi_pack( this, buffer, position, comm ) - ! Packs the temperature range onto a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - - class(temperature_range_t), intent(in) :: this ! temperature range to be packed - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos - - prev_pos = position - call musica_mpi_pack( buffer, position, this%min_temperature_, comm ) - call musica_mpi_pack( buffer, position, this%max_temperature_, comm ) - call musica_mpi_pack( buffer, position, this%is_fixed_, comm ) - call musica_mpi_pack( buffer, position, this%fixed_temperature_, comm ) - call assert( 409699380, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_range_mpi_pack - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_range_mpi_unpack( this, buffer, position, comm ) - ! Unpacks a temperature range from a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - - class(temperature_range_t), intent(out) :: this ! temperature range to be unpacked - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos - - prev_pos = position - call musica_mpi_unpack( buffer, position, this%min_temperature_, comm ) - call musica_mpi_unpack( buffer, position, this%max_temperature_, comm ) - call musica_mpi_unpack( buffer, position, this%is_fixed_, comm ) - call musica_mpi_unpack( buffer, position, this%fixed_temperature_, comm ) - call assert( 164457757, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_range_mpi_unpack - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function temperature_parameterization_constructor( config, wavelengths ) & - result( this ) - ! Constructs temperature_parameterization_t objects - - use musica_assert, only : assert_msg - use musica_config, only : config_t - use musica_iterator, only : iterator_t - use musica_string, only : string_t - use tuvx_grid, only : grid_t - - type(temperature_parameterization_t) :: this - type(config_t), intent(inout) :: config - class(grid_t), intent(in) :: wavelengths - - character(len=*), parameter :: my_name = & - "temperature parameterization constructor" - type(string_t) :: required_keys(3), optional_keys(3) - type(config_t) :: temp_ranges, temp_range - class(iterator_t), pointer :: iter - integer :: i_range - logical :: found - - required_keys(1) = "AA" - required_keys(2) = "BB" - required_keys(3) = "lp" - optional_keys(1) = "minimum wavelength" - optional_keys(2) = "maximum wavelength" - optional_keys(3) = "temperature ranges" - call assert_msg( 256315527, & - config%validate( required_keys, optional_keys ), & - "Bad configuration for temperature parameterization." ) - - call config%get( "AA", this%AA_, my_name ) - call config%get( "BB", this%BB_, my_name ) - call config%get( "lp", this%lp_, my_name ) - call assert_msg( 467090427, size( this%AA_ ) == size( this%BB_ ) .and. & - size( this%AA_ ) == size( this%lp_ ), & - "Arrays AA, BB, and lp must be the same size for "// & - "temperature-based cross sections." ) - call config%get( "minimum wavelength", this%min_wavelength_, my_name, & - default = 0.0_dk ) - call config%get( "maximum wavelength", this%max_wavelength_, my_name, & - default = huge(1.0_dk) ) - this%min_wavelength_index_ = 1 - do while( wavelengths%mid_( this%min_wavelength_index_ ) & - < this%min_wavelength_ & - .and. this%min_wavelength_index_ <= wavelengths%ncells_ ) - this%min_wavelength_index_ = this%min_wavelength_index_ + 1 - end do - call assert_msg( 286143383, & - wavelengths%mid_( this%min_wavelength_index_ ) & - >= this%min_wavelength_, & - "Minimum wavelength for temperature-based cross section is "// & - "outside the bounds of the wavelength grid." ) - this%max_wavelength_index_ = wavelengths%ncells_ - do while( wavelengths%mid_( this%max_wavelength_index_ ) & - > this%max_wavelength_ & - .and. this%max_wavelength_index_ >= 1 ) - this%max_wavelength_index_ = this%max_wavelength_index_ - 1 - end do - call assert_msg( 490175140, & - wavelengths%mid_( this%max_wavelength_index_ ) & - <= this%max_wavelength_, & - "Maximum wavelength for temperature-based cross section is "// & - "outside the bounds of the wavelength grid." ) - call config%get( "temperature ranges", temp_ranges, my_name, & - found = found ) - if( .not. found ) then - allocate( this%ranges_( 1 ) ) - return - end if - allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) - iter => temp_ranges%get_iterator( ) - i_range = 0 - do while( iter%next( ) ) - i_range = i_range + 1 - call temp_ranges%get( iter, temp_range, my_name ) - this%ranges_( i_range ) = temperature_range_t( temp_range ) - end do - deallocate( iter ) - - end function temperature_parameterization_constructor - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - function merge_wavelength_grids( this, input_grid, tuv_grid ) & - result( merged_grid ) - ! Merges wavelength grid from NetCDF input data with parameterization - ! grid (same as the TUV-x grid). - ! Where they overlap, the parameterization is used. - ! Updates the parameterization wavelength indices for new grid. - ! Returns merged wavelength grid. - ! - ! NOTE: Uses mid-points on the TUV-x wavelength grid - - use musica_assert, only : assert - use tuvx_grid, only : grid_t - - class(temperature_parameterization_t), intent(inout) :: this - real(kind=dk), intent(in) :: input_grid(:) - class(grid_t), intent(in) :: tuv_grid - real(kind=dk), allocatable :: merged_grid(:) + !> Clean-up memory + subroutine finalize( this ) - logical :: found_min - integer :: i_wl, n_wl, i_input_wl, i_tuv_wl, n_tuv_wl + type(cross_section_temperature_based_t), intent(inout) :: this - if( size( input_grid ) == 0 ) then - merged_grid = tuv_grid%mid_ - return + if( associated( this%parameterization_ ) ) then + deallocate( this%parameterization_ ) end if - associate( wl_min_index => this%min_wavelength_index_, & - wl_max_index => this%max_wavelength_index_, & - min_wl => this%min_wavelength_, & - max_wl => this%max_wavelength_ ) - n_wl = 0 - do i_input_wl = 1, size( input_grid(:) ) - if( min_wl > input_grid( i_input_wl ) .or. & - max_wl < input_grid( i_input_wl ) ) n_wl = n_wl + 1 - end do - i_tuv_wl = wl_min_index - n_tuv_wl = wl_max_index - n_wl = n_wl + ( n_tuv_wl - i_tuv_wl + 1 ) - allocate( merged_grid( n_wl ) ) - i_input_wl = 1 - i_wl = 1 - found_min = .false. - do - if( i_wl > n_wl ) then - ! end of merged grid - exit - else if( i_tuv_wl > n_tuv_wl .and. & - input_grid( i_input_wl ) <= max_wl ) then - ! skipping input data wavelengths in parameterization range - i_input_wl = i_input_wl + 1 - else if( .not. ( min_wl <= input_grid( i_input_wl ) .and. & - max_wl >= input_grid( i_input_wl ) ) ) then - ! adding input data wavelengths outside of parameterization range - merged_grid( i_wl ) = input_grid( i_input_wl ) - i_input_wl = i_input_wl + 1 - i_wl = i_wl + 1 - else if( i_tuv_wl <= n_tuv_wl ) then - ! adding TUV-x wavelengths in parameterization range - ! - ! TODO This follows logic from original TUV, but perhaps should - ! be modified to assign TUV-x wavelength edges - merged_grid( i_wl ) = tuv_grid%mid_( i_tuv_wl ) - if( .not. found_min ) then - found_min = .true. - wl_min_index = i_wl - end if - wl_max_index = i_wl - i_tuv_wl = i_tuv_wl + 1 - i_wl = i_wl + 1 - end if - end do - call assert( 265861594, i_tuv_wl == n_tuv_wl + 1 ) - call assert( 537808229, i_input_wl == size( input_grid ) + 1 ) - call assert( 422870529, i_wl == n_wl + 1 ) - end associate - - end function merge_wavelength_grids - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_parameterization_calculate( this, temperature, & - wavelengths, cross_section ) - - use tuvx_profile, only : profile_t - - class(temperature_parameterization_t), intent(in) :: this - real(kind=dk), intent(in) :: temperature - real(kind=dk), intent(in) :: wavelengths(:) - real(kind=dk), intent(inout) :: cross_section(:) - - ! local variables - real(kind=dk) :: temp, temp_xs( size( cross_section ) ) - integer :: i_lp, i_range, w_min, w_max - - w_min = this%min_wavelength_index_ - w_max = this%max_wavelength_index_ - do i_range = 1, size( this%ranges_ ) - associate( temp_range => this%ranges_( i_range ) ) - if( temperature < temp_range%min_temperature_ .or. & - temperature > temp_range%max_temperature_ ) cycle - if( temp_range%is_fixed_ ) then - temp = temp_range%fixed_temperature_ - else - temp = temperature - end if - temp_xs(:) = 0.0_dk - do i_lp = 1, size( this%lp_ ) - temp_xs( w_min:w_max ) = temp_xs( w_min:w_max ) + & - ( this%AA_( i_lp ) + (temp - 273.0_dk) * this%BB_( i_lp ) ) * & - wavelengths( w_min:w_max )**this%lp_( i_lp ) - end do - cross_section( w_min:w_max ) = cross_section( w_min:w_max ) & - + 10**temp_xs( w_min:w_max ) - end associate - end do - - end subroutine temperature_parameterization_calculate - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - integer function temperature_parameterization_pack_size( this, comm ) & - result( pack_size ) - ! Returns the size of a character buffer required to pack the - ! parameterization - - use musica_mpi, only : musica_mpi_pack_size - - class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: i_range - - pack_size = musica_mpi_pack_size( this%AA_, comm ) + & - musica_mpi_pack_size( this%BB_, comm ) + & - musica_mpi_pack_size( this%lp_, comm ) + & - musica_mpi_pack_size( this%min_wavelength_, comm ) + & - musica_mpi_pack_size( this%max_wavelength_, comm ) + & - musica_mpi_pack_size( this%min_wavelength_index_, comm ) + & - musica_mpi_pack_size( this%max_wavelength_index_, comm ) + & - musica_mpi_pack_size( allocated( this%ranges_ ), comm ) - if( allocated( this%ranges_ ) ) then - pack_size = pack_size + & - musica_mpi_pack_size( size( this%ranges_ ), comm ) - do i_range = 1, size( this%ranges_ ) - pack_size = pack_size + this%ranges_( i_range )%pack_size( comm ) - end do - end if -#else - pack_size = 0 -#endif - - end function temperature_parameterization_pack_size - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_parameterization_mpi_pack( this, buffer, position, & - comm ) - ! Packs the parameterization onto a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - - class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos, i_range - - prev_pos = position - call musica_mpi_pack( buffer, position, this%AA_, comm ) - call musica_mpi_pack( buffer, position, this%BB_, comm ) - call musica_mpi_pack( buffer, position, this%lp_, comm ) - call musica_mpi_pack( buffer, position, this%min_wavelength_, comm ) - call musica_mpi_pack( buffer, position, this%max_wavelength_, comm ) - call musica_mpi_pack( buffer, position, this%min_wavelength_index_, comm ) - call musica_mpi_pack( buffer, position, this%max_wavelength_index_, comm ) - call musica_mpi_pack( buffer, position, allocated( this%ranges_ ), comm ) - if( allocated( this%ranges_ ) ) then - call musica_mpi_pack( buffer, position, size( this%ranges_ ), comm ) - do i_range = 1, size( this%ranges_ ) - call this%ranges_( i_range )%mpi_pack( buffer, position, comm ) - end do - end if - call assert( 267439201, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_parameterization_mpi_pack - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine temperature_parameterization_mpi_unpack( this, buffer, position, & - comm ) - ! Unpacks a parameterization from a character buffer - - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - - class(temperature_parameterization_t), intent(out) :: this ! parameterization to be unpacked - character, intent(inout) :: buffer(:) ! memory buffer - integer, intent(inout) :: position ! current buffer position - integer, intent(in) :: comm ! MPI communicator - -#ifdef MUSICA_USE_MPI - integer :: prev_pos, i_range, n_ranges - logical :: alloced - - prev_pos = position - call musica_mpi_unpack( buffer, position, this%AA_, comm ) - call musica_mpi_unpack( buffer, position, this%BB_, comm ) - call musica_mpi_unpack( buffer, position, this%lp_, comm ) - call musica_mpi_unpack( buffer, position, this%min_wavelength_, comm ) - call musica_mpi_unpack( buffer, position, this%max_wavelength_, comm ) - call musica_mpi_unpack( buffer, position, this%min_wavelength_index_,comm ) - call musica_mpi_unpack( buffer, position, this%max_wavelength_index_,comm ) - call musica_mpi_unpack( buffer, position, alloced, comm ) - if( alloced ) then - call musica_mpi_unpack( buffer, position, n_ranges, comm ) - allocate( this%ranges_( n_ranges ) ) - do i_range = 1, size( this%ranges_ ) - call this%ranges_( i_range )%mpi_unpack( buffer, position, comm ) - end do - end if - call assert( 483905106, position - prev_pos <= this%pack_size( comm ) ) -#endif - - end subroutine temperature_parameterization_mpi_unpack + end subroutine finalize !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/cross_sections/util/CMakeLists.txt b/src/cross_sections/util/CMakeLists.txt new file mode 100644 index 00000000..546c0260 --- /dev/null +++ b/src/cross_sections/util/CMakeLists.txt @@ -0,0 +1,13 @@ +################################################################################ +# utilities for cross section parameterizations + +target_sources(tuvx_object + PRIVATE + temperature_parameterization.F90 + temperature_parameterization_burkholder.F90 + temperature_parameterization_harwood.F90 + temperature_parameterization_taylor_series.F90 + temperature_range.F90 +) + +################################################################################ \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization.F90 b/src/cross_sections/util/temperature_parameterization.F90 new file mode 100644 index 00000000..32b863dc --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization.F90 @@ -0,0 +1,436 @@ +! Copyright (C) 2020-4 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization +! Calculates cross-section elements based on a temperature parameterization + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_t + + !> Parameters for calculating cross section values based on + !! temperature + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! 10^{\sum_i{(AA_i + (T-273)*BB_i)*\lambda^{lp_i}}} + !! \f] + !! + !! where \f$\lambda\f$ is the wavelength [nm] and + !! \f$T\f$ is the temperature [K]. + type :: temperature_parameterization_t + integer :: n_sets_ = 0 + real(kind=dk), allocatable :: AA_(:) + real(kind=dk), allocatable :: BB_(:) + real(kind=dk), allocatable :: lp_(:) + !> Wavelengths in parameterization range [nm] + real(kind=dk), allocatable :: wavelengths_(:) + !> Base temperature [K] to use in calculations + real(kind=dk) :: base_temperature_ = 0.0_dk + !> Base wavelength [nm] to use in calcuations + real(kind=dk) :: base_wavelength_ = 0.0_dk + !> Flag indicating whether cross section algorithm is base 10 (true) + !! or base e (false) + logical :: is_base_10_ = .true. + !> Flad indicating whether to subtract base temperature from + !! actual temperature (false) or to subtract actual temperature + !! from base temperature (true) + logical :: is_temperature_inverted_ = .false. + !> Minimum wavelength [nm] to calculate values for + real(kind=dk) :: min_wavelength_ = 0.0_dk + !> Maximum wavelength [nm] to calculate values for + real(kind=dk) :: max_wavelength_ = 0.0_dk + !> Index of minimum wavelength [nm] to calculate values for + integer :: min_wavelength_index_ = 0 + !> Index of maximum wavelength to calculate values for + integer :: max_wavelength_index_ = 0 + !> Temperature ranges used in parameterization + type(temperature_range_t), allocatable :: ranges_(:) + contains + !> Merges NetCDF wavelength grid with parameterization grid + procedure :: merge_wavelength_grids + !> Calculate the cross section value for a specific temperature + !! and wavelength + procedure :: calculate => calculate + !> Returns the number of bytes required to pack the parameterization + !! onto a character buffer + procedure :: pack_size => pack_size + !> Packs the parameterization onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks the parameterization from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_parameterization_t + + !> Constructor for temperature_parameterization_t + interface temperature_parameterization_t + module procedure :: constructor + end interface temperature_parameterization_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function constructor( config, wavelengths ) result( this ) + ! Constructs temperature_parameterization_t objects + + use musica_assert, only : assert_msg, die_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t + use tuvx_grid, only : grid_t + + type(temperature_parameterization_t) :: this + type(config_t), intent(inout) :: config + class(grid_t), intent(in) :: wavelengths + + character(len=*), parameter :: my_name = & + "temperature parameterization constructor" + type(string_t) :: required_keys(6), optional_keys(4), exp_base + type(config_t) :: temp_ranges, temp_range + class(iterator_t), pointer :: iter + integer :: i_range + logical :: found + + required_keys(1) = "AA" + required_keys(2) = "BB" + required_keys(3) = "lp" + required_keys(4) = "base temperature" + required_keys(5) = "base wavelength" + required_keys(6) = "logarithm" + optional_keys(1) = "minimum wavelength" + optional_keys(2) = "maximum wavelength" + optional_keys(3) = "temperature ranges" + optional_keys(4) = "invert temperature offset" + call assert_msg( 256315527, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for temperature parameterization." ) + + call config%get( "AA", this%AA_, my_name ) + call config%get( "BB", this%BB_, my_name ) + call config%get( "lp", this%lp_, my_name ) + call config%get( "base temperature", this%base_temperature_, my_name ) + call config%get( "base wavelength", this%base_wavelength_, my_name ) + call config%get( "logarithm", exp_base, my_name ) + call config%get( "invert temperature offset", & + this%is_temperature_inverted_, my_name, default = .false.) + if( exp_base == "base 10" ) then + this%is_base_10_ = .true. + else if( exp_base == "natural" ) then + this%is_base_10_ = .false. + else + call die_msg( 104603249, "Invalid logarithm type in temperature-based"//& + " cross section: '"//exp_base//"'" ) + end if + call assert_msg( 467090427, size( this%AA_ ) == size( this%BB_ ) .and. & + size( this%AA_ ) == size( this%lp_ ), & + "Arrays AA, BB, and lp must be the same size for "// & + "temperature-based cross sections." ) + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = huge(1.0_dk) ) + this%min_wavelength_index_ = 1 + do while( wavelengths%mid_( this%min_wavelength_index_ ) & + < this%min_wavelength_ & + .and. this%min_wavelength_index_ <= wavelengths%ncells_ ) + this%min_wavelength_index_ = this%min_wavelength_index_ + 1 + end do + call assert_msg( 286143383, & + wavelengths%mid_( this%min_wavelength_index_ ) & + >= this%min_wavelength_, & + "Minimum wavelength for temperature-based cross section is "// & + "outside the bounds of the wavelength grid." ) + this%max_wavelength_index_ = wavelengths%ncells_ + do while( wavelengths%mid_( this%max_wavelength_index_ ) & + > this%max_wavelength_ & + .and. this%max_wavelength_index_ >= 1 ) + this%max_wavelength_index_ = this%max_wavelength_index_ - 1 + end do + call assert_msg( 490175140, & + wavelengths%mid_( this%max_wavelength_index_ ) & + <= this%max_wavelength_, & + "Maximum wavelength for temperature-based cross section is "// & + "outside the bounds of the wavelength grid." ) + ! TODO This follows logic from original TUV, but perhaps should + ! be modified to assign TUV-x wavelength edges + this%wavelengths_ = wavelengths%mid_( this%min_wavelength_index_ : & + this%max_wavelength_index_ ) + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function merge_wavelength_grids( this, input_grid ) result( merged_grid ) + ! Merges wavelength grid from NetCDF input data with parameterization + ! grid. + ! Where they overlap, the parameterization is used. + ! Updates the parameterization wavelength indices for new grid. + ! Returns merged wavelength grid. + + use musica_assert, only : assert + use tuvx_grid, only : grid_t + + class(temperature_parameterization_t), intent(inout) :: this + real(kind=dk), intent(in) :: input_grid(:) + real(kind=dk), allocatable :: merged_grid(:) + + logical :: found_min + integer :: i_wl, n_wl, i_input_wl, i_param_wl + + if( size( input_grid ) == 0 ) then + merged_grid = this%wavelengths_ + this%min_wavelength_index_ = 1 + this%max_wavelength_index_ = size( merged_grid ) + return + end if + + associate( wl_min_index => this%min_wavelength_index_, & + wl_max_index => this%max_wavelength_index_, & + min_wl => this%min_wavelength_, & + max_wl => this%max_wavelength_ ) + n_wl = 0 + do i_input_wl = 1, size( input_grid(:) ) + if( min_wl > input_grid( i_input_wl ) .or. & + max_wl < input_grid( i_input_wl ) ) n_wl = n_wl + 1 + end do + n_wl = n_wl + size( this%wavelengths_ ) + allocate( merged_grid( n_wl ) ) + i_input_wl = 1 + i_param_wl = 1 + i_wl = 1 + found_min = .false. + do + if( i_wl > n_wl ) then + ! end of merged grid + exit + else if( i_param_wl > size( this%wavelengths_ ) .and. & + input_grid( i_input_wl ) <= max_wl ) then + ! skipping input data wavelengths in parameterization range + i_input_wl = i_input_wl + 1 + else if( .not. ( min_wl <= input_grid( i_input_wl ) .and. & + max_wl >= input_grid( i_input_wl ) ) ) then + ! adding input data wavelengths outside of parameterization range + merged_grid( i_wl ) = input_grid( i_input_wl ) + i_input_wl = i_input_wl + 1 + i_wl = i_wl + 1 + else if( i_param_wl <= size( this%wavelengths_ ) ) then + ! adding TUV-x wavelengths in parameterization range + merged_grid( i_wl ) = this%wavelengths_( i_param_wl ) + if( .not. found_min ) then + found_min = .true. + wl_min_index = i_wl + end if + wl_max_index = i_wl + i_param_wl = i_param_wl + 1 + i_wl = i_wl + 1 + end if + end do + call assert( 265861594, i_param_wl == size( this%wavelengths_ ) + 1 ) + call assert( 537808229, i_input_wl <= size( input_grid ) + 1 ) + call assert( 422870529, i_wl == n_wl + 1 ) + end associate + + end function merge_wavelength_grids + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + ! local variables + real(kind=dk) :: temp, temp_xs( size( cross_section ) ) + integer :: i_lp, i_range, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ + else + temp = temperature + end if + if ( this%is_temperature_inverted_ ) then + temp = this%base_temperature_ - temp + else + temp = temp - this%base_temperature_ + end if + temp_xs(:) = 0.0_dk + do i_lp = 1, size( this%lp_ ) + temp_xs( w_min:w_max ) = temp_xs( w_min:w_max ) + & + ( this%AA_( i_lp ) + temp * this%BB_( i_lp ) ) * & + ( wavelengths( w_min:w_max ) & + - this%base_wavelength_ )**this%lp_( i_lp ) + end do + if (this%is_base_10_) then + cross_section( w_min:w_max ) = cross_section( w_min:w_max ) & + + 10**temp_xs( w_min:w_max ) + else + cross_section( w_min:w_max ) = cross_section( w_min:w_max ) & + + exp( temp_xs( w_min:w_max ) ) + end if + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function pack_size( this, comm ) + ! Returns the size of a character buffer required to pack the + ! parameterization + + use musica_mpi, only : musica_mpi_pack_size + + class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: i_range + + pack_size = musica_mpi_pack_size( this%AA_, comm ) + & + musica_mpi_pack_size( this%BB_, comm ) + & + musica_mpi_pack_size( this%lp_, comm ) + & + musica_mpi_pack_size( this%wavelengths_, comm ) + & + musica_mpi_pack_size( this%base_temperature_, comm ) + & + musica_mpi_pack_size( this%base_wavelength_, comm ) + & + musica_mpi_pack_size( this%is_base_10_, comm ) + & + musica_mpi_pack_size( this%is_temperature_inverted_, comm ) + & + musica_mpi_pack_size( this%min_wavelength_, comm ) + & + musica_mpi_pack_size( this%max_wavelength_, comm ) + & + musica_mpi_pack_size( this%min_wavelength_index_, comm ) + & + musica_mpi_pack_size( this%max_wavelength_index_, comm ) + & + musica_mpi_pack_size( allocated( this%ranges_ ), comm ) + if( allocated( this%ranges_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( size( this%ranges_ ), comm ) + do i_range = 1, size( this%ranges_ ) + pack_size = pack_size + this%ranges_( i_range )%pack_size( comm ) + end do + end if +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_pack( this, buffer, position, comm ) + ! Packs the parameterization onto a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + class(temperature_parameterization_t), intent(in) :: this ! parameterization to be packed + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_range + + prev_pos = position + call musica_mpi_pack( buffer, position, this%AA_, comm ) + call musica_mpi_pack( buffer, position, this%BB_, comm ) + call musica_mpi_pack( buffer, position, this%lp_, comm ) + call musica_mpi_pack( buffer, position, this%wavelengths_, comm ) + call musica_mpi_pack( buffer, position, this%base_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%base_wavelength_, comm ) + call musica_mpi_pack( buffer, position, this%is_base_10_, comm ) + call musica_mpi_pack( buffer, position, this%is_temperature_inverted_, & + comm ) + call musica_mpi_pack( buffer, position, this%min_wavelength_, comm ) + call musica_mpi_pack( buffer, position, this%max_wavelength_, comm ) + call musica_mpi_pack( buffer, position, this%min_wavelength_index_, comm ) + call musica_mpi_pack( buffer, position, this%max_wavelength_index_, comm ) + call musica_mpi_pack( buffer, position, allocated( this%ranges_ ), comm ) + if( allocated( this%ranges_ ) ) then + call musica_mpi_pack( buffer, position, size( this%ranges_ ), comm ) + do i_range = 1, size( this%ranges_ ) + call this%ranges_( i_range )%mpi_pack( buffer, position, comm ) + end do + end if + call assert( 267439201, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_unpack( this, buffer, position, comm ) + ! Unpacks a parameterization from a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + class(temperature_parameterization_t), intent(out) :: this ! parameterization to be unpacked + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_range, n_ranges + logical :: alloced + + prev_pos = position + call musica_mpi_unpack( buffer, position, this%AA_, comm ) + call musica_mpi_unpack( buffer, position, this%BB_, comm ) + call musica_mpi_unpack( buffer, position, this%lp_, comm ) + call musica_mpi_unpack( buffer, position, this%wavelengths_, comm ) + call musica_mpi_unpack( buffer, position, this%base_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%base_wavelength_, comm ) + call musica_mpi_unpack( buffer, position, this%is_base_10_, comm ) + call musica_mpi_unpack( buffer, position, this%is_temperature_inverted_, & + comm ) + call musica_mpi_unpack( buffer, position, this%min_wavelength_, comm ) + call musica_mpi_unpack( buffer, position, this%max_wavelength_, comm ) + call musica_mpi_unpack( buffer, position, this%min_wavelength_index_,comm ) + call musica_mpi_unpack( buffer, position, this%max_wavelength_index_,comm ) + call musica_mpi_unpack( buffer, position, alloced, comm ) + if( alloced ) then + call musica_mpi_unpack( buffer, position, n_ranges, comm ) + allocate( this%ranges_( n_ranges ) ) + do i_range = 1, size( this%ranges_ ) + call this%ranges_( i_range )%mpi_unpack( buffer, position, comm ) + end do + end if + call assert( 483905106, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization_burkholder.F90 b/src/cross_sections/util/temperature_parameterization_burkholder.F90 new file mode 100644 index 00000000..b483775f --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization_burkholder.F90 @@ -0,0 +1,257 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization_burkholder +! Calculates cross-section elements using a temperature-based +! parameterization from Burkholder et al. Phys. Chem. Chem. Phys. 4, 1432-1437 (2002). + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_burkholder_t + + !> Parameters for calculating cross section values based on + !! temperature using the algoritm in Burkholder et al. + !! Phys. Chem. Chem. Phys. 4, 1432-1437 (2002). + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! Q(T) = 1 + e^{\frac{A}{B*T}} + !! \sigma(T,\lambda) = \frac{aa(\lambda)}{Q(T)} + bb(\lambda)*\[1-\frac{1}{Q(T)}\] + !! \f] + !! + !! where A, B, aa, and bb are constants, T is temperature [K] and \f$\lambda\f$ is + !! wavelength [nm]. + type, extends(temperature_parameterization_t) :: temperature_parameterization_burkholder_t + real(kind=dk) :: A_ + real(kind=dk) :: B_ + contains + !> Calculate the cross section value for a specific temperature and wavelength + procedure :: calculate + !> Returns the number of bytes required to pack the parameterization + !! onto a character buffer + procedure :: pack_size => pack_size + !> Packs the parameterization onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks the parameterization from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_parameterization_burkholder_t + + !> Constructor for temperature_parameterization_burkholder_t + interface temperature_parameterization_burkholder_t + module procedure :: constructor + end interface temperature_parameterization_burkholder_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a Burkholder (2002) temperature-based parameterization + function constructor( config ) 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 + use tuvx_grid, only : grid_t + use tuvx_netcdf, only : netcdf_t + + type(temperature_parameterization_burkholder_t) :: this + type(config_t), intent(inout) :: config + + character(len=*), parameter :: my_name = & + "Burkholder (2002) temperature parameterization constructor" + type(string_t) :: required_keys(3), optional_keys(4), file_path + type(config_t) :: temp_ranges, temp_range, netcdf_file + class(iterator_t), pointer :: iter + type(netcdf_t) :: netcdf + integer :: i_range, i_param, n_param + logical :: found + + required_keys(1) = "netcdf file" + required_keys(2) = "A" + required_keys(3) = "B" + optional_keys(1) = "type" + optional_keys(2) = "temperature ranges" + optional_keys(3) = "minimum wavelength" + optional_keys(4) = "maximum wavelength" + call assert_msg( 235183546, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for Burkholder (2002) temperature "// & + "parameterization." ) + + ! Load NetCDF file + call config%get( "netcdf file", netcdf_file, my_name ) + call netcdf_file%get( "file path", file_path, my_name ) + call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & + variable_name = "temperature_" ) + n_param = size( netcdf%parameters, dim = 2 ) + call assert_msg( 164185428, n_param >= 2, "Burkholder (2002) "// & + "parameterization must have at two sets of "// & + "coefficients" ) + + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = netcdf%wavelength(1) ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = netcdf%wavelength( size( netcdf%wavelength ) ) ) + this%min_wavelength_ = max( this%min_wavelength_, netcdf%wavelength(1) ) + this%max_wavelength_ = min( this%max_wavelength_, & + netcdf%wavelength( size( netcdf%wavelength ) ) ) + call assert_msg( 856954069, this%min_wavelength_ < this%max_wavelength_, & + "Invalid wavelength range for Burkholder temperature "// & + "parameterization" ) + + ! Load parameters + call config%get( "A", this%A_, my_name ) + call config%get( "B", this%B_, my_name ) + this%wavelengths_ = netcdf%wavelength(:) + this%AA_ = netcdf%parameters(:,1) + this%BB_ = netcdf%parameters(:,2) + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + + ! initialize unused data members + allocate( this%lp_(0) ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_burkholder_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + real(kind=dk) :: temp, Q + integer :: i_range, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ - this%base_temperature_ + else + temp = temperature - this%base_temperature_ + end if + Q = 1.0_dk + exp( this%A_ / ( this%B_ * temp ) ) + cross_section( w_min:w_max ) = ( this%AA_(:) / Q + & + this%BB_(:) * ( 1.0_dk - 1.0_dk / Q ) & + ) * 1.0e-20_dk + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer required to pack the + !! parameterization + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Parameterization to be packed + class(temperature_parameterization_burkholder_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%temperature_parameterization_t%pack_size( comm ) + & + musica_mpi_pack_size( this%A_, comm ) + & + musica_mpi_pack_size( this%B_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the parameterization onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Parameterization to be packed + class(temperature_parameterization_burkholder_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_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%A_, comm ) + call musica_mpi_pack( buffer, position, this%B_, comm ) + call assert( 190816083, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a parameterization from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> The parameterization to be unpacked + class(temperature_parameterization_burkholder_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_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%A_, comm ) + call musica_mpi_unpack( buffer, position, this%B_, comm ) + call assert( 634825156, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization_burkholder \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization_harwood.F90 b/src/cross_sections/util/temperature_parameterization_harwood.F90 new file mode 100644 index 00000000..877885a7 --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization_harwood.F90 @@ -0,0 +1,195 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization_harwood +! Calculates cross-section elements using a temperature-based +! parameterization. TODO: need reference + + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_harwood_t + + !> Parameterization for calculating cross section values + !! TODO: need reference + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! \sigma(T,\lambda_i) = 10^{\(aa_i + bb_i / T\)} + !! \f] + !! + !! where aa_i and bb_i are constants, T is temperature [K], and + !! \f$\lambda_i\f$ is wavelength [nm]. The size of the aa and bb + !! arrays must equal the number of wavelengths in the parameterization + !! range. + type, extends(temperature_parameterization_t) :: temperature_parameterization_harwood_t + contains + !> Calculate the cross section value for a specific temperature and wavelength + procedure :: calculate + end type temperature_parameterization_harwood_t + + !> Constructor for temperature_parameterization_harwood_t + interface temperature_parameterization_harwood_t + module procedure :: constructor + end interface temperature_parameterization_harwood_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a Harwood (TODO: need ref) temperature-based parameterization + function constructor( config, wavelengths ) result( this ) + + use musica_assert, only : assert_msg, die_msg + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_string, only : string_t, to_char + use tuvx_grid, only : grid_t + + type(temperature_parameterization_harwood_t) :: this + type(config_t), intent(inout) :: config + class(grid_t), intent(in) :: wavelengths + + character(len=*), parameter :: my_name = & + "Harwood temperature parameterization" + type(string_t) :: required_keys(5), optional_keys(5), exp_base + type(config_t) :: temp_ranges, temp_range + class(iterator_t), pointer :: iter + integer :: i_range, i_param, n_param, n_wl + logical :: found + + required_keys(1) = "aa" + required_keys(2) = "bb" + required_keys(3) = "base temperature" + required_keys(4) = "base wavelength" + required_keys(5) = "logarithm" + optional_keys(1) = "type" + optional_keys(2) = "minimum wavelength" + optional_keys(3) = "maximum wavelength" + optional_keys(4) = "temperature ranges" + optional_keys(5) = "invert temperature offset" + call assert_msg( 581965121, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for Harwood temperature "// & + "parameterization." ) + call config%get( "aa", this%aa_, my_name ) + call config%get( "bb", this%bb_, my_name ) + call config%get( "base temperature", this%base_temperature_, my_name ) + call config%get( "base wavelength", this%base_wavelength_, my_name ) + call config%get( "logarithm", exp_base, my_name ) + + call config%get( "invert temperature offset", & + this%is_temperature_inverted_, my_name, default = .false.) + if( exp_base == "base 10" ) then + this%is_base_10_ = .true. + else if( exp_base == "natural" ) then + this%is_base_10_ = .false. + else + call die_msg( 768514789, "Invalid logarithm type in Harwood "// & + "temperature-based cross section: '"// & + exp_base//"'" ) + end if + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = huge(1.0_dk) ) + this%min_wavelength_index_ = 1 + do while( wavelengths%mid_( this%min_wavelength_index_ ) & + < this%min_wavelength_ & + .and. this%min_wavelength_index_ <= wavelengths%ncells_ ) + this%min_wavelength_index_ = this%min_wavelength_index_ + 1 + end do + call assert_msg( 654743205, & + wavelengths%mid_( this%min_wavelength_index_ ) & + >= this%min_wavelength_, & + "Minimum wavelength for Harawood temperature-based cross "// & + "section is outside the bounds of the wavelength grid." ) + this%max_wavelength_index_ = wavelengths%ncells_ + do while( wavelengths%mid_( this%max_wavelength_index_ ) & + > this%max_wavelength_ & + .and. this%max_wavelength_index_ >= 1 ) + this%max_wavelength_index_ = this%max_wavelength_index_ - 1 + end do + call assert_msg( 309165090, & + wavelengths%mid_( this%max_wavelength_index_ ) & + <= this%max_wavelength_, & + "Maximum wavelength for Harwood temperature-based cross "// & + "section is outside the bounds of the wavelength grid." ) + ! TODO This follows logic from original TUV, but perhaps should + ! be modified to assign TUV-x wavelength edges + this%wavelengths_ = wavelengths%mid_( this%min_wavelength_index_ : & + this%max_wavelength_index_ ) + call assert_msg( 760344004, size( this%aa_ ) .eq. size( this%bb_ ), & + "Parameter arrays for Harwood temperature-based cross "//& + "section (aa and bb) must be of the same size." ) + n_param = size( this%aa_ ) + n_wl = this%max_wavelength_index_ - this%min_wavelength_index_ + 1 + call assert_msg( 641308113, n_param .eq. n_wl, & + "Parameter arrays for Harwood temperature-based cross "//& + "section (aa and bb) must be the same size as the "// & + "parameterized portion of the wavelength grid. "// & + "Expected "//trim( to_char( n_wl ) )//" but got "// & + trim( to_char( n_param ) )//"." ) + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + allocate( this%lp_( 0 ) ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_harwood_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + real(kind=dk) :: temp + integer :: i_range, i_wl, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ - this%base_temperature_ + else + temp = temperature - this%base_temperature_ + end if + do i_wl = 1, w_max - w_min + 1 + cross_section( w_min + i_wl - 1 ) = & + 10.0d0**( this%aa_( i_wl ) + this%bb_( i_wl ) / temp ) + end do + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization_harwood \ No newline at end of file diff --git a/src/cross_sections/util/temperature_parameterization_taylor_series.F90 b/src/cross_sections/util/temperature_parameterization_taylor_series.F90 new file mode 100644 index 00000000..8003af83 --- /dev/null +++ b/src/cross_sections/util/temperature_parameterization_taylor_series.F90 @@ -0,0 +1,273 @@ +! Copyright (C) 2020-4 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_parameterization_taylor_series +! Calculates cross-section elements using a Taylor-series temperature-based +! parameterization + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use tuvx_temperature_parameterization, & + only : temperature_parameterization_t + use tuvx_temperature_range, only : temperature_range_t + + implicit none + + private + public :: temperature_parameterization_taylor_series_t + + !> Parameters for calculating cross section values based on + !! temperature using a Taylor series + !! + !! Cross section elements are calculated as: + !! + !! \f[ + !! \sigma(T_{base}) * \[ 1.0 + A_1 * (T - T_{base}) + A_2 * (T - T_{base})^2 \] + !! \f] + !! + !! where \f$\sigma\f$ is a reference cross section at temperature [K] + !! \f$T_{base}\f$, \f$A_1\f$ and \f$A_2\f$ are fitting parameters, and + !! \f$T\f$ is temperature [K]. + type, extends(temperature_parameterization_t) :: temperature_parameterization_taylor_series_t + !> Base cross section element + real(kind=dk), allocatable :: sigma_(:) + !> Taylor-series coefficients A_n (n,wavelength) + real(kind=dk), allocatable :: A_(:,:) + contains + !> Calculate the cross section value for a specific temperature and wavelength + procedure :: calculate + !> Returns the number of bytes required to pack the parameterization + !! onto a character buffer + procedure :: pack_size => pack_size + !> Packs the parameterization onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks the parameterization from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_parameterization_taylor_series_t + + !> Constructor for temperature_parameterization_taylor_series_t + interface temperature_parameterization_taylor_series_t + module procedure :: constructor + end interface temperature_parameterization_taylor_series_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a Taylor-series temperature-based parameterization + function constructor( config ) 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 + use tuvx_grid, only : grid_t + use tuvx_netcdf, only : netcdf_t + + type(temperature_parameterization_taylor_series_t) :: this + type(config_t), intent(inout) :: config + + character(len=*), parameter :: my_name = & + "Taylor-series temperature parameterization constructor" + type(string_t) :: required_keys(2), optional_keys(4), file_path + type(config_t) :: temp_ranges, temp_range, netcdf_file + class(iterator_t), pointer :: iter + type(netcdf_t) :: netcdf + integer :: i_range, i_param, n_param, i_min_wl, i_max_wl + logical :: found + + required_keys(1) = "netcdf file" + required_keys(2) = "base temperature" + optional_keys(1) = "minimum wavelength" + optional_keys(2) = "maximum wavelength" + optional_keys(3) = "temperature ranges" + optional_keys(4) = "type" + call assert_msg( 235183546, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for temperature parameterization." ) + + ! Load NetCDF file + call config%get( "netcdf file", netcdf_file, my_name ) + call netcdf_file%get( "file path", file_path, my_name ) + call netcdf%read_netcdf_file( file_path = file_path%to_char( ), & + variable_name = "temperature_" ) + n_param = size( netcdf%parameters, dim = 2 ) - 1 + call assert_msg( 164185428, n_param >= 1, "Taylor-series temperature "// & + "parameterization must have at least one set of "// & + "coefficients" ) + + ! Load parameters + call config%get( "base temperature", this%base_temperature_, my_name ) + call config%get( "minimum wavelength", this%min_wavelength_, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", this%max_wavelength_, my_name, & + default = huge( 1.0_dk ) ) + i_min_wl = 1 + do while( netcdf%wavelength( i_min_wl ) < this%min_wavelength_ & + .and. i_min_wl <= size( netcdf%wavelength ) ) + i_min_wl = i_min_wl + 1 + end do + call assert_msg( 504874740, & + netcdf%wavelength( i_min_wl ) >= this%min_wavelength_, & + "Minimum wavelength for Taylor-series temperature-based cross "//& + "section is outside the bounds of the wavelength grid." ) + i_max_wl = size( netcdf%wavelength ) + do while( netcdf%wavelength( i_max_wl ) > this%max_wavelength_ & + .and. i_max_wl >= 1 ) + i_max_wl = i_max_wl - 1 + end do + call assert_msg( 587703546, & + netcdf%wavelength( i_max_wl ) <= this%max_wavelength_, & + "Maximum wavelength for Taylor-series temperature-based cross "//& + "section is outside the bounds of the wavelength grid." ) + allocate( this%A_( n_param, i_max_wl - i_min_wl + 1 ) ) + this%wavelengths_ = netcdf%wavelength( i_min_wl:i_max_wl ) + this%sigma_ = netcdf%parameters( i_min_wl:i_max_wl, 1 ) + do i_param = 1, n_param + this%A_( i_param, : ) = & + netcdf%parameters( i_min_wl:i_max_wl , i_param + 1 ) + end do + call config%get( "temperature ranges", temp_ranges, my_name, & + found = found ) + if( .not. found ) then + allocate( this%ranges_( 1 ) ) + return + end if + allocate( this%ranges_( temp_ranges%number_of_children( ) ) ) + iter => temp_ranges%get_iterator( ) + i_range = 0 + do while( iter%next( ) ) + i_range = i_range + 1 + call temp_ranges%get( iter, temp_range, my_name ) + this%ranges_( i_range ) = temperature_range_t( temp_range ) + end do + deallocate( iter ) + + ! initialize unused data members + allocate( this%AA_(0) ) + allocate( this%BB_(0) ) + allocate( this%lp_(0) ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate( this, temperature, wavelengths, cross_section ) + + use tuvx_profile, only : profile_t + + class(temperature_parameterization_taylor_series_t), intent(in) :: this + real(kind=dk), intent(in) :: temperature + real(kind=dk), intent(in) :: wavelengths(:) + real(kind=dk), intent(inout) :: cross_section(:) + + real(kind=dk) :: temp, temp_xs( size( this%wavelengths_ ) ) + integer :: i_A, i_range, w_min, w_max + + w_min = this%min_wavelength_index_ + w_max = this%max_wavelength_index_ + do i_range = 1, size( this%ranges_ ) + associate( temp_range => this%ranges_( i_range ) ) + if( temperature < temp_range%min_temperature_ .or. & + temperature > temp_range%max_temperature_ ) cycle + if( temp_range%is_fixed_ ) then + temp = temp_range%fixed_temperature_ - this%base_temperature_ + else + temp = temperature - this%base_temperature_ + end if + temp_xs(:) = 1.0 + do i_A = 1, size( this%A_, dim = 1 ) + temp_xs(:) = temp_xs(:) + this%A_(i_A,:) * temp**i_A + end do + cross_section( w_min:w_max ) = temp_xs(:) * this%sigma_(:) + end associate + end do + + end subroutine calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer required to pack the + !! parameterization + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Parameterization to be packed + class(temperature_parameterization_taylor_series_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%temperature_parameterization_t%pack_size( comm ) + & + musica_mpi_pack_size( this%sigma_, comm ) + & + musica_mpi_pack_size( this%A_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the parameterization onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Parameterization to be packed + class(temperature_parameterization_taylor_series_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_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%sigma_, comm ) + call musica_mpi_pack( buffer, position, this%A_, comm ) + call assert( 342538714, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a parameterization from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> The parameterization to be unpacked + class(temperature_parameterization_taylor_series_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_pos + + prev_pos = position + call this%temperature_parameterization_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%sigma_, comm ) + call musica_mpi_unpack( buffer, position, this%A_, comm ) + call assert( 966515884, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_parameterization_taylor_series \ No newline at end of file diff --git a/src/cross_sections/util/temperature_range.F90 b/src/cross_sections/util/temperature_range.F90 new file mode 100644 index 00000000..19dbdaf0 --- /dev/null +++ b/src/cross_sections/util/temperature_range.F90 @@ -0,0 +1,158 @@ +! Copyright (C) 2020-4 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_temperature_range +! Defines a temperature range for use in temperature-based cross +! section parameterizations + + ! Including musica_config at the module level to avoid an ICE + ! with Intel 2022.1 compiler + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + + implicit none + + private + public :: temperature_range_t + + + !> Range for temperature-based calculations + type :: temperature_range_t + !> Minimum temperature [K] for inclusion in range + real(kind=dk) :: min_temperature_ = 0.0_dk + !> Maximum temperature [K] for include in range + real(kind=dk) :: max_temperature_ = huge(1.0_dk) + !> Indicates whether to use a fixed temperature for the + !! parameterization calculation. If FALSE, the actual + !! temperature is used. + logical :: is_fixed_ = .false. + !> Fixed temperature [K] to use in paramterization calculation + !! + !! Is only used if is_fixed == TRUE + real(kind=dk) :: fixed_temperature_ = 0.0_dk + contains + !> Returns the number of bytes required to pack the range onto a + !! character buffer + procedure :: pack_size => pack_size + !> Packs the range onto a character buffer + procedure :: mpi_pack => mpi_pack + !> Unpacks a range from a character buffer + procedure :: mpi_unpack => mpi_unpack + end type temperature_range_t + + !> Constructor for temperature_range_t + interface temperature_range_t + module procedure :: constructor + end interface temperature_range_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function constructor( config ) result( this ) + ! Constructs temperature range objects + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t + + type(temperature_range_t) :: this + type(config_t), intent(inout) :: config + + character(len=*), parameter :: my_name = "temperature range constructor" + type(string_t) :: required_keys(0), optional_keys(3) + logical :: found + + optional_keys(1) = "minimum" + optional_keys(2) = "maximum" + optional_keys(3) = "fixed value" + call assert_msg( 355912601, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for temperature range" ) + + call config%get( "minimum", this%min_temperature_, my_name, & + default = 0.0_dk ) + call config%get( "maximum", this%max_temperature_, my_name, & + default = huge(1.0_dk) ) + call config%get( "fixed value", this%fixed_temperature_, my_name, & + found = found ) + this%is_fixed_ = found + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + integer function pack_size( this, comm ) + ! Returns the size of a character buffer required to pack the range + + use musica_mpi, only : musica_mpi_pack_size + + class(temperature_range_t), intent(in) :: this ! temperature range to be packed + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + pack_size = musica_mpi_pack_size( this%min_temperature_, comm ) + & + musica_mpi_pack_size( this%max_temperature_, comm ) + & + musica_mpi_pack_size( this%is_fixed_, comm ) + & + musica_mpi_pack_size( this%fixed_temperature_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_pack( this, buffer, position, comm ) + ! Packs the temperature range onto a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + class(temperature_range_t), intent(in) :: this ! temperature range to be packed + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call musica_mpi_pack( buffer, position, this%min_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%max_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%is_fixed_, comm ) + call musica_mpi_pack( buffer, position, this%fixed_temperature_, comm ) + call assert( 409699380, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine mpi_unpack( this, buffer, position, comm ) + ! Unpacks a temperature range from a character buffer + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + class(temperature_range_t), intent(out) :: this ! temperature range to be unpacked + character, intent(inout) :: buffer(:) ! memory buffer + integer, intent(inout) :: position ! current buffer position + integer, intent(in) :: comm ! MPI communicator + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + + prev_pos = position + call musica_mpi_unpack( buffer, position, this%min_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%max_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%is_fixed_, comm ) + call musica_mpi_unpack( buffer, position, this%fixed_temperature_, comm ) + call assert( 164457757, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_temperature_range \ No newline at end of file diff --git a/src/grid_warehouse.F90 b/src/grid_warehouse.F90 index 04f68d8f..fa14251b 100644 --- a/src/grid_warehouse.F90 +++ b/src/grid_warehouse.F90 @@ -152,10 +152,10 @@ function get_grid_string( this, name, units ) result( a_grid_ptr ) use musica_string, only : string_t use tuvx_grid, only : grid_t - class(grid_warehouse_t), intent(inout) :: this ! This :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` - type(string_t), intent(in) :: name ! The name of a grid, see :ref:`configuration-grids` for grid names - type(string_t), intent(in) :: units ! The units of the grid - class(grid_t), pointer :: a_grid_ptr ! The :f:type:`~tuvx_grid/grid_t` which matches the name passed in + class(grid_warehouse_t), intent(in) :: this ! This :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` + type(string_t), intent(in) :: name ! The name of a grid, see :ref:`configuration-grids` for grid names + type(string_t), intent(in) :: units ! The units of the grid + class(grid_t), pointer :: a_grid_ptr ! The :f:type:`~tuvx_grid/grid_t` which matches the name passed in a_grid_ptr => this%get_grid_char( name%to_char( ), units%to_char( ) ) @@ -169,9 +169,9 @@ function get_grid_ptr( this, ptr ) result( grid ) use musica_assert, only : assert_msg use tuvx_grid, only : grid_t - class(grid_warehouse_t), intent(inout) :: this ! This grid warehouse - type(grid_warehouse_ptr), intent(in) :: ptr ! Pointer to a grid in the warehouse - class(grid_t), pointer :: grid + class(grid_warehouse_t), intent(in) :: this ! This grid warehouse + type(grid_warehouse_ptr), intent(in) :: ptr ! Pointer to a grid in the warehouse + class(grid_t), pointer :: grid call assert_msg( 870082797, ptr%index_ > 0, "Invalid grid pointer" ) allocate( grid, source = this%grids_( ptr%index_ )%val_ ) diff --git a/src/heating_rates.F90 b/src/heating_rates.F90 new file mode 100644 index 00000000..5ee76c16 --- /dev/null +++ b/src/heating_rates.F90 @@ -0,0 +1,584 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_heating_rates + ! The chemical potential heating rates type heating_rates_t and related functions + + use musica_assert, only : assert, assert_msg + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_iterator, only : iterator_t + use musica_mpi, only : musica_mpi_pack, musica_mpi_pack_size, musica_mpi_unpack + use musica_string, only : string_t + use tuvx_constants, only : hc + use tuvx_cross_section, only : cross_section_ptr + use tuvx_cross_section_factory, only : cross_section_allocate, cross_section_builder, cross_section_type_name + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_ptr, grid_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_ptr, profile_warehouse_t + use tuvx_quantum_yield, only : quantum_yield_ptr + use tuvx_quantum_yield_factory, only : quantum_yield_allocate, quantum_yield_builder, quantum_yield_type_name + use tuvx_solver, only : radiation_field_t + use tuvx_spherical_geometry, only : spherical_geometry_t + + implicit none + + private + public :: heating_rates_t + + type :: heating_parameters_t + ! Heating parameters for a single photolyzing species + type(string_t) :: label_ ! label for the heating rate + type(cross_section_ptr) :: cross_section_ ! cross section + type(quantum_yield_ptr) :: quantum_yield_ ! quantum yield + real(kind=dk) :: scaling_factor_ ! scaling factor for the heating rate + real(kind=dk), allocatable :: energy_(:) ! wavelength resolved bond-dissociation energy [J] + contains + !> Returns the size of a character buffer needed to pack the heating parameters + procedure :: pack_size => heating_parameters_pack_size + !> Packs the heating parameters into a character buffer + procedure :: mpi_pack => heating_parameters_mpi_pack + !> Unpacks the heating parameters from a character buffer + procedure :: mpi_unpack => heating_parameters_mpi_unpack + end type heating_parameters_t + + !> heating_parameters_t constructor + interface heating_parameters_t + module procedure :: heating_parameters_constructor + end interface heating_parameters_t + + type, public :: heating_rates_t + type(heating_parameters_t), allocatable :: heating_parameters_(:) ! heating parameters for each photolyzing species + type(grid_warehouse_ptr) :: height_grid_ ! height grid + type(grid_warehouse_ptr) :: wavelength_grid_ ! wavelength grid + type(profile_warehouse_ptr) :: etfl_profile_ ! Extraterrestrial flux profile + type(profile_warehouse_ptr) :: air_profile_ ! Air profile + integer, allocatable :: o2_rate_indices_(:) ! indices in the heating rates array where O2 + ! corrections to the cross-section in the + ! Lyman-Alpha and Schumann-Runge bands should + ! be applied + contains + !> Calulates the heating rates + procedure :: get + !> Returns the names of each photolysis reaction with a heating rate + procedure :: labels + !> Returns the number of heating rates + procedure :: size => get_number + !> Returns the size of a character buffer needed to pack the heating rates + procedure :: pack_size + !> Packs the heating rates into a character buffer + procedure :: mpi_pack + !> Unpacks the heating rates from a character buffer + procedure :: mpi_unpack + !> Cleans up memory + final :: destructor + end type heating_rates_t + + !> heating_rates_t constructor + interface heating_rates_t + module procedure :: constructor + end interface heating_rates_t + +contains +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> heating_rates_t constructor + function constructor( config, grids, profiles ) result( this ) + + + !> Heating rate collection + type(heating_rates_t), pointer :: this + !> Configuration + type(config_t), intent(inout) :: config + !> Grids + type(grid_warehouse_t), intent(inout) :: grids + !> Profiles + type(profile_warehouse_t), intent(inout) :: profiles + + character(len=*), parameter :: Iam = 'heating rates constructor' + type(config_t) :: reaction_set, reaction_config, heating_config + class(iterator_t), pointer :: iter + type(string_t) :: label + type(string_t) :: required_keys(1), optional_keys(1) + logical :: found, do_apply_bands + integer :: n_hr, i_hr, n_O2, i_O2 + + required_keys(1) = "reactions" + optional_keys(1) = "enable diagnostics" + + call assert_msg( 310567326, & + config%validate( required_keys, optional_keys ), & + "Invalid configuration for heating rates" ) + + allocate( this ) + this%height_grid_ = grids%get_ptr( "height", "km" ) + this%wavelength_grid_ = grids%get_ptr( "wavelength", "nm" ) + this%etfl_profile_ = profiles%get_ptr( "extraterrestrial flux", & + "photon cm-2 s-1" ) + this%air_profile_ = profiles%get_ptr( "air", "molecule cm-3" ) + + ! iterate over photolysis reactions looking for those with + ! heating rate parameters + allocate( this%o2_rate_indices_( 0 ) ) + call config%get( "reactions", reaction_set, Iam ) + iter => reaction_set%get_iterator( ) + n_hr = 0 + n_O2 = 0 + do while( iter%next( ) ) + call reaction_set%get( iter, reaction_config, Iam ) + call reaction_config%get( "heating", heating_config, Iam, found = found ) + if( found ) then + n_hr = n_hr + 1 + call reaction_config%get( "apply O2 bands", do_apply_bands, Iam, & + default = .false. ) + if( do_apply_bands ) n_O2 = n_O2 + 1 + end if + end do + allocate( this%heating_parameters_( n_hr ) ) + call iter%reset( ) + i_hr = 0 + i_O2 = 0 + do while( iter%next( ) ) + call reaction_set%get( iter, reaction_config, Iam ) + call reaction_config%get( "heating", heating_config, Iam, found = found ) + if( found ) then + i_hr = i_hr + 1 + call reaction_config%get( "name", label, Iam ) + this%heating_parameters_( i_hr ) = & + heating_parameters_constructor( reaction_config, grids, profiles ) + call reaction_config%get( "apply O2 bands", do_apply_bands, Iam, & + default = .false. ) + if( do_apply_bands ) then + i_O2 = i_O2 + 1 + this%o2_rate_indices_( i_O2 ) = i_hr + end if + end if + end do + call assert( 357615745, i_hr .eq. n_hr ) + call assert( 336635308, i_O2 .eq. n_O2 ) + deallocate( iter ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> heating_parameters_t constructor + function heating_parameters_constructor( config, grids, profiles ) & + result( this ) + + + !> Heating parameters for a single photolyzing species + type(heating_parameters_t) :: this + !> Configuration for the photolysis reaction + type(config_t), intent(inout) :: config + !> Grids + type(grid_warehouse_t), intent(inout) :: grids + !> Profiles + type(profile_warehouse_t), intent(inout) :: profiles + + character(len=*), parameter :: Iam = 'heating parameters constructor' + type(config_t) :: heating_config, cs_config, qy_config + class(grid_t), pointer :: wavelengths + real(kind=dk) :: energy_term + type(string_t) :: required_keys(4), optional_keys(1) + type(string_t) :: heating_required_keys(1), heating_optional_keys(0) + + required_keys(1) = "name" + required_keys(2) = "cross section" + required_keys(3) = "quantum yield" + required_keys(4) = "heating" + optional_keys(1) = "scaling factor" + + call assert_msg( 316144353, & + config%validate( required_keys, optional_keys ), & + "Invalid configuration for photolysis reactions with "// & + "heating parameters" ) + + call config%get( "heating", heating_config, Iam ) + + heating_required_keys(1) = "energy term" + + call assert_msg( 316144354, & + heating_config%validate( heating_required_keys, & + heating_optional_keys ), & + "Invalid configuration for heating parameters" ) + + call config%get( "name", this%label_, Iam ) + call config%get( "cross section", cs_config, Iam ) + this%cross_section_%val_ => cross_section_builder( cs_config, grids, & + profiles ) + call config%get( "quantum yield", qy_config, Iam ) + this%quantum_yield_%val_ => quantum_yield_builder( qy_config, grids, & + profiles ) + call config%get( "scaling factor", this%scaling_factor_, Iam, & + default = 1.0_dk ) + call heating_config%get( "energy term", energy_term, Iam ) + wavelengths => grids%get_grid( "wavelength", "nm" ) + allocate( this%energy_( wavelengths%ncells_ ) ) + this%energy_(:) = & + max( 0.0_dk, hc * 1.0e9_dk * ( energy_term - wavelengths%mid_(:) ) / & + ( energy_term * wavelengths%mid_(:) ) ) + deallocate( wavelengths ) + + end function heating_parameters_constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> calculate heating rates + subroutine get( this, la_srb, spherical_geometry, grids, profiles, & + radiation_field, heating_rates ) + + + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + !> Lyman Alpha and Schumann-Runge bands + class(la_sr_bands_t), intent(inout) :: la_srb + !> Spherical geometry + class(spherical_geometry_t), intent(inout) :: spherical_geometry + !> Grids + class(grid_warehouse_t), intent(inout) :: grids + !> Profiles + class(profile_warehouse_t), intent(inout) :: profiles + !> Radiation field + class(radiation_field_t), intent(in) :: radiation_field + !> Heating rates (vertical interface, reaction) [J s-1] + real(kind=dk), intent(inout) :: heating_rates(:,:) + + character(len=*), parameter :: Iam = 'heating rates get' + class(grid_t), pointer :: heights, wavelengths + class(profile_t), pointer :: etfl, air + real(kind=dk), allocatable :: actinic_flux(:,:), xsqy(:,:) + real(kind=dk), allocatable :: cross_section(:,:), quantum_yield(:,:) + real(kind=dk), allocatable :: air_vertical_column(:), air_slant_column(:) + integer :: i_rate, n_rates, i_height + + heights => grids%get_grid( this%height_grid_ ) + wavelengths => grids%get_grid( this%wavelength_grid_ ) + etfl => profiles%get_profile( this%etfl_profile_ ) + air => profiles%get_profile( this%air_profile_ ) + + n_rates = size( this%heating_parameters_ ) + call assert( 966855732, & + size( heating_rates, 1 ) .eq. heights%ncells_ + 1 .and. & + size( heating_rates, 2 ) .eq. n_rates ) + + actinic_flux = transpose( radiation_field%fdr_ + radiation_field%fup_ + & + radiation_field%fdn_ ) + do i_height = 1, heights%ncells_ + 1 + actinic_flux( :, i_height ) = actinic_flux( :, i_height ) * etfl%mid_val_ + end do + where( actinic_flux < 0.0_dk ) + actinic_flux = 0.0_dk + end where + + do i_rate = 1, n_rates + associate( params => this%heating_parameters_( i_rate ) ) + cross_section = params%cross_section_%val_%calculate( grids, profiles ) + quantum_yield = params%quantum_yield_%val_%calculate( grids, profiles ) + + ! O2 photolysis can have special la & srb band handling + if( any( this%o2_rate_indices_ == i_rate ) ) then + allocate( air_vertical_column( air%ncells_ ), & + air_slant_column( air%ncells_ + 1 ) ) + call spherical_geometry%air_mass( air%exo_layer_dens_, & + air_vertical_column, & + air_slant_column ) + call la_srb%cross_section( grids, profiles, air_vertical_column, & + air_slant_column, cross_section, & + spherical_geometry ) + deallocate( air_vertical_column, air_slant_column ) + end if + + xsqy = transpose( cross_section * quantum_yield ) + do i_height = 1, heights%ncells_ + 1 + heating_rates( i_height, i_rate ) = & + dot_product( actinic_flux( :, i_height ), & + params%energy_(:) * xsqy( :, i_height ) ) * & + params%scaling_factor_ + end do + end associate + end do + + deallocate( heights ) + deallocate( wavelengths ) + deallocate( etfl ) + deallocate( air ) + + end subroutine get + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the names of each photolysis reaction with a heating rate + function labels( this ) + + !> Photolysis reaction labels + type(string_t), allocatable :: labels(:) + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + + allocate( labels( size( this%heating_parameters_ ) ) ) + labels(:) = this%heating_parameters_(:)%label_ + + end function labels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of heating rates + function get_number( this ) result( n_rates ) + + !> Number of heating rates + integer :: n_rates + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + + n_rates = 0 + if( allocated( this%heating_parameters_ ) ) then + n_rates = size( this%heating_parameters_ ) + end if + + end function get_number + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer needed to pack the heating rates + function pack_size( this, comm ) + + + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + !> Size of the character buffer + integer :: pack_size + +#ifdef MUSICA_USE_MPI + integer :: i_elem + + pack_size = musica_mpi_pack_size( allocated( this%heating_parameters_ ), & + comm ) + if( allocated( this%heating_parameters_ ) ) then + pack_size = pack_size + & + musica_mpi_pack_size( size( this%heating_parameters_ ), comm ) + do i_elem = 1, size( this%heating_parameters_ ) + pack_size = pack_size + & + this%heating_parameters_( i_elem )%pack_size( comm ) + end do + end if + pack_size = pack_size + & + this%height_grid_%pack_size( comm ) + & + this%wavelength_grid_%pack_size( comm ) + & + this%etfl_profile_%pack_size( comm ) + & + this%air_profile_%pack_size( comm ) + & + musica_mpi_pack_size( this%o2_rate_indices_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the heating rates into a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + !> Heating rate collection + class(heating_rates_t), intent(in) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_elem + + prev_pos = position + call musica_mpi_pack( buffer, position, & + allocated( this%heating_parameters_ ), comm ) + if( allocated( this%heating_parameters_ ) ) then + call musica_mpi_pack( buffer, position, & + size( this%heating_parameters_ ), comm ) + do i_elem = 1, size( this%heating_parameters_ ) + call this%heating_parameters_( i_elem )%mpi_pack( buffer, position, & + comm ) + end do + end if + call this%height_grid_%mpi_pack( buffer, position, comm ) + call this%wavelength_grid_%mpi_pack( buffer, position, comm ) + call this%etfl_profile_%mpi_pack( buffer, position, comm ) + call this%air_profile_%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%o2_rate_indices_, comm ) + call assert( 247051769, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks the heating rates from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + !> Heating rate collection + class(heating_rates_t), intent(out) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos, i_elem, n_elems + logical :: is_allocated + + prev_pos = position + call musica_mpi_unpack( buffer, position, is_allocated, comm ) + if( is_allocated ) then + call musica_mpi_unpack( buffer, position, n_elems, comm ) + allocate( this%heating_parameters_( n_elems ) ) + do i_elem = 1, n_elems + call this%heating_parameters_( i_elem )%mpi_unpack( buffer, position, & + comm ) + end do + end if + call this%height_grid_%mpi_unpack( buffer, position, comm ) + call this%wavelength_grid_%mpi_unpack( buffer, position, comm ) + call this%etfl_profile_%mpi_unpack( buffer, position, comm ) + call this%air_profile_%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%o2_rate_indices_, comm ) + call assert( 631316749, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the size of a character buffer needed to pack the heating + !! parameters + function heating_parameters_pack_size( this, comm ) result( pack_size ) + + !> Heating parameters for a single photolyzing species + class(heating_parameters_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + !> Size of the character buffer + integer :: pack_size + +#ifdef MUSICA_USE_MPI + type(string_t) :: cs_type_name, qy_type_name + + cs_type_name = cross_section_type_name( this%cross_section_%val_ ) + qy_type_name = quantum_yield_type_name( this%quantum_yield_%val_ ) + pack_size = this%label_%pack_size( comm ) + & + cs_type_name%pack_size( comm ) + & + this%cross_section_%val_%pack_size( comm ) + & + qy_type_name%pack_size( comm ) + & + this%quantum_yield_%val_%pack_size( comm ) + & + musica_mpi_pack_size( this%scaling_factor_, comm ) + & + musica_mpi_pack_size( this%energy_, comm ) +#else + pack_size = 0 +#endif + + end function heating_parameters_pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the heating parameters into a character buffer + subroutine heating_parameters_mpi_pack( this, buffer, position, comm ) + + !> Heating parameters for a single photolyzing species + class(heating_parameters_t), intent(in) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + type(string_t) :: cs_type_name, qy_type_name + + prev_pos = position + cs_type_name = cross_section_type_name( this%cross_section_%val_ ) + qy_type_name = quantum_yield_type_name( this%quantum_yield_%val_ ) + call this%label_%mpi_pack( buffer, position, comm ) + call cs_type_name%mpi_pack( buffer, position, comm ) + call this%cross_section_%val_%mpi_pack( buffer, position, comm ) + call qy_type_name%mpi_pack( buffer, position, comm ) + call this%quantum_yield_%val_%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%scaling_factor_, comm ) + call musica_mpi_pack( buffer, position, this%energy_, comm ) + call assert( 243240701, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine heating_parameters_mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks the heating parameters from a character buffer + subroutine heating_parameters_mpi_unpack( this, buffer, position, comm ) + + !> Heating parameters for a single photolyzing species + class(heating_parameters_t), intent(out) :: this + !> Character buffer + character, intent(inout) :: buffer(:) + !> Position in the buffer + integer, intent(inout) :: position + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + integer :: prev_pos + type(string_t) :: cs_type_name, qy_type_name + + prev_pos = position + call this%label_%mpi_unpack( buffer, position, comm ) + call cs_type_name%mpi_unpack( buffer, position, comm ) + this%cross_section_%val_ => cross_section_allocate( cs_type_name ) + call this%cross_section_%val_%mpi_unpack( buffer, position, comm ) + call qy_type_name%mpi_unpack( buffer, position, comm ) + this%quantum_yield_%val_ => quantum_yield_allocate( qy_type_name ) + call this%quantum_yield_%val_%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%scaling_factor_, comm ) + call musica_mpi_unpack( buffer, position, this%energy_, comm ) + call assert( 243240702, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine heating_parameters_mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Cleans up memory + elemental subroutine destructor( this ) + + !> Heating rates + type(heating_rates_t), intent(inout) :: this + + integer :: i_rate + + if( allocated( this%heating_parameters_ ) ) then + do i_rate = 1, size( this%heating_parameters_ ) + associate( params => this%heating_parameters_( i_rate ) ) + if( associated( params%cross_section_%val_ ) ) then + deallocate( params%cross_section_%val_ ) + nullify( params%cross_section_%val_ ) + end if + if( associated( params%quantum_yield_%val_ ) ) then + deallocate( params%quantum_yield_%val_ ) + nullify( params%quantum_yield_%val_ ) + end if + end associate + end do + deallocate( this%heating_parameters_ ) + end if + + end subroutine destructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_heating_rates \ No newline at end of file diff --git a/src/output.F90 b/src/output.F90 index faf041a7..e2561a93 100644 --- a/src/output.F90 +++ b/src/output.F90 @@ -23,9 +23,11 @@ module tuvx_output class(io_t), pointer :: file_ => null( ) logical :: do_photo_ = .false. logical :: do_dose_ = .false. + logical :: do_heating_ = .false. logical :: do_radiation_ = .false. type(string_t), allocatable :: photo_labels_(:) type(string_t), allocatable :: dose_labels_(:) + type(string_t), allocatable :: heating_labels_(:) type(string_t), allocatable :: photo_cross_sections_(:) type(string_t), allocatable :: photo_quantum_yields_(:) contains @@ -58,13 +60,14 @@ function constructor( config, core ) result( this ) character(len=*), parameter :: Iam = "output writer" integer :: stat type(string_t) :: file_path - type(string_t) :: required_keys(2), optional_keys(3) + type(string_t) :: required_keys(2), optional_keys(4) type(config_t) :: tuvx_config, rad_config required_keys(1) = "file path" required_keys(2) = "tuv-x configuration" optional_keys(1) = "include photolysis" optional_keys(2) = "include dose rates" + optional_keys(3) = "include heating rates" call assert_msg( 215370625, & config%validate( required_keys, optional_keys ), & @@ -93,6 +96,10 @@ function constructor( config, core ) result( this ) default = .false. ) if( this%do_dose_ ) this%dose_labels_ = core%dose_rate_labels( ) + call config%get( "include heating rates", this%do_heating_, Iam, & + default = .false. ) + if( this%do_heating_ ) this%heating_labels_ = core%heating_rate_labels( ) + ! Add custom diagnostics call config%get( "tuv-x configuration", tuvx_config, Iam ) call this%add_photolysis_diagnostics( tuvx_config ) @@ -106,7 +113,7 @@ end function constructor !> Outputs results subroutine output( this, step, core, photolysis_rate_constants, dose_rates, & - time, solar_zenith_angle, earth_sun_distance ) + heating_rates, time, solar_zenith_angle, earth_sun_distance ) use musica_assert, only : assert_msg use musica_constants, only : dk => musica_dk @@ -124,6 +131,8 @@ subroutine output( this, step, core, photolysis_rate_constants, dose_rates, & real(dk), optional, intent(in) :: photolysis_rate_constants(:,:) !> Dose rates (vertical level, dose rate type) real(dk), optional, intent(in) :: dose_rates(:,:) + !> Heating rates (vertical level, reaction) + real(dk), optional, intent(in) :: heating_rates(:,:) !> Time [hours] real(dk), optional, intent(in) :: time !> Solar zenith angle [degrees] @@ -209,6 +218,18 @@ subroutine output( this, step, core, photolysis_rate_constants, dose_rates, & end do end if + if( present( heating_rates ) ) then + call assert_msg( 935671025, this%do_heating_, "Heating rates are not " & + //"configured to be output" ) + dim_names(1) = "vertical_level" + units = "J s-1" + do i_rate = 1, size( this%heating_labels_ ) + var_name = clean_string( this%heating_labels_( i_rate ) ) + call this%file_%append( var_name, units, append_dim, step, & + dim_names(1), heating_rates( :, i_rate ), Iam ) + end do + end if + dim_names(1) = "vertical_level" dim_names(2) = "wavelength" units = "cm2 molecule-1" diff --git a/src/photolysis_rates.F90 b/src/photolysis_rates.F90 index 682ba14d..cdfbfa8f 100644 --- a/src/photolysis_rates.F90 +++ b/src/photolysis_rates.F90 @@ -178,7 +178,7 @@ subroutine add( this, config, grid_warehouse, profile_warehouse ) real(dk) :: scale_factor type(string_t) :: reaction_key logical :: do_apply_bands, found - type(string_t) :: required_keys(3), optional_keys(1) + type(string_t) :: required_keys(3), optional_keys(2) type(cross_section_ptr), allocatable :: temp_cs(:) type(quantum_yield_ptr), allocatable :: temp_qy(:) type(string_t), allocatable :: temp_handle(:) @@ -190,6 +190,7 @@ subroutine add( this, config, grid_warehouse, profile_warehouse ) required_keys(2) = "cross section" required_keys(3) = "quantum yield" optional_keys(1) = "scaling factor" + optional_keys(2) = "heating" call assert_msg( 780273355, & config%validate( required_keys, optional_keys ), & @@ -294,7 +295,7 @@ subroutine get( this, la_srb, spherical_geometry, grid_warehouse, & !> Local variables character(len=*), parameter :: Iam = "photolysis rates calculator" integer :: vertNdx, rateNdx, nRates - real(dk), allocatable :: airVcol(:), airScol(:) + real(dk), allocatable :: air_vertical_column(:), air_slant_column(:) real(dk), allocatable :: xsqyWrk(:) real(dk), allocatable :: cross_section(:,:) real(dk), allocatable :: quantum_yield(:,:) @@ -343,13 +344,15 @@ subroutine get( this, la_srb, spherical_geometry, grid_warehouse, & ! O2 photolysis can have special la & srb band handling if( any( this%o2_rate_indices_ == rateNdx ) ) then airProfile => profile_warehouse%get_profile( this%air_profile_ ) - allocate( airVcol( airProfile%ncells_ ), & - airScol( airProfile%ncells_ + 1 ) ) - call spherical_geometry%air_mass( airProfile%exo_layer_dens_, airVcol,& - airScol ) - call la_srb%cross_section( grid_warehouse, profile_warehouse, airVcol,& - airScol, cross_section, spherical_geometry ) - deallocate( airVcol, airScol ) + allocate( air_vertical_column( airProfile%ncells_ ), & + air_slant_column( airProfile%ncells_ + 1 ) ) + call spherical_geometry%air_mass( airProfile%exo_layer_dens_, & + air_vertical_column, & + air_slant_column ) + call la_srb%cross_section( grid_warehouse, profile_warehouse, & + air_vertical_column, air_slant_column, & + cross_section, spherical_geometry ) + deallocate( air_vertical_column, air_slant_column ) deallocate( airProfile ) endif @@ -370,7 +373,8 @@ subroutine get( this, la_srb, spherical_geometry, grid_warehouse, & xsqy = transpose( cross_section * quantum_yield ) do vertNdx = 1, zGrid%ncells_ + 1 photolysis_rates( vertNdx, rateNdx ) = & - dot_product( actinicFlux( :, vertNdx ), xsqy( :, vertNdx ) ) + dot_product( actinicFlux( :, vertNdx ), xsqy( :, vertNdx ) ) * & + this%scaling_factors_( rateNdx ) enddo if( allocated( cross_section ) ) deallocate( cross_section ) if( allocated( quantum_yield ) ) deallocate( quantum_yield ) diff --git a/src/quantum_yield.F90 b/src/quantum_yield.F90 index 2f388e39..6a316e96 100644 --- a/src/quantum_yield.F90 +++ b/src/quantum_yield.F90 @@ -226,12 +226,10 @@ subroutine base_constructor( this, config, grid_warehouse, & else has_netcdf_file ! check for quantum yield constant call config%get( 'constant value', quantum_yield_constant, Iam, & - found = found ) - if( found ) then - allocate( this%quantum_yield_parms(1) ) - allocate( this%quantum_yield_parms(1)%array( lambdaGrid%ncells_, 1 ) ) - this%quantum_yield_parms(1)%array(:,1) = quantum_yield_constant - endif + default = 0.0_dk ) + allocate( this%quantum_yield_parms(1) ) + allocate( this%quantum_yield_parms(1)%array( lambdaGrid%ncells_, 1 ) ) + this%quantum_yield_parms(1)%array(:,1) = quantum_yield_constant endif has_netcdf_file ! get values to overlay for specific bands @@ -601,16 +599,43 @@ function override_constructor( config, wavelengths ) result( this ) character(len=*), parameter :: my_name = & "quantum yield band override constructor" type(string_t) :: type_name - type(string_t) :: required_keys(2), optional_keys(0) + type(string_t) :: required_keys(2), optional_keys(2) + real(kind=dk) :: min_wl, max_wl + integer :: i_wl required_keys(1) = "band" required_keys(2) = "value" + optional_keys(1) = "minimum wavelength" + optional_keys(2) = "maximum wavelength" call assert_msg( 257437273, & config%validate( required_keys, optional_keys ), & "Bad configuration for quantum yield band averride" ) call config%get( "band", type_name, my_name ) - this%min_wavelength_index_ = get_band_min_index( type_name, wavelengths ) - this%max_wavelength_index_ = get_band_max_index( type_name, wavelengths ) + if( type_name == "range" ) then + call config%get( "minimum wavelength", min_wl, my_name, & + default = 0.0_dk ) + call config%get( "maximum wavelength", max_wl, my_name, & + default = huge(1.0_dk) ) + call assert_msg( 976365464, & + min_wl <= wavelengths%mid_( wavelengths%ncells_ ), & + "Minimum wavelength is out-of-bounds for quantum yield") + call assert_msg( 166625638, & + max_wl >= wavelengths%mid_( 1 ), & + "Maximum wavelength is out-of-bounds for quantum yield") + do i_wl = 1, wavelengths%ncells_ + if( wavelengths%mid_( i_wl ) < min_wl ) then + this%min_wavelength_index_ = i_wl + 1 + end if + if( wavelengths%mid_( i_wl ) <= max_wl ) then + this%max_wavelength_index_ = i_wl + else + exit + end if + end do + else + this%min_wavelength_index_ = get_band_min_index( type_name, wavelengths ) + this%max_wavelength_index_ = get_band_max_index( type_name, wavelengths ) + end if call config%get( "value", this%value_, my_name ) end function override_constructor diff --git a/src/quantum_yield_factory.F90 b/src/quantum_yield_factory.F90 index 240bcc6d..466c99a2 100644 --- a/src/quantum_yield_factory.F90 +++ b/src/quantum_yield_factory.F90 @@ -29,6 +29,8 @@ module tuvx_quantum_yield_factory use tuvx_quantum_yield_clono2_cl_no3,only : quantum_yield_clono2_cl_no3_t use tuvx_quantum_yield_clono2_clo_no2, & only : quantum_yield_clono2_clo_no2_t + use tuvx_quantum_yield_h2so4_mills, only : quantum_yield_h2so4_mills_t + use tuvx_quantum_yield_taylor_series, only : quantum_yield_taylor_series_t implicit none @@ -125,6 +127,13 @@ function quantum_yield_builder( config, grid_warehouse, profile_warehouse ) & quantum_yield => quantum_yield_clono2_clo_no2_t( config, & grid_warehouse, & profile_warehouse ) + case( 'H2SO4 Mills' ) + quantum_yield => quantum_yield_h2so4_mills_t( config, grid_warehouse, & + profile_warehouse ) + case( 'Taylor series' ) + quantum_yield => quantum_yield_taylor_series_t( config, & + grid_warehouse, & + profile_warehouse ) case default call die_msg( 450768214, "Invalid quantum yield type: '"// & quantum_yield_type%to_char( )//"'" ) @@ -182,6 +191,10 @@ type(string_t) function quantum_yield_type_name( quantum_yield ) & name = "quantum_yield_clono2_cl_no3_t" type is( quantum_yield_clono2_clo_no2_t ) name = "quantum_yield_clono2_clo_no2_t" + type is( quantum_yield_h2so4_mills_t ) + name = "quantum_yield_h2so4_mills_t" + type is( quantum_yield_taylor_series_t ) + name = "quantum_yield_taylor_series_t" class default call die( 853572483 ) end select @@ -238,6 +251,10 @@ function quantum_yield_allocate( type_name ) result( quantum_yield ) allocate( quantum_yield_clono2_cl_no3_t :: quantum_yield ) case( 'quantum_yield_clono2_clo_no2_t' ) allocate( quantum_yield_clono2_clo_no2_t :: quantum_yield ) + case( 'quantum_yield_h2so4_mills_t' ) + allocate( quantum_yield_h2so4_mills_t :: quantum_yield ) + case( 'quantum_yield_taylor_series_t' ) + allocate( quantum_yield_taylor_series_t :: quantum_yield ) case default call die_msg( 894617177, "Invalid quantum yield type: '"//type_name//"'" ) end select diff --git a/src/quantum_yields/CMakeLists.txt b/src/quantum_yields/CMakeLists.txt index fa93b668..1b089e5f 100644 --- a/src/quantum_yields/CMakeLists.txt +++ b/src/quantum_yields/CMakeLists.txt @@ -15,11 +15,13 @@ target_sources(tuvx_object clono2-clo_no2.F90 clono2-cl_no3.F90 ho2-oh_o.F90 + h2so4_mills.F90 mvk.F90 no2_tint.F90 no3_aq.F90 o3-o2_o1d.F90 o3-o2_o3p.F90 + taylor_series.F90 tint.F90 ) diff --git a/src/quantum_yields/acetone-ch3co_ch3.F90 b/src/quantum_yields/acetone-ch3co_ch3.F90 index 9cfd92f5..7f4d8bb7 100644 --- a/src/quantum_yields/acetone-ch3co_ch3.F90 +++ b/src/quantum_yields/acetone-ch3co_ch3.F90 @@ -6,6 +6,7 @@ module tuvx_quantum_yield_ch3coch3_ch3co_ch3 ! Including musica_config at the module level to avoid an ICE ! with Intel 2022.1 compiler + use musica_constants, only : dk => musica_dk use musica_config, only : config_t use tuvx_quantum_yield, only : quantum_yield_t, base_constructor @@ -16,9 +17,21 @@ module tuvx_quantum_yield_ch3coch3_ch3co_ch3 type, extends(quantum_yield_t) :: quantum_yield_ch3coch3_ch3co_ch3_t ! Calculator for acetone quantum_yield + logical :: do_CO_ = .false. + logical :: do_CH3CO_ = .false. + real(kind=dk) :: low_wavelength_value_ + real(kind=dk) :: high_wavelength_value_ + real(kind=dk) :: minimum_temperature_ + real(kind=dk) :: maximum_temperature_ contains !> Initialize the quantum_yield procedure :: calculate => run + ! 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 end type quantum_yield_ch3coch3_ch3co_ch3_t interface quantum_yield_ch3coch3_ch3co_ch3_t @@ -33,17 +46,54 @@ function constructor( config, grid_warehouse, profile_warehouse ) & result( this ) ! Build the quantum yield + use musica_assert, only : assert_msg, die_msg + use musica_string, only : string_t use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_profile_warehouse, only : profile_warehouse_t - class(quantum_yield_t), pointer :: this ! This :f:type:`~tuvx_quantum_yield/quantum_yield_t` calculator - type(config_t), intent(inout) :: config ! Quantum yield configuration data - type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` - type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` - - allocate ( quantum_yield_ch3coch3_ch3co_ch3_t :: this ) - + type(quantum_yield_ch3coch3_ch3co_ch3_t), pointer :: this ! This :f:type:`~tuvx_quantum_yield/quantum_yield_t` calculator + type(config_t), intent(inout) :: config ! Quantum yield configuration data + type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` + type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` + + character(len=*), parameter :: my_name = & + "Acetone quantum yield constructor" + type(string_t) :: required_keys(1), optional_keys(6), branch + + required_keys(1) = "type" + optional_keys(1) = "name" + optional_keys(2) = "low wavelength value" + optional_keys(3) = "high wavelength value" + optional_keys(4) = "minimum temperature" + optional_keys(5) = "maximum temperature" + optional_keys(6) = "branch" + call assert_msg( 253342443, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for acetone quantum yield." ) + allocate ( this ) call base_constructor( this, config, grid_warehouse, profile_warehouse ) + call config%get( "low wavelength value", this%low_wavelength_value_, & + my_name, default = 0.95_dk ) + call config%get( "high wavelength value", this%high_wavelength_value_, & + my_name, default = 0.0_dk ) + call config%get( "minimum temperature", this%minimum_temperature_, & + my_name, default = 0.0_dk ) + call config%get( "maximum temperature", this%maximum_temperature_, & + my_name, default = huge( 1.0_dk ) ) + call config%get( "branch", branch, my_name, default = "CH3CO" ) + if( branch .eq. "CO" ) then + this%do_CO_ = .true. + this%do_CH3CO_ = .false. + else if( branch .eq. "CH3CO" ) then + this%do_CO_ = .false. + this%do_CH3CO_ = .true. + else if( branch .eq. "CO+CH3CO" ) then + this%do_CO_ = .true. + this%do_CH3CO_ = .true. + else + call die_msg( 534162111, "Invalid branch for acetone quantum yield: '"//& + branch//"'." ) + end if end function constructor @@ -62,7 +112,6 @@ function run( this, grid_warehouse, profile_warehouse ) & ! Res. Lett., 31, L06111, `doi:10.1029/2003GL018793. ! `_ - use musica_constants, only : dk => musica_dk use tuvx_grid, only : grid_t use tuvx_grid_warehouse, only : grid_warehouse_t use tuvx_profile, only : profile_t @@ -95,7 +144,7 @@ function run( this, grid_warehouse, profile_warehouse ) & real(dk) :: c3 real(dk) :: cA0, cA1, cA2, cA3, cA4 real(dk) :: dumexp - real(dk) :: fco, fac + real(dk) :: fco, fac, qy zGrid => grid_warehouse%get_grid( this%height_grid_ ) lambdaGrid => grid_warehouse%get_grid( this%wavelength_grid_ ) @@ -112,15 +161,17 @@ function run( this, grid_warehouse, profile_warehouse ) & vert_loop: & do vertNdx = 1, nzdim - Tadj = modelTemp( vertNdx ) / 295._dk + Tadj = max( this%minimum_temperature_, & + min( this%maximum_temperature_, modelTemp( vertNdx ) ) ) & + / 295._dk M = modelDens( vertNdx ) lambda_loop: & do lambdaNdx = 1, lambdaGrid%ncells_ w = lambdaGrid%mid_( lambdaNdx ) if( w < 279._dk ) then - fac = 0.95_dk + qy = this%low_wavelength_value_ elseif( w > 327._dk ) then - fac = rZERO + qy = this%high_wavelength_value_ else ! CO (carbon monoxide) quantum yields: a0 = 0.350_dk * Tadj**( -1.28_dk ) @@ -158,8 +209,11 @@ function run( this, grid_warehouse, profile_warehouse ) & fac = ( rONE - fco ) * ( rONE + cA3 + cA4 * M ) & / ( ( rONE + cA3 + cA2 * M ) * ( rONE + cA4 * M ) ) endif + qy = 0.0_dk + if( this%do_CO_ ) qy = qy + fco + if( this%do_CH3CO_ ) qy = qy + fac endif - quantum_yield( lambdaNdx, vertNdx ) = fac + quantum_yield( lambdaNdx, vertNdx ) = qy enddo lambda_loop enddo vert_loop @@ -172,6 +226,98 @@ function run( this, grid_warehouse, profile_warehouse ) & end function run +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of bytes required to pack the object onto a buffer + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Quantum yield to be packed + class(quantum_yield_ch3coch3_ch3co_ch3_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%quantum_yield_t%pack_size( comm ) + & + musica_mpi_pack_size( this%do_CO_, comm ) + & + musica_mpi_pack_size( this%do_CH3CO_, comm ) + & + musica_mpi_pack_size( this%low_wavelength_value_, comm ) + & + musica_mpi_pack_size( this%high_wavelength_value_, comm ) + & + musica_mpi_pack_size( this%minimum_temperature_, comm ) + & + musica_mpi_pack_size( this%maximum_temperature_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the quantum yield onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Quantum yield to pack + class(quantum_yield_ch3coch3_ch3co_ch3_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_pos + + prev_pos = position + call this%quantum_yield_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%do_CO_, comm ) + call musica_mpi_pack( buffer, position, this%do_CH3CO_, comm ) + call musica_mpi_pack( buffer, position, this%low_wavelength_value_, comm ) + call musica_mpi_pack( buffer, position, this%high_wavelength_value_, comm ) + call musica_mpi_pack( buffer, position, this%minimum_temperature_, comm ) + call musica_mpi_pack( buffer, position, this%maximum_temperature_, comm ) + call assert( 985830490, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a quantum yield calculator from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> Quantum yield to unpack + class(quantum_yield_ch3coch3_ch3co_ch3_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_pos + + prev_pos = position + call this%quantum_yield_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%do_CO_, comm ) + call musica_mpi_unpack( buffer, position, this%do_CH3CO_, comm ) + call musica_mpi_unpack( buffer, position, this%low_wavelength_value_, comm ) + call musica_mpi_unpack( buffer, position, this%high_wavelength_value_, comm ) + call musica_mpi_unpack( buffer, position, this%minimum_temperature_, comm ) + call musica_mpi_unpack( buffer, position, this%maximum_temperature_, comm ) + call assert( 301844101, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module tuvx_quantum_yield_ch3coch3_ch3co_ch3 diff --git a/src/quantum_yields/h2so4_mills.F90 b/src/quantum_yields/h2so4_mills.F90 new file mode 100644 index 00000000..63538e65 --- /dev/null +++ b/src/quantum_yields/h2so4_mills.F90 @@ -0,0 +1,262 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_quantum_yield_h2so4_mills + ! The temperature and pressure dependent quantum yield calculations + ! used in WACCM simulations + + use musica_constants, only : dk => musica_dk + use tuvx_quantum_yield + + implicit none + + private + public :: quantum_yield_h2so4_mills_t + + !> Quantum yield calculator for H2SO4 + !! + !! See Miller et al. (GRL, 2007) + !! + !! Quantum yields qy_x are based on parameters r_x set in the + !! configuration: + !! + !! lambda = R T / ( 2^(1/2) pi d^2 Na P ) + !! v = ( 8 R T / ( pi MW ) )^(1/2) + !! qy_x = r_x / ( r_x + v / lambda ) + !! + !! where R is the universal gas constant (J mol-1 K-1 ), T is + !! temperature (K), P is pressure (Pa), Na is Avogadro's number (mol-1) + !! and MW is the molecular weight of H2SO4 (kg mol-1), d is the + !! molecular diameter (m), and x corresponds to the wavelength band + !! being parameterized. + type, extends(quantum_yield_t) :: quantum_yield_h2so4_mills_t + !> Indices for wavelengths to update + integer, allocatable :: wavelength_indices_(:) + !> Collision rate [s-1] + real(kind=dk), allocatable :: collision_rate_(:) + !> Molecular diameter [m] + real(kind=dk) :: molecular_diameter_ + !> Molecular weight [kg mol-1] + real(kind=dk) :: molecular_weight_ + contains + !> Calculate the quantum yields + procedure :: calculate + ! 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 + end type quantum_yield_h2so4_mills_t + + interface quantum_yield_h2so4_mills_t + module procedure :: constructor + end interface quantum_yield_h2so4_mills_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructor of H2SO4 quantum yield calculators + function constructor( config, grids, profiles ) result ( this ) + + use musica_assert, only : assert_msg + use musica_config, only : config_t + use musica_string, only : string_t, to_char + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + + class(quantum_yield_h2so4_mills_t), pointer :: this + type(config_t), intent(inout) :: config + type(grid_warehouse_t), intent(inout) :: grids + type(profile_warehouse_t), intent(inout) :: profiles + + character(len=*), parameter :: my_name = "H2SO4 quantum yield constructor" + type(string_t) :: required_keys(5), optional_keys(6) + real(kind=dk), allocatable :: param_wavelengths(:) + type(grid_t), pointer :: wavelengths + integer :: i_param, i_wl + + required_keys(1) = "type" + required_keys(2) = "parameterized wavelengths" + required_keys(3) = "collision interval s" + required_keys(4) = "molecular diameter m" + required_keys(5) = "molecular weight kg mol-1" + optional_keys(1) = "netcdf files" + optional_keys(2) = "lower extrapolation" + optional_keys(3) = "upper extrapolation" + optional_keys(4) = "name" + optional_keys(5) = "constant value" + optional_keys(6) = "override bands" + call assert_msg( 157064056, & + config%validate( required_keys, optional_keys ), & + "Bad configration data format for H2SO4 quantum yield." ) + allocate( this ) + call base_constructor( this, config, grids, profiles ) + + call config%get( "parameterized wavelengths", param_wavelengths, my_name ) + call config%get( "collision interval s", this%collision_rate_, & + my_name ) + this%collision_rate_(:) = 1.0_dk / this%collision_rate_(:) + call config%get( "molecular diameter m", this%molecular_diameter_, & + my_name ) + call config%get( "molecular weight kg mol-1", this%molecular_weight_, & + my_name ) + call assert_msg( 472700337, size( param_wavelengths ) .eq. & + size( this%collision_rate_ ), & + "Size mismatch between parameterized wavelengths and "// & + "collision frequency in H2SO4 quantum yield calculator" ) + wavelengths => grids%get_grid( "wavelength", "nm" ) + allocate( this%wavelength_indices_( size( param_wavelengths ) ) ) + this%wavelength_indices_(:) = 0 + do i_param = 1, size( param_wavelengths ) + do i_wl = 1, wavelengths%ncells_ + if( wavelengths%mid_( i_wl ) .eq. param_wavelengths( i_param ) ) then + this%wavelength_indices_( i_param ) = i_wl + exit + end if + end do + call assert_msg( 170811868, this%wavelength_indices_( i_param ) > 0, & + "Parameterized wavelength in H2SO4 quantum yield "// & + "configuration not on wavelength grid: "// & + trim( to_char( param_wavelengths( i_param ) ) ) ) + end do + deallocate( wavelengths ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Calculates the quantum yield + function calculate( this, grid_warehouse, profile_warehouse ) & + result( quantum_yield ) + + use tuvx_constants, only : gas_constant, Avogadro, pi + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_t + + class(quantum_yield_h2so4_mills_t), intent(in) :: this + type(grid_warehouse_t), intent(inout) :: grid_warehouse + type(profile_warehouse_t), intent(inout) :: profile_warehouse + real(dk), allocatable :: quantum_yield(:,:) + + class(profile_t), pointer :: temperature, air + integer :: i_wl + real(dk) :: lambda, velocity + + quantum_yield = & + this%quantum_yield_t%calculate( grid_warehouse, profile_warehouse ) + temperature => profile_warehouse%get_profile( this%temperature_profile_ ) + air => profile_warehouse%get_profile( this%air_profile_ ) + + ! Overwrite the quantum yields for the parameterized wavelengths + do i_wl = 1, size( this%wavelength_indices_ ) + quantum_yield( :, this%wavelength_indices_( i_wl ) ) = & + this%collision_rate_( i_wl ) / & + ( this%collision_rate_( i_wl ) + & + sqrt( 16.0_dk * gas_constant * temperature%edge_val_(:) & + / ( pi * this%molecular_weight_ ) ) & + * ( pi * this%molecular_diameter_**2 * & + air%edge_val_(:) * 1.0e6_dk ) ) + end do + ! The top layer has quantum yields set to 1.0 + quantum_yield( size( quantum_yield, dim=1 ), & + this%wavelength_indices_(:) ) = 1.0_dk + + deallocate( temperature ) + deallocate( air ) + + end function calculate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Returns the number of bytes required to pack the object onto a buffer + integer function pack_size( this, comm ) + + use musica_mpi, only : musica_mpi_pack_size + + !> Quantum yield to be packed + class(quantum_yield_h2so4_mills_t), intent(in) :: this + !> MPI communicator + integer, intent(in) :: comm + +#ifdef MUSICA_USE_MPI + pack_size = this%quantum_yield_t%pack_size( comm ) + & + musica_mpi_pack_size( this%wavelength_indices_, comm ) + & + musica_mpi_pack_size( this%collision_rate_, comm ) + & + musica_mpi_pack_size( this%molecular_diameter_, comm ) + & + musica_mpi_pack_size( this%molecular_weight_, comm ) +#else + pack_size = 0 +#endif + + end function pack_size + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Packs the quantum yield onto a character buffer + subroutine mpi_pack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_pack + + !> Quantum yield to pack + class(quantum_yield_h2so4_mills_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_pos + + prev_pos = position + call this%quantum_yield_t%mpi_pack( buffer, position, comm ) + call musica_mpi_pack( buffer, position, this%wavelength_indices_, comm ) + call musica_mpi_pack( buffer, position, this%collision_rate_, comm ) + call musica_mpi_pack( buffer, position, this%molecular_diameter_, comm ) + call musica_mpi_pack( buffer, position, this%molecular_weight_, comm ) + call assert( 931898871, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_pack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Unpacks a quantum yield calculator from a character buffer + subroutine mpi_unpack( this, buffer, position, comm ) + + use musica_assert, only : assert + use musica_mpi, only : musica_mpi_unpack + + !> Quantum yield to unpack + class(quantum_yield_h2so4_mills_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_pos + + prev_pos = position + call this%quantum_yield_t%mpi_unpack( buffer, position, comm ) + call musica_mpi_unpack( buffer, position, this%wavelength_indices_, comm ) + call musica_mpi_unpack( buffer, position, this%collision_rate_, comm ) + call musica_mpi_unpack( buffer, position, this%molecular_diameter_, comm ) + call musica_mpi_unpack( buffer, position, this%molecular_weight_, comm ) + call assert( 237836163, position - prev_pos <= this%pack_size( comm ) ) +#endif + + end subroutine mpi_unpack + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_quantum_yield_h2so4_mills \ No newline at end of file diff --git a/src/quantum_yields/taylor_series.F90 b/src/quantum_yields/taylor_series.F90 new file mode 100644 index 00000000..7ed16c68 --- /dev/null +++ b/src/quantum_yields/taylor_series.F90 @@ -0,0 +1,99 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 + +module tuvx_quantum_yield_taylor_series + ! A quantum yield calculator based on a Taylor series + + use musica_config, only : config_t + use tuvx_quantum_yield, only : quantum_yield_t, base_constructor + + implicit none + + private + public :: quantum_yield_taylor_series_t + + type, extends(quantum_yield_t) :: quantum_yield_taylor_series_t + ! Calculator of quantum yields using a Taylor series + contains + end type quantum_yield_taylor_series_t + + interface quantum_yield_taylor_series_t + module procedure :: constructor + end interface quantum_yield_taylor_series_t + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function constructor( config, grid_warehouse, profile_warehouse ) & + result( this ) + ! Constructor + + use musica_assert, only : assert_msg + use musica_constants, only : dk => musica_dk + use musica_string, only : string_t + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + + class(quantum_yield_t), pointer :: this ! This :f:type:`~tuvx_quantum_yield/quantum_yield_t` calculator + type(config_t), intent(inout) :: config ! Quantum yield configuration data + type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` + type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` + + character(len=*), parameter :: my_name = "Taylor-series quantum yield constructor" + type(string_t) :: required_keys(1), optional_keys(9) + real(kind=dk) :: min_wl, max_wl + class(grid_t), pointer :: wavelengths + real(kind=dk), allocatable :: coeff(:) + integer :: i_wl, i_coeff + + required_keys(1) = "coefficients" + optional_keys(1) = "type" + optional_keys(2) = "netcdf files" + optional_keys(3) = "lower extrapolation" + optional_keys(4) = "upper extrapolation" + optional_keys(5) = "name" + optional_keys(6) = "constant value" + optional_keys(7) = "override bands" + optional_keys(8) = "minimum wavelength" + optional_keys(9) = "maximum wavelength" + + allocate( quantum_yield_taylor_series_t :: this ) + + call assert_msg( 268043622, & + config%validate( required_keys, optional_keys ), & + "Bad configuration for Taylor-series quantum yield." ) + call base_constructor( this, config, grid_warehouse, profile_warehouse ) + + call config%get( "coefficients", coeff, my_name ) + call assert_msg( 589032591, size( coeff ) .ge. 1, & + "Taylor-series quantum yield must have at least one "// & + "coefficient.") + call config%get( "minimum wavelength", min_wl, my_name, default = 0.0_dk ) + call config%get( "maximum wavelength", max_wl, my_name, & + default = huge(1.0_dk) ) + wavelengths => grid_warehouse%get_grid( this%wavelength_grid_ ) + call assert_msg( 401342404, size( this%quantum_yield_parms ) .eq. 1, & + "Taylor-series quantum yield cannot be used with "// & + "multiple data files" ) + associate( params => this%quantum_yield_parms(1)%array ) + do i_wl = 1, wavelengths%ncells_ + if( wavelengths%mid_( i_wl ) .lt. min_wl .or. & + wavelengths%mid_( i_wl ) .gt. max_wl ) cycle + params( i_wl, 1 ) = coeff(1) + do i_coeff = 2, size( coeff ) + params( i_wl, 1 ) = params( i_wl, 1 ) + & + coeff( i_coeff ) & + * wavelengths%mid_( i_wl )**( i_coeff - 1 ) + end do + params( i_wl, 1 ) = max( 0.0, min( 1.0, params( i_wl, 1 ) ) ) + end do + end associate + deallocate( wavelengths ) + + end function constructor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_quantum_yield_taylor_series \ No newline at end of file diff --git a/src/radiative_transfer/radiative_transfer.F90 b/src/radiative_transfer/radiative_transfer.F90 index edece329..50f02daf 100644 --- a/src/radiative_transfer/radiative_transfer.F90 +++ b/src/radiative_transfer/radiative_transfer.F90 @@ -4,13 +4,26 @@ module tuvx_radiative_transfer ! A calculator for atmospheric radiation - use musica_config, only : config_t - use musica_constants, only : dk => musica_dk - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_ptr - use tuvx_radiator_warehouse, only : radiator_warehouse_t, & - radiator_warehouse_ptr - use tuvx_solver, only : solver_t + use musica_assert, only : assert, assert_msg, die_msg + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_pack, musica_mpi_pack_size, musica_mpi_unpack + use musica_string, only : string_t + use tuvx_cross_section_warehouse, only : cross_section_warehouse_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_ptr, profile_warehouse_t + use tuvx_radiator, only : radiator_state_t, radiator_t + use tuvx_radiator_from_host, only : radiator_updater_t + use tuvx_radiator_warehouse, only : radiator_warehouse_t, radiator_warehouse_ptr + use tuvx_radiator_warehouse, only : warehouse_iterator_t + use tuvx_solver, only : solver_t, radiation_field_t + use tuvx_solver_factory, only : solver_allocate, solver_builder, solver_type_name + use tuvx_spherical_geometry, only : spherical_geometry_t + + implicit none private @@ -58,12 +71,6 @@ function constructor( config, grid_warehouse, profile_warehouse, radiators )& result( this ) ! Initializes the components necessary to solve radiative transfer - use musica_assert, only : assert_msg, die_msg - use musica_string, only : string_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_solver_factory, only : solver_builder - type(radiative_transfer_t), pointer :: this ! New :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` type(config_t), intent(inout) :: config ! radXfer configuration data type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` @@ -119,7 +126,6 @@ end function constructor type(string_t) function component_name( this ) ! Model component name - use musica_string, only : string_t class(radiative_transfer_t), intent(in) :: this ! A :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` @@ -132,7 +138,6 @@ end function component_name type(string_t) function description( this ) ! Model component description - use musica_string, only : string_t class(radiative_transfer_t), intent(in) :: this ! A :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` @@ -146,17 +151,6 @@ subroutine calculate( this, la_srb, spherical_geometry, grid_warehouse, & profile_warehouse, radiation_field ) ! Calculate the radiation field - use musica_assert, only : die_msg - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_radiator_warehouse, only : warehouse_iterator_t - use tuvx_radiator, only : radiator_t - use tuvx_radiator, only : radiator_state_t - use tuvx_profile, only : profile_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_spherical_geometry, only : spherical_geometry_t - use tuvx_la_sr_bands, only : la_sr_bands_t - use tuvx_solver, only : radiation_field_t - class(radiative_transfer_t), intent(inout) :: this ! A :f:type:`~tuvx_radiative_transfer/radxfer_component_core_t` type(grid_warehouse_t), intent(inout) :: grid_warehouse ! :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` @@ -221,10 +215,6 @@ function get_radiator_updater( this, radiator, found ) result( updater ) ! If the optional `found` flag is omitted, an error is returned if the ! radiator does not exist in TUV-x - use musica_assert, only : assert_msg - use tuvx_radiator, only : radiator_t - use tuvx_radiator_from_host, only : radiator_updater_t - class(radiative_transfer_t), intent(in) :: this ! Radiative transfer calculator class(radiator_t), intent(in) :: radiator ! The radiator to get an updater for logical, optional, intent(out) :: found ! Flag indicating whether the @@ -243,9 +233,6 @@ integer function pack_size( this, comm ) ! Returns the size of a character buffer required to pack the radiative ! transfer calculator - use musica_mpi, only : musica_mpi_pack_size - use musica_string, only : string_t - use tuvx_solver_factory, only : solver_type_name class(radiative_transfer_t), intent(inout) :: this ! radiative transfer to be packed integer, intent(in) :: comm ! MPI communicator @@ -272,11 +259,6 @@ end function pack_size subroutine mpi_pack( this, buffer, position, comm ) ! Packs the radiative transfer calculator onto a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - use musica_string, only : string_t - use tuvx_solver_factory, only : solver_type_name - class(radiative_transfer_t), intent(inout) :: this ! radiative transfer to be packed character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -306,10 +288,6 @@ end subroutine mpi_pack subroutine mpi_unpack( this, buffer, position, comm ) ! Unpacks a radiative transfer calculator from a character buffer - use musica_assert, only : assert, die_msg - use musica_string, only : string_t - use musica_mpi, only : musica_mpi_unpack - use tuvx_solver_factory, only : solver_allocate class(radiative_transfer_t), intent(out) :: this ! radiative transfer to be packed character, intent(inout) :: buffer(:) ! memory buffer diff --git a/src/radiative_transfer/radiator.F90 b/src/radiative_transfer/radiator.F90 index e586a3ad..1d99f8a5 100644 --- a/src/radiative_transfer/radiator.F90 +++ b/src/radiative_transfer/radiator.F90 @@ -4,11 +4,22 @@ module tuvx_radiator ! Represents an atmospheric constituent that affects radiative transfer calculations by absorbing or scattering radiation - use musica_constants, only : dk => musica_dk - use musica_string, only : string_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_ptr - use tuvx_grid_warehouse, only : grid_warehouse_ptr - use tuvx_profile_warehouse, only : profile_warehouse_ptr + use musica_assert, only : assert, assert_msg + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_pack, musica_mpi_pack_size, musica_mpi_unpack + use musica_string, only : string_t + use tuvx_constants, only : largest, precis + use tuvx_cross_section, only : cross_section_t + use tuvx_cross_section_warehouse, only : cross_section_warehouse_ptr + use tuvx_cross_section_warehouse, only : cross_section_warehouse_t + use tuvx_diagnostic_util, only : diagout + use tuvx_grid, only : grid_t + use tuvx_grid_warehouse, only : grid_warehouse_ptr + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_ptr + use tuvx_profile_warehouse, only : profile_warehouse_t implicit none @@ -79,11 +90,6 @@ function constructor( config, grid_warehouse, profile_warehouse, & cross_section_warehouse ) result( new_radiator ) ! Constructs a base_radiator_t object - use musica_config, only : config_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(radiator_t), pointer :: new_radiator ! New :f:type:`~tuvx_radiator/radiator_t` object type(config_t), intent(inout) :: config ! Radiator configuration type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` @@ -103,13 +109,6 @@ subroutine base_constructor( this, config, grid_warehouse, & ! ! This should only be called by subclasses of radiator_t - use musica_assert, only : assert_msg - use musica_config, only : config_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_grid, only : grid_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(radiator_t), intent(inout) :: this ! New :f:type:`~tuvx_radiator/radiator_t` object type(config_t), intent(inout) :: config ! Radiator configuration type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` @@ -175,15 +174,6 @@ subroutine update_state( this, grid_warehouse, profile_warehouse, & cross_section_warehouse ) ! Update radiator state - use musica_assert, only : assert_msg - use tuvx_cross_section, only : cross_section_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_diagnostic_util, only : diagout - use tuvx_grid, only : grid_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile, only : profile_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(radiator_t), intent(inout) :: this ! A :f:type:`~tuvx_radiator/radiator_state_t` type(grid_warehouse_t), intent(inout) :: grid_warehouse ! A :f:type:`~tuvx_grid_warehouse/grid_warehouse_t` type(profile_warehouse_t), intent(inout) :: profile_warehouse ! A :f:type:`~tuvx_profile_warehouse/profile_warehouse_t` @@ -246,7 +236,6 @@ end subroutine update_state !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine output_diagnostics( this ) - use tuvx_diagnostic_util, only : diagout class(radiator_t), intent(in) :: this ! A :f:type:`~tuvx_radiator/radiator_state_t` character(len=:), allocatable :: filename @@ -273,7 +262,6 @@ end subroutine output_diagnostics integer function pack_size( this, comm ) ! Returns the size of a character buffer required to pack the radiator - use musica_mpi, only : musica_mpi_pack_size class(radiator_t), intent(in) :: this ! radiator to be packed integer, intent(in) :: comm ! MPI communicator @@ -302,9 +290,6 @@ end function pack_size subroutine mpi_pack( this, buffer, position, comm ) ! Packs the radiator onto a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - class(radiator_t), intent(in) :: this ! radiator to be packed character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -336,9 +321,6 @@ end subroutine mpi_pack subroutine mpi_unpack( this, buffer, position, comm ) ! Unpacks a radiator from a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - class(radiator_t), intent(out) :: this ! radiator to be unpacked character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -375,7 +357,6 @@ subroutine accumulate( this, radiators ) ! ! Optical properties for radiators configured to 'treat as air' are ! unique. - use tuvx_constants, only : largest, precis class(radiator_state_t), intent(inout) :: this class(radiator_ptr), intent(in) :: radiators(:) @@ -476,9 +457,6 @@ end function state_pack_size subroutine state_mpi_pack( this, buffer, position, comm ) ! Packs the radiator state onto a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_pack - class(radiator_state_t), intent(in) :: this ! radiator state to be packed character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position @@ -501,9 +479,6 @@ end subroutine state_mpi_pack subroutine state_mpi_unpack( this, buffer, position, comm ) ! Unpacks a radiator state from a character buffer - use musica_assert, only : assert - use musica_mpi, only : musica_mpi_unpack - class(radiator_state_t), intent(out) :: this ! radiator state to be unpacked character, intent(inout) :: buffer(:) ! memory buffer integer, intent(inout) :: position ! current buffer position diff --git a/src/tuvx.F90 b/src/tuvx.F90 index e0e63126..b56a6602 100644 --- a/src/tuvx.F90 +++ b/src/tuvx.F90 @@ -139,11 +139,13 @@ subroutine run_tuvx( ) class(profile_t), pointer :: earth_sun_distance ! [AU] real(dk), allocatable :: photo_rates(:,:,:) ! (time, vertical level, reaction) [s-1] real(dk), allocatable :: dose_rates(:,:,:) ! (time, vertical level, dose rate) [?] + real(dk), allocatable :: heating_rates(:,:,:) ! (vertical level, reaction, thread) [K s-1] real(dk), allocatable :: thread_photo_rates(:,:,:) ! (vertical level, reaction, thread) [s-1] real(dk), allocatable :: thread_dose_rates(:,:,:) ! (vertical level, dose rate, thread) [?] + real(dk), allocatable :: thread_heating_rates(:,:,:)! (vertical level, reaction, thread) [K s-1] type(string_t) :: file_path character(len=2) :: diagnostic_label - class(output_t), pointer :: photo_output, dose_output + class(output_t), pointer :: photo_output, dose_output, heating_output type(config_t) :: config height => core%get_grid( "height", "km" ) @@ -161,10 +163,15 @@ subroutine run_tuvx( ) allocate( dose_rates( sza%ncells_ + 1, & height%ncells_ + 1, & core%number_of_dose_rates( ) ) ) + allocate( heating_rates( sza%ncells_ + 1, & + height%ncells_ + 1, & + core%number_of_heating_rates( ) ) ) + ! set up output files nullify( photo_output ) nullify( dose_output ) + nullify( heating_output ) if( core%number_of_photolysis_reactions( ) > 0 ) then call config%empty( ) call config%add( "file path", "photolysis_rate_constants.nc", Iam ) @@ -179,6 +186,13 @@ subroutine run_tuvx( ) call config%add( "tuv-x configuration", tuvx_config, Iam ) dose_output => output_t( config, core ) end if + if( core%number_of_heating_rates( ) > 0 ) then + call config%empty( ) + call config%add( "file path", "heating_rates.nc", Iam ) + call config%add( "include heating rates", .true., Iam ) + call config%add( "tuv-x configuration", tuvx_config, Iam ) + heating_output => output_t( config, core ) + end if ! calculate photolysis and dose rates do i_sza = 1, sza%ncells_ + 1 @@ -187,6 +201,7 @@ subroutine run_tuvx( ) earth_sun_distance%edge_val_( i_sza ), & photolysis_rate_constants = photo_rates( i_sza, :, : ), & dose_rates = dose_rates( i_sza, :, : ), & + heating_rates = heating_rates( i_sza, :, : ), & diagnostic_label = diagnostic_label ) ! output results @@ -204,6 +219,13 @@ subroutine run_tuvx( ) solar_zenith_angle = sza%edge_val_( i_sza ), & earth_sun_distance = earth_sun_distance%edge_val_( i_sza ) ) end if + if( associated( heating_output ) ) then + call heating_output%output( i_sza, core, & + heating_rates = heating_rates( i_sza, : , : ), & + time = time%edge_( i_sza ), & + solar_zenith_angle = sza%edge_val_( i_sza ), & + earth_sun_distance = earth_sun_distance%edge_val_( i_sza ) ) + end if end do deallocate( height ) @@ -212,6 +234,7 @@ subroutine run_tuvx( ) deallocate( earth_sun_distance ) if( associated( photo_output ) ) deallocate( photo_output ) if( associated( dose_output ) ) deallocate( dose_output ) + if( associated( heating_output ) ) deallocate( heating_output ) #if MUSICA_USE_OPENMP ! Compare results from threads for fixed solar zenith angle @@ -221,15 +244,20 @@ subroutine run_tuvx( ) allocate( thread_dose_rates( size( dose_rates, 2 ), & size( dose_rates, 3 ), & omp_get_max_threads( ) ) ) + allocate( thread_heating_rates( size( heating_rates, 2 ), & + size( heating_rates, 3 ), & + omp_get_max_threads( ) ) ) !$omp parallel & !$omp shared( threads, thread_photo_rates, thread_dose_rates ) associate( thread => threads( omp_get_thread_num( ) + 1 ), & photos => thread_photo_rates(:,:, omp_get_thread_num( ) + 1 ), & - doses => thread_dose_rates( :,:, omp_get_thread_num( ) + 1 ) ) + doses => thread_dose_rates( :,:, omp_get_thread_num( ) + 1 ), & + heat => thread_heating_rates( :,:, omp_get_thread_num( ) + 1 ) ) call thread%core_%run( 40.0_dk, & 1.0_dk, & photolysis_rate_constants = photos, & - dose_rates = doses ) + dose_rates = doses, & + heating_rates = heat ) end associate !$omp end parallel @@ -249,6 +277,13 @@ subroutine run_tuvx( ) "Thread result mismatch for thread "// & to_char( i_thread ) ) end do + do i_photo = 1, size( thread_heating_rates, 2 ) + call assert_msg( 389419926, & + thread_heating_rates( i_level, i_photo, i_thread ) & + .eq. thread_heating_rates( i_level, i_photo, 1 ), & + "Thread result mismatch for thread "// & + to_char( i_thread ) ) + end do end do end do #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 ef24ac8f..103518eb 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 @@ -24,8 +24,10 @@ add_custom_target(copy_test_data ALL ${CMAKE_COMMAND} -E copy_directory ################################################################################ # Add subdirectories +string(REGEX MATCH "^[0-9]+" CMAKE_Fortran_COMPILER_MAJOR_VERSION ${CMAKE_Fortran_COMPILER_VERSION}) + add_subdirectory(unit) -if(NOT ${CMAKE_Fortran_COMPILER_ID} MATCHES "NAG") +if(NOT ${CMAKE_Fortran_COMPILER_ID} MATCHES "NAG" AND NOT (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU" AND ${CMAKE_Fortran_COMPILER_MAJOR_VERSION} VERSION_EQUAL 13)) # oldtuv doesn't build with NAG, so bypass the regression tests add_subdirectory(oldtuv) add_subdirectory(regression) @@ -34,7 +36,33 @@ endif() ################################################################################ # Run examples as tests -add_test(NAME full_example COMMAND tuv-x examples/full_config.json - WORKING_DIRECTORY ${CMAKE_BINARY_DIR}) +add_custom_target(make-tuv54-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_tuv_5_4) +add_custom_target(link-tuv54-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_tuv_5_4/data) +add_test(NAME TUV_5_4 COMMAND tuv-x ../examples/tuv_5_4.json + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_tuv_5_4) +add_custom_target(make-ts1-tsmlt-example-dir ALL COMMAND ${CMAKE_COMMAND} + -E make_directory ${CMAKE_BINARY_DIR}/example_ts1_tsmlt) +add_custom_target(link-ts1-tsmlt-example-data ALL COMMAND ${CMAKE_COMMAND} + -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../data ${CMAKE_BINARY_DIR}/example_ts1_tsmlt/data) +add_test(NAME TS1_TSMLT COMMAND tuv-x ../examples/ts1_tsmlt.json + WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/example_ts1_tsmlt) +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/cross_sections/cross_section.base.config.json b/test/data/cross_sections/cross_section.base.config.json index 02512e28..25fd74d9 100644 --- a/test/data/cross_sections/cross_section.base.config.json +++ b/test/data/cross_sections/cross_section.base.config.json @@ -48,6 +48,18 @@ "upper extrapolation": { "type": "constant", "value": 32.3 } } ] + }, + { + "name": "from config", + "type": "base", + "data": { + "default value": 12.3, + "point values": [ + { "wavelength": 102.5, "value": 92.3 }, + { "wavelength": 103.75, "value": 53.2 } + ] + } + } ] } diff --git a/test/data/cross_sections/util/burkholder.config.json b/test/data/cross_sections/util/burkholder.config.json new file mode 100644 index 00000000..36a3efcf --- /dev/null +++ b/test/data/cross_sections/util/burkholder.config.json @@ -0,0 +1,22 @@ +{ + "type": "BURKHOLDER", + "netcdf file": { + "file path": "test/data/cross_sections/util/burkholder.nc" + }, + "A": 12.5, + "B": 202.3, + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] +} \ No newline at end of file diff --git a/test/data/cross_sections/util/burkholder.nc b/test/data/cross_sections/util/burkholder.nc new file mode 100644 index 00000000..1b73b9d5 Binary files /dev/null and b/test/data/cross_sections/util/burkholder.nc differ diff --git a/test/data/cross_sections/util/taylor.config.json b/test/data/cross_sections/util/taylor.config.json new file mode 100644 index 00000000..54b0c7d3 --- /dev/null +++ b/test/data/cross_sections/util/taylor.config.json @@ -0,0 +1,23 @@ +{ + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "test/data/cross_sections/util/taylor.nc" + }, + "base temperature": 295.2, + "minimum wavelength": 280.5, + "maximum wavelength": 540.2, + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] +} \ No newline at end of file diff --git a/test/data/cross_sections/util/taylor.nc b/test/data/cross_sections/util/taylor.nc new file mode 100644 index 00000000..1b73b9d5 Binary files /dev/null and b/test/data/cross_sections/util/taylor.nc differ diff --git a/test/data/heating_rates.json b/test/data/heating_rates.json new file mode 100644 index 00000000..7ff2a056 --- /dev/null +++ b/test/data/heating_rates.json @@ -0,0 +1,100 @@ +{ + "grids" : [ + { + "name": "height", + "type": "equal interval", + "units": "km", + "begins at": 1.0, + "ends at": 5.0, + "cell delta": 1.0 + }, + { + "name": "wavelength", + "type": "equal interval", + "units": "nm", + "begins at": 400.0, + "ends at": 700.0, + "cell delta": 50.0 + } + ], + "profiles": [ + { + "name": "temperature", + "type": "from config file", + "units": "K", + "grid": { + "name": "height", + "units": "km" + }, + "values": [ 200.0, 250.0, 300.0, 350.0, 400.0 ] + }, + { + "name": "extraterrestrial flux", + "type": "from config file", + "units": "photon cm-2 s-1", + "grid": { + "name": "wavelength", + "units": "nm" + }, + "values": [ 1.0e+4, 1.0e+5, 1.0e+6, 1.0e+7, 1.0e+8, 1.0e+9, 1.0e+10 ] + }, + { + "name": "air", + "type": "from config file", + "units": "molecule cm-3", + "grid": { + "name": "height", + "units": "km" + }, + "values": [ 2.5e+19, 2.0e+19, 1.5e+19, 1.0e+19, 5.0e+18 ] + } + ], + "reactions": [ + { + "name": "jfoo", + "cross section": { + "type": "base", + "data": { + "default value": 12.3 + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.75 + }, + "heating": { + "energy term": 2.0 + } + }, + { + "name": "jbar", + "cross section": { + "type": "base", + "data": { + "default value": 45.6 + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.25 + } + }, + { + "name": "jbaz", + "cross section": { + "type": "base", + "data": { + "default value": 78.9 + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.5 + }, + "scaling factor": 1.1, + "heating": { + "energy term": 3000.0 + } + } + ] +} \ 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/la_srb_bands.config.json b/test/data/la_srb_bands.config.json index 51bd6d98..a00baaa2 100644 --- a/test/data/la_srb_bands.config.json +++ b/test/data/la_srb_bands.config.json @@ -1,18 +1,24 @@ { "grids" : [ { - "name": "height", - "type": "equal interval", - "units": "km", - "begins at" : 0.0, - "ends at" : 120.0, - "cell delta" : 1.0 + "name": "height", + "type": "equal interval", + "units": "km", + "begins at" : 0.5, + "ends at" : 150.5, + "cell delta" : 1.0 }, { - "name": "wavelength", - "type": "from csv file", - "units": "nm", - "file path": "data/grids/wavelength/combined.grid" + "name": "wavelength", + "type": "from csv file", + "units": "nm", + "file path": "test/data/waccm2_ref_101_mod.grid" + }, + { + "name": "LUT wavelength", + "type": "from csv file", + "units": "nm", + "file path": "test/data/waccm2_ref_101.grid" } ], "cross section parameters file": "data/cross_sections/O2_parameters.txt", @@ -26,9 +32,28 @@ "name": "height", "units": "km" } + }, + { + "name": "air", + "type": "air", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" + }, + { + "name": "O2", + "type": "O2", + "units": "molecule cm-3", + "file path": "data/profiles/atmosphere/ussa.dens" } ], - "O2 estimate" :{ - "scale factor": 0.2095 + "O2 cross section": { + "netcdf files": [ + { + "file path": "data/cross_sections/O2_1.nc", + "lower extrapolation": { "type": "boundary" }, + "interpolator": { "type": "fractional target" } + } + ], + "type": "base" } } diff --git a/test/data/quantum_yields/base.config.json b/test/data/quantum_yields/base.config.json index e5a5d883..c1b52b82 100644 --- a/test/data/quantum_yields/base.config.json +++ b/test/data/quantum_yields/base.config.json @@ -25,6 +25,12 @@ { "band": "schumann-runge continuum", "value": 0.932 + }, + { + "band": "range", + "minimum wavelength": 207.0, + "maximum wavelength": 250.0, + "value": 0.243 } ] }, diff --git a/test/data/quantum_yields/h2so4_mills.config.json b/test/data/quantum_yields/h2so4_mills.config.json new file mode 100644 index 00000000..ea6511cf --- /dev/null +++ b/test/data/quantum_yields/h2so4_mills.config.json @@ -0,0 +1,143 @@ +{ + "grids": [ + { + "type": "from config file", + "name": "wavelength", + "units": "nm", + "values": [ + 120.0000, + 121.0000, + 122.0000, + 123.5000, + 124.3000, + 125.5000, + 126.3000, + 127.1000, + 130.1000, + 131.1000, + 135.0000, + 140.0000, + 145.0000, + 150.0000, + 155.0000, + 160.0000, + 165.0000, + 168.0000, + 171.0000, + 173.0000, + 174.4000, + 177.0000, + 178.6000, + 180.2000, + 181.8000, + 183.5000, + 185.2000, + 186.9000, + 188.7000, + 190.5000, + 192.3000, + 194.2000, + 196.1000, + 198.0000, + 200.0000, + 202.0000, + 204.1000, + 205.8000, + 208.0000, + 211.0000, + 214.0000, + 217.0000, + 220.0000, + 223.0000, + 226.0000, + 229.0000, + 232.0000, + 235.0000, + 238.0000, + 241.0000, + 244.0000, + 247.0000, + 250.0000, + 253.0000, + 256.0000, + 259.0000, + 263.0000, + 267.0000, + 271.0000, + 275.0000, + 279.0000, + 283.0000, + 287.0000, + 291.0000, + 295.0000, + 298.5000, + 302.5000, + 305.5000, + 308.5000, + 311.5000, + 314.5000, + 317.5000, + 322.5000, + 327.5000, + 332.5000, + 337.5000, + 342.5000, + 347.5000, + 350.0000, + 355.0000, + 360.0000, + 365.0000, + 370.0000, + 375.0000, + 380.0000, + 385.0000, + 390.0000, + 395.0000, + 400.0000, + 405.0000, + 410.0000, + 415.0000, + 420.0000, + 430.0000, + 440.0000, + 450.0000, + 500.0000, + 550.0000, + 600.0000, + 650.0000, + 700.0000, + 750.0000 + ] + } + ], + "quantum yield": { + "type": "H2SO4 Mills", + "netcdf files": [ + "data/quantum_yields/H2SO4_mills.nc" + ], + "parameterized wavelengths": [ + 525, + 625, + 725 + ], + "collision interval s": [ + 1.1e-9, + 8.9e-9, + 1.7e-7 + ], + "molecular diameter m": 4.18e-10, + "molecular weight kg mol-1": 98.078479e-3 + }, + "cross section": { + "type": "base", + "data": { + "default value": 0.0, + "point values": [ + { "wavelength": 121.5, "value": 6.3e-17 }, + { "wavelength": 525.0, "value": 1.43e-26 }, + { "wavelength": 625.0, "value": 1.8564e-25 }, + { "wavelength": 725.0, "value": 3.086999e-24 } + ] + } + } +} \ No newline at end of file diff --git a/test/data/quantum_yields/jh2so4.nc b/test/data/quantum_yields/jh2so4.nc new file mode 100644 index 00000000..db0126a1 Binary files /dev/null and b/test/data/quantum_yields/jh2so4.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/data/waccm2_ref_101.grid b/test/data/waccm2_ref_101.grid new file mode 100644 index 00000000..3988bcef --- /dev/null +++ b/test/data/waccm2_ref_101.grid @@ -0,0 +1,104 @@ + 102 + 120.0000 + 121.0000 + 122.0000 + 123.5000 + 124.3000 + 125.5000 + 126.3000 + 127.1000 + 130.1000 + 131.1000 + 135.0000 + 140.0000 + 145.0000 + 150.0000 + 155.0000 + 160.0000 + 165.0000 + 168.0000 + 171.0000 + 173.0000 + 174.4000 + 177.0000 + 178.6000 + 180.2000 + 181.8000 + 183.5000 + 185.2000 + 186.9000 + 188.7000 + 190.5000 + 192.3000 + 194.2000 + 196.1000 + 198.0000 + 200.0000 + 202.0000 + 204.1000 + 205.8000 + 208.0000 + 211.0000 + 214.0000 + 217.0000 + 220.0000 + 223.0000 + 226.0000 + 229.0000 + 232.0000 + 235.0000 + 238.0000 + 241.0000 + 244.0000 + 247.0000 + 250.0000 + 253.0000 + 256.0000 + 259.0000 + 263.0000 + 267.0000 + 271.0000 + 275.0000 + 279.0000 + 283.0000 + 287.0000 + 291.0000 + 295.0000 + 298.5000 + 302.5000 + 305.5000 + 308.5000 + 311.5000 + 314.5000 + 317.5000 + 322.5000 + 327.5000 + 332.5000 + 337.5000 + 342.5000 + 347.5000 + 350.0000 + 355.0000 + 360.0000 + 365.0000 + 370.0000 + 375.0000 + 380.0000 + 385.0000 + 390.0000 + 395.0000 + 400.0000 + 405.0000 + 410.0000 + 415.0000 + 420.0000 + 430.0000 + 440.0000 + 450.0000 + 500.0000 + 550.0000 + 600.0000 + 650.0000 + 700.0000 + 750.0000 + diff --git a/test/data/waccm2_ref_101_mod.grid b/test/data/waccm2_ref_101_mod.grid new file mode 100644 index 00000000..2fd1304c --- /dev/null +++ b/test/data/waccm2_ref_101_mod.grid @@ -0,0 +1,104 @@ + 102 + 120.0000 + 121.4000 + 121.9000 + 123.5000 + 124.3000 + 125.5000 + 126.3000 + 127.1000 + 130.1000 + 131.1000 + 135.0000 + 140.0000 + 145.0000 + 150.0000 + 155.0000 + 160.0000 + 165.0000 + 168.0000 + 171.0000 + 173.0000 + 175.4000 + 177.0000 + 178.6000 + 180.2000 + 181.8000 + 183.5000 + 185.2000 + 186.9000 + 188.7000 + 190.5000 + 192.3000 + 194.2000 + 196.1000 + 198.0000 + 200.0000 + 202.0000 + 204.1000 + 206.2000 + 208.0000 + 211.0000 + 214.0000 + 217.0000 + 220.0000 + 223.0000 + 226.0000 + 229.0000 + 232.0000 + 235.0000 + 238.0000 + 241.0000 + 244.0000 + 247.0000 + 250.0000 + 253.0000 + 256.0000 + 259.0000 + 263.0000 + 267.0000 + 271.0000 + 275.0000 + 279.0000 + 283.0000 + 287.0000 + 291.0000 + 295.0000 + 298.5000 + 302.5000 + 305.5000 + 308.5000 + 311.5000 + 314.5000 + 317.5000 + 322.5000 + 327.5000 + 332.5000 + 337.5000 + 342.5000 + 347.5000 + 350.0000 + 355.0000 + 360.0000 + 365.0000 + 370.0000 + 375.0000 + 380.0000 + 385.0000 + 390.0000 + 395.0000 + 400.0000 + 405.0000 + 410.0000 + 415.0000 + 420.0000 + 430.0000 + 440.0000 + 450.0000 + 500.0000 + 550.0000 + 600.0000 + 650.0000 + 700.0000 + 750.0000 + diff --git a/test/data/xsqy.doug.config.json b/test/data/xsqy.doug.config.json index 901c9c2d..ee7164c2 100644 --- a/test/data/xsqy.doug.config.json +++ b/test/data/xsqy.doug.config.json @@ -87,6 +87,9 @@ "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], "minimum wavelength": 210.0, "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", "temperature ranges": [ { "maximum": 209.999999999999, @@ -109,5 +112,1227 @@ }, "label": "CH2Br2 + hv -> 2Br", "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/BRO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "BRO + hv -> Br + O", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask" : [ { "index": 62 }, { "index": 86 }] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/BRO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "BRO + hv -> Br + O", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CL2O2_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "Cl2O2 + hv -> Cl + ClOO", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask" : [ { "index": 34 }, { "index": 97 } ] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CL2O2_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "Cl2O2 + hv -> Cl + ClOO", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CLO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "ClO + hv -> Cl + O", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [ { "index": 51 }, { "index": 71 }] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CLO_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "ClO + hv -> Cl + O", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "HNO3+hv->OH+NO2", + "netcdf files": [ + { "file path": "data/cross_sections/HNO3_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HNO3 + hv -> OH + NO2", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [ { "index": 30 }, { "index": 79 } ] + }, + { + "cross section": { + "type": "HNO3+hv->OH+NO2", + "netcdf files": [ + { "file path": "data/cross_sections/HNO3_JPL06.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HNO3 + hv -> OH + NO2", + "__note": "second test: including lower edge of interpolation with relaxed tolerance (upper edge is a very small value with large relative difference)", + "tolerance": 1.0e-3, + "mask": [ { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CF2CL2_JPL06.nc", + "parameterization": { + "AA": [ -43.8954569, -2.403597e-1, -4.2619e-4, 9.8743e-6, 0.0 ], + "BB": [ 4.8438e-3, 4.96145e-4, -5.6953e-6, 0.0, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 231.0, + "base temperature": 296.0, + "base wavelength": 200.0, + "logarithm": "natural", + "temperature ranges": [ + { + "maximum": 219.999999999999, + "fixed value": 220.0 + }, + { + "minimum": 220, + "maximum": 296 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CF2Cl2 + hv -> 2Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC113_JPL06.nc", + "parameterization": { + "AA": [ -1087.9, 20.004, -1.3920e-1, 4.2828e-4, -4.9384e-7 ], + "BB": [ 12.493, -2.3937e-1, 1.7142e-3, -5.4393e-6, 6.4548e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 182.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC113 + hv -> 3Cl", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFC114_JPL10.nc", + "parameterization": { + "AA": [ -160.50, 2.4807, -1.5202e-2, 3.8412e-5, -3.4373e-8 ], + "BB": [ -1.5296, 3.5248e-2, -2.9951e-4, 1.1129e-6, -1.5259e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 220.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC114 + hv -> 2Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CFC115_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC115 + hv -> Cl", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [ { "index": 19 }, { "index": 46 } ] + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/CFC115_JPL10.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFC115 + hv -> Cl", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-4 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CFCL3_JPL06.nc", + "parameterization": { + "AA": [ -84.611, 7.9551e-1, -2.0550e-3, -4.4812e-6, 1.5838e-8 ], + "BB": [ -5.7912, 1.1689e-1, -8.8069e-4, 2.9335e-6, -3.6421e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CFCl3 + hv -> 3Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3BR_JPL06.nc", + "parameterization": { + "AA": [ 46.520, -1.4580, 1.1469e-2, -3.7627e-5, 4.3264e-8 ], + "BB": [ 9.3408e-1, -1.6887e-2, 1.1487e-4, -3.4881e-7, 3.9945e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 200.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CH3Br + hv -> Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CHBR3_JPL10.nc", + "parameterization": { + "AA": [ -32.6067, 0.10308, 6.39e-5, -7.7392e-7, -2.2513e-9, 6.1376e-12 ], + "BB": [ 0.1582, -0.0014758, 3.8058e-6, 9.187e-10, -1.0772e-11, 0.0 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0, 5.0 ], + "minimum wavelength": 260.0, + "maximum wavelength": 362.0, + "base temperature": 296.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "invert temperature offset": true, + "temperature ranges": [ + { + "maximum": 259.999999999999, + "fixed value": 260.0 + }, + { + "minimum": 260.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CHBr3 + hv -> 3Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H1301_JPL06.nc", + "parameterization": { + "AA": [ 62.563, -2.0068, 1.6592e-2, -5.6465e-5, 6.7459e-8 ], + "BB": [ -9.1755e-1, 1.8575e-2, -1.3857e-4, 4.5066e-7, -5.3803e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 178.0, + "maximum wavelength": 280.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "H1301 + hv -> Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/H2402_JPL06.nc", + "parameterization": { + "AA": [ 34.026, -1.152616, 8.959798e-3, -2.9089e-5, 3.307212e-8 ], + "BB": [ 4.010664e-1, -8.358968e-3, 6.415741e-5, -2.157554e-7, 2.691871e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 190.0, + "maximum wavelength": 290.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "H2402 + hv -> 2Br", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC22_JPL06.nc", + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 169.0, 171.0, 173.0, 175.0, 177.0, 179.0, 181.0, 183.0, 185.0, + 187.0, 189.0, 191.0, 193.0, 195.0, 197.0, 199.0, 201.0, 203.0, + 205.0, 207.0, 209.0, 211.0, 213.0, 215.0, 217.0, 219.0, 221.0 + ] + }, + "parameterization": { + "AA": [ -106.029, 1.5038, -8.2476e-3, 1.4206e-5 ], + "BB": [ -1.3399e-1, 2.7405e-3, -1.8028e-5, 3.8504e-8 ], + "lp": [ 0.0, 1.0, 2.0, 3.0 ], + "minimum wavelength": 174.0, + "maximum wavelength": 204.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HCFC22 + hv -> Cl", + "tolerance": 1.0e-3, + "__note": "excluding upper edge of interpolation, which has a small value", + "mask": [ { "index": 43 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC141b_JPL10.nc", + "parameterization": { + "AA": [ -682.913042, 12.122290, -8.187699e-2, 2.437244e-4, -2.719103e-7 ], + "BB": [ 4.074747, -8.053899e-2, 5.946552e-4, -1.945048e-6, 2.380143e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 240.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HCFC141b + hv -> 2Cl", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HCFC142b_JPL10.nc", + "parameterization": { + "AA": [ -328.092008, 6.342799, -4.810362e-2, 1.611991e-4, -2.042613e-7 ], + "BB": [ 4.289533e-1, -9.042817e-3, 7.018009e-5, -2.389064e-7, 3.039799e-10 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 172.0, + "maximum wavelength": 230.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210.0, + "maximum": 300.0 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "HCFC142b + hv -> Cl", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.85 + }, + "label": "BrONO2 + hv -> Br + NO3", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [{ "index": 97 }, { "index": 34 }] + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.85 + }, + "label": "BrONO2 + hv -> Br + NO3", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.15 + }, + "label": "BrONO2 + hv -> BrO + NO2", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "mask": [{ "index": 97 }, { "index": 34 }] + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/BRONO2_JPL06.nc" + }, + "base temperature": 296.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200.0 + }, + { + "minimum": 200.0, + "maximum": 296.0 + }, + { + "minimum": 296.00000000001, + "fixed value": 296.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.15 + }, + "label": "BrONO2 + hv -> BrO + NO2", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3 + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.30, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.20 + } + ] + }, + "label": "HO2NO2 + hv -> OH + NO3", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "tolerance": 1.0e-5, + "mask": [ { "index": 29 }, { "index": 78 }, { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.30, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.20 + } + ] + }, + "label": "HO2NO2 + hv -> OH + NO3", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3, + "mask": [ { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.70, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.80 + } + ] + }, + "label": "HO2NO2 + hv -> HO2 + NO2", + "__note": "first test: excluding edges of interpolation because of double vs float algorithms", + "tolerance": 1.0e-5, + "mask": [ { "index": 29 }, { "index": 78 }, { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/HO2NO2_JPL06.nc", + "parameterization": { + "type": "BURKHOLDER", + "netcdf file": { + "file path": "data/cross_sections/HO2NO2_temp_JPL06.nc" + }, + "A": -988.0, + "B": 0.69, + "temperature ranges": [ + { + "maximum": 279.999999999999, + "fixed value": 280.0 + }, + { + "minimum": 280.0, + "maximum": 350.0 + }, + { + "minimum": 350.00000000001, + "fixed value": 350.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 0.70, + "override bands": [ + { + "band": "range", + "minimum wavelength": 200.0, + "value": 0.80 + } + ] + }, + "label": "HO2NO2 + hv -> HO2 + NO2", + "__note": "second test: including edges of interpolation with relaxed tolerance", + "tolerance": 1.0e-3, + "mask": [ { "index": 79 } ] + }, + { + "cross section": { + "type": "temperature based", + "netcdf file": "data/cross_sections/CH3CL_JPL06.nc", + "parameterization": { + "AA": [ -299.80, 5.1047, -3.3630e-2, 9.5805e-5, -1.0135e-7 ], + "BB": [ -7.1727, 1.4837e-1, -1.1463e-3, 3.9188e-6, -4.9994e-9 ], + "lp": [ 0.0, 1.0, 2.0, 3.0, 4.0 ], + "minimum wavelength": 174.1, + "maximum wavelength": 216.0, + "base temperature": 273.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "temperature ranges": [ + { + "maximum": 209.999999999999, + "fixed value": 210.0 + }, + { + "minimum": 210, + "maximum": 300 + }, + { + "minimum": 300.00000000001, + "fixed value": 300.0 + } + ] + } + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "CH3Cl + hv -> Cl", + "tolerance": 5.0e-3 + }, + { + "cross section": { + "type": "base", + "netcdf files": [ + { "file path": "data/cross_sections/SO2_Mills.nc" } + ] + }, + "quantum yield": { + "type": "base", + "constant value": 1.0 + }, + "label": "SO2 + hv -> SO + O", + "tolerance": 1.0e-4 + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ -2.832441, 0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 1.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO2", + "tolerance": 1.0e-3, + "mask": [ { "index": 93 } ] + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ -2.832441, 0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 1.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO2", + "tolerance": 1.0e-2 + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ 3.832441, -0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 0.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO + O", + "tolerance": 1.0e-3, + "mask": [ { "index": 93 } ] + }, + { + "cross section": { + "type":"temperature based", + "netcdf file": "data/cross_sections/N2O5_JPL06.nc", + "parameterization": { + "type": "HARWOOD", + "aa": [ -18.27, -18.42, -18.59, -18.72, -18.84, + -18.90, -18.93, -18.87, -18.77, -18.71, + -18.31, -18.14, -18.01, -18.42, -18.59, + -18.13 ], + "bb": [ -91.0, -104.0, -112.0, -135.0, -170.0, + -226.0, -294.0, -388.0, -492.0, -583.0, + -770.0, -885.0, -992.0, -949.0, -966.0, + -1160.0 ], + "base temperature": 0.0, + "base wavelength": 0.0, + "logarithm": "base 10", + "minimum wavelength": 260.0, + "maximum wavelength": 410.0, + "temperature ranges": [ + { + "maximum": 199.999999999999, + "fixed value": 200 + }, + { + "minimum": 200, + "maximum": 295 + }, + { + "minimum": 295.00000000001, + "fixed value": 295.0 + } + ] + }, + "parameterization wavelength grid": { + "name": "custom wavelengths", + "type": "from config file", + "units": "nm", + "values": [ + 255.0, 265.0, 275.0, 285.0, 295.0, 305.0, + 315.0, 325.0, 335.0, 345.0, 355.0, 365.0, + 375.0, 385.0, 395.0, 405.0, 415.0 + ] + } + }, + "quantum yield": { + "type": "Taylor series", + "constant value": 0.0, + "coefficients": [ 3.832441, -0.012809638 ], + "override bands": [ + { + "band": "range", + "minimum wavelength": 300.0, + "value": 0.0 + } + ] + }, + "label": "N2O5 + hv -> NO3 + NO + O", + "tolerance": 1.0e-2 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/ACETONE_JPL06.nc" + }, + "base temperature": 0.0, + "temperature ranges": [ + { + "maximum": 234.999999999999, + "fixed value": 235.0 + }, + { + "minimum": 235.0, + "maximum": 298.0 + }, + { + "minimum": 298.00000000001, + "fixed value": 298.0 + } + ] + } + }, + "quantum yield": { + "type": "CH3COCH3+hv->CH3CO+CH3", + "low wavelength value": 1, + "minimum temperature": 218, + "maximum temperature": 295 + }, + "label": "CH3COCH3 + hv -> CH3CO3 + CH3O2", + "__note": "quantum yield parameterization includes multiple chained exponentials and single vs double precision seems to be quite different", + "tolerance": 2 + }, + { + "cross section": { + "type": "temperature based", + "parameterization": { + "type": "TAYLOR_SERIES", + "netcdf file": { + "file path": "data/cross_sections/ACETONE_JPL06.nc" + }, + "base temperature": 0.0, + "temperature ranges": [ + { + "maximum": 234.999999999999, + "fixed value": 235.0 + }, + { + "minimum": 235.0, + "maximum": 298.0 + }, + { + "minimum": 298.00000000001, + "fixed value": 298.0 + } + ] + } + }, + "quantum yield": { + "type": "CH3COCH3+hv->CH3CO+CH3", + "branch": "CO+CH3CO", + "low wavelength value": 1, + "minimum temperature": 218, + "maximum temperature": 295 + }, + "label": "CH3COCH3 + hv -> CH3CO3 + CH3O2", + "__note": "quantum yield parameterization includes multiple chained exponentials and single vs double precision seems to be quite different", + "tolerance": 1.0e-3 } ] diff --git a/test/json_yaml_compare.py b/test/json_yaml_compare.py new file mode 100644 index 00000000..b22dddcb --- /dev/null +++ b/test/json_yaml_compare.py @@ -0,0 +1,26 @@ +import os +import filecmp +import sys + +def compare_files(file_name, folder_path1, folder_path2): + file1 = os.path.join(folder_path1, file_name) + file2 = os.path.join(folder_path2, file_name) + + if os.path.isfile(file1) and os.path.isfile(file2): + if filecmp.cmp(file1, file2): + print("The files are equal.") + else: + print("The files are not equal.") + return 1 # Return a failure code + else: + print("One or both files do not exist.") + return 1 # Return a failure code + +if __name__ == "__main__": + if len(sys.argv) != 3: + print("Usage: python script.py ") + else: + folder_path1 = sys.argv[1] + folder_path2 = sys.argv[2] + compare_files("photolysis_rate_constants.nc", folder_path1, folder_path2) + compare_files("dose_rates.nc", folder_path1, folder_path2) 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 e2e46248..262cf009 100644 --- a/test/unit/CMakeLists.txt +++ b/test/unit/CMakeLists.txt @@ -14,11 +14,13 @@ add_subdirectory(radiative_transfer) add_subdirectory(radiator) add_subdirectory(spectral_weight) add_subdirectory(tuv_doug) +add_subdirectory(util) ################################################################################ # TUV-x tests create_standard_test(NAME grid_warehouse SOURCES grid_warehouse.F90) +create_standard_test(NAME heating_rates SOURCES heating_rates.F90) create_standard_test(NAME la_sr_bands SOURCES la_sr_bands.F90 ) create_standard_test(NAME spherical_geometry SOURCES spherical_geometry.F90 ) diff --git a/test/unit/cross_section/CMakeLists.txt b/test/unit/cross_section/CMakeLists.txt index 08b27742..4733957c 100644 --- a/test/unit/cross_section/CMakeLists.txt +++ b/test/unit/cross_section/CMakeLists.txt @@ -33,4 +33,6 @@ create_standard_test(NAME cross_section_rono2 SOURCES rono2_test.F90 ) create_standard_test(NAME cross_section_t_butyl_nitrate SOURCES t_butyl_nitrate_test.F90 ) create_standard_test(NAME cross_section_tint SOURCES tint_test.F90 ) +add_subdirectory(util) + ################################################################################ diff --git a/test/unit/cross_section/acetone-ch3co_ch3_test.F90 b/test/unit/cross_section/acetone-ch3co_ch3_test.F90 index 181a0bbc..e95feccf 100644 --- a/test/unit/cross_section/acetone-ch3co_ch3_test.F90 +++ b/test/unit/cross_section/acetone-ch3co_ch3_test.F90 @@ -5,11 +5,19 @@ !> Tests for the base cross_section_t type program test_cross_section - use musica_mpi, only : musica_mpi_init, & - musica_mpi_finalize use tuvx_cross_section, only : cross_section_t use tuvx_cross_section_ch3coch3_ch3co_ch3 use tuvx_test_utils, only : check_values + use musica_assert, only : assert + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use musica_iterator, only : iterator_t + use musica_mpi + use musica_string, only : string_t + use tuvx_cross_section_factory, only : cross_section_type_name, & + cross_section_allocate + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t implicit none @@ -23,17 +31,6 @@ program test_cross_section subroutine test_cross_section_ch3coch3_ch3co_ch3_t( ) - use musica_assert, only : assert - use musica_constants, only : dk => musica_dk - use musica_config, only : config_t - use musica_iterator, only : iterator_t - use musica_mpi - use musica_string, only : string_t - use tuvx_cross_section_factory, only : cross_section_type_name, & - cross_section_allocate - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(grid_warehouse_t), pointer :: grids class(profile_warehouse_t), pointer :: profiles class(cross_section_t), pointer :: cross_section diff --git a/test/unit/cross_section/base.F90 b/test/unit/cross_section/base.F90 index 3c28a18b..87739c63 100644 --- a/test/unit/cross_section/base.F90 +++ b/test/unit/cross_section/base.F90 @@ -218,6 +218,49 @@ subroutine test_cross_section_t( ) deallocate( input_grid ) deallocate( cross_section ) + ! load and test cross section w/ specified data points + call assert( 906510764, iter%next( ) ) + call cs_set%get( iter, cs_config, Iam ) + if( musica_mpi_rank( comm ) == 0 ) then + cross_section => cross_section_t( cs_config, grids, profiles ) + type_name = cross_section_type_name( cross_section ) + pack_size = type_name%pack_size( comm ) + cross_section%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call type_name%mpi_pack( buffer, pos , comm ) + call cross_section%mpi_pack( buffer, pos , comm ) + call assert( 283721707, 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 type_name%mpi_unpack( buffer, pos , comm ) + cross_section => cross_section_allocate( type_name ) + call cross_section%mpi_unpack( buffer, pos , comm ) + call assert( 396040052, pos <= pack_size ) + end if + deallocate( buffer ) + + results = cross_section%calculate( grids, profiles, at_mid_point = .false. ) + do i_height = 1, 6 + call assert( 666985743, results( i_height, 1 ) .eq. 12.3_dk ) + call assert( 775945315, results( i_height, 2 ) .eq. 12.3_dk ) + call assert( 940837912, results( i_height, 3 ) .eq. 92.3_dk ) + call assert( 488205759, results( i_height, 4 ) .eq. 53.2_dk ) + call assert( 383057255, results( i_height, 5 ) .eq. 12.3_dk ) + call assert( 547949852, results( i_height, 6 ) .eq. 12.3_dk ) + call assert( 430367200, results( i_height, 7 ) .eq. 12.3_dk ) + call assert( 942743446, results( i_height, 8 ) .eq. 12.3_dk ) + call assert( 207636044, results( i_height, 9 ) .eq. 12.3_dk ) + call assert( 655003890, results( i_height, 10 ) .eq. 12.3_dk ) + call assert( 884904887, results( i_height, 11 ) .eq. 12.3_dk ) + end do + deallocate( cross_section ) + ! clean up deallocate( iter ) deallocate( grids ) diff --git a/test/unit/cross_section/cross_section_warehouse.F90 b/test/unit/cross_section/cross_section_warehouse.F90 index b997a93f..6117ca24 100644 --- a/test/unit/cross_section/cross_section_warehouse.F90 +++ b/test/unit/cross_section/cross_section_warehouse.F90 @@ -3,9 +3,16 @@ ! program test_cross_section_warehouse - use musica_mpi, only : musica_mpi_init, & - musica_mpi_finalize + use musica_assert, only : almost_equal, assert + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_init, musica_mpi_finalize, musica_mpi_rank, musica_mpi_bcast, & + MPI_COMM_WORLD + use musica_string, only : string_t + use tuvx_cross_section, only : cross_section_t use tuvx_cross_section_warehouse + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t implicit none @@ -18,16 +25,6 @@ program test_cross_section_warehouse !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine test_cross_section_warehouse_t( ) - - use musica_assert, only : almost_equal, assert - use musica_constants, only : dk => musica_dk - use musica_config, only : config_t - use musica_mpi - use musica_string, only : string_t - use tuvx_cross_section, only : cross_section_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - class(grid_warehouse_t), pointer :: grids class(profile_warehouse_t), pointer :: profiles class(cross_section_warehouse_t), pointer :: cross_sections diff --git a/test/unit/cross_section/hno3-oh_no2_test.F90 b/test/unit/cross_section/hno3-oh_no2_test.F90 index c62b4e6a..4032ea01 100644 --- a/test/unit/cross_section/hno3-oh_no2_test.F90 +++ b/test/unit/cross_section/hno3-oh_no2_test.F90 @@ -45,75 +45,135 @@ subroutine test_cross_section_hno3_oh_no2_t( ) ! So, these tests are testing that any changes don't produce unexpected ! changes. The values here are meaningless. no_extrap = reshape([ & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 6.35e-21, 6.28e-21, 6.21e-21, 6.14e-21, 6.07e-21, 6.01e-21, & - 1.27e-17, 1.25e-17, 1.24e-17, 1.22e-17, 1.21e-17, 1.20e-17, & - 1.14e-17, 1.12e-17, 1.11e-17, 1.10e-17, 1.09e-17, 1.07e-17, & - 1.00e-17, 9.89e-18, 9.78e-18, 9.67e-18, 9.57e-18, 9.46e-18, & - 8.41e-18, 8.31e-18, 8.22e-18, 8.13e-18, 8.05e-18, 7.96e-18, & - 6.68e-18, 6.60e-18, 6.53e-18, 6.46e-18, 6.39e-18, 6.33e-18, & - 5.09e-18, 5.03e-18, 4.98e-18, 4.92e-18, 4.87e-18, 4.82e-18, & - 3.81e-18, 3.76e-18, 3.72e-18, 3.68e-18, 3.64e-18, 3.60e-18, & - 2.74e-18, 2.71e-18, 2.68e-18, 2.65e-18, 2.62e-18, 2.59e-18, & - 1.90e-18, 1.87e-18, 1.85e-18, 1.83e-18, 1.81e-18, 1.79e-18, & - 1.27e-18, 1.26e-18, 1.24e-18, 1.22e-18, 1.21e-18, 1.19e-18, & - 5.35e-22, 5.28e-22, 5.21e-22, 5.15e-22, 5.08e-22, 5.02e-22, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0], & - (/ size(no_extrap, 2), size(no_extrap, 1) /) & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 6.35272794E-21, 6.28292740E-21, 6.21391491E-21, & + 6.14568136E-21, 6.07821774E-21, 6.01152535E-21, & + 1.27103729E-17, 1.25707177E-17, 1.24326394E-17, & + 1.22961194E-17, 1.21611400E-17, 1.20277036E-17, & + 1.14073753E-17, 1.12820368E-17, 1.11581135E-17, & + 1.10355888E-17, 1.09144467E-17, 1.07946895E-17, & + 1.00060382E-17, 9.89609694E-18, 9.78739694E-18, & + 9.67992382E-18, 9.57366339E-18, 9.46861771E-18, & + 8.41009301E-18, 8.31903871E-18, 8.22899780E-18, & + 8.13995871E-18, 8.05191002E-18, 7.96485376E-18, & + 6.68020845E-18, 6.60874219E-18, 6.53806213E-18, & + 6.46815940E-18, 6.39902523E-18, 6.33066143E-18, & + 5.09031945E-18, 5.03520764E-18, 4.98070919E-18, & + 4.92681712E-18, 4.87352449E-18, 4.82083254E-18, & + 3.81009039E-18, 3.76785972E-18, 3.72610992E-18, & + 3.68483537E-18, 3.64403051E-18, 3.60369606E-18, & + 2.74709876E-18, 2.71594406E-18, 2.68515211E-18, & + 2.65471858E-18, 2.62463919E-18, 2.59491429E-18, & + 1.90080756E-18, 1.87857899E-18, 1.85661710E-18, & + 1.83491859E-18, 1.81348025E-18, 1.79230211E-18, & + 1.27577108E-18, 1.26003270E-18, 1.24449323E-18, & + 1.22915010E-18, 1.21400077E-18, 1.19904502E-18, & + 5.35507275E-22, 5.28694862E-22, 5.21971170E-22, & + 5.15335016E-22, 5.08785237E-22, 5.02321672E-22, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00], & + (/ size(no_extrap, 2), size(no_extrap, 1) /) & ) lower_extrap = reshape([ real:: & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 1.27e-17, 1.25e-17, 1.24e-17, 1.22e-17, 1.21e-17, 1.20e-17, & - 1.14e-17, 1.12e-17, 1.11e-17, 1.10e-17, 1.09e-17, 1.07e-17, & - 1.00e-17, 9.89e-18, 9.78e-18, 9.67e-18, 9.57e-18, 9.46e-18, & - 8.41e-18, 8.31e-18, 8.22e-18, 8.13e-18, 8.05e-18, 7.96e-18, & - 6.68e-18, 6.60e-18, 6.53e-18, 6.46e-18, 6.39e-18, 6.33e-18, & - 5.09e-18, 5.03e-18, 4.98e-18, 4.92e-18, 4.87e-18, 4.82e-18, & - 3.81e-18, 3.76e-18, 3.72e-18, 3.68e-18, 3.64e-18, 3.60e-18, & - 2.74e-18, 2.71e-18, 2.68e-18, 2.65e-18, 2.62e-18, 2.59e-18, & - 1.90e-18, 1.87e-18, 1.85e-18, 1.83e-18, 1.81e-18, 1.79e-18, & - 1.27e-18, 1.26e-18, 1.24e-18, 1.22e-18, 1.21e-18, 1.19e-18, & - 5.35e-22, 5.28e-22, 5.21e-22, 5.15e-22, 5.08e-22, 5.02e-22, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0], & - (/ size(lower_extrap, 2), size(lower_extrap, 1) /) & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84878151E+02, 1.82846803E+02, 1.80838391E+02, & + 1.78852646E+02, 1.76889309E+02, 1.74948416E+02, & + 1.84790334E+02, 1.82759951E+02, 1.80752492E+02, & + 1.78767691E+02, 1.76805286E+02, 1.74865315E+02, & + 1.27103729E-17, 1.25707177E-17, 1.24326394E-17, & + 1.22961194E-17, 1.21611400E-17, 1.20277036E-17, & + 1.14073753E-17, 1.12820368E-17, 1.11581135E-17, & + 1.10355888E-17, 1.09144467E-17, 1.07946895E-17, & + 1.00060382E-17, 9.89609694E-18, 9.78739694E-18, & + 9.67992382E-18, 9.57366339E-18, 9.46861771E-18, & + 8.41009301E-18, 8.31903871E-18, 8.22899780E-18, & + 8.13995871E-18, 8.05191002E-18, 7.96485376E-18, & + 6.68020845E-18, 6.60874219E-18, 6.53806213E-18, & + 6.46815940E-18, 6.39902523E-18, 6.33066143E-18, & + 5.09031945E-18, 5.03520764E-18, 4.98070919E-18, & + 4.92681712E-18, 4.87352449E-18, 4.82083254E-18, & + 3.81009039E-18, 3.76785972E-18, 3.72610992E-18, & + 3.68483537E-18, 3.64403051E-18, 3.60369606E-18, & + 2.74709876E-18, 2.71594406E-18, 2.68515211E-18, & + 2.65471858E-18, 2.62463919E-18, 2.59491429E-18, & + 1.90080756E-18, 1.87857899E-18, 1.85661710E-18, & + 1.83491859E-18, 1.81348025E-18, 1.79230211E-18, & + 1.27577108E-18, 1.26003270E-18, 1.24449323E-18, & + 1.22915010E-18, 1.21400077E-18, 1.19904502E-18, & + 5.35507275E-22, 5.28694862E-22, 5.21971170E-22, & + 5.15335016E-22, 5.08785237E-22, 5.02321672E-22, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, & + 0.00000000E+00, 0.00000000E+00, 0.00000000E+00], & + (/ size(lower_extrap, 2), size(lower_extrap, 1) /) & ) upper_extrap = reshape([ real:: & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.33e-17, 1.32e-17, 1.30e-17, 1.29e-17, 1.27e-17, 1.26e-17, & - 1.27e-17, 1.25e-17, 1.24e-17, 1.22e-17, 1.21e-17, 1.20e-17, & - 1.14e-17, 1.12e-17, 1.11e-17, 1.10e-17, 1.09e-17, 1.07e-17, & - 1.00e-17, 9.89e-18, 9.78e-18, 9.67e-18, 9.57e-18, 9.46e-18, & - 8.41e-18, 8.31e-18, 8.22e-18, 8.13e-18, 8.05e-18, 7.96e-18, & - 6.68e-18, 6.60e-18, 6.53e-18, 6.46e-18, 6.39e-18, 6.33e-18, & - 5.09e-18, 5.03e-18, 4.98e-18, 4.92e-18, 4.87e-18, 4.82e-18, & - 3.81e-18, 3.76e-18, 3.72e-18, 3.68e-18, 3.64e-18, 3.60e-18, & - 2.74e-18, 2.71e-18, 2.68e-18, 2.65e-18, 2.62e-18, 2.59e-18, & - 1.90e-18, 1.87e-18, 1.85e-18, 1.83e-18, 1.81e-18, 1.79e-18, & - 1.27e-18, 1.26e-18, 1.24e-18, 1.22e-18, 1.21e-18, 1.19e-18, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0], & - (/ size(upper_extrap, 2), size(upper_extrap, 1) /) & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.33741641E-17, 1.32272156E-17, 1.30819261E-17, & + 1.29382766E-17, 1.27962479E-17, 1.26558428E-17, & + 1.27103729E-17, 1.25707177E-17, 1.24326394E-17, & + 1.22961194E-17, 1.21611400E-17, 1.20277036E-17, & + 1.14073753E-17, 1.12820368E-17, 1.11581135E-17, & + 1.10355888E-17, 1.09144467E-17, 1.07946895E-17, & + 1.00060382E-17, 9.89609694E-18, 9.78739694E-18, & + 9.67992382E-18, 9.57366339E-18, 9.46861771E-18, & + 8.41009301E-18, 8.31903871E-18, 8.22899780E-18, & + 8.13995871E-18, 8.05191002E-18, 7.96485376E-18, & + 6.68020845E-18, 6.60874219E-18, 6.53806213E-18, & + 6.46815940E-18, 6.39902523E-18, 6.33066143E-18, & + 5.09031945E-18, 5.03520764E-18, 4.98070919E-18, & + 4.92681712E-18, 4.87352449E-18, 4.82083254E-18, & + 3.81009039E-18, 3.76785972E-18, 3.72610992E-18, & + 3.68483537E-18, 3.64403051E-18, 3.60369606E-18, & + 2.74709876E-18, 2.71594406E-18, 2.68515211E-18, & + 2.65471858E-18, 2.62463919E-18, 2.59491429E-18, & + 1.90080756E-18, 1.87857899E-18, 1.85661710E-18, & + 1.83491859E-18, 1.81348025E-18, 1.79230211E-18, & + 1.27577108E-18, 1.26003270E-18, 1.24449323E-18, & + 1.22915010E-18, 1.21400077E-18, 1.19904502E-18, & + 2.07816741E+02, 2.05173017E+02, 2.02563723E+02, & + 1.99988400E+02, 1.97446598E+02, 1.94938253E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02, & + 2.07925902E+02, 2.05280789E+02, 2.02670124E+02, & + 2.00093449E+02, 1.97550312E+02, 1.95040649E+02], & + (/ size(upper_extrap, 2), size(upper_extrap, 1) /) & ) ! load test grids @@ -142,6 +202,7 @@ subroutine test_cross_section_hno3_oh_no2_t( ) call cs_set%get( iter, cs_config, Iam ) cross_section => cross_section_hno3_oh_no2_t( cs_config, grids, profiles ) results = cross_section%calculate( grids, profiles ) + call check_values( results, lower_extrap, .01_dk ) deallocate( cross_section ) diff --git a/test/unit/cross_section/rono2_test.F90 b/test/unit/cross_section/rono2_test.F90 index d1bde104..e6184407 100644 --- a/test/unit/cross_section/rono2_test.F90 +++ b/test/unit/cross_section/rono2_test.F90 @@ -45,29 +45,44 @@ subroutine test_cross_section_rono2_t( ) ! So, these tests are testing that any changes don't produce unexpected ! changes. The values here are meaningless. no_extrap = reshape([ real:: & - 3.33e-24, 3.21e-24, 3.10e-24, 2.99e-24, 2.89e-24, 2.79e-24, & - 4.01e-21, 3.87e-21, 3.73e-21, 3.60e-21, 3.47e-21, 3.35e-21, & - 3.22e-21, 3.10e-21, 2.99e-21, 2.88e-21, 2.77e-21, 2.67e-21, & - 2.55e-21, 2.45e-21, 2.36e-21, 2.27e-21, 2.18e-21, 2.10e-21, & - 1.75e-24, 1.68e-24, 1.61e-24, 1.55e-24, 1.49e-24, 1.43e-24], & + 3.3302044212254328E-024, 3.2161952124512202E-024, 3.1061223947672814E-024, & + 2.9998489273903812E-024, 2.8972425790838159E-024, 2.7981907562917913E-024, & + 4.0122656353068610E-021, 3.8717595318338420E-021, 3.7362148177227141E-021, & + 3.6054548800794594E-021, 3.4793094427501407E-021, 3.3576327537719567E-021, & + 3.2269583072774368E-021, 3.1085946499675142E-021, 2.9946069663498917E-021, & + 2.8848322221146335E-021, 2.7791135029650159E-021, 2.6773151777054408E-021, & + 2.5576809099900323E-021, 2.4589071748754612E-021, 2.3639765819585908E-021, & + 2.2727385030188113E-021, 2.1850482559046444E-021, 2.1007795988510739E-021, & + 1.7524893730671802E-024, 1.6829505050933260E-024, 1.6161910805734185E-024, & + 1.5520992136486835E-024, 1.4905675538255535E-024, 1.4315020191061525E-024], & (/ size(no_extrap, 2), size(no_extrap, 1) /) & ) lower_extrap = reshape([ real:: & - 0, 0, 0, 0, 0, 0, & - 4.01e-21, 3.87e-21, 3.73e-21, 3.60e-21, 3.47e-21, 3.35e-21, & - 3.22e-21, 3.10e-21, 2.99e-21, 2.88e-21, 2.77e-21, 2.67e-21, & - 2.55e-21, 2.45e-21, 2.36e-21, 2.27e-21, 2.18e-21, 2.10e-21, & - 1.75e-24, 1.68e-24, 1.61e-24, 1.55e-24, 1.49e-24, 1.43e-24], & + 284.35719862387975, 274.62225892536395, 265.22343707474488, & + 256.14903152812633, 247.38775141585484, 238.92998267703231, & + 4.0122656353068610E-021, 3.8717595318338420E-021, 3.7362148177227141E-021, & + 3.6054548800794594E-021, 3.4793094427501407E-021, 3.3576327537719567E-021, & + 3.2269583072774368E-021, 3.1085946499675142E-021, 2.9946069663498917E-021, & + 2.8848322221146335E-021, 2.7791135029650159E-021, 2.6773151777054408E-021, & + 2.5576809099900323E-021, 2.4589071748754612E-021, 2.3639765819585908E-021, & + 2.2727385030188113E-021, 2.1850482559046444E-021, 2.1007795988510739E-021, & + 1.7524893730671802E-024, 1.6829505050933260E-024, 1.6161910805734185E-024, & + 1.5520992136486835E-024, 1.4905675538255535E-024, 1.4315020191061525E-024], & (/ size(lower_extrap, 2), size(lower_extrap, 1) /) & ) upper_extrap = reshape([ real:: & - 4.41e-21, 4.25e-21, 4.11e-21, 3.97e-21, 3.83e-21, 3.70e-21, & - 4.01e-21, 3.87e-21, 3.73e-21, 3.60e-21, 3.47e-21, 3.35e-21, & - 3.22e-21, 3.10e-21, 2.99e-21, 2.88e-21, 2.77e-21, 2.67e-21, & - 2.55e-21, 2.45e-21, 2.36e-21, 2.27e-21, 2.18e-21, 2.10e-21, & - 0, 0, 0, 0, 0, 0], & + 4.4108667830913617E-021, 4.2598612085555927E-021, 4.1140693970533126E-021, & + 3.9733098376133487E-021, 3.8374073895248339E-021, 3.7062129222502928E-021, & + 4.0122656353068610E-021, 3.8717595318338420E-021, 3.7362148177227141E-021, & + 3.6054548800794594E-021, 3.4793094427501407E-021, 3.3576327537719567E-021, & + 3.2269583072774368E-021, 3.1085946499675142E-021, 2.9946069663498917E-021, & + 2.8848322221146335E-021, 2.7791135029650159E-021, 2.6773151777054408E-021, & + 2.5576809099900323E-021, 2.4589071748754612E-021, 2.3639765819585908E-021, & + 2.2727385030188113E-021, 2.1850482559046444E-021, 2.1007795988510739E-021, & + 291.32413139180113, 279.76437495516359, 268.66665781098493, & + 258.01238067351579, 247.78369819101036, 237.96497069299082], & (/ size(upper_extrap, 2), size(upper_extrap, 1) /) & ) ! load test grids diff --git a/test/unit/cross_section/util/CMakeLists.txt b/test/unit/cross_section/util/CMakeLists.txt new file mode 100644 index 00000000..6b2abbbd --- /dev/null +++ b/test/unit/cross_section/util/CMakeLists.txt @@ -0,0 +1,14 @@ +################################################################################ +# Test utilities + +include(test_util) + +################################################################################ +# Cross section utility tests + +create_standard_test( NAME temperature_parameterization_burkholder + SOURCES temperature_parameterization_burkholder.F90 ) +create_standard_test( NAME temperature_parameterization_taylor_series + SOURCES temperature_parameterization_taylor_series.F90 ) + +################################################################################ \ No newline at end of file diff --git a/test/unit/cross_section/util/temperature_parameterization_burkholder.F90 b/test/unit/cross_section/util/temperature_parameterization_burkholder.F90 new file mode 100644 index 00000000..eb05df26 --- /dev/null +++ b/test/unit/cross_section/util/temperature_parameterization_burkholder.F90 @@ -0,0 +1,102 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the temperature_parameterization_burkholder_t type +program test_temperature_parameterization_burkholder + + use musica_mpi, only : musica_mpi_init, & + musica_mpi_finalize + use tuvx_temperature_parameterization_burkholder + + implicit none + + call musica_mpi_init( ) + call test_burkholder_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_burkholder_t( ) + + use musica_assert, only : assert + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use musica_mpi + use musica_string, only : string_t + use tuvx_test_utils, only : check_values + + type(temperature_parameterization_burkholder_t) :: burkholder_param + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pack_size, pos + integer, parameter :: comm = MPI_COMM_WORLD + + call config%from_file( & + "test/data/cross_sections/util/burkholder.config.json" ) + + if( musica_mpi_rank( comm ) == 0 ) then + burkholder_param = temperature_parameterization_burkholder_t( config ) + pack_size = burkholder_param%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call burkholder_param%mpi_pack( buffer, pos, comm ) + call assert( 984049167, 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 burkholder_param%mpi_unpack( buffer, pos, comm ) + call assert( 761318011, pos <= pack_size ) + end if + deallocate( buffer ) + + ! Check temperature parameterization data members + call check_values( 756053704, burkholder_param%wavelengths_, & + (/ 302.0_dk, 304.0_dk, 306.0_dk, 308.0_dk, 310.0_dk /),& + 1.0e-6_dk ) + call check_values( 973109062, burkholder_param%AA_, & + (/ 13.3_dk, 14.4_dk, 15.5_dk, 16.6_dk, 17.7_dk /), & + 1.0e-6_dk ) + call check_values( 187744433, burkholder_param%BB_, & + (/ 21.4_dk, 22.3_dk, 23.2_dk, 24.1_dk, 25.0_dk /), & + 1.0e-6_dk ) + call assert( 301968312, burkholder_param%A_ == 12.5_dk ) + call assert( 521340695, burkholder_param%B_ == 202.3_dk ) + call assert( 405663577, size( burkholder_param%ranges_ ) == 3 ) + call assert( 800457171, burkholder_param%ranges_(1)%min_temperature_ == & + 0.0_dk ) + call assert( 412833418, burkholder_param%ranges_(1)%max_temperature_ == & + 209.999999999999_dk ) + call assert( 860201264, burkholder_param%ranges_(1)%is_fixed_ .eqv. & + .true. ) + call assert( 125093862, burkholder_param%ranges_(1)%fixed_temperature_ == & + 210.0_dk ) + call assert( 289986459, burkholder_param%ranges_(2)%min_temperature_ == & + 210.0_dk ) + call assert( 802362705, burkholder_param%ranges_(2)%max_temperature_ == & + 300.0_dk ) + call assert( 967255302, burkholder_param%ranges_(2)%is_fixed_ .eqv. & + .false. ) + call assert( 514623149, burkholder_param%ranges_(2)%fixed_temperature_ == & + 0.0_dk ) + call assert( 126999396, burkholder_param%ranges_(3)%min_temperature_ == & + 300.00000000001_dk ) + call assert( 574367242, burkholder_param%ranges_(3)%max_temperature_ == & + huge(1.0_dk) ) + call assert( 739259839, burkholder_param%ranges_(3)%is_fixed_ .eqv. & + .true. ) + call assert( 351636086, burkholder_param%ranges_(3)%fixed_temperature_ == & + 300.0_dk ) + + end subroutine test_burkholder_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_temperature_parameterization_burkholder \ No newline at end of file diff --git a/test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 b/test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 new file mode 100644 index 00000000..509cad13 --- /dev/null +++ b/test/unit/cross_section/util/temperature_parameterization_taylor_series.F90 @@ -0,0 +1,103 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +!> \file +!> Tests for the temperature_parameterization_taylor_series_t type +program test_temperature_parameterization_taylor_series + + use musica_mpi, only : musica_mpi_init, & + musica_mpi_finalize + use tuvx_temperature_parameterization_taylor_series + + implicit none + + call musica_mpi_init( ) + call test_taylor_series_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_taylor_series_t( ) + + use musica_assert, only : assert + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use musica_mpi + use musica_string, only : string_t + use tuvx_test_utils, only : check_values + + type(temperature_parameterization_taylor_series_t) :: taylor_param + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pack_size, pos + integer, parameter :: comm = MPI_COMM_WORLD + + call config%from_file( "test/data/cross_sections/util/taylor.config.json" ) + + if( musica_mpi_rank( comm ) == 0 ) then + taylor_param = temperature_parameterization_taylor_series_t( config ) + pack_size = taylor_param%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call taylor_param%mpi_pack( buffer, pos, comm ) + call assert( 857895829, 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 taylor_param%mpi_unpack( buffer, pos, comm ) + call assert( 960137855, pos <= pack_size ) + end if + deallocate( buffer ) + + ! Check temperature parameterization data members + call check_values( 405965907, taylor_param%wavelengths_, & + (/ 302.0_dk, 304.0_dk, 306.0_dk, 308.0_dk, 310.0_dk /),& + 1.0e-6_dk ) + call check_values( 973109062, taylor_param%sigma_, & + (/ 13.3_dk, 14.4_dk, 15.5_dk, 16.6_dk, 17.7_dk /), & + 1.0e-6_dk ) + call assert( 614095855, size( taylor_param%A_, dim = 1) == 2 ) + call check_values( 178709862, taylor_param%A_(1,:), & + (/ 21.4_dk, 22.3_dk, 23.2_dk, 24.1_dk, 25.0_dk /), & + 1.0e-6_dk ) + call check_values( 842091318, taylor_param%A_(2,:), & + (/ 6.0_dk, 7.0_dk, 8.0_dk, 9.0_dk, 10.0_dk /), & + 1.0e-6_dk ) + call assert( 161915997, taylor_param%base_temperature_ == 295.2_dk ) + call assert( 940974571, taylor_param%min_wavelength_ == 280.5_dk ) + call assert( 992095584, taylor_param%max_wavelength_ == 540.2_dk ) + call assert( 483530406, size( taylor_param%ranges_ ) == 3 ) + call assert( 815221134, taylor_param%ranges_(1)%min_temperature_ == & + 0.0_dk ) + call assert( 182355758, taylor_param%ranges_(1)%max_temperature_ == & + 209.999999999999_dk ) + call assert( 977207253, taylor_param%ranges_(1)%is_fixed_ .eqv. .true. ) + call assert( 242099851, taylor_param%ranges_(1)%fixed_temperature_ == & + 210.0_dk ) + call assert( 689467697, taylor_param%ranges_(2)%min_temperature_ == & + 210.0_dk ) + call assert( 301843944, taylor_param%ranges_(2)%max_temperature_ == & + 300.0_dk ) + call assert( 466736541, taylor_param%ranges_(2)%is_fixed_ .eqv. .false. ) + call assert( 914104387, taylor_param%ranges_(2)%fixed_temperature_ == & + 0.0_dk ) + call assert( 178996985, taylor_param%ranges_(3)%min_temperature_ == & + 300.00000000001_dk ) + call assert( 691373231, taylor_param%ranges_(3)%max_temperature_ == & + huge(1.0_dk) ) + call assert( 856265828, taylor_param%ranges_(3)%is_fixed_ .eqv. .true. ) + call assert( 403633675, taylor_param%ranges_(3)%fixed_temperature_ == & + 300.0_dk ) + + end subroutine test_taylor_series_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_temperature_parameterization_taylor_series \ No newline at end of file diff --git a/test/unit/heating_rates.F90 b/test/unit/heating_rates.F90 new file mode 100644 index 00000000..002821a3 --- /dev/null +++ b/test/unit/heating_rates.F90 @@ -0,0 +1,138 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +program test_heating_rates + + use musica_mpi, only : musica_mpi_init, & + musica_mpi_finalize + use tuvx_heating_rates + + implicit none + + call musica_mpi_init( ) + call test_heating_rates_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> @brief Test the heating rates + subroutine test_heating_rates_t( ) + + use musica_assert, only : assert + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_mpi, only : musica_mpi_bcast, & + musica_mpi_rank, & + MPI_COMM_WORLD + use musica_string, only : string_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_solver, only : radiation_field_t + use tuvx_spherical_geometry, only : spherical_geometry_t + use tuvx_test_utils, only : check_values + + type(heating_rates_t), pointer :: heating_rates + class(grid_warehouse_t), pointer :: grids + class(profile_warehouse_t), pointer :: profiles + + character(len=*), parameter :: Iam = "heating_rates_t tests" + type(config_t) :: config, sub_config, reactions_config + type(string_t), allocatable :: labels(:) + character, allocatable :: buffer(:) + integer :: pos, pack_size, i_height, i_wavelength + integer, parameter :: comm = MPI_COMM_WORLD + real(dk), parameter :: hc = 6.62608e-34_dk * 2.9979e8_dk / 1.e-9_dk + real(dk) :: bde(6,2), actinic_flux(5,6), etfl(6) + real(dk) :: wc(6) = (/ 425.0_dk, 475.0_dk, 525.0_dk, 575.0_dk, 625.0_dk, & + 675.0_dk /) + type(radiation_field_t) :: radiation_field + real(dk) :: calculated_rates(5,2), expected_rates(5,2) + type(la_sr_bands_t) :: la_srb + type(spherical_geometry_t) :: spherical_geometry + + call config%from_file( "test/data/heating_rates.json" ) + call config%get( "grids", sub_config, Iam ) + grids => grid_warehouse_t( sub_config ) + call config%get( "profiles", sub_config, Iam ) + profiles => profile_warehouse_t( sub_config, grids ) + + if( musica_mpi_rank( comm ) == 0 ) then + call config%get( "reactions", reactions_config, Iam ) + call sub_config%empty( ) + call sub_config%add( "reactions", reactions_config, Iam ) + heating_rates => heating_rates_t( sub_config, grids, profiles ) + pack_size = heating_rates%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call heating_rates%mpi_pack( buffer, pos, comm ) + call assert( 534250649, 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 + allocate( heating_rates ) + call heating_rates%mpi_unpack( buffer, pos, comm ) + call assert( 192483602, pos <= pack_size ) + end if + deallocate( buffer ) + + ! check labels + labels = heating_rates%labels( ) + call assert( 152892147, size(labels) == 2 ) + call assert( 437272930, labels(1) == "jfoo" ) + call assert( 884640776, labels(2) == "jbaz" ) + + ! check bond dissociation energies + call assert( 613305591, size( heating_rates%heating_parameters_ ) == 2 ) + bde(:,1) = max( 0.0_dk, hc * ( 2.0_dk - wc(:) ) / ( 2.0_dk * wc(:) ) ) + call check_values( heating_rates%heating_parameters_(1)%energy_, & + bde(:,1), 1.0e-4_dk ) + bde(:,2) = max( 0.0_dk, hc * ( 3000.0_dk - wc(:) ) / ( 3000.0_dk * wc(:) ) ) + call check_values( heating_rates%heating_parameters_(2)%energy_, & + bde(:,2), 1.0e-4_dk ) + + ! check calculated heating rates + calculated_rates(:,:) = 0.0_dk + allocate( radiation_field%fdr_(5,6), radiation_field%fdn_(5,6), & + radiation_field%fup_(5,6) ) + do i_wavelength = 1, 6 + etfl(i_wavelength) = 0.5_dk * ( 1.0e3_dk * 10.0_dk**i_wavelength + & + 1.0e4_dk * 10.0_dk**i_wavelength ) + end do + do i_height = 1, 5 + do i_wavelength = 1, 6 + radiation_field%fdr_( i_height, i_wavelength ) = & + 1.0_dk * i_height * i_wavelength + radiation_field%fdn_( i_height, i_wavelength ) = & + 2.0_dk * i_height * i_wavelength + radiation_field%fup_( i_height, i_wavelength ) = & + 3.0_dk * i_height * i_wavelength + actinic_flux( i_height, i_wavelength ) = & + 6.0_dk * i_height * i_wavelength * etfl( i_wavelength ) + expected_rates( i_height, 1 ) = & + dot_product( actinic_flux(i_height,:), bde(:,1) * 12.3_dk * 0.75_dk ) + expected_rates( i_height, 2 ) = 1.1_dk * & + dot_product( actinic_flux(i_height,:), bde(:,2) * 78.9_dk * 0.5_dk ) + end do + end do + call heating_rates%get( la_srb, spherical_geometry, grids, profiles, & + radiation_field, calculated_rates ) + + call check_values( calculated_rates, expected_rates, 1.0e-4_dk ) + + deallocate( grids ) + deallocate( profiles ) + deallocate( heating_rates ) + + end subroutine test_heating_rates_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_heating_rates diff --git a/test/unit/la_sr_bands.F90 b/test/unit/la_sr_bands.F90 index e5fb6c12..f1cbfed9 100644 --- a/test/unit/la_sr_bands.F90 +++ b/test/unit/la_sr_bands.F90 @@ -67,22 +67,31 @@ program test_la_sr_bands !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine test_optical_depth( ) - use tuvx_grid, only : grid_t - use tuvx_spherical_geometry, only : spherical_geometry_t + + use tuvx_profile, only : profile_t + use tuvx_grid, only : grid_t + use tuvx_spherical_geometry, only : spherical_geometry_t real(dk), allocatable :: air_vertical_column(:), air_slant_column(:) real(dk), allocatable :: o2_optical_depth(:,:) - class(grid_t), pointer :: height_grid => null( ) ! specified altitude working grid [km] - type(spherical_geometry_t) :: spherical_geometry + class(grid_t), pointer :: height_grid ! specified altitude working grid [km] + class(grid_t), pointer :: wavelength_grid ! [nm] + class(spherical_geometry_t), pointer :: spherical_geometry + class(profile_t), pointer :: air height_grid => grid_warehouse%get_grid( "height", "km" ) - allocate( air_vertical_column( height_grid%ncells_ ), & - air_slant_column( height_grid%ncells_ + 1 ) ) + wavelength_grid => grid_warehouse%get_grid( "wavelength", "nm" ) + air => profile_warehouse%get_profile( "air", "molecule cm-3" ) + + spherical_geometry => spherical_geometry_t( grid_warehouse ) + call spherical_geometry%set_parameters( 45.0_dk, grid_warehouse ) - allocate( o2_optical_depth(120, 38) ) + allocate( air_vertical_column( air%ncells_ ), & + air_slant_column( air%ncells_ + 1 ) ) + call spherical_geometry%air_mass( air%exo_layer_dens_, air_vertical_column,& + air_slant_column ) - air_vertical_column(:) = 1 - air_slant_column(:) = 3 + allocate( o2_optical_depth(height_grid%ncells_, wavelength_grid%ncells_) ) o2_optical_depth(:,:) = 0 ! just checking that it runs. This method apparently requires at least @@ -93,6 +102,9 @@ subroutine test_optical_depth( ) spherical_geometry ) deallocate( height_grid ) + deallocate( wavelength_grid ) + deallocate( air ) + deallocate( spherical_geometry ) deallocate( o2_optical_depth ) deallocate( air_vertical_column ) deallocate( air_slant_column ) 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/CMakeLists.txt b/test/unit/quantum_yield/CMakeLists.txt index c662cdcb..66a31f22 100644 --- a/test/unit/quantum_yield/CMakeLists.txt +++ b/test/unit/quantum_yield/CMakeLists.txt @@ -7,6 +7,7 @@ include(test_util) # Quantum yield tests create_standard_test(NAME quantum_yield SOURCES base.F90 ) +create_standard_test(NAME quantum_yield_h2so4_mills SOURCES h2so4_mills.F90 ) create_standard_test(NAME quantum_yield_no2_tint SOURCES no2_tint.F90 ) create_standard_test(NAME quantum_yield_tint SOURCES tint.F90 ) diff --git a/test/unit/quantum_yield/base.F90 b/test/unit/quantum_yield/base.F90 index a68e6fba..86044638 100644 --- a/test/unit/quantum_yield/base.F90 +++ b/test/unit/quantum_yield/base.F90 @@ -217,7 +217,7 @@ subroutine test_quantum_yield_t( ) call assert( 896493526, results( i_height, 8 ) == 0.932_dk ) call assert( 443861373, results( i_height, 9 ) == 0.122_dk ) call assert( 891229219, results( i_height, 10 ) == 0.122_dk ) - call assert( 438597066, results( i_height, 11 ) == 0.0_dk ) + call assert( 438597066, results( i_height, 11 ) == 0.243_dk ) end do call add_points( input, input_grid, 0.0_dk, 0.0_dk ) call check_values( results(:,1:4), input, input_grid, 6 ) diff --git a/test/unit/quantum_yield/h2so4_mills.F90 b/test/unit/quantum_yield/h2so4_mills.F90 new file mode 100644 index 00000000..90822fd0 --- /dev/null +++ b/test/unit/quantum_yield/h2so4_mills.F90 @@ -0,0 +1,210 @@ +! Copyright (C) 2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +program test_quantum_yield_h2so4_mills + + use musica_mpi + use tuvx_quantum_yield_h2so4_mills + + implicit none + + call musica_mpi_init( ) + call test_quantum_yield_h2so4_mills_t( ) + call musica_mpi_finalize( ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Test the temperature and pressure dependent H2SO4 quantum yield + !! calculations against previously generated results from an older version + !! of TUV + subroutine test_quantum_yield_h2so4_mills_t( ) + + use musica_assert, only : assert, die, almost_equal + use musica_config, only : config_t + use musica_constants, only : dk => musica_dk + use musica_io, only : io_t + use musica_io_netcdf, only : io_netcdf_t + use musica_string, only : string_t + use tuvx_constants, only : gas_constant, Avogadro, pi + use tuvx_cross_section, only : cross_section_t + use tuvx_grid, only : grid_t + use tuvx_grid_from_host, only : grid_from_host_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile, only : profile_t + use tuvx_profile_from_host, only : profile_from_host_t, & + profile_updater_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_quantum_yield, only : quantum_yield_t + use tuvx_quantum_yield_factory + use tuvx_test_utils, only : check_values + + character(len=*), parameter :: my_name = "h2so4 quantum yield test" + class(grid_warehouse_t), pointer :: grids + class(profile_warehouse_t), pointer :: profiles + class(quantum_yield_t), pointer :: quantum_yield + class(cross_section_t), pointer :: cross_section + type(config_t) :: config, qy_config, cs_config, grids_config, & + profiles_config + + class(grid_from_host_t), pointer :: heights + class(profile_from_host_t), pointer :: temperature, air + type(profile_updater_t) :: temperature_updater, air_updater + class(grid_t), pointer :: wavelength_grid + class(profile_t), pointer :: temperature_profile, air_profile + character, allocatable :: buffer(:) + real(kind=dk), allocatable :: update_temperatures(:), update_air(:) + real(kind=dk), allocatable :: file_temperatures(:), file_pressures(:), & + file_photo_rates(:,:,:), & + file_wavelengths(:), & + quantum_yields(:,:), cross_sections(:,:) + class(io_t), pointer :: file + type(string_t) :: type_name, file_name, var_name + integer :: pos, pack_size, n_bins, i_temp, i_pres, i_wl, i_height, n_wl, & + i_file_offset + integer, parameter :: comm = MPI_COMM_WORLD + + file_name = "test/data/quantum_yields/jh2so4.nc" + file => io_netcdf_t( file_name ) + var_name = "temperature" + call file%read( var_name, file_temperatures, my_name ) + var_name = "pressure" + call file%read( var_name, file_pressures, my_name ) + file_pressures(:) = file_pressures(:) * 100.0_dk ! convert hPa to Pa + var_name = "jh2so4" + call file%read( var_name, file_photo_rates, my_name ) + var_name = "wavelength" + call file%read( var_name, file_wavelengths, my_name ) + deallocate( file ) + + call config%from_file( "test/data/quantum_yields/h2so4_mills.config.json" ) + call config%get( "grids", grids_config, my_name ) + call config%get( "quantum yield", qy_config, my_name ) + call config%get( "cross section", cs_config, my_name ) + + n_bins = size( file_temperatures ) * size( file_pressures ) - 1 + heights => grid_from_host_t( "height", "km", n_bins ) + temperature => profile_from_host_t( "temperature", "K", n_bins ) + air => profile_from_host_t( "air", "molecule cm-3", n_bins ) + + grids => grid_warehouse_t( grids_config ) + call grids%add( heights ) + call profiles_config%empty( ) + profiles => profile_warehouse_t( profiles_config, grids ) + call profiles%add( temperature ) + call profiles%add( air ) + temperature_updater = profiles%get_updater( temperature ) + air_updater = profiles%get_updater( air ) + + cross_section => cross_section_t( cs_config, grids, profiles ) + + if( musica_mpi_rank( comm ) == 0 ) then + quantum_yield => quantum_yield_builder( qy_config, grids, profiles ) + type_name = quantum_yield_type_name( quantum_yield ) + pack_size = type_name%pack_size( comm ) + quantum_yield%pack_size( comm ) + allocate( buffer( pack_size ) ) + pos = 0 + call type_name%mpi_pack( buffer, pos, comm ) + call quantum_yield%mpi_pack( buffer, pos, comm ) + call assert( 837477723, 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 type_name%mpi_unpack( buffer, pos, comm ) + quantum_yield => quantum_yield_allocate( type_name ) + call quantum_yield%mpi_unpack( buffer, pos, comm ) + call assert( 599405941, pos <= pack_size ) + end if + deallocate( buffer ) + + i_height = 0 + allocate( update_temperatures( n_bins + 1 ) ) + allocate( update_air( n_bins + 1 ) ) + do i_temp = 1, size( file_temperatures ) + do i_pres = 1, size( file_pressures ) + i_height = i_height + 1 + update_temperatures( i_height ) = file_temperatures( i_temp ) + update_air( i_height ) = file_pressures( i_pres ) / gas_constant / & + update_temperatures( i_height ) * & + Avogadro * 1.0e-6_dk ! convert mol m-3 to molec cm-3 + end do + end do + call temperature_updater%update( edge_values = update_temperatures ) + call air_updater%update( edge_values = update_air ) + + quantum_yields = quantum_yield%calculate( grids, profiles ) + cross_sections = cross_section%calculate( grids, profiles ) + + wavelength_grid => grids%get_grid( "wavelength", "nm" ) + temperature_profile => profiles%get_profile( "temperature", "K" ) + air_profile => profiles%get_profile( "air", "molecule cm-3" ) + + n_wl = size( quantum_yields, 2 ) + i_file_offset = 1 + do i_wl = 1, n_wl + if ( almost_equal( file_wavelengths( 1 ), & + wavelength_grid%mid_( i_wl ) ) ) then + exit + end if + i_file_offset = i_file_offset + 1 + end do + call assert( 462064586, size( cross_sections, 2 ) .eq. n_wl ) + call assert( 234069123, size( file_photo_rates, 1 ) + i_file_offset - 1 & + .eq. n_wl ) + + i_height = 0 + do i_temp = 1, size( file_temperatures ) + do i_pres = 1, size( file_pressures ) + i_height = i_height + 1 + do i_wl = 1, i_file_offset - 1 + call assert( 897976065, & + almost_equal( quantum_yields( i_height, i_wl ), & + 1.0_dk ) ) + if( i_wl .eq. 2 ) then + call assert( 126374455, & + almost_equal( cross_sections( i_height, i_wl ), & + 6.3e-17_dk ) ) + else + call assert( 291267052, & + almost_equal( cross_sections( i_height, i_wl ), & + 0.0_dk ) ) + end if + end do + do i_wl = i_file_offset, n_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 + if( i_pres .eq. size( file_pressures ) .and. & + i_temp < size( file_temperatures ) ) cycle + call assert( 342289277, & + almost_equal( quantum_yields( i_height, i_wl ) * & + cross_sections( i_height, i_wl ), & + file_photo_rates( i_wl - i_file_offset + 1, i_temp, i_pres ), & + relative_tolerance = 1.0e-3_dk )) + end do + end do + end do + + ! clean up + deallocate( grids ) + deallocate( profiles ) + deallocate( quantum_yield ) + deallocate( cross_section ) + deallocate( wavelength_grid ) + deallocate( temperature_profile ) + deallocate( air_profile ) + deallocate( heights ) + deallocate( temperature ) + deallocate( air ) + + end subroutine test_quantum_yield_h2so4_mills_t + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_quantum_yield_h2so4_mills \ No newline at end of file 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/from_host.F90 b/test/unit/radiator/from_host.F90 index eea1e50c..9117bf73 100644 --- a/test/unit/radiator/from_host.F90 +++ b/test/unit/radiator/from_host.F90 @@ -3,9 +3,20 @@ ! program test_radiator_from_host - use musica_mpi, only : musica_mpi_init, & - musica_mpi_finalize - use tuvx_test_utils, only : check_values + use musica_mpi, only : musica_mpi_finalize, musica_mpi_init, musica_mpi_rank, musica_mpi_bcast, & + MPI_COMM_WORLD + use tuvx_grid, only : grid_t + use tuvx_radiator, only : radiator_t + use tuvx_cross_section_warehouse, only : cross_section_warehouse_t + use tuvx_grid_from_host, only : grid_from_host_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_radiator_from_host, only : radiator_updater_t, radiator_from_host_t + use musica_string, only : string_t + use musica_constants, only : dk => musica_dk + use musica_assert, only : assert, die + use tuvx_radiator_factory, only : radiator_type_name, radiator_allocate + use tuvx_test_utils, only : check_values implicit none @@ -19,31 +30,16 @@ program test_radiator_from_host subroutine test_radiator_from_host_t( ) - use musica_assert, only : assert, almost_equal, die - use musica_constants, only : dk => musica_dk - use musica_mpi - use musica_string, only : string_t - use tuvx_cross_section_warehouse, only : cross_section_warehouse_t - use tuvx_grid, only : grid_t - use tuvx_grid_from_host, only : grid_from_host_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_profile_warehouse, only : profile_warehouse_t - use tuvx_radiator, only : radiator_t - use tuvx_radiator_from_host, only : radiator_from_host_t, & - radiator_updater_t - use tuvx_radiator_factory, only : radiator_type_name, & - radiator_allocate - - class(radiator_t), pointer :: radiator - type(radiator_updater_t) :: radiator_updater + character, allocatable :: buffer(:) class(grid_t), pointer :: height, wavelength + class(radiator_t), pointer :: radiator + integer :: pos, pack_size + integer, parameter :: comm = MPI_COMM_WORLD + type(cross_section_warehouse_t) :: cross_sections type(grid_warehouse_t) :: grids type(profile_warehouse_t) :: profiles - type(cross_section_warehouse_t) :: cross_sections - character, allocatable :: buffer(:) - integer :: pos, pack_size + type(radiator_updater_t) :: radiator_updater type(string_t) :: type_name - integer, parameter :: comm = MPI_COMM_WORLD real(kind=dk), parameter :: tol = 1.0e-10_dk real(kind=dk) :: od(3,2) 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/test_utils.F90 b/test/unit/test_utils.F90 index c4d88bb8..7f01b4b7 100644 --- a/test/unit/test_utils.F90 +++ b/test/unit/test_utils.F90 @@ -15,8 +15,9 @@ module tuvx_test_utils subroutine check_values_1D( code, results, expected_results, & relative_tolerance ) - use musica_assert, only : assert, almost_equal + use musica_assert, only : assert, assert_msg, almost_equal use musica_constants, only : dk => musica_dk + use musica_string, only : to_char integer, intent(in) :: code real(kind=dk), intent(in) :: results(:) @@ -27,10 +28,15 @@ subroutine check_values_1D( code, results, expected_results, & call assert( code, size( results ) == size( expected_results ) ) do i_elem = 1, size( results ) - call assert( code, almost_equal( & + call assert_msg( code, almost_equal( & results( i_elem ), & expected_results( i_elem ), & - relative_tolerance)) + relative_tolerance), "Array check failed at index "// & + trim( to_char( i_elem ) )//"; expected "// & + trim( to_char( expected_results( i_elem ) ) )//" but got "// & + trim( to_char( results( i_elem ) ) )// & + " which is outside of tolerance "// & + trim( to_char( relative_tolerance ) ) ) end do end subroutine check_values_1D @@ -40,8 +46,9 @@ end subroutine check_values_1D subroutine check_values_2D( code, results, expected_results, & relative_tolerance ) - use musica_assert, only : assert, almost_equal + use musica_assert, only : assert, assert_msg, almost_equal use musica_constants, only : dk => musica_dk + use musica_string, only : to_char integer, intent(in) :: code real(kind=dk), intent(in) :: results(:,:) @@ -56,10 +63,17 @@ subroutine check_values_2D( code, results, expected_results, & size( results, dim = 2 ) == size( expected_results, dim = 2) ) do i_wavelength = 1, size( results, dim = 2 ) do i_level = 1, size( results, dim = 1 ) - call assert( code, almost_equal( & + call assert_msg( code, almost_equal( & results( i_level, i_wavelength ), & expected_results( i_level, i_wavelength ), & - relative_tolerance)) + relative_tolerance), "2D Array check failed at indices "// & + trim( to_char( i_level ) )//","// & + trim( to_char( i_wavelength ) )//"; expected "// & + trim( to_char( expected_results( i_level, i_wavelength ) ) ) & + //" but got "// & + trim( to_char( results( i_level, i_wavelength ) ) )// & + " which is outside of tolerance "// & + trim( to_char( relative_tolerance ) ) ) end do end do diff --git a/test/unit/tuv_doug/CMakeLists.txt b/test/unit/tuv_doug/CMakeLists.txt index b5d422d0..5de66475 100644 --- a/test/unit/tuv_doug/CMakeLists.txt +++ b/test/unit/tuv_doug/CMakeLists.txt @@ -20,16 +20,21 @@ target_sources(tuv_doug inter2.f inter3.f inter4.f + la_srb.f + lymana.f + rdo2xs.f + schum.f + ../test_utils.F90 ) add_subdirectory(JCALC) -target_link_libraries(tuv_doug PUBLIC musica::tuvx musica::musicacore) +target_link_libraries(tuv_doug PUBLIC musica::tuvx) ################################################################################ # Tests refactored configurations based on Doug's data sets and Fortran code -add_executable(test_data_sets data_sets.F90 ../test_utils.F90) +add_executable(test_data_sets data_sets.F90) target_link_libraries(test_data_sets PUBLIC tuv_doug) if(ENABLE_OPENMP) target_link_libraries(test_data_sets PUBLIC OpenMP::OpenMP_Fortran) @@ -37,3 +42,14 @@ endif() add_tuvx_test(data_sets test_data_sets "" ${CMAKE_BINARY_DIR}) ################################################################################ + +# Tests the Lymann-Alpha and Schumann Runge bands calculations in TUV-x against +# Doug's version used to generate the lookup tables used in CAM +add_executable(test_la_srb_lut test_la_srb.F90) +target_link_libraries(test_la_srb_lut PUBLIC tuv_doug) +if(ENABLE_OPENMP) + target_link_libraries(test_la_srb_lut PUBLIC OpenMP::OpenMP_Fortran) +endif() +add_tuvx_test(la_srb_lut test_la_srb_lut "" ${CMAKE_BINARY_DIR}) + +################################################################################ diff --git a/test/unit/tuv_doug/JCALC/CMakeLists.txt b/test/unit/tuv_doug/JCALC/CMakeLists.txt index 93fd2604..20069a21 100644 --- a/test/unit/tuv_doug/JCALC/CMakeLists.txt +++ b/test/unit/tuv_doug/JCALC/CMakeLists.txt @@ -3,9 +3,30 @@ target_sources(tuv_doug PRIVATE + XSQY_ACETONE.f + XSQY_BRO.f + XSQY_BRONO2.f + XSQY_CF2CL2.f + XSQY_CFC113.f + XSQY_CFC114.f + XSQY_CFC115.f + XSQY_CFCL3.f XSQY_CH2BR2.f + XSQY_CH3BR.f + XSQY_CH3CL.f + XSQY_CHBR3.f + XSQY_CL2O2.f + XSQY_CLO.f XSQY_H2O.f + XSQY_H1301.f + XSQY_H2402.f + XSQY_HCFC22.f + XSQY_HCFC141b.f + XSQY_HCFC142b.f + XSQY_HNO3.f + XSQY_HO2NO2.f XSQY_N2O5.f + XSQY_SO2.f ) ################################################################################ diff --git a/test/unit/tuv_doug/JCALC/XSQY_ACETONE.f b/test/unit/tuv_doug/JCALC/XSQY_ACETONE.f new file mode 100644 index 00000000..f5dd4d1f --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_ACETONE.f @@ -0,0 +1,274 @@ + SUBROUTINE XSQY_ACETONE(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,pn) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Provide product (cross section) x (quantum yield) for CH3COCH3 photolysis! +! CH3COCH3 + hv -> Products ! +! ! +! Cross section: Choice between ! +! (1) Calvert and Pitts ! +! (2) Martinez et al., 1991, alson in IUPAC 97 ! +! (3) NOAA, 1998, unpublished as of 01/98 ! +! Quantum yield: Choice between ! +! (1) Gardiner et al, 1984 ! +! (2) IUPAC 97 ! +! (3) McKeen et al., 1997 ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lower limits of wavelength intervals in (I)! +! working wavelength grid ! +! WC - REAL, vector of center points of wavelength intervals in (I)! +! working wavelength grid ! +! NZ - INTEGER, number of altitude levels in working altitude grid (I)! +! TLEV - REAL, temperature (K) at each specified altitude level (I)! +! AIRDEN - REAL, air density (molec/cc) at each altitude level (I)! +! J - INTEGER, counter for number of weighting functions defined (IO)! +! SQ - REAL, cross section x quantum yield (cm^2) for each (O)! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)! +! defined ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + INCLUDE 'params' + +!---------------------------------------------------------------------------! +! ... input ! +!---------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airden(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter (kdata=150) + + integer i, n, n1, n2, n3, iw, ierr, iz, idum + real x1(kdata), x2(kdata), A(kdata), B(kdata), C(kdata) + real y1(kdata), y2(kdata), y3(kdata) + real xs(nz,kdata), sig(nz,kw) + real yg(kw), yg1(kw), yg2(kw), yg3(kw) + real tin(nz), AD(nz) + real qytot(kw), qyCO(kw), qyCH3CO(kw) + real AA0, a0, b0 + real AA1, a1, b1, t, qy + real AA2, AA3, AA4, a2, b2, a3, b3, c3, a4, b4 + + !!! TUV-x MOD - initializing qyCO, qyCH3CO !!! + qyCO(:) = 0.0 + qyCH3CO(:) = 0.0 + !!! end TUV-x mod !!! + +!--------------------------------------------- +! ... tin set to tlev +!--------------------------------------------- + tin(:) = tlev(:) + AD (:) = airden(:) + +!--------------------------------------------- +! ... CH3COCH3 photodissociation +!--------------------------------------------- + j = j + 1 + jlabel(j) = 'CH3COCH3 + hv -> CH3CO3 + CH3O2' + +!--------------------------------------------- +! ... cross sections JPL06 +!--------------------------------------------- + open(kin,file=TRIM(pn)//'XS_ACETONE_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) x1(i), y1(i) +! print*, x1(i), y1(i) + enddo + close(kin) + +!--------------------------------------------- +! ... cross sections TD coeff JPL06 +!--------------------------------------------- + open(kin,file=TRIM(pn)//'XS_ACETONE_TD_JPL06.txt',status='old') + + read(kin,*) idum, n1 + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n1 + read(kin,*) x1(i), A(i), B(i), C(i) + A(i) = A(i)*1e-3 + B(i) = B(i)*1e-5 + C(i) = C(i)*1e-8 +! print*, x1(i), y1(i), A(i), B(i), C(i) + enddo + close(kin) +! stop +!--------------------------------------------- +! ... Derive XS at given temperature +!--------------------------------------------- + + do iz = 1, nz + + do iw = 1, n1 + + if ((tin(iz) .GE. 235.) .AND. (tin(iz) .LE. 298.)) Then + xs(iz,iw) = y1(iw) *( 1 + (A(iw)*tin(iz)) + + & (B(iw)*tin(iz)**2) + + & (C(iw)*tin(iz)**3) ) + + endif + + if (tin(iz) .LT. 235.) then + xs(iz,iw) = y1(iw) *( 1 + (A(iw)*235.) + + & (B(iw)*(235.)**2) + + & (C(iw)*(235.)**3) ) + + endif + + if (tin(iz) .GT. 298.) then + xs(iz,iw) = y1(iw) *( 1 + (A(iw)*298.) + + & (B(iw)*(298.)**2) + + & (C(iw)*(298.)**3) ) + + endif + + enddo + + n = n1 + x2(:) = x1(:) + y2(:) = xs(iz,:) + +!--------------------------------------------- +! ... Interpolate +!--------------------------------------------- + call addpnt(x2,y2,kdata,n,x2(1)*(1.-deltax),0.) + call addpnt(x2,y2,kdata,n, 0.,0.) + call addpnt(x2,y2,kdata,n,x2(n)*(1.+deltax),0.) + call addpnt(x2,y2,kdata,n, 1e38,0.) + call inter2(nw,wl,yg, n,x2, y2,ierr) + + sig(iz,:) = yg(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + + enddo + +!--------------------------------------------- +! ... Check Routine +! iz = 10 +! print*, 'tin=', tin(iz) +! do iw = 40, 80 +! print*, iw, wc(iw), sig(iz,iw) +! enddo +! stop +!--------------------------------------------- +!--------------------------------------------- +! ... quantum yield JPL06 +!--------------------------------------------- + DO iz = 1, nz + + T = min(tin(iz), 295.) + T = max(T, 218.) + + DO iw = 1, nw-1 + + IF ((wc(iw) .GE. 279.).AND.(wc(iw) .LT. 327.) ) THEN + + a0 = 0.350* (T/295.)**(-1.28) + b0 = 0.068* (T/295.)**(-2.65) + AA0 = (a0 / (1-a0))* exp(b0*(wc(iw)-248.)) + qyCO(iw) = 1. / (1. + AA0) + ! print*, 'qyCO', qyCO(iw) + + ENDIF + + IF ((wc(iw) .GE. 279.).AND.(wc(iw) .LT. 302.)) THEN + + a1 = 1.6e-19* (T/295.)**(-2.38) + b1 = 0.55e-3* (T/295.)**(-3.19) + AA1 = a1* exp(-b1*((1e7/wc(iw)) - 33113.)) + qyCH3CO(iw) = (1-qyCO(iw)) / (1 + AA1*AD(iz)) + + ! print*, 'qyCO', qyCO(iw), 'qyCH3CO', qyCH3CO(iw) + + ELSEIF ((wc(iw) .GE. 302.).AND.(wc(iw) .LE. 327.5)) THEN + + a2= 1.62e-17* (T/295.)**(-10.03) + b2= 1.79e-3 * (T/295.)**(-1.364) + AA2= a2* exp(-b2*((1e7/wc(iw))-30488.)) + + a3= 26.29* (T/295.)**(-6.59) + b3= 5.72e-7* (T/295.)**(-2.93) + c3= 30006.* (T/295.)**(-0.064) + AA3= a3* exp(-b3*((1e7/wc(iw))-c3)**2) + + a4= 1.67e-15* (T/295.)**(-7.25) + b4= 2.08e-3* (T/295.)**(-1.16) + AA4= a4* exp(-b4*((1e7/wc(iw)) - 30488.)) + + qyCH3CO(iw) = ((1 + AA4*AD(iz) + AA3) / + & ((1 + AA2*AD(iz) + AA3)* + & (1 + AA4*AD(iz))))*(1-qyCO(iw)) + +! print*, 'qyCH3CO', qyCH3CO(iw) + + ELSEIF (wc(iw) .GT. 327.5) THEN + qytot(iw) = 0. + ENDIF + + qytot(iw) = qyCO(iw) + qyCH3CO(iw) + + if (wc(iw) .LT. 279.) then + qytot(iw) = 1.0 + endif + + qytot(iw) = max(0., qytot(iw)) + qytot(iw) = min(1., qytot(iw)) + + + sq(j,iz,iw) = sig(iz,iw)*qytot(iw) + + ENDDO + ENDDO +!--------------------------------------------- +! ... Check Routine +! iz = 10 +! print*, 'tin=', tin(iz) +! do iw = 40, 80 +! print*, iw, wc(iw), sig(iz,iw), qytot(iw) +! print*, iw, wc(iw), sq(j,iz,iw) +! enddo +! stop +!--------------------------------------------- +! c210417 there are issues with Actone being less than zero. +! do iz = 1, nz-1 +! do iw = 1, nw-1 +! IF (sq(j,iz,iw) .LE. 0.0) THEN +! sq(j,iz,iw) = 0.0 +! ENDIF +! ENDDO +! ENDDO + + end subroutine XSQY_ACETONE diff --git a/test/unit/tuv_doug/JCALC/XSQY_BRO.f b/test/unit/tuv_doug/JCALC/XSQY_BRO.f new file mode 100644 index 00000000..df054c6e --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_BRO.f @@ -0,0 +1,116 @@ + subroutine XSQY_BRO(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield): ! +! BrO + hv -> Br + O ! +! cross section: JPL06 ! +! quantum yield: is unity. ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/27/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, ierr, iz + real x1(kdata) + real y1(kdata) + real yg(kw) + real qy + +!---------------------------------------------- +! ... jlabel(j) = 'BRO + hv -> Br + O' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'BRO + hv -> Br + O' + +!---------------------------------------------------- +! ... cross sections from JPL06 recommendation +!---------------------------------------------------- +! ... 0.5nm resolution JPL06. + open(kin,file=TRIM(pn)//'XS_BRO_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + close(kin) + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + call inter2(nw,wl,yg, n,x1, y1,ierr) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + +!------------------------------------------------------- +! ... quantum yield (assumed) to be unity (JPL06) +!------------------------------------------------------- + qy = 1.0 + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * yg(iw) + + enddo + enddo + +!------------------------------------------------------- +! ... Check Routine +! do iw = 61, 87 +! print*, iw, wc(iw), (qy * yg(iw)) +! enddo +! stop +!------------------------------------------------------- + + end subroutine XSQY_BRO diff --git a/test/unit/tuv_doug/JCALC/XSQY_BRONO2.f b/test/unit/tuv_doug/JCALC/XSQY_BRONO2.f new file mode 100644 index 00000000..5083671a --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_BRONO2.f @@ -0,0 +1,176 @@ + subroutine XSQY_BRONO2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for brono2 photolysis: ! +! BrONO2 + hv -> products ! +! ! +! cross section: jpl 06 recommendation ! +! quantum yield: jpl 06 recommendation ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/27/07: Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=200) + integer i, iw, n, n1, idum, ierr, iz + real x1 (kdata), y1(kdata) + real xin (kdata) + real a1 (kdata), a2(kdata) + real ytmp(nz,kdata) + real ytd (nz,kw) + real yg1 (kw) + real tin (nz) + real qy1 + real qy2 +!----------------------------------------------- +! ... tin set to tlev +!----------------------------------------------- + tin(:) = tlev(:) + +!----------------------------------------------- +! ... jlabel(j) = 'BrONO2 + hv -> Br + NO3' +! ... jlabel(j) = 'BrONO2 + hv -> BrO + NO2' +!----------------------------------------------- + j = j+1 + jlabel(j) = 'BrONO2 + hv -> Br + NO3' + +!----------------------------------------------- +! ... cross sections from JPL06 +!----------------------------------------------- + open(kin, + & file=TRIM(pn)//'XS_BRONO2_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do iw = 1, n + read(kin,*) xin(iw), y1(iw) + enddo + close(kin) + +!----------------------------------------------- +! ... Read in temperature dep coeff +!----------------------------------------------- + open(kin, + & file=TRIM(pn)//'XS_BRONO2_td_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do iw = 1, n + read(kin,*) xin(iw), a1(iw), a2(iw) + enddo + close(kin) + +!----------------------------------------------- +! ... derive T-dep (200-296K) +!----------------------------------------------- + do iz = 1, nz + do iw = 1 , n + if ((tin(iz) .GE. 200.) .AND. (tin(iz) .LE. 296.)) Then + ytmp(iz,iw) = y1(iw) * + & ( 1. + + & A1(iw)* (tin(iz)-296.) + + & A2(iw)*((tin(iz)-296.)**2) + & ) + endif + if (tin(iz) .LT. 200.) then + ytmp(iz,iw) = y1(iw) * + & ( 1. + + & A1(iw)* (200.-296.) + + & A2(iw)*((200.-296.)**2) + & ) + endif + if (tin(iz) .GT. 296.) then + ytmp(iz,iw) = y1(iw) + endif + enddo + enddo + +!----------------------------------------------- +! ... Interpolate +!----------------------------------------------- + do iz = 1, nz + n1 = n + y1 = ytmp(iz,:) + x1 = xin + + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------- +! ...Quantum yields JPL06 +! ...This recommendation is only for >300nm +! However, it is used at all wavelengths +!---------------------------------------------- + qy1 = 0.85 + qy2 = 0.15 + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy1 * ytd(iz,iw) + sq(j+1,iz,iw) = qy2 * ytd(iz,iw) + enddo + enddo + + j = j+1 + jlabel(j) = 'BrONO2 + hv -> BrO + NO2' + + end subroutine XSQY_BRONO2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f b/test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f new file mode 100644 index 00000000..c9fab686 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CF2CL2.f @@ -0,0 +1,234 @@ + subroutine XSQY_CF2CL2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cf2cl2 photolysis: ! +! CF2Cl2 + hv -> 2Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/16/08 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + + AA(1) = -43.8954569 + AA(2) = -2.403597e-1 + AA(3) = -4.2619e-4 + AA(4) = 9.8743e-6 + + BB(1) = 4.8438e-3 + BB(2) = 4.96145e-4 + BB(3) = -5.6953e-6 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'CF2Cl2 + hv -> 2Cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CF2Cl2 + hv -> 2Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 220-296K and 200 nm-231 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 200.) .AND. (wc(iw) .LE.231.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 220.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)-200.)**lp(nloop) + enddo + do nloop = 1, 3 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + (220.-296.)* BB(nloop)*(wc(iw)-200.)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 220.).AND.(tin(iz) .LE. 296.)) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)-200.)**lp(nloop) + enddo + do nloop = 1, 3 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + (tin(iz)-296.)* BB(nloop)*(wc(iw)-200.)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 296.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)-200.)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >232 nm and <200 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CF2CL2_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + + close(kin) +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 200nm + do i = 1, n + IF (xin(i) .LT. 200.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 200-231 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = exp(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >231nm + do i = 1, n + IF (xin(i) .GT. 231.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo +!-------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!-------------------------------------------------- +!-------------------------------------------------- +! ...quantum yield assumed to be unity +!-------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CF2CL2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFC113.f b/test/unit/tuv_doug/JCALC/XSQY_CFC113.f new file mode 100644 index 00000000..8a3e4ac1 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFC113.f @@ -0,0 +1,233 @@ + subroutine XSQY_CFC113(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! CFC113 + hv -> 3Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -1087.9 + AA(2) = 20.004 + AA(3) = -1.3920e-1 + AA(4) = 4.2828e-4 + AA(5) = -4.9384e-7 + + BB(1) = 12.493 + BB(2) = -2.3937e-1 + BB(3) = 1.7142e-3 + BB(4) = -5.4393e-6 + BB(5) = 6.4548e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'cfc113 -> 3cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFC113 + hv -> 3Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 182 nm-230 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 182.) .AND. (wc(iw) .LE.230.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >230nm and <182 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFC113_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 182nm + do i = 1, n + IF (xin(i) .LT. 182.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 182-230 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >230nm + do i = 1, n + IF (xin(i) .GT. 230.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFC113 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFC114.f b/test/unit/tuv_doug/JCALC/XSQY_CFC114.f new file mode 100644 index 00000000..d51129ec --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFC114.f @@ -0,0 +1,224 @@ + subroutine XSQY_CFC114(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! CFC114 + hv -> 2Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -160.50 + AA(2) = 2.4807 + AA(3) = -1.5202e-2 + AA(4) = 3.8412e-5 + AA(5) = -3.4373e-8 + + BB(1) = -1.5296 + BB(2) = 3.5248e-2 + BB(3) = -2.9951e-4 + BB(4) = 1.1129e-6 + BB(5) = -1.5259e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'cfc114 -> 2cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFC114 + hv -> 2Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-220 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.220.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFC114_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... 172-220 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >20nm + do i = 1, n + IF (xin(i) .GT. 220.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFC114 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFC115.f b/test/unit/tuv_doug/JCALC/XSQY_CFC115.f new file mode 100644 index 00000000..f5253398 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFC115.f @@ -0,0 +1,227 @@ + subroutine XSQY_CFC115(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! CFC115 + hv -> Cl ! +! cross section: from JPL10 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(4), BB(4), lp(4) + real qy, ysave + + AA(1) = 5.8281 + AA(2) = -2.9990e-1 + AA(3) = 1.3525e-3 + AA(4) = -2.6851e-6 + + BB(1) = 0.0 + BB(2) = 0.0 + BB(3) = 0.0 + BB(4) = 0.0 + + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'cfc115 -> cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFC115 + hv -> Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-204 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.204.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,4 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFC115_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... 172-204 nm +! do i = 1, iwc-1 +! ycomb(iz,icnt) = 10**(ytmp(iz,i)) +! wcb (icnt) = wctmp(i) +! icnt = icnt+1 +! enddo +! ... >204nm + +!NOTE: I left the temperature depence logic in, but am not using it. +! See comment in JPL-10. +! These results are from Table 4F-40. + do i = 1, n + IF (xin(i) .GE. 170.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFC115 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CFCL3.f b/test/unit/tuv_doug/JCALC/XSQY_CFCL3.f new file mode 100644 index 00000000..d2d89948 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CFCL3.f @@ -0,0 +1,231 @@ + subroutine XSQY_CFCL3(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfcl3 photolysis: ! +! CFCl3 + hv -> 3Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/16/08 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -84.611 + AA(2) = 7.9551e-1 + AA(3) = -2.0550e-3 + AA(4) = -4.4812e-6 + AA(5) = 1.5838e-8 + + BB(1) = -5.7912 + BB(2) = 1.1689e-1 + BB(3) = -8.8069e-4 + BB(4) = 2.9335e-6 + BB(5) = -3.6421e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'CFCl3 + hv -> 3Cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'CFCl3 + hv -> 3Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 174 nm-230 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 174.) .AND. (wc(iw) .LE.230.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >230 nm and <174 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CFCL3_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + + close(kin) +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 174nm + do i = 1, n + IF (xin(i) .LT. 174.1) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 174-230 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >230nm + do i = 1, n + IF (xin(i) .GT. 230.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!--------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- +!--------------------------------------------------- +! ...quantum yield assumed to be unity +!--------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CFCL3 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CH3BR.f b/test/unit/tuv_doug/JCALC/XSQY_CH3BR.f new file mode 100644 index 00000000..687b8d3d --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CH3BR.f @@ -0,0 +1,235 @@ + subroutine XSQY_CH3BR(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for ch3br photolysis: ! +! CH3Br + hv -> Br ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1(kdata) + real xin (kdata), yin(kdata) + real ytmp (nz,kdata) + real ycomb(nz,kdata) + real wctmp(kdata), wcb(kdata) + real yg1 (kw) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real tin(nz) + real ysave, qy + + AA(1) = 46.520 + AA(2) = -1.4580 + AA(3) = 1.1469e-2 + AA(4) = -3.7627e-5 + AA(5) = 4.3264e-8 + + BB(1) = 9.3408e-1 + BB(2) = -1.6887e-2 + BB(3) = 1.1487e-4 + BB(4) = -3.4881e-7 + BB(5) = 3.9945e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'CH3Br -> Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'CH3Br + hv -> Br' + +!---------------------------------------------------------- +! Derive temperature dependence +!---------------------------------------------------------- +! Temperature dependence good between 210-300K and 200-280nm + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 200.) .AND. (wc(iw) .LE.280.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!---------------------------------------------------------- +! ... For wavelengths >280nm and <200 nm +!---------------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CH3BR_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------------------- +! ... Combine cross sections +!---------------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 200nm + do i = 1, n + IF (xin(i) .LT. 200.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 200-280 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >280nm + do i = 1, n + IF (xin(i) .GT. 280.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!---------------------------------------------------------- +! ... interpolate +!---------------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------------- +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- +!---------------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CH3BR diff --git a/test/unit/tuv_doug/JCALC/XSQY_CH3CL.f b/test/unit/tuv_doug/JCALC/XSQY_CH3CL.f new file mode 100644 index 00000000..7f14e97a --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CH3CL.f @@ -0,0 +1,236 @@ + subroutine XSQY_CH3CL(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for ch3cl photolysis: ! +! ch3cl + hv -> products ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real ytd (nz,kw), tin (nz) + real AA(5), BB(5), lp(5) + real yg1 (kw) + real qy, ysave + + AA(1) = -299.80 + AA(2) = 5.1047 + AA(3) = -3.3630e-2 + AA(4) = 9.5805e-5 + AA(5) = -1.0135e-7 + + BB(1) = -7.1727 + BB(2) = 1.4837e-1 + BB(3) = -1.1463e-3 + BB(4) = 3.9188e-6 + BB(5) = -4.9994e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'CH3Cl + hv -> Cl' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'CH3Cl + hv -> Cl' + +!---------------------------------------------- +! Derive temperature dependence +!---------------------------------------------- +! Temperature dependence good between 210-300K +! and 174 nm-216 nm. +!---------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 174.) .AND. (wc(iw) .LE.216.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!---------------------------------------------- +! ... For wavelengths >216 nm and <174 nm +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CH3CL_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------- +! ... Combine cross sections +!---------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 174nm + do i = 1, n + IF (xin(i) .LT. 174.1) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 174-216 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >216nm + do i = 1, n + IF (xin(i) .GT. 216.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo + +!---------------------------------------------- +! ... interpolate +!---------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------- +! Check routine +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------- +! Check routine +! iz = 1 +! do iw = 19, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- +!---------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CH3CL diff --git a/test/unit/tuv_doug/JCALC/XSQY_CHBR3.f b/test/unit/tuv_doug/JCALC/XSQY_CHBR3.f new file mode 100644 index 00000000..d7351720 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CHBR3.f @@ -0,0 +1,241 @@ + subroutine XSQY_CHBR3(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for chbr3 photolysis: ! +! CHBr3 + hv -> 3Br ! +! cross section: from Papanastasiou et al, ACP, 2014 ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/02/14 Doug Kinnison ! +! 09/17/14 added <260 +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloopAA, nloopBB, n1 + integer ierr, iz, iwc, icnt + + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata),ycomb(nz,kdata) + real yg1 (kw), ytd (nz,kw) + real qy + real AA(6), BB(5), lp(6) + real tin(nz) + + AA(1) = -32.6067 + AA(2) = 0.10308 + AA(3) = 6.39e-5 + AA(4) = -7.7392e-7 + AA(5) = -2.2513e-9 + AA(6) = 6.1376e-12 + + BB(1) = 0.1582 + BB(2) = -0.0014758 + BB(3) = 3.8058e-6 + BB(4) = 9.187e-10 + BB(5) = -1.0772e-11 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + lp(6) = 5.0 + +!---------------------------------------------- +! ... set tin to tlev +!---------------------------------------------- + tin(:) = tlev(:) +!---------------------------------------------- +! ... jlabel(j) = 'CHBr3 + hv -> 3Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'CHBr3 + hv -> 3Br' + +!---------------------------------------------- +! Derive temperature dependence +!---------------------------------------------- +! Temperature dependence good between +! 260-330K and 260 nm to 345 nm +! 99% of the loss in this region +!---------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + +! Extrapolate to 357.5nm with TUV grid + IF ((wc(iw) .GE. 260.) .AND. (wc(iw) .LE. 362.)) THEN + do iz = 1, nz + + IF (tin(iz) .LT. 260.) THEN + do nloopAA = 1, 6 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloopAA)* (wc(iw)**lp(nloopAA)) + enddo + do nloopBB = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + + & (296.0-260.0)*BB(nloopBB)*wc(iw)**lp(nloopBB) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 260.).AND.(tin(iz) .LE. 330.)) THEN + do nloopAA = 1, 6 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloopAA)* (wc(iw)**lp(nloopAA)) + enddo + do nloopBB = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + + & (296.0-tin(iz))*BB(nloopBB)*wc(iw)**lp(nloopBB) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 330.) THEN + do nloopAA = 1, 6 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloopAA)* (wc(iw)**lp(nloopAA)) + enddo + do nloopBB = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + + & (296.0-tin(iz))*BB(nloopBB)*wc(iw)**lp(nloopBB) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!---------------------------------------------- +! ... For wavelengths >310 nm and <240 nm +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CHBR3_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------- +! ... Combine cross sections +!---------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 260nm + do i = 1, n + IF (xin(i) .LT. 260.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 260-362 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo + + enddo +!---------------------------------------------- +! ... interpolate +!---------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------- +! +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo +!---------------------------------------------- +! iz = 1 +! do iw = 1, nw-1 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- +!---------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_CHBR3 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CL2O2.f b/test/unit/tuv_doug/JCALC/XSQY_CL2O2.f new file mode 100644 index 00000000..87abe738 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CL2O2.f @@ -0,0 +1,117 @@ + subroutine XSQY_CL2O2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for hcl photolysis: ! +! cl2o2 + hv -> cl + cloo ! +! cross section: from JPL10 ! +! ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/13/2012 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=600) + integer i, iw, n, idum, ierr, iz + real x1(kdata) + real y1(kdata) + real yg(kw) + real qy + +!---------------------------------------------- +! ... jlabel(j) = 'cl2o2 -> cl + cloo' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'Cl2O2 + hv -> Cl + ClOO' +! print*,jlabel(j) +!---------------------------------------------------- +! ... cross sections +!---------------------------------------------------- + open(kin,file= + $ TRIM(pn)//'XS_CL2O2_JPL10_500nm.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + close(kin) + +!---------------------------------------------------------- +! do i = 1, n +! print*, i, x1(i), y1(i) +! enddo +! stop +!---------------------------------------------------------- + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + call inter2(nw,wl,yg,n,x1,y1,ierr) + + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + +!-------------------------------------------------------------- +! ... quantum yield assumed to be 1.0 +!-------------------------------------------------------------- + qy = 1.0 + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * yg(iw) + enddo + enddo +!---------------------------------------------------------- +! do iw = 28, 99 +! print*, iw, wc(iw), yg(iw) +! enddo +! stop +!---------------------------------------------------------- + end subroutine XSQY_CL2O2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_CLO.f b/test/unit/tuv_doug/JCALC/XSQY_CLO.f new file mode 100644 index 00000000..2dab1cae --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_CLO.f @@ -0,0 +1,115 @@ + subroutine XSQY_CLO(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield): ! +! ClO + hv -> Cl + O ! +! cross section: JPL06 ! +! quantum yield: is unity. ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/27/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, ierr, iz + real x1(kdata) + real y1(kdata) + real yg(kw) + real qy + +!---------------------------------------------- +! ... jlabel(j) = 'ClO + hv -> Cl + O' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'ClO + hv -> Cl + O' + +!---------------------------------------------------- +! ... cross sections from JPL06 recommendation +!---------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_CLO_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + close(kin) + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + + call inter2(nw,wl,yg,n,x1,y1,ierr) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif +!------------------------------------------------------- +! ... quantum yield (assumed) to be unity (JPL06) +!------------------------------------------------------- + qy = 1.0 + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * yg(iw) + + enddo + enddo +!------------------------------------------------------- +! ... Check routine (no temperature dependence +! print*,'jclo' +! do iw = 30, 72 +! print*, iw, wc(iw), (qy * yg(iw)) +! enddo +! stop +!------------------------------------------------------- + + end subroutine XSQY_CLO diff --git a/test/unit/tuv_doug/JCALC/XSQY_H1301.f b/test/unit/tuv_doug/JCALC/XSQY_H1301.f new file mode 100644 index 00000000..dcfa341e --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_H1301.f @@ -0,0 +1,230 @@ + subroutine XSQY_H1301(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for h1301 photolysis: ! +! h1301 + hv -> products ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + + real x1 (kdata), y1 (kdata) + real xin (kdata), yin(kdata) + real wctmp (kdata), wcb(kdata) + real ytmp (nz,kdata) + real ycomb (nz,kdata) + real ytd (nz,kw) + real yg1 (kw) + real AA (5), BB(5), lp(5) + real tin(nz) + real ysave, qy + + AA(1) = 62.563 + AA(2) = -2.0068 + AA(3) = 1.6592e-2 + AA(4) = -5.6465e-5 + AA(5) = 6.7459e-8 + + BB(1) = -9.1755e-1 + BB(2) = 1.8575e-2 + BB(3) = -1.3857e-4 + BB(4) = 4.5066e-7 + BB(5) = -5.3803e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'H1301 -> Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'H1301 + hv -> Br' + +!---------------------------------------------------------- +! Derive temperature dependence +!----------------------------------------------------------- +! Temperature dependence good between 210-300K and 178 nm-280 nm + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 178.) .AND. (wc(iw) .LE.280.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +! ... For wavelengths >280 nm and <178 nm + open(kin,file=TRIM(pn)//'XS_H1301_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +! ... Combine cross sections + do iz = 1, nz + icnt = 1 + +! ... < 178nm + do i = 1, n + IF (xin(i) .LT. 178.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 178-280 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >280nm + do i = 1, n + IF (xin(i) .GT. 280.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo + +! ... interpolate + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------------- +! iz = 1 +! do iw = 15, 70 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------------- +!---------------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_H1301 diff --git a/test/unit/tuv_doug/JCALC/XSQY_H2402.f b/test/unit/tuv_doug/JCALC/XSQY_H2402.f new file mode 100644 index 00000000..23b9f246 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_H2402.f @@ -0,0 +1,235 @@ + subroutine XSQY_H2402(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for h2402 photolysis: ! +! H2402 (CF2BrCF2Br)+ hv -> 2Br ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata),ycomb(nz,kdata) + real yg1 (kw), ytd (nz,kw) + real qy + real AA(5), BB(5), lp(5) + real tin(nz) + + AA(1) = 34.026 + AA(2) = -1.152616 + AA(3) = 8.959798e-3 + AA(4) = -2.9089e-5 + AA(5) = 3.307212e-8 + + BB(1) = 4.010664e-1 + BB(2) = -8.358968e-3 + BB(3) = 6.415741e-5 + BB(4) = -2.157554e-7 + BB(5) = 2.691871e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!---------------------------------------------- +! ... set tin to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'H2402 (CF2BrCF2Br)+ hv -> 2Br' +!---------------------------------------------- + j = j+1 + jlabel(j) = 'H2402 + hv -> 2Br' + +!---------------------------------------------- +! Derive temperature dependence +!---------------------------------------------- +! Temperature dependence good between +! 210-300K and 190 nm to 290 nm +!---------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 190.) .AND. (wc(iw) .LE.290.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!---------------------------------------------- +! ... For wavelengths >290 nm and <190 nm +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_H2402_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!---------------------------------------------- +! ... Combine cross sections +!---------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 190nm + do i = 1, n + IF (xin(i) .LT. 190.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 190-290 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >290nm + do i = 1, n + IF (xin(i) .GT. 290.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!---------------------------------------------- +! ... interpolate +!---------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!---------------------------------------------- +! print*,'jh2402' +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------- +! iz = 1 +! do iw = 15, 77 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------- +!---------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_H2402 diff --git a/test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f b/test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f new file mode 100644 index 00000000..9c49b980 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HCFC141b.f @@ -0,0 +1,231 @@ + subroutine XSQY_HCFC141b(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! HCFC141b + hv -> 2Cl ! +! cross section: from JPL10 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -682.913042 + AA(2) = 12.122290 + AA(3) = -8.187699e-2 + AA(4) = 2.437244e-4 + AA(5) = -2.719103e-7 + + BB(1) = 4.074747 + BB(2) = -8.053899e-2 + BB(3) = 5.946552e-4 + BB(4) = -1.945048e-6 + BB(5) = 2.380143e-9 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'hcfc141b -> 2cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'HCFC141b + hv -> 2Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-240 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.240.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HCFC141b_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 +! ... LT 172nm + do i = 1, n + IF (xin(i) .LT. 172.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo +! ... 172-240 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >240nm + do i = 1, n + IF (xin(i) .GT. 240.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_HCFC141b diff --git a/test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f b/test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f new file mode 100644 index 00000000..723ced35 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HCFC142b.f @@ -0,0 +1,231 @@ + subroutine XSQY_HCFC142b(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for cfc113 photolysis: ! +! HCFC142b + hv -> Cl ! +! cross section: from JPL10 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 01/06/12 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(5), BB(5), lp(5) + real qy, ysave + + AA(1) = -328.092008 + AA(2) = 6.342799 + AA(3) = -4.810362e-2 + AA(4) = 1.611991e-4 + AA(5) = -2.042613e-7 + + BB(1) = 4.289533e-1 + BB(2) = -9.042817e-3 + BB(3) = 7.018009e-5 + BB(4) = -2.389064e-7 + BB(5) = 3.039799e-10 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + lp(5) = 4.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) +!--------------------------------------------------- +! ... jlabel(j) = 'hcfc142b -> cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'HCFC142b + hv -> Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 172 nm-243 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + + do iw = 1, nw-1 + + IF ((wc(iw) .GE. 172.) .AND. (wc(iw) .LE.230.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1,5 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (tin(iz)-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 5 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wc(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wc(iw)**lp(nloop) + enddo + wctmp(iwc) = wc(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo +!--------------------------------------------------- +! ... For wavelengths >220nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HCFC142b_JPL10.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 +! ... LT 172nm + do i = 1, n + IF (xin(i) .LT. 172.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo +! ... 172-240 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >240nm + do i = 1, n + IF (xin(i) .GT. 240.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! iz = 1 +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!---------------------------------------------------- +! iz = 1 +! do iw = 10, 64 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!---------------------------------------------------- +!---------------------------------------------------- +! ...quantum yield assumed to be unity +!---------------------------------------------------- + qy = 1. + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_HCFC142b diff --git a/test/unit/tuv_doug/JCALC/XSQY_HCFC22.f b/test/unit/tuv_doug/JCALC/XSQY_HCFC22.f new file mode 100644 index 00000000..a3901a4b --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HCFC22.f @@ -0,0 +1,238 @@ + subroutine XSQY_HCFC22(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product (cross section) x (quantum yield) for photolysis: ! +! HCFC22 + hv -> Cl ! +! cross section: from JPL06 recommendation ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 07/30/07 Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=300) + + integer i, iw, n, idum, nloop, n1 + integer ierr, iz, iwc, icnt + real x1 (kdata), y1 (kdata) + real xin (kdata), yin (kdata) + real wctmp(kdata), wcb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real yg1(kw), tin (nz) + real ytd (nz,kw) + real AA(4), BB(4), lp(4) + real qy, ysave + real wctd(26) + + data wctd /170., 172., 174., 176., 178., 180., 182., 184., 186., + $ 188., 190., 192., 194., 196., 198., 200., 202., 204., + $ 206., 208., 210., 212., 214., 216., 218., 220./ + + AA(1) =-106.029 + AA(2) = 1.5038 + AA(3) = -8.2476e-3 + AA(4) = 1.4206e-5 + + BB(1) = -1.3399e-1 + BB(2) = 2.7405e-3 + BB(3) = -1.8028e-5 + BB(4) = 3.8504e-8 + + lp(1) = 0.0 + lp(2) = 1.0 + lp(3) = 2.0 + lp(4) = 3.0 + +!--------------------------------------------------- +! ... tin set to tlev +!--------------------------------------------------- + tin(:) = tlev(:) + +!--------------------------------------------------- +! ... jlabel(j) = 'HCFC22 -> Cl' +!--------------------------------------------------- + j = j+1 + jlabel(j) = 'HCFC22 + hv -> Cl' + +!--------------------------------------------------- +! Derive temperature dependence +!--------------------------------------------------- +! Temperature dependence good between +! 210-300K and 174 nm-204 nm +!--------------------------------------------------- + iwc = 1 + ytmp(:,:)= 0.0 + wctmp(:) = 0.0 + + do iw = 1, 26 + + IF ((wctd(iw) .GE. 174.) .AND. (wctd(iw) .LE.204.)) THEN + + do iz = 1, nz + + IF (tin(iz) .LT. 210.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wctd(iw)**lp(nloop)) + & + (210.0-273.0)*BB(nloop)*wctd(iw)**lp(nloop) + enddo + wctmp(iwc) = wctd(iw) + ENDIF + + IF ((tin(iz) .GE. 210.).AND.(tin(iz) .LE. 300.)) THEN + do nloop = 1, 4 + + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wctd(iw)**lp(nloop)) + & +(tin(iz)-273.0)*BB(nloop)*wctd(iw)**lp(nloop) + enddo + wctmp(iwc) = wctd(iw) + ENDIF + + IF (tin(iz) .GT. 300.) THEN + do nloop = 1, 4 + ytmp(iz,iwc) = ytmp(iz,iwc) + & + AA(nloop)* (wctd(iw)**lp(nloop)) + & + (300.0-273.0)*BB(nloop)*wctd(iw)**lp(nloop) + enddo + wctmp(iwc) = wctd(iw) + ENDIF + enddo + iwc = iwc+ 1 + + ENDIF + + enddo + +!--------------------------------------------------- +! ... For wavelengths >204 nm and <174 nm +!--------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HCFC22_JPL06.txt',status='old') + + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + + do i = 1, n + read(kin,*) xin(i), yin(i) + enddo + close(kin) + +!--------------------------------------------------- +! ... Combine cross sections +!--------------------------------------------------- + do iz = 1, nz + icnt = 1 + +! ... < 174nm + do i = 1, n + IF (xin(i) .LT. 174.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt + 1 + ENDIF + enddo +! ... 174-204 nm + do i = 1, iwc-1 + ycomb(iz,icnt) = 10**(ytmp(iz,i)) + wcb (icnt) = wctmp(i) + icnt = icnt+1 + enddo +! ... >204nm + do i = 1, n + IF (xin(i) .GT. 204.) THEN + ycomb(iz,icnt) = yin(i) + wcb (icnt) = xin(i) + icnt = icnt+1 + ENDIF + enddo + enddo +!--------------------------------------------------- +! ... interpolate +!--------------------------------------------------- + do iz = 1, nz + n1 = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb +!--------------------------------------------------- +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- + call addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n1, 0.,0.) + call addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n1, 1e38,0.) + call inter2(nw,wl,yg1,n1,x1,y1,ierr) + ytd(iz,:) = yg1(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!--------------------------------------------------- +! iz = 1 +! do iw = 10, 45 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!--------------------------------------------------- +!--------------------------------------------------- +! ...quantum yield assumed to be unity +!--------------------------------------------------- + qy = 1. + + do iw = 1, nw-1 + do iz = 1, nz + sq(j,iz,iw) = qy * ytd(iz,iw) + enddo + enddo + + end subroutine XSQY_HCFC22 diff --git a/test/unit/tuv_doug/JCALC/XSQY_HNO3.f b/test/unit/tuv_doug/JCALC/XSQY_HNO3.f new file mode 100644 index 00000000..67792b40 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HNO3.f @@ -0,0 +1,140 @@ + subroutine XSQY_HNO3(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product of (cross section) x (quantum yield) for photolysis ! +! hno3 + hv -> oh + no2 ! +! cross section: burkholder et al., 1993 (and JPL06) ! +! quantum yield: assumed to be unity ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 05/98 original, adapted from former jspec1 subroutine ! +! 01/15/08 minor update,dek ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=100) + integer n1, n2 + integer i, iw, n, idum, iz + integer ierr + real x1 (kdata), x2 (kdata) + real y1 (kdata), y2 (kdata) + real yg1(kw), yg2(kw) + real yg( kw) + real tin(nz) + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'HNO3 -> OH + NO2 +!---------------------------------------------- + j = j + 1 + jlabel(j) = 'HNO3 + hv -> OH + NO2' + +!----------------------------------------------------------------------- +! ... hno3 cross section parameters from burkholder et al. 1993 +!----------------------------------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HNO3_JPL06.txt',status='old') + +!... read lambda and cross sections + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + +!... read lambda and T-dep coeff. + read(kin,*) + do i = 1, n + read(kin,*) x2(i), y2(i) + enddo + close(kin) + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1e38,0.) + call inter2(nw,wl,yg1,n,x1,y1,ierr) + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + + n= 80 + call addpnt(x2,y2,kdata,n,x2(1)*(1.-deltax),0.) + call addpnt(x2,y2,kdata,n, 0.,0.) + call addpnt(x2,y2,kdata,n,x2(n)*(1.+deltax),0.) + call addpnt(x2,y2,kdata,n, 1.e+38,0.) + call inter2(nw,wl,yg2,n,x2,y2,ierr) + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + +!-------------------------------------------------- +! ... quantum yield = 1 +! correct for temperature dependence +!-------------------------------------------------- + do iw = 1, nw - 1 + do iz = 1, nz + sq(j,iz,iw) = yg1(iw) + $ * exp( yg2(iw)/1.e3*(tin(iz)-298.) ) + enddo + enddo + +!------------------------------------------------------- +! ... Check routine (no temperature dependence +! iz = 1 +! do iw = 29, 79 +! print*, iw, wc(iw), sq(j,iz,iw) +! enddo +! stop +!------------------------------------------------------- + + end subroutine XSQY_HNO3 diff --git a/test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f b/test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f new file mode 100644 index 00000000..5865bf03 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_HO2NO2.f @@ -0,0 +1,210 @@ + subroutine XSQY_HO2NO2(nw,wl,wc,nz,tlev,airlev,j,sq,jlabel,pn) +!-----------------------------------------------------------------------------! +! purpose: ! +! provide product of (cross section) x (quantum yield) for hno4 photolysis ! +! 1) HO2NO2 + hv -> HO2 + NO2 ! +! 2) HO2NO2 + hv -> OH + NO3 ! +! cross sections and QY from JPL06 ! +!-----------------------------------------------------------------------------! +! parameters: ! +! nw - integer, number of specified intervals + 1 in working (i) ! +! wavelength grid ! +! wl - real, vector of lower limits of wavelength intervals in (i) ! +! working wavelength grid ! +! wc - real, vector of center points of wavelength intervals in (i) ! +! working wavelength grid ! +! nz - integer, number of altitude levels in working altitude grid (i) ! +! tlev - real, temperature (k) at each specified altitude level (i) ! +! airlev - real, air density (molec/cc) at each altitude level (i) ! +! j - integer, counter for number of weighting functions defined (io) ! +! sq - real, cross section x quantum yield (cm^2) for each (o) ! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! jlabel - character*60, string identifier for each photolysis reaction (o) ! +! defined ! +!-----------------------------------------------------------------------------! +! edit history: ! +! 05/98 original, adapted from former jspec1 subroutine ! +! 06/01 modified by doug kinnison ! +! 01/08 modified by Doug Kinnison ! +!-----------------------------------------------------------------------------! + implicit none + include 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airlev(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!-----------------------------------------------------------------------------! +! ... input/output ! +!-----------------------------------------------------------------------------! + integer, intent(inout) :: j + +!-----------------------------------------------------------------------------! +! ... local ! +!-----------------------------------------------------------------------------! + integer kdata + parameter(kdata=100) + integer i, iw, iz, n, n1, idum, ierr, icnt + real x1 (kdata), x2(kdata), wcb(kdata) + real y1 (kdata), aa(kdata), bb (kdata) + real ytmp (nz,kdata), ycomb(nz,kdata) + real ytd (nz,kw), yg(kw) + real Q(nz), tin(nz), t + +!---------------------------------------------- +! ... tin set to tlev +!---------------------------------------------- + tin(:) = tlev(:) + +!---------------------------------------------- +! ... jlabel(j) = 'HO2NO2 -> HO2 + NO2 +! jlabel(j) = 'HO2NO2 -> OH + NO3 +!---------------------------------------------- + j = j + 1 + jlabel(j) = 'HO2NO2 + hv -> OH + NO3' + +!---------------------------------------------- +! ...ho2no2 cross sections plus T-dep. +! (Burkholder et al., 2002.) +!---------------------------------------------- + open(kin,file=TRIM(pn)//'XS_HO2NO2_JPL06.txt',status='old') + +!... read lambda and cross sections + read(kin,*) idum, n + do i = 1, idum-2 + read(kin,*) + enddo + do i = 1, n + read(kin,*) x1(i), y1(i) + enddo + +!... read lambda and T-dep coeff. + read(kin,*) + read(kin,*) idum, n1 + do i = 1, n1 + read(kin,*) x2(i), aa(i), bb(i) + enddo + close(kin) + +!---------------------------------------------- +! ...Derive T-dep Burkholder et al., 2002.) +!---------------------------------------------- + do iz = 1, nz + do iw = 1, n1 + t = MAX(280.,MIN(tin(iz),350.)) + Q(iz) = 1 + exp(-988./(0.69*t)) + ytmp(iz,iw) = ( aa(iw)/Q(iz) + bb(iw)*(1-1/Q(iz)))*1e-20 + enddo + enddo +!---------------------------------------------- +! ... Check routine +! iz = 1 +! do iw = 1, n1 +! print*, iw, x2(iw), ytmp(iz,iw) +! enddo +! stop +!---------------------------------------------- +! ... Combine cross sections + do iz = 1, nz + icnt = 1 + +! ... < 280 nm +! ... x1(iw) goes from 190-350nm + do iw = 1, n + IF (x1(iw) .LT. 280.) THEN + ycomb(iz,icnt) = y1(iw) + wcb (icnt) = x1(iw) + icnt = icnt + 1 + ENDIF + enddo +! ... 280-350 nm + do iw = 1, n1 + ycomb(iz,icnt) = ytmp(iz,iw) + wcb (icnt) = x2 (iw) + icnt = icnt+1 + enddo + enddo + +!... Test No TD +! do iz = 1, nz +! icnt = 1 +! do iw = 1, n +! ycomb(iz,icnt) = y1(iw) +! wcb (icnt) = x1(iw) +! icnt = icnt + 1 +! enddo +! enddo +!---------------------------------------------- +! ... Check routine +! iz = 1 +! print*,"tin=", tin(iz) +! do iw = 1, icnt-1 +! print*, iw, wcb(iw), ycomb(iz,iw) +! enddo +! stop +!---------------------------------------------- +! ... Interpolate Combine cross sections + do iz = 1, nz + n = icnt-1 + y1 = ycomb(iz,:) + x1 = wcb + + call addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + call addpnt(x1,y1,kdata,n, 0.,0.) + call addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + call addpnt(x1,y1,kdata,n, 1.e+38,0.) + call inter2(nw,wl,yg,n,x1,y1,ierr) + ytd(iz,:) = yg(:) + + if (ierr .ne. 0) then + write(*,*) ierr, jlabel(j) + stop + endif + enddo + +!------------------------------------------------- +! iz = 1 +! do iw = 24, 80 +! print*, iw, wc(iw), ytd(iz,iw), tin(iz) +! enddo +! stop +!------------------------------------------------- + do iw = 1, nw - 1 + IF (wc(iw) .LT. 200.0) THEN + do iz = 1, nz + sq(j, iz,iw) = 0.30 * ytd(iz,iw) + sq(j+1,iz,iw) = 0.70 * ytd(iz,iw) + enddo + ENDIF + IF (wc(iw) .GE. 200.0) THEN + do iz = 1, nz + sq(j, iz,iw) = 0.20 * ytd(iz,iw) + sq(j+1,iz,iw) = 0.80 * ytd(iz,iw) + enddo + ENDIF + enddo + +!-------------------------------------------------- +! iz = 1 +! do iw = 24, 80 +! print*, wc(iw), sq(j,iz,iw), sq(j+1,iz,iw) +! print*, sq(j,iz,iw)+sq(j+1,iz,iw) +! enddo +! stop +!------------------------------------------------- + j = j + 1 + jlabel(j) = 'HO2NO2 + hv -> HO2 + NO2' + + end subroutine XSQY_HO2NO2 diff --git a/test/unit/tuv_doug/JCALC/XSQY_SO2.f b/test/unit/tuv_doug/JCALC/XSQY_SO2.f new file mode 100644 index 00000000..c0e49950 --- /dev/null +++ b/test/unit/tuv_doug/JCALC/XSQY_SO2.f @@ -0,0 +1,108 @@ + SUBROUTINE XSQY_SO2(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,pn) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Provide the product (cross section) x (quantum yield) for photolysis: ! +! SO2 + hv -> Products ! +! ! +! Cross section from Mike Mills, CU/LASP, Base on: ! +! 1. Yung, Y.L., and W.B. Demore (1982) Photochemistry of the Stratosphere ! +! of Venus: Implications for Atmospheric Evolution, Icarus, 51, 199-247. ! +! 2. Okabe, H. In Photochemistry of Small Molecules; John Wiley and Sons ! +! Inc.: New York, 1978; pp 248-249 ! +! ! +! Quantum yield = 1.0 ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lower limits of wavelength intervals in (I)! +! working wavelength grid ! +! WC - REAL, vector of center points of wavelength intervals in (I)! +! working wavelength grid ! +! NZ - INTEGER, number of altitude levels in working altitude grid (I)! +! TLEV - REAL, temperature (K) at each specified altitude level (I)! +! AIRDEN - REAL, air density (molec/cc) at each altitude level (I)! +! J - INTEGER, counter for number of weighting functions defined (IO)! +! SQ - REAL, cross section x quantum yield (cm^2) for each (O)! +! photolysis reaction defined, at each defined wavelength and ! +! at each defined altitude level ! +! JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)! +! defined ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + INCLUDE 'params' + +!---------------------------------------------------------------------------! +! ... input ! +!---------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + real, intent(in) :: tlev(kz) + real, intent(in) :: airden(kz) + + integer, intent(in) :: nz + integer, intent(in) :: nw + + character*80, intent(in) :: pn + character*60, intent(out) :: jlabel(kj) + real, intent(out) :: sq(kj,kz,kw) + +!---------------------------------------------------------------------------! +! ... input/output ! +!---------------------------------------------------------------------------! + integer, intent(inout) :: j + +!---------------------------------------------------------------------------! +! ... local ! +!---------------------------------------------------------------------------! + integer kdata + parameter (kdata=300) + integer i, n, ierr, iw + real x_min(kdata), x_max(kdata), x(kdata), y(kdata) + real yg(kw) + real qy + +!----------------------------------------------- +! ... SO2 photolysis +!----------------------------------------------- + j = j+1 + jlabel(j) = 'SO2 + hv -> SO + O' + +!----------------------------------------------- +! ... SO2 cross sections +!---------------------------------------------- + OPEN(UNIT=kin,FILE=TRIM(pn)//'XS_SO2_mills.txt', + $ STATUS='old') + DO i = 1, 13 + READ(kin,*) + ENDDO + n = 125 + DO i = 1, n + READ(kin,*) x_min(i), x_max(i), y(i) + x(i) = (x_min(i)+x_max(i)) / 2.0 + ENDDO + + CLOSE(kin) + + CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.) + CALL addpnt(x,y,kdata,n, 0.,0.) + CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.) + CALL addpnt(x,y,kdata,n, 1.e+38,0.) + CALL inter2(nw,wl,yg,n,x,y,ierr) + IF (ierr .NE. 0) THEN + WRITE(*,*) ierr, jlabel(j) + STOP + ENDIF + +!----------------------------------------------- +! ... combine +!----------------------------------------------- + qy = 1.0 + + DO iw = 1, nw - 1 + DO i = 1, nz + sq(j,i,iw) = yg(iw) * qy + ENDDO + ENDDO + + end subroutine XSQY_SO2 diff --git a/test/unit/tuv_doug/data_sets.F90 b/test/unit/tuv_doug/data_sets.F90 index 434014ee..4347753f 100644 --- a/test/unit/tuv_doug/data_sets.F90 +++ b/test/unit/tuv_doug/data_sets.F90 @@ -10,6 +10,8 @@ program doug_data_set implicit none + integer, parameter :: OUTPUT_LEVEL = 62 + call musica_mpi_init( ) call test_data_set( ) call musica_mpi_finalize( ) @@ -36,7 +38,8 @@ subroutine test_data_set( ) use tuvx_profile, only : profile_t use tuvx_profile_warehouse, only : profile_warehouse_t use tuvx_quantum_yield, only : quantum_yield_t - use tuvx_quantum_yield_factory, only : quantum_yield_type_name, & + use tuvx_quantum_yield_factory, only : quantum_yield_builder, & + quantum_yield_type_name, & quantum_yield_allocate use tuvx_test_utils, only : check_values @@ -45,9 +48,10 @@ subroutine test_data_set( ) class(cross_section_t), pointer :: cross_section class(quantum_yield_t), pointer :: quantum_yield - character(len=*), parameter :: Iam = "H2O cross section test" + character(len=*), parameter :: Iam = "Doug's cross section tests" type(config_t) :: config, config_pair, cs_config, qy_config - class(iterator_t), pointer :: iter + type(config_t) :: mask_points_config, mask_point_config + class(iterator_t), pointer :: iter, mask_points_iter type(string_t) :: cs_type_name, qy_type_name, label character, allocatable :: buffer(:) integer :: pos, pack_size @@ -59,7 +63,9 @@ subroutine test_data_set( ) class(profile_t), pointer :: air, temperature class(grid_t), pointer :: wavelength real(kind=dk) :: tolerance + integer, allocatable :: mask_points(:) integer :: i + logical :: found ! Load grids based on Doug's TUV grids => get_grids( ) @@ -84,12 +90,28 @@ subroutine test_data_set( ) call config_pair%get( "label", label, Iam ) call config_pair%get( "tolerance", tolerance, Iam, & default = 1.0e-6_dk ) + call config_pair%get( "mask", mask_points_config, Iam, & + found = found ) + if( found ) then + mask_points_iter => mask_points_config%get_iterator( ) + allocate( mask_points( mask_points_config%number_of_children( ) ) ) + do i = 1, size( mask_points ) + call assert( 564855121, mask_points_iter%next( ) ) + call mask_points_config%get( mask_points_iter, mask_point_config, & + Iam ) + call mask_point_config%get( "index", mask_points( i ), Iam ) + end do + call assert( 888375064, .not. mask_points_iter%next( ) ) + deallocate( mask_points_iter ) + else + allocate( mask_points(0) ) + end if ! Load and test cross section if( musica_mpi_rank( comm ) == 0 ) then cross_section => cross_section_builder( cs_config, grids, profiles ) cs_type_name = cross_section_type_name( cross_section ) - quantum_yield => quantum_yield_t( qy_config, grids, profiles ) + quantum_yield => quantum_yield_builder( qy_config, grids, profiles ) qy_type_name = quantum_yield_type_name( quantum_yield ) pack_size = cs_type_name%pack_size( comm ) + & cross_section%pack_size( comm ) + & @@ -127,23 +149,13 @@ subroutine test_data_set( ) call calculate( label%val_, & real( temperature%edge_val_(:temperature%ncells_+1) ), & - real( air%mid_val_ ), doug_xsqy ) - - wavelength => grids%get_grid( "wavelength", "nm" ) - write(*,*) label%val_ - do i = 1, size( tuvx_xsqy, dim=2 ) - write(*,*) i, wavelength%edge_(i), wavelength%mid_(i), & - cross_section_data(62,i), & - quantum_yield_data(62,i), tuvx_xsqy(62,i), wl(i), & - real( doug_xsqy(62,i), kind=dk ) - end do - write(*,*) size( tuvx_xsqy, dim=2 ) + 1, & - wavelength%edge_(wavelength%ncells_+1) - deallocate( wavelength ) + real( air%edge_val_ ), doug_xsqy ) ! 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 + ! Also skip any points explicitly masked in the configuration + tuvx_xsqy(:,mask_points(:)) = doug_xsqy(:,mask_points(:)) call check_values( 377150482, tuvx_xsqy(:,3:), & real( doug_xsqy(:,3:), kind=dk ), tolerance ) @@ -152,6 +164,7 @@ subroutine test_data_set( ) deallocate( cross_section_data ) deallocate( quantum_yield_data ) deallocate( tuvx_xsqy ) + deallocate( mask_points ) end do diff --git a/test/unit/tuv_doug/driver.F90 b/test/unit/tuv_doug/driver.F90 index cbdd8a7c..952c2503 100644 --- a/test/unit/tuv_doug/driver.F90 +++ b/test/unit/tuv_doug/driver.F90 @@ -141,6 +141,75 @@ subroutine calculate( label, temperature, air_density, xsqy ) case( "CH2Br2 + hv -> 2Br" ) call XSQY_CH2BR2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "BRO + hv -> Br + O" ) + call XSQY_BRO(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "Cl2O2 + hv -> Cl + ClOO" ) + call XSQY_CL2O2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "ClO + hv -> Cl + O" ) + call XSQY_CLO(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "HNO3 + hv -> OH + NO2" ) + call XSQY_HNO3(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CF2Cl2 + hv -> 2Cl" ) + call XSQY_CF2CL2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CFC113 + hv -> 3Cl" ) + call XSQY_CFC113(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CFC114 + hv -> 2Cl" ) + call XSQY_CFC114(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "CFC115 + hv -> Cl" ) + call XSQY_CFC115(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CFCl3 + hv -> 3Cl" ) + call XSQY_CFCL3(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "CH3Br + hv -> Br" ) + call XSQY_CH3BR(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case ( "CHBr3 + hv -> 3Br" ) + call XSQY_CHBR3(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "H1301 + hv -> Br" ) + call XSQY_H1301(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "H2402 + hv -> 2Br" ) + call XSQY_H2402(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HCFC22 + hv -> Cl" ) + call XSQY_HCFC22(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HCFC141b + hv -> 2Cl" ) + call XSQY_HCFC141b(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HCFC142b + hv -> Cl" ) + call XSQY_HCFC142b(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "BrONO2 + hv -> Br + NO3" ) + call XSQY_BRONO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "BrONO2 + hv -> BrO + NO2" ) + call XSQY_BRONO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(2,:nz,:nw) + case( "HO2NO2 + hv -> OH + NO3" ) + call XSQY_HO2NO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "HO2NO2 + hv -> HO2 + NO2" ) + call XSQY_HO2NO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(2,:nz,:nw) + case( "CH3Cl + hv -> Cl" ) + call XSQY_CH3CL(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "SO2 + hv -> SO + O" ) + call XSQY_SO2(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) + case( "CH3COCH3 + hv -> CH3CO3 + CH3O2" ) + call xsqy_acetone(nw,wl,wc,nz,temperature,air_density,j,l_xsqy,all_labels,pn) + xsqy(:,:) = l_xsqy(1,:nz,:nw) case default call die( 946669022 ) end select diff --git a/test/unit/tuv_doug/la_srb.f b/test/unit/tuv_doug/la_srb.f new file mode 100644 index 00000000..eddd17e6 --- /dev/null +++ b/test/unit/tuv_doug/la_srb.f @@ -0,0 +1,196 @@ + SUBROUTINE la_srb(nz,z,tlev,nw,wl,o2col,vcol,scol, + $ o2xs1,dto2,o2xs,pathname) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Compute equivalent optical depths for O2 absorption, and O2 effective ! +! absorption cross sections, parameterized in the Lyman-alpha and SR bands ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NZ - INTEGER, number of specified altitude levels in the working (I)! +! grid ! +! Z - REAL, specified altitude working grid (km) (I)! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lxower limits of wavelength intervals in (I)! +! working wavelength grid ! +! CZ - REAL, number of air molecules per cm^2 at each specified (I)! +! altitude layer ! +! ZEN - REAL, solar zenith angle (I)! +! ! +! O2XS1 - REAL, O2 cross section from rdo2xs (I)! +! ! +! DTO2 - REAL, optical depth due to O2 absorption at each specified (O)! +! vertical layer at each specified wavelength ! +! O2XS - REAL, molecular absorption cross section in SR bands at (O)! +! each specified altitude and wavelength. Includes Herzberg ! +! continuum. ! +!---------------------------------------------------------------------------! +! EDIT HISTORY: ! +! 02/02 Major revision only over-write LA and SRB ! +! 02/02 add Koppers and delete Korcarts ! +! 02/98 Included Lyman-alpha parameterization ! +! 03/97 Fix dto2 problem at top level (nz) ! +! 02/97 Changed offset for grid-end interpolation to relative number ! +! (x * (1 +- deltax)) ! +! 08/96 Modified for early exit, no redundant read of data and smaller ! +! internal grid if possible; internal grid uses user grid points ! +! whenever possible ! +! 07/96 Modified to work on internal grid and interpolate final values ! +! onto the user-defined grid ! +!---------------------------------------------------------------------------! + implicit none + include 'params' + + integer nz, nw, iz, iw + real wl(kw), z(kz) + real vcol (kz), scol (kz) + real o2col(kz), o2xs1(kw) + real dto2(kz,kw), o2xs(kz,kw) + real secchi(kz) + real tlev(kz) + character*80 pathname + +!---------------------------------------------------------------------- +! Lyman-alpha variables +! O2 optical depth and equivalent cross section in the +! Lyman-alpha region +!---------------------------------------------------------------------- + integer ila, nla, kla + parameter (kla = 2) + real wlla(kla) + real dto2la(kz, kla-1), o2xsla(kz, kla-1) + save ila + +!---------------------------------------------------------------------- +! Grid on which Koppers' parameterization is defined +! O2 optical depth and equivalent cross section on Koppers' grid +!---------------------------------------------------------------------- + integer isrb, nsrb, ksrb + parameter(ksrb = 18) + real wlsrb(ksrb) + real dto2k(kz, ksrb-1), o2xsk(kz, ksrb-1) + save isrb + + integer i + + logical call1 + data call1/.TRUE./ + save call1 + +!---------------------------------------------------------------------- +! Wavelengths for Lyman alpha and SRB parameterizations: +!---------------------------------------------------------------------- + data nla /1/ + data wlla/ 121.0, 122.0/ + + data nsrb /17/ + data wlsrb/174.4, 177.0, 178.6, 180.2, 181.8, 183.5, 185.2, 186.9, + $ 188.7, 190.5, 192.3, 194.2, 196.1, 198.0, 200.0, 202.0, + $ 204.1, 205.8/ + +!---------------------------------------------------------------------- +! initalize O2 cross sections +!---------------------------------------------------------------------- + DO iz = 1, nz + DO iw =1, nw - 1 + o2xs(iz,iw) = o2xs1(iw) + ENDDO + ENDDO + + IF(wl(1) .GT. wlsrb(nsrb)) RETURN + +!---------------------------------------------------------------------- +! On first call, check that the user wavelength grid, WL(IW), is compatible +! with the wavelengths for the parameterizations of the Lyman-alpha and SRB. +! Also compute and save corresponding grid indices (ILA, ISRB) +!---------------------------------------------------------------------- + IF (call1) THEN + +! locate Lyman-alpha wavelengths on grid + + ila = 0 + DO iw = 1, nw + IF(ABS(wl(iw) - wlla(1)) .LT. 10.*precis) THEN + ila = iw + GO TO 5 + ENDIF + ENDDO + 5 CONTINUE + +! check + IF(ila .EQ. 0) STOP ' Lyman alpha grid mis-match - 1' + DO i = 2, nla + 1 + IF(ABS(wl(ila + i - 1) - wlla(i)) .GT. 10.*precis) THEN + WRITE(*,*) 'Lyman alpha grid mis-match - 2' + STOP + ENDIF + ENDDO + +! locate Schumann-Runge wavelengths on grid + isrb = 0 + DO iw = 1, nw + IF(ABS(wl(iw) - wlsrb(1)) .LT. 10.*precis) THEN + isrb = iw + GO TO 6 + ENDIF + ENDDO + 6 CONTINUE + + +! check + IF(isrb .EQ. 0) STOP ' SRB grid mis-match - 1' + DO i = 2, nsrb + 1 + IF(ABS(wl(isrb + i - 1) - wlsrb(i)) .GT. 10.* precis) THEN + WRITE(*,*) ' SRB grid mismatch - w' + STOP + ENDIF + ENDDO + + IF (call1) call1 = .FALSE. + ENDIF + +!---------------------------------------------------------------------- +! Effective secant of solar zenith angle. +! Use 2.0 if no direct sun (value for isotropic radiation) +! For nz, use value at nz-1 +!---------------------------------------------------------------------- + DO i = 1, nz - 1 + secchi(i) = scol(i)/vcol(i) + IF(scol(i) .GT. largest/10.) secchi(i) = 2. + ENDDO + secchi(nz) = secchi(nz-1) + +!--------------------------------------------------------------------- +! Lyman-Alpha parameterization, output values of O2 optical depth +! and O2 effective (equivalent) cross section +!--------------------------------------------------------------------- + CALL lymana(nz,o2col,secchi,dto2la,o2xsla) + + DO iw = ila, ila + nla - 1 + DO iz = 1, nz + dto2(iz,iw) = dto2la(iz, iw - ila + 1) + o2xs(iz,iw) = o2xsla(iz, iw - ila + 1) + ENDDO + ENDDO + +!---------------------------------------------------------------------- +! Koppers' parameterization of the SR bands, output values of O2 +! optical depth and O2 equivalent cross section +!---------------------------------------------------------------------- + + CALL schum(nz,o2col,tlev,secchi,dto2k,o2xsk,pathname) + DO iw = isrb, isrb + nsrb - 1 + DO iz = 1, nz + dto2(iz,iw) = dto2k(iz, iw - isrb + 1) + o2xs(iz,iw) = o2xsk(iz, iw - isrb + 1) + ENDDO + ENDDO + + + RETURN + END + + + + + diff --git a/test/unit/tuv_doug/lymana.f b/test/unit/tuv_doug/lymana.f new file mode 100644 index 00000000..45f3b268 --- /dev/null +++ b/test/unit/tuv_doug/lymana.f @@ -0,0 +1,120 @@ + SUBROUTINE lymana(nz,o2col,secchi,dto2la,o2xsla) + +*-----------------------------------------------------------------------------* +*= PURPOSE: =* +*= Calculate the effective absorption cross section of O2 in the Lyman-Alpha=* +*= bands and an effective O2 optical depth at all altitudes. Parameterized =* +*= after: Chabrillat, S., and G. Kockarts, Simple parameterization of the =* +*= absorption of the solar Lyman-Alpha line, Geophysical Research Letters, =* +*= Vol.24, No.21, pp 2659-2662, 1997. =* +*-----------------------------------------------------------------------------* +*= PARAMETERS: =* +*= NZ - INTEGER, number of specified altitude levels in the working (I)=* +*= grid =* +*= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I)=* +*= altitude =* +*= DTO2LA - REAL, optical depth due to O2 absorption at each specified (O)=* +*= vertical layer =* +*= O2XSLA - REAL, molecular absorption cross section in LA bands (O)=* +*-----------------------------------------------------------------------------* +*= EDIT HISTORY: =* +*= 01/98 Original =* +*-----------------------------------------------------------------------------* +*= This program is free software; you can redistribute it and/or modify =* +*= it under the terms of the GNU General Public License as published by the =* +*= Free Software Foundation; either version 2 of the license, or (at your =* +*= option) any later version. =* +*= The TUV package is distributed in the hope that it will be useful, but =* +*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =* +*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =* +*= License for more details. =* +*= To obtain a copy of the GNU General Public License, write to: =* +*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =* +*-----------------------------------------------------------------------------* +*= To contact the authors, please mail to: =* +*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =* +*= send email to: sasha@ucar.edu =* +*-----------------------------------------------------------------------------* +*= Copyright (C) 1994 - 1998 University Corporation for Atmospheric Research =* +*-----------------------------------------------------------------------------* + + IMPLICIT NONE + +* input: + + INCLUDE 'params' + INTEGER nz + REAL o2col(kz) + REAL secchi(kz) + +* output + + REAL dto2la(kz,*), o2xsla(kz,*) + +* local variables + + DOUBLE PRECISION rm(kz), ro2(kz) + DOUBLE PRECISION b(3), c(3), d(3), e(3) + DATA b/ 6.8431D-01, 2.29841D-01, 8.65412D-02/, + > c/8.22114D-21, 1.77556D-20, 8.22112D-21/, + > d/ 6.0073D-21, 4.28569D-21, 1.28059D-20/, + > e/8.21666D-21, 1.63296D-20, 4.85121D-17/ + + INTEGER iz, i + REAL xsmin +*------------------------------------------------------------------------------* +! sm: set minimum cross section + xsmin = 1.D-20 + + DO iz = 1, nz + rm(iz) = 0.D+00 + ro2(iz) = 0.D+00 + DO i = 1, 3 + rm(iz) = rm(iz) + b(i) * DEXP(-c(i) * DBLE(o2col(iz))) + END DO + ! TUV-x logic difference + ! DO i = 1, 2 + DO i = 1, 3 + ro2(iz) = ro2(iz) + d(i) * DEXP(-e(i) * DBLE(o2col(iz))) + ENDDO + + ENDDO + +* calculate effective O2 optical depths and effective O2 cross sections + DO iz = 1, nz-1 + + IF (rm(iz) .GT. 1.0D-100) THEN + IF (ro2(iz) .GT. 1.D-100) THEN + o2xsla(iz,1) = ro2(iz)/rm(iz) + ELSE + ! TUV-x logic difference + ! o2xsla(iz,1) = 0. + o2xsla(iz,1) = xsmin + ENDIF + + IF (rm(iz+1) .GT. 0.) THEN + + dto2la(iz,1) = LOG(rm(iz+1)) / secchi(iz+1) + $ - LOG(rm(iz)) / secchi(iz) + + ELSE + dto2la(iz,1) = 1000. + ENDIF + ELSE + dto2la(iz,1) = 1000. + o2xsla(iz,1) = xsmin + ENDIF + + ENDDO + +* do top layer separately + + dto2la(nz,1) = 0. + IF(rm(nz) .GT. 1.D-100) THEN + o2xsla(nz,1) = ro2(nz)/rm(nz) + ELSE + o2xsla(nz,1) = xsmin + ENDIF + +*------------------------------------------------------------------------------* + END diff --git a/test/unit/tuv_doug/rdo2xs.f b/test/unit/tuv_doug/rdo2xs.f new file mode 100644 index 00000000..2f874245 --- /dev/null +++ b/test/unit/tuv_doug/rdo2xs.f @@ -0,0 +1,117 @@ + SUBROUTINE rdo2xs(nw,wl,wc,o2xs1,pn) +!---------------------------------------------------------------------------! +! PURPOSE: ! +! Read O2 absorption cross section. Except the SR bands and L-alpha line ! +!---------------------------------------------------------------------------! +! PARAMETERS: ! +! NW - INTEGER, number of specified intervals + 1 in working (I)! +! wavelength grid ! +! WL - REAL, vector of lower limits of wavelength intervals in (I)! +! working wavelength grid ! +!---------------------------------------------------------------------------! +! EDIT HISTORY: ! +! 02/02 By Xuexi ! +!---------------------------------------------------------------------------! + IMPLICIT NONE + INCLUDE 'params' + +!-----------------------------------------------------------------------------! +! ... input ! +!-----------------------------------------------------------------------------! + real, intent(in) :: wl(kw) + real, intent(in) :: wc(kw) + integer, intent(in) :: nw + +!-----------------------------------------------------------------------------! +! ... output ! +!-----------------------------------------------------------------------------! + real, intent(out) :: o2xs1(kw) + +!... Internal + + integer i, iw, n, kdata, ierr + parameter (kdata = 200) + real x1(kdata), y1(kdata) + real x, y + character*80 pn + +!------------------------------------------------------------------------ +! NOTE: Output O2 xsect, is temporary and will be over-written in +! Lyman-alpha and Schumann-Runge wavelength bands. +!------------------------------------------------------------------------ +! ... data +!------------------------------------------------------------------------ +! Read O2 absorption cross section data: +! 116.65 to 203.05 nm = from Brasseur and Solomon 1986 +! 205 to 240 nm = Yoshino et al. 1988 (same as JPL06) +! +! Note that subroutine seto2.f will over-write values in the +! spectral regions corresponding to: +! Lyman-alpha (LA: 121.4-121.9 nm, Chabrillat and Kockarts +! parameterization +! Schumann-Runge bands (SRB: 174.4-205.8 nm, Koppers +! parameteriaztion) +!----------------------------------------------------------------------- + n = 0 + + OPEN(UNIT=kin,FILE=Trim(pn)//'XS_O2_brasseur.txt') + DO i = 1, 7 + READ(kin,*) + ENDDO + DO i = 1, 78 + READ(kin,*) x, y + IF (x .LE. 204.) THEN + n = n + 1 + x1(n) = x + y1(n) = y +! print*, x1(n), y1(n) + ENDIF + ENDDO + CLOSE(kin) + + OPEN(UNIT=kin, + $ FILE=Trim(pn)//'XS_O2_yoshino.txt',STATUS='old') + DO i = 1, 8 + READ(kin,*) + ENDDO + DO i = 1, 36 + n = n + 1 + READ(kin,*) x, y + y1(n) = y*1.E-24 + x1(n) = x +! print*, x1(n), y1(n) + END DO + CLOSE (kin) + +!----------------------------------------------------------------------------- +! Add termination points and interpolate onto the +! user grid (set in subroutine gridw): +!----------------------------------------------------------------------------- + CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1)) + CALL addpnt(x1,y1,kdata,n,0. ,y1(1)) + CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n, 1.E+38,0.) + +! CALL inter2(nw,wl,o2xs1, n,x1,y1, ierr) + print*, "* interp4 used in rdo2xs.f" + ierr = 0 + CALL inter4(nw,wl,o2xs1, n+1,x1,y1, ierr) +!--------------------------------------------------------------- +! ... Check routine +! do iw = 1,51 +! print*, iw, wc(iw), o2xs1(iw) +! enddo +! stop +!--------------------------------------------------------------- + IF (ierr .NE. 0) THEN + WRITE(*,*) ierr, 'O2 -> O + O' + STOP + ENDIF + + end subroutine rdo2xs + + + + + + diff --git a/test/unit/tuv_doug/schum.f b/test/unit/tuv_doug/schum.f new file mode 100644 index 00000000..3823c8e0 --- /dev/null +++ b/test/unit/tuv_doug/schum.f @@ -0,0 +1,320 @@ + SUBROUTINE schum(nz, o2col,tlev,secchi,dto2,o2xsk,pathname) + +*-----------------------------------------------------------------------------* +*= PURPOSE: =* +*= Calculate the equivalent absorption cross section of O2 in the SR bands. =* +*= The algorithm is based on parameterization of G.A. Koppers, and =* +*= D.P. Murtagh [ref. Ann.Geophys., 14 68-79, 1996] =* +*= Final values do include effects from the Herzberg continuum. =* +*-----------------------------------------------------------------------------* +*= PARAMETERS: =* +*= NZ - INTEGER, number of specified altitude levels in the working (I)=* +*= grid =* +*= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I)=* +*= altitude =* +*= TLEV - tmeperature at each level (I)=* +*= SECCHI - ratio of slant to vertical o2 columns (I)=* +*= DTO2 - REAL, optical depth due to O2 absorption at each specified (O)=* +*= vertical layer at each specified wavelength =* +*= O2XSK - REAL, molecular absorption cross section in SR bands at (O)=* +*= each specified wavelength. Includes Herzberg continuum =* +*-----------------------------------------------------------------------------* + + + IMPLICIT NONE + INCLUDE 'params' + + INTEGER nz + REAL o2col(kz), o2col1(kz) + REAL tlev(kz), secchi(kz) + + REAL dto2(kz,17), o2xsk(kz,17) + + CHARACTER*80 pathname + INTEGER i, k, ktop, ktop1, kbot + + REAL XS(17), X + REAL xslod(17) + LOGICAL firstcall + SAVE firstcall + DATA firstcall /.TRUE./ + + DATA xslod /6.2180730E-21, 5.8473627E-22, 5.6996334E-22, + $ 4.5627094E-22, 1.7668250E-22, 1.1178808E-22, + $ 1.2040544E-22, 4.0994668E-23, 1.8450616E-23, + $ 1.5639540E-23, 8.7961075E-24, 7.6475608E-24, + $ 7.6260556E-24, 7.5565696E-24, 7.6334338E-24, + $ 7.4371992E-24, 7.3642966E-24/ +c------------------------------------------ +C Initialize values +c------------------------------------------ + dto2(:,:) = 0.0 + +c------------------------------------------ +c sm Initialize cross sections to values +c sm at large optical depth +c------------------------------------------ + + DO k = 1, nz + DO i = 1, 17 + o2xsk(k,i) = xslod(i) + ENDDO + ENDDO + +c------------------------------------------ +c Loads Chebyshev polynomial Coeff. +c------------------------------------------ + + if (firstcall) then + call INIT_XS(pathname) + firstcall = .FALSE. + endif + +c------------------------------------------ +c Calculate cross sections +c sm: Set smallest O2col = exp(38.) molec cm-2 +c sm to stay in range of parameterization +c sm given by Koppers et al. at top of atm. +c------------------------------------------ + + ktop = nz + kbot = 0 + +c EXP(38.) = 3.185e16 +c EXP(56.) = 2.091e24 + DO k=1,nz !! loop for alt + o2col1(k) = MAX(o2col(k),EXP(38.)) + + x = ALOG(o2col1(k)) + + IF (x .LT. 38.0) THEN + ktop1 = k-1 + write(*,*) ktop1 + ktop = MIN(ktop1,ktop) + ELSE IF (x .GT. 56.0) THEN + kbot = k + ELSE + CALL effxs( x, tlev(k), xs ) + DO i=1,17 + o2xsk(k,i) = xs(i) + END DO + ENDIF + + END DO !! finish loop for alt + +c------------------------------------------ +c fill in cross section where X is out of range +c by repeating edge table values +c------------------------------------------ + +c sm do not allow kbot = nz to avoid division by zero in +c no light case. + + IF(kbot .EQ. nz) kbot = nz - 1 + + DO k=1,kbot + DO i=1,17 + o2xsk(k,i) = o2xsk(kbot+1,i) + END DO + END DO + + DO k=ktop+1,nz + DO i=1,17 + o2xsk(k,i) = o2xsk(ktop,i) + END DO + END DO + +c------------------------------------------ +c Calculate incremental optical depths +c------------------------------------------ + + DO i=1,17 ! loop over wavelength + + DO k=1,nz-1 ! loop for alt + +c... calculate an optical depth weighted by density +c sm: put in mean value estimate, if in shade + + IF (ABS(1. - o2col1(k+1)/o2col1(k)) .LE. 2.*precis) THEN + + dto2(k,i) = o2xsk(k+1,i)*o2col1(k+1)/(nz-1) + + ELSE + + dto2(k,i) = ABS( + $ ( o2xsk(k+1,i)*o2col1(k+1) - o2xsk(k,i)*o2col1(k) ) + $ / ( 1. + ALOG(o2xsk(k+1,i)/o2xsk(k,i)) + $ / ALOG(o2col1(k+1)/o2col1(k)) ) ) + +c... change to vertical optical depth + + dto2(k,i) = 2. * dto2(k,i) / (secchi(k)+secchi(k+1)) + + ENDIF + + END DO + dto2(nz,i) = 0.0 ! set optical depth to zero at top + + + END DO + + return + end + +C------------------------------------------------------------- + SUBROUTINE EFFXS( X, T, XS ) +C------------------------------------------------------------- +C +C Subroutine for evaluating the effective cross section +C of O2 in the Schumann-Runge bands using parameterization +C of G.A. Koppers, and D.P. Murtagh [ref. Ann.Geophys., 14 +C 68-79, 1996] +C +C method: +C ln(xs) = A(X)[T-220]+B(X) +C X = log of slant column of O2 +C A,B calculated from Chebyshev polynomial coeffs +C AC and BC using NR routine chebev. Assume interval +C is 38 Tests against Doug's LA and SR band calculations + + use musica_assert, only : assert, almost_equal + use musica_constants, only : dk => musica_dk + use musica_config, only : config_t + use tuvx_cross_section, only : cross_section_t + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use tuvx_la_sr_bands, only : la_sr_bands_t + use tuvx_test_utils, only : check_values + + implicit none + + character(len=*), parameter :: my_name = "LUT LA/SRB test" + character(len=*), parameter :: conf_l = 'test/data/la_srb_bands.config.json' + type(config_t) :: grid_config, la_config, profile_config, o2_config + class(grid_warehouse_t), pointer :: grids => null( ) + class(profile_warehouse_t), pointer :: profiles => null( ) + class(la_sr_bands_t), pointer :: la_sr_bands => null( ) + class(cross_section_t), pointer :: o2_cross_section => null( ) + character, allocatable :: buffer(:) + + call la_config%from_file( conf_l ) + call la_config%get( "grids", grid_config, my_name ) + call la_config%get( "profiles", profile_config, my_name ) + call la_config%get( "O2 cross section", o2_config, my_name ) + + grids => grid_warehouse_t( grid_config ) + profiles => profile_warehouse_t( profile_config, grids ) + la_sr_bands => la_sr_bands_t( la_config, grids, profiles ) + o2_cross_section => cross_section_t( o2_config, grids, profiles ) + + call compare_o2_cross_sections( la_sr_bands, grids, profiles ) + + deallocate( grids ) + deallocate( profiles ) + deallocate( la_sr_bands ) + deallocate( o2_cross_section ) + +contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine compare_o2_cross_sections( la_sr_bands, grids, profiles ) + + use tuvx_grid, only : grid_t + use tuvx_profile, only : profile_t + use tuvx_spherical_geometry, only : spherical_geometry_t + + class(la_sr_bands_t), intent(inout) :: la_sr_bands + class(grid_warehouse_t), intent(inout) :: grids + class(profile_warehouse_t), intent(inout) :: profiles + + character(len=80) :: file_path + real(dk), allocatable :: air_vertical_column(:), air_slant_column(:) + real(dk), allocatable :: o2_vertical_column(:), o2_slant_column(:) + real(dk), allocatable :: tuvx_o2_optical_depth(:,:), & + tuvx_o2_cross_section(:,:) + real, dimension(151) :: lut_heights, lut_temperature, & + lut_air_vertical_column, lut_air_slant_column, & + lut_o2_column + real, dimension(700) :: lut_wavelength_edges, lut_wavelength_centers, & + lut_o2_base_cross_section + real, dimension(151,700) :: lut_o2_cross_section, lut_o2_optical_depth + class(grid_t), pointer :: heights, wavelengths, lut_wavelengths + class(spherical_geometry_t), pointer :: geometry + class(profile_t), pointer :: air, o2, temperature + real(dk), allocatable :: solar_zenith_angles(:) + integer :: i_sza, i_height, i_wl, n_heights, n_wavelengths, i_output_height + integer :: output_heights(4) = (/ 1, 50, 100, 150 /) + real(dk) :: rel_tol + + heights => grids%get_grid( "height", "km" ) + wavelengths => grids%get_grid( "wavelength", "nm" ) + lut_wavelengths => grids%get_grid( "LUT wavelength", "nm" ) + air => profiles%get_profile( "air", "molecule cm-3" ) + o2 => profiles%get_profile( "O2", "molecule cm-3" ) + temperature => profiles%get_profile( "temperature", "K" ) + geometry => spherical_geometry_t( grids ) + solar_zenith_angles = (/ 0.0_dk, 13.2_dk, 45.0_dk, 87.3_dk, 90.0_dk /) + allocate( air_vertical_column( air%ncells_ ), & + air_slant_column( air%ncells_ + 1 ) ) + allocate( o2_vertical_column( o2%ncells_ ), & + o2_slant_column( o2%ncells_ + 1) ) + allocate( tuvx_o2_optical_depth( heights%ncells_, wavelengths%ncells_ ) ) + lut_heights(:) = huge(1.0) + lut_temperature(:) = huge(1.0) + lut_air_vertical_column(:) = huge(1.0) + lut_air_slant_column(:) = huge(1.0) + lut_o2_column(:) = huge(1.0) + lut_wavelength_edges(:) = huge(1.0) + lut_wavelength_centers(:) = huge(1.0) + lut_o2_base_cross_section(:) = huge(1.0) + lut_o2_cross_section(:,:) = huge(1.0) + lut_o2_optical_depth(:,:) = huge(1.0) + + do i_sza = 1, size( solar_zenith_angles ) + + ! calculate slant O2 column + call geometry%set_parameters( solar_zenith_angles( i_sza ), grids ) + call geometry%air_mass( air%exo_layer_dens_, & + air_vertical_column, & + air_slant_column ) + call geometry%air_mass( o2%exo_layer_dens_, & + o2_vertical_column, & + o2_slant_column ) + + tuvx_o2_optical_depth(:,:) = 0.0_dk + lut_o2_cross_section(:,:) = 0.0 + lut_o2_optical_depth(:,:) = 0.0 + + ! get TUV-x O2 optical depths and cross sections + call la_sr_bands%optical_depth( grids, profiles, air_vertical_column, & + air_slant_column, tuvx_o2_optical_depth, geometry ) + tuvx_o2_cross_section = o2_cross_section%calculate( grids, profiles ) + call la_sr_bands%cross_section( grids, profiles, air_vertical_column, & + air_slant_column, tuvx_o2_cross_section, geometry ) + + ! get LUT O2 optical depths and cross sections + n_heights = heights%ncells_ + 1 + n_wavelengths = lut_wavelengths%ncells_ + 1 + lut_heights(1:n_heights) = real( heights%edge_(:) ) + lut_temperature(1:n_heights) = real( temperature%edge_val_(:) ) + lut_wavelength_edges(1:n_wavelengths) = real( lut_wavelengths%edge_(:) ) + lut_wavelength_centers(1:n_wavelengths-1) = & + real( lut_wavelengths%mid_(:) ) + lut_o2_column(1:n_heights) = real( o2_slant_column(:) ) + lut_air_vertical_column(1:air%ncells_) = real( air_vertical_column(:) ) + lut_air_slant_column(1:air%ncells_+1) = real( air_slant_column(:) ) + + file_path = "test/unit/tuv_doug/INPUT/XSQY/" + call rdo2xs( n_wavelengths, lut_wavelength_edges, & + lut_wavelength_centers, lut_o2_base_cross_section, & + file_path ) + + call la_srb( n_heights, lut_heights, lut_temperature, & + n_wavelengths, lut_wavelength_edges, lut_o2_column, & + lut_air_vertical_column, lut_air_slant_column, & + lut_o2_base_cross_section, lut_o2_optical_depth, & + lut_o2_cross_section, file_path ) + + do i_height = 1, n_heights - 1 + do i_wl = 1, n_wavelengths - 1 + rel_tol = 1.0e-4 + if ( i_wl == 1 .or. i_wl == 3 ) cycle + if ( i_wl == 20 .or. i_wl == 38 ) rel_tol = 0.5_dk + if ( i_wl == 2 .and. i_height >= 112 ) rel_tol = 0.05_dk + call assert( 624510149, & + almost_equal( tuvx_o2_cross_section( i_height, i_wl ), & + real( lut_o2_cross_section( i_height, i_wl ), kind=dk ),& + relative_tolerance = rel_tol ) ) + call assert( 746904813, & + almost_equal( tuvx_o2_optical_depth( i_height, i_wl ), & + real( lut_o2_optical_depth( i_height, i_wl ), kind=dk ),& + relative_tolerance = rel_tol ) ) + end do + end do + deallocate( tuvx_o2_cross_section ) + end do + + deallocate( heights ) + deallocate( wavelengths ) + deallocate( lut_wavelengths ) + deallocate( air ) + deallocate( o2 ) + deallocate( temperature ) + deallocate( geometry ) + deallocate( tuvx_o2_optical_depth ) + deallocate( air_vertical_column ) + deallocate( air_slant_column ) + deallocate( o2_vertical_column ) + deallocate( o2_slant_column ) + + end subroutine compare_o2_cross_sections + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end program test_la_srb \ No newline at end of file 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..ad2dca7e --- /dev/null +++ b/test/unit/util/map.F90 @@ -0,0 +1,505 @@ +! 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(:), omp_to(:,:) + type(config_t) :: config + character, allocatable :: buffer(:) + integer :: pos, pack_size, i_thread, n_threads + 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 /) + +#ifdef MUSICA_USE_OPENMP + n_threads = omp_get_num_threads( ) +#else + n_threads = 1 +#endif + + allocate( omp_to( n_threads, 3 ) ) + + map = map_t( config, from_labels, to_labels ) + + !$omp parallel do private(i_thread) + do i_thread = 1, n_threads + call check_omp_case( map, from, omp_to( i_thread, : ) ) + end do + !$omp end parallel do + + deallocate( from_labels ) + deallocate( to_labels ) + deallocate( from ) + deallocate( omp_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 - ... -} diff --git a/tool/data_conversion/json_to_yaml.py b/tool/data_conversion/json_to_yaml.py new file mode 100644 index 00000000..0e40e674 --- /dev/null +++ b/tool/data_conversion/json_to_yaml.py @@ -0,0 +1,19 @@ +import json +import yaml +import sys + +def convert_json_to_yaml(json_file, yaml_file): + with open(json_file, 'r') as f: + data = json.load(f) + + with open(yaml_file, 'w') as f: + yaml.dump(data, f) + +# Usage example +if len(sys.argv) != 3: + print("Usage: python json_to_yaml.py ") + sys.exit(1) + +json_file = sys.argv[1] +yaml_file = sys.argv[2] +convert_json_to_yaml(json_file, yaml_file) diff --git a/tool/data_conversion/photo.config.json b/tool/data_conversion/photo.config.json new file mode 100644 index 00000000..2eae337b --- /dev/null +++ b/tool/data_conversion/photo.config.json @@ -0,0 +1,124 @@ +{ + "photoreactions": [ + { + "molecule": "CF2CL2_JPL06", + "cross-sections": [ + { + "filespec": "XS_CF2CL2_JPL06.txt", + "nPreSkip": 45, + "nRead": 36 + } + ] + }, + { + "molecule": "CFCL3_JPL06", + "cross-sections": [ + { + "filespec": "XS_CFCL3_JPL06.txt", + "nPreSkip": 24, + "nRead": 35 + } + ] + }, + { + "molecule": "CH3BR_JPL06", + "cross-sections": [ + { + "filespec": "XS_CH3BR_JPL06.txt", + "nPreSkip": 87, + "nRead": 56 + } + ] + }, + { + "molecule": "CHBR3_JPL10", + "cross-sections": [ + { + "filespec": "XS_CHBR3_JPL10.txt", + "nPreSkip": 35, + "nRead": 97 + } + ] + }, + { + "molecule": "H1301_JPL06", + "cross-sections": [ + { + "filespec": "XS_H1301_JPL06.txt", + "nPreSkip": 45, + "nRead": 61 + } + ] + }, + { + "molecule": "H2402_JPL06", + "cross-sections": [ + { + "filespec": "XS_H2402_JPL06.txt", + "nPreSkip": 50, + "nRead": 76 + } + ] + }, + { + "molecule": "HCFC22_JPL06", + "cross-sections": [ + { + "filespec": "XS_HCFC22_JPL06.txt", + "nPreSkip": 29, + "nRead": 26 + } + ] + }, + { + "molecule": "HCFC141b_JPL10", + "cross-sections": [ + { + "filespec": "XS_HCFC141b_JPL10.txt", + "nPreSkip": 35, + "nRead": 36 + } + ] + }, + { + "molecule": "HCFC142b_JPL10", + "cross-sections": [ + { + "filespec": "XS_HCFC142b_JPL10.txt", + "nPreSkip": 49, + "nRead": 25 + } + ] + }, + { + "molecule": "CFC113_JPL06", + "cross-sections": [ + { + "filespec": "XS_CFC113_JPL06.txt", + "nPreSkip": 38, + "nRead": 36 + } + ] + }, + { + "molecule": "CFC114_JPL10", + "cross-sections": [ + { + "filespec": "XS_CFC114_JPL10.txt", + "nPreSkip": 20, + "nRead": 33 + } + ] + }, + { + "molecule": "CFC115_JPL10", + "cross-sections": [ + { + "filespec": "XS_CFC115_JPL10.txt", + "nPreSkip": 31, + "nRead": 23 + } + ] + } + ] +} diff --git a/tool/data_conversion/text_to_netcdf.py b/tool/data_conversion/text_to_netcdf.py new file mode 100644 index 00000000..bdf99226 --- /dev/null +++ b/tool/data_conversion/text_to_netcdf.py @@ -0,0 +1,61 @@ +#!/Library/Frameworks/Python.framework/Versions/3.8/bin/python3 + +import numpy as np +import sys +import json +from xsqy_subs import xform_to_netCDF + +#----------------------------------------------------- +# json config file is only possible argument +#----------------------------------------------------- +if( len(sys.argv) > 2 ): + print(f'\n{sys.argv[0]}: requires one or no arguments') + sys.exit( -1) +elif( len(sys.argv) == 2 ): + filespec = sys.argv[1] +else: + filespec = 'photo.config.json' + + +#----------------------------------------------------- +# open json photo config file +#----------------------------------------------------- +#ilespec = 'photo.config.tst.json' +try: + fp = open(filespec,'r') +except: + print(f"Failed to open {filespec}") + sys.exit(-1) + +#----------------------------------------------------- +# transfer config file into dictionary +#----------------------------------------------------- +try: + photDict = json.load(fp) +except: + print(f"Failed to load json file {filespec}") + sys.exit(-1) + +#----------------------------------------------------- +# done with json input file +#----------------------------------------------------- +fp.close() + +#----------------------------------------------------- +# loop through photo reactions in dictionary +#----------------------------------------------------- +list = photDict['photoreactions'] +molecule = "" +for rxt in list: +#----------------------------------------------------- +# call xform_to_netCDF +#----------------------------------------------------- + if( molecule != rxt['molecule']): + nFile = 1 + molecule = rxt['molecule'] + else: + nFile += 1 + xform_to_netCDF(nFile,rxt,'./') + +print('\n') +print(f'\nThere are {len(list)} photoreactions in {filespec}') diff --git a/tool/data_conversion/xsqy_subs.py b/tool/data_conversion/xsqy_subs.py new file mode 100644 index 00000000..d8c2263d --- /dev/null +++ b/tool/data_conversion/xsqy_subs.py @@ -0,0 +1,218 @@ +import numpy as np +import sys +from netCDF4 import Dataset +import netCDF4 as ncd +from datetime import datetime as dt + +""" +Function to read the data file(s) +""" +def read_data_file(data_dictionary,dataTray): + + InpFileSpec = data_dictionary['filespec'] + try: + InpFile = open(InpFileSpec,'r') + except: + print(f'Failed to open data file {InpFileSpec}') + sys.exit(-3) + + print(f'Opened data file {InpFileSpec}') + nLines = len(InpFile.readlines()) + InpFile.seek(0) + nskipHdr = data_dictionary['nPreSkip'] if 'nPreSkip' in data_dictionary else 0 + nRead = data_dictionary['nRead'] if 'nRead' in data_dictionary else 0 + + header = '' +# if header lines exist then read them + if( nskipHdr > 0 ): + for ndx in range(nskipHdr): + header += InpFile.readline() + InpFile.seek(0) + + nskipHdr = abs(nskipHdr) + nskipEnd = nLines - (nskipHdr + nRead) + print(f'nLines,nskipHdr,nRead,nskipEnd = {nLines},{nskipHdr},{nRead},{nskipEnd}') + try: + data = np.genfromtxt(InpFile,dtype='float64',skip_header=nskipHdr,skip_footer=nskipEnd,comments=None) + print(f'Read cross section file {InpFileSpec}') + except: + print(f'Failed to read data file {InpFileSpec}') + sys.exit(-2) + + try: + dataTray.append(data) + except: + print('Failed to append data array to dataTray') + sys.exit(-2) + + InpFile.close() + print(f'Closed data file {InpFileSpec}') + return(header) + +""" +Function to write the netCDF file +""" +def stuff_netCDF_file(ncFile,interpolationTemps,dataTray,hasLambdaGrid,InpFileSpecs,var_typ,Headers): + + ndataVars = len(dataTray) + print(f'ndataVars = {ndataVars}') + + for dataVarNdx in range(ndataVars): + nparameterRow,nparameterCol = np.shape(dataTray[dataVarNdx]) + if( hasLambdaGrid ): + nparameterCol -= 1 + ntemperature = min( len(interpolationTemps),nparameterCol ) + print(f'data array is ({nparameterRow},{nparameterCol})') + DataTag = var_typ + "_parameters" +# define dimensions + RowDimName = 'bins' + ColDimName = 'parameters' + TempDimName = 'temperatures' + print(f'Variable type = {var_typ}') + print(f'RowDimName,ColDimName = {RowDimName},{ColDimName}') + ncFile.createDimension(RowDimName,nparameterRow) + ncFile.createDimension(ColDimName,nparameterCol) + ncFile.createDimension(TempDimName,ntemperature) +# create wavelength grid + if( hasLambdaGrid ): + Var = ncFile.createVariable('wavelength',np.float64,(RowDimName)) + Var.units = 'nm' +# write wavelength grid + Var[:] = dataTray[dataVarNdx][:,0] +# create interpolation temperature array + if( len(interpolationTemps) > 0 ): + Var = ncFile.createVariable('temperature',np.float64,(TempDimName)) + Var.units = 'K' +# write interpolation temperature array + Var[:] = interpolationTemps[:ntemperature] +# create cross section or quantum yield data array + Var = ncFile.createVariable(DataTag,np.float64,(ColDimName,RowDimName)) + Var.hdr = Headers[dataVarNdx] +# write data array + if( hasLambdaGrid ): + Var[:,:] = np.transpose(dataTray[dataVarNdx][:,1:]) + else: + Var[:,:] = np.transpose(dataTray[dataVarNdx]) + if( var_typ == 'cross_section' ): + if( hasLambdaGrid ): + Var.units = 'cm^2' + else: + Var.units = 'see source code' + else: + Var.units = 'fraction' + +# global attributes + version = '1.0' + ncFile.Author = 'TUV Data Xformer ' + version + now = dt.now() + ncFile.created = now.strftime("%Y-%m-%d %H:%M:%S") + if( var_typ == 'cross_section' ): + ncFile.title = 'Cross section parameters' + else: + ncFile.title = 'Quantum yield parameters' + ncFile.file = InpFileSpecs + +""" +Transform ascii data file(s) to netCDF counterpart +""" +def xform_to_netCDF(nFile,phtDictionary,ncd_path): + +# cross section + if( 'cross-sections' in phtDictionary ): +# form netCDF file for cross sections + molecule = phtDictionary['molecule'] + + print(f'\nProcessing {molecule} cross section') + xsects = phtDictionary['cross-sections'] + nxsects = len(xsects) + print(f' There are {nxsects} cross section files') + dataTray = [] + interpolationTemps = [] + Headers = [] + +# loop over ascii input data files + for xsect in xsects: + ncdFilespec = ncd_path + '/' + molecule + '.nc' +# create the netcdf dataset + print(f'\nCreating netCDF file {ncdFilespec}') + + try: + ncFile = Dataset(ncdFilespec,mode='w',format='NETCDF4_CLASSIC') + except: + print(f'Failed to create netCDF4 dataset {ncdFilespec}') + sys.exit(-1) + +# 1st data column wavelength grid? + if( 'has lambda grid' in xsect ): + hasLambdaGrid = xsect['has lambda grid'] + else: + hasLambdaGrid = True + +# interpolation temperatures? + if( 'interpolation temperature' in xsect ): + interpolationTemps = xsect['interpolation temperature'] + print("\nInterpolation temperatures:") + print(interpolationTemps) + + header = '' + header = read_data_file(xsect,dataTray) + Headers.append(header) + + InpFileSpecs = xsect['filespec'] + + print(f'\nThere are {len(dataTray)} arrays in dataTray') + print(f'\nShape data array is {dataTray[0].shape}') + stuff_netCDF_file(ncFile,interpolationTemps,dataTray,hasLambdaGrid,InpFileSpecs,'cross_section',Headers) +# close netcdf file + ncFile.close() + + print('\n') + +# quantum yield + if( 'quantum-yields' in phtDictionary ): +# form netCDF file for cross sections + molecule = phtDictionary['molecule'] + + print(f'\nProcessing {molecule} quantum yield') + qylds = phtDictionary['quantum-yields'] + nqylds = len(qylds) + print(f' There are {nqylds} quantum yield files') + dataTray = [] + interpolationTemps = [] + Headers = [] + +# loop over ascii input data files + for qyld in qylds: + ncdFilespec = ncd_path + '/' + molecule + '_quantum_yield_' + str(nFile) + '.nc' +# create the netcdf dataset + print(f'\nCreating netCDF file {ncdFilespec}') + + try: + ncFile = Dataset(ncdFilespec,mode='w',format='NETCDF4_CLASSIC') + except: + print(f'Failed to create netCDF4 dataset {ncdFilespec}') + sys.exit(-1) + +# 1st data column wavelength grid? + if( 'has lambda grid' in qyld ): + hasLambdaGrid = qyld['has lambda grid'] + else: + hasLambdaGrid = True + +# interpolation temperatures? + if( 'interpolation temperature' in qyld ): + interpolationTemps = qyld['interpolation temperature'] + print("\nInterpolation temperatures:") + print(interpolationTemps) + + header = '' + header = read_data_file(qyld,dataTray) + Headers.append(header) + + InpFileSpecs = qyld['filespec'] + + print(f'\nThere are {len(dataTray)} arrays in dataTray') + print(f'\nShape data array is {dataTray[0].shape}') + stuff_netCDF_file(ncFile,interpolationTemps,dataTray,hasLambdaGrid,InpFileSpecs,'quantum_yield',Headers) +# close netcdf file + ncFile.close()