diff --git a/.dockerignore b/.dockerignore index 536a22ad..293e77a1 100644 --- a/.dockerignore +++ b/.dockerignore @@ -16,4 +16,4 @@ !python/ !pyproject.toml !LICENSE -!README.md \ No newline at end of file +!README.md diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml new file mode 100644 index 00000000..d3857ea1 --- /dev/null +++ b/.github/workflows/release.yml @@ -0,0 +1,85 @@ +name: Publish Python Package + +on: + workflow_dispatch: + release: + types: + - published + +jobs: + build_sdist: + name: Build SDist + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + with: + submodules: true + + - name: Build SDist + run: pipx run build --sdist + + - name: Check metadata + run: pipx run twine check dist/* + + - uses: actions/upload-artifact@v4 + with: + name: cibw-sdist + path: dist/*.tar.gz + + build_wheels: + name: Build wheels on ${{ matrix.os }} with Python ${{ matrix.python-version }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, windows-latest, macos-latest] + python-version: ["3.12"] + + steps: + - uses: actions/checkout@v4 + with: + submodules: true + + - uses: actions/setup-python@v5 + with: + python-version: ${{ matrix.python-version }} + + - uses: pypa/cibuildwheel@v2.17 + env: + CIBW_ARCHS_MACOS: arm64 x86_64 + CIBW_SKIP: cp27-* cp34-* cp35-* cp36-* *musllinux* + CIBW_BUILD: cp37-* cp38-* cp39-* cp310-* cp311-* cp312-* + + - name: Verify clean directory + run: git diff --exit-code + shell: bash + + - name: Upload wheels + uses: actions/upload-artifact@v4 + with: + name: cibw-wheels-${{ matrix.os }}-py${{ matrix.python-version }} + path: wheelhouse/*.whl + + upload_all: + name: Upload release + needs: [build_wheels, build_sdist] + runs-on: ubuntu-latest + environment: + name: pypi + url: https://pypi.org/p/musica + permissions: + id-token: write + + steps: + - uses: actions/setup-python@v5 + with: + python-version: "3.x" + + - uses: actions/download-artifact@v4 + with: + pattern: cibw-* + path: dist + merge-multiple: true + + - name: Publish package distributions to PyPI + uses: pypa/gh-action-pypi-publish@release/v1 diff --git a/.github/workflows/ubuntu.yml b/.github/workflows/ubuntu.yml index 9a92a71c..510c1c6c 100644 --- a/.github/workflows/ubuntu.yml +++ b/.github/workflows/ubuntu.yml @@ -55,7 +55,7 @@ jobs: strategy: matrix: gcc_version: [12, 13, 14] - build_type: [Release] + build_type: [Debug, Release] env: CXX: g++-${{ matrix.gcc_version }} CC: gcc-${{ matrix.gcc_version }} diff --git a/CITATION.cff b/CITATION.cff index 0e880813..590cfe13 100644 --- a/CITATION.cff +++ b/CITATION.cff @@ -64,4 +64,4 @@ number: 10 page: "E1743 - E1760" doi: "10.1175/BAMS-D-19-0331.1" url: "https://journals.ametsoc.org/view/journals/bams/101/10/bamsD190331.xml" -version: 0.7.0 \ No newline at end of file +version: 0.7.1 \ No newline at end of file diff --git a/CMakeLists.txt b/CMakeLists.txt index 8f19d7a3..4f3831d0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,7 +1,7 @@ cmake_minimum_required(VERSION 3.21) # must be on the same line so that pyproject.toml can correctly identify the version -project(musica-distribution VERSION 0.7.0) +project(musica-distribution VERSION 0.7.1) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH};${PROJECT_SOURCE_DIR}/cmake) set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_MODULE_PATH}/SetDefaults.cmake) @@ -30,6 +30,8 @@ option(MUSICA_BUILD_DOCS "Build the documentation" OFF) option(MUSICA_ENABLE_MICM "Enable MICM" ON) option(MUSICA_ENABLE_TUVX "Enable TUV-x" ON) +set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "1" CACHE STRING "Set MICM vector-ordered matrix dimension") + cmake_dependent_option( MUSICA_ENABLE_PYTHON_LIBRARY "Adds pybind11, a lightweight header-only library that exposes C++ types in Python and vice versa" OFF "MUSICA_BUILD_C_CXX_INTERFACE" OFF) diff --git a/README.md b/README.md index 48267493..76377770 100644 --- a/README.md +++ b/README.md @@ -7,6 +7,8 @@ [![windows](https://github.com/NCAR/musica/actions/workflows/windows.yml/badge.svg)](https://github.com/NCAR/musica/actions/workflows/windows.yml) [![pip](https://github.com/NCAR/musica/actions/workflows/pip.yml/badge.svg)](https://github.com/NCAR/musica/actions/workflows/pip.yml) [![DOI](https://zenodo.org/badge/550370528.svg)](https://zenodo.org/doi/10.5281/zenodo.7458559) +[![PyPI version](https://badge.fury.io/py/musica.svg)](https://pypi.org/p/musica) +[![FAIR checklist badge](https://fairsoftwarechecklist.net/badge.svg)](https://fairsoftwarechecklist.net/v0.2?f=31&a=32113&i=22322&r=123) Multi-Scale Infrastructure for Chemistry and Aerosols diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index ef501863..52719f9f 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -51,7 +51,7 @@ endif() if (MUSICA_ENABLE_MICM AND MUSICA_BUILD_C_CXX_INTERFACE) set_git_default(MICM_GIT_REPOSITORY https://github.com/NCAR/micm.git) - set_git_default(MICM_GIT_TAG v3.5.0) + set_git_default(MICM_GIT_TAG 6b1c58a9be14095e3f3c6df403c91c4e800f23de) FetchContent_Declare(micm GIT_REPOSITORY ${MICM_GIT_REPOSITORY} @@ -60,6 +60,7 @@ if (MUSICA_ENABLE_MICM AND MUSICA_BUILD_C_CXX_INTERFACE) ) set(MICM_ENABLE_TESTS OFF) set(MICM_ENABLE_EXAMPLES OFF) + set(MICM_DEFAULT_VECTOR_MATRIX_SIZE ${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) FetchContent_MakeAvailable(micm) endif() @@ -74,7 +75,7 @@ if (MUSICA_ENABLE_TUVX AND MUSICA_BUILD_C_CXX_INTERFACE) set(TUVX_INSTALL_INCLUDE_DIR ${MUSICA_INSTALL_INCLUDE_DIR} CACHE STRING "" FORCE) set_git_default(TUVX_GIT_REPOSITORY https://github.com/NCAR/tuv-x.git) - set_git_default(TUVX_GIT_TAG v0.9.0) + set_git_default(TUVX_GIT_TAG 674ee1e72853bb44d23c36602fa73c955b2f021d) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/cmake/test_util.cmake b/cmake/test_util.cmake index 074f01d5..39cafea1 100644 --- a/cmake/test_util.cmake +++ b/cmake/test_util.cmake @@ -43,7 +43,7 @@ function(create_standard_test_cxx) add_executable(test_${TEST_NAME} ${TEST_SOURCES}) target_link_libraries(test_${TEST_NAME} PUBLIC musica::musica GTest::gtest_main) if(MUSICA_ENABLE_OPENMP) - target_link_libraries(test_${TEST_NAME} PUBLIC OpenMP::OpenMP_CXX OpenMP::OpenMP_Fortran) + target_link_libraries(test_${TEST_NAME} PUBLIC OpenMP::OpenMP_CXX) endif() if(NOT DEFINED TEST_WORKING_DIRECTORY) set(TEST_WORKING_DIRECTORY "${CMAKE_BINARY_DIR}") diff --git a/configs/chapman/species.json b/configs/chapman/species.json index 8e76fadf..bb496e2c 100644 --- a/configs/chapman/species.json +++ b/configs/chapman/species.json @@ -3,7 +3,7 @@ { "name": "M", "type": "CHEM_SPEC", - "tracer type": "CONSTANT" + "tracer type": "THIRD_BODY" }, { "name": "O2", diff --git a/docker/Dockerfile b/docker/Dockerfile index 6fa6c930..31f319f2 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -9,7 +9,6 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index 7e6410c9..0a181191 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=release +ARG BUILD_TYPE=Release RUN dnf -y update \ && dnf -y install \ @@ -13,7 +13,6 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - lapack-devel \ lcov \ libcurl-devel \ m4 \ @@ -38,6 +37,7 @@ RUN cd musica \ && cmake -S . \ -B build \ -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ + -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -D MUSICA_BUILD_FORTRAN_INTERFACE=ON \ -D MUSICA_ENABLE_MEMCHECK=ON \ && cd build \ diff --git a/docker/Dockerfile.fortran-gcc.integration b/docker/Dockerfile.fortran-gcc.integration index 4df87708..610eebc8 100644 --- a/docker/Dockerfile.fortran-gcc.integration +++ b/docker/Dockerfile.fortran-gcc.integration @@ -14,7 +14,6 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - lapack-devel \ lcov \ libcurl-devel \ m4 \ @@ -50,6 +49,7 @@ RUN cd musica/fortran/test/fetch_content_integration \ -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -D MUSICA_ENABLE_MICM=ON \ -D MUSICA_ENABLE_TUVX=OFF \ + -D MUSICA_ENABLE_MEMCHECK=ON \ && make -j WORKDIR musica/fortran/test/fetch_content_integration/build \ No newline at end of file diff --git a/docker/Dockerfile.fortran-intel b/docker/Dockerfile.fortran-intel index d6f2fe61..34bb0eb7 100644 --- a/docker/Dockerfile.fortran-intel +++ b/docker/Dockerfile.fortran-intel @@ -12,6 +12,7 @@ ARG MUSICA_GIT_TAG=main RUN apt update \ && apt -y install \ cmake \ + cmake-curses-gui \ curl \ gcc \ gfortran \ @@ -50,7 +51,7 @@ COPY . musica RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=Release \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ && cd build \ && make install -j @@ -65,8 +66,7 @@ RUN cd musica/fortran/test/fetch_content_integration \ -D CMAKE_BUILD_TYPE=Release \ -D CMAKE_EXE_LINKER_FLAGS="-Wl,--copy-dt-needed-entries" \ -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ + -D MUSICA_ENABLE_MEMCHECK=ON \ && make -j -WORKDIR musica/fortran/test/fetch_content_integration/build -RUN cp -r /musica/build/_deps/tuvx-src/examples/ . -RUN cp -r /musica/build/_deps/tuvx-src/data/ . \ No newline at end of file +WORKDIR musica/fortran/test/fetch_content_integration/build \ No newline at end of file diff --git a/docker/Dockerfile.fortran-nvhpc b/docker/Dockerfile.fortran-nvhpc index 82b8fdc9..ffdfc9b5 100644 --- a/docker/Dockerfile.fortran-nvhpc +++ b/docker/Dockerfile.fortran-nvhpc @@ -66,6 +66,7 @@ RUN cd musica/fortran/test/fetch_content_integration \ -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ -D CMAKE_EXE_LINKER_FLAGS="-Wl,--copy-dt-needed-entries" \ -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ + -D MUSICA_ENABLE_MEMCHECK=ON \ && make -j WORKDIR musica/fortran/test/fetch_content_integration/build \ No newline at end of file diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index 25c61637..8b330b51 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Debug + RUN dnf -y update \ && dnf -y install \ cmake \ @@ -7,7 +9,6 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - lapack-devel \ lcov \ make \ netcdf-fortran-devel \ @@ -22,7 +23,7 @@ COPY . musica RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=Debug \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ -D MUSICA_ENABLE_MEMCHECK=ON \ && cd build \ && make install -j 8 diff --git a/docker/Dockerfile.mpi b/docker/Dockerfile.mpi index 91acf76e..8935ca62 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Debug + RUN dnf -y update \ && dnf install -y sudo \ && adduser test_user \ @@ -14,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ lcov \ make \ netcdf-fortran-devel \ @@ -38,9 +39,9 @@ RUN sudo chown -R test_user.test_user musica RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=debug \ - -D ENABLE_TESTS=ON \ - -D ENABLE_MPI=ON \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ + -D MUSICA_ENABLE_TESTS=ON \ + -D MUSICA_ENABLE_MPI=ON \ -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 \ diff --git a/docker/Dockerfile.mpi_openmp b/docker/Dockerfile.mpi_openmp index a9147545..7a5eb9b8 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Debug + RUN dnf -y update \ && dnf install -y sudo \ && adduser test_user \ @@ -14,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ lcov \ make \ netcdf-fortran-devel \ @@ -38,10 +39,10 @@ RUN sudo chown -R test_user.test_user musica RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=debug \ - -D ENABLE_MPI=ON \ - -D ENABLE_OPENMP=ON \ - -D ENABLE_TESTS=ON \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ + -D MUSICA_ENABLE_MPI=ON \ + -D MUSICA_ENABLE_OPENMP=ON \ + -D MUSICA_ENABLE_TESTS=ON \ -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 \ diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index 7ad2c7af..cb612509 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Debug + RUN dnf -y update \ && dnf install -y sudo \ && adduser test_user \ @@ -14,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ lcov \ make \ netcdf-fortran-devel \ @@ -37,9 +38,9 @@ RUN sudo chown -R test_user.test_user musica RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=debug \ - -D ENABLE_OPENMP:BOOL=TRUE \ - -D ENABLE_TESTS=ON \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ + -D MUSICA_ENABLE_OPENMP=ON \ + -D MUSICA_ENABLE_TESTS=ON \ -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/mpic++ \ diff --git a/docker/Dockerfile.python b/docker/Dockerfile.python index e7c27299..8484ddc7 100644 --- a/docker/Dockerfile.python +++ b/docker/Dockerfile.python @@ -1,5 +1,7 @@ FROM fedora:latest +ARG BUILD_TYPE=Release + RUN dnf -y update \ && dnf -y install \ cmake \ @@ -7,7 +9,6 @@ RUN dnf -y update \ gcc-fortran \ gdb \ git \ - lapack-devel \ make \ netcdf-fortran-devel \ pip \ @@ -45,7 +46,7 @@ RUN pip install -r requirements.txt RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=Release \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ -D MUSICA_ENABLE_PYTHON_LIBRARY=ON \ -D MUSICA_ENABLE_TUVX=OFF \ && cd build \ diff --git a/docs/source/tutorial/chapter0.rst b/docs/source/tutorial/chapter0.rst new file mode 100644 index 00000000..60993b44 --- /dev/null +++ b/docs/source/tutorial/chapter0.rst @@ -0,0 +1,40 @@ +Chapter 0 +========= + +The MUSICA CMake Package +------------------------ + +The MUSICA library installs with `CMake` ``musica`` and ``musica_fortran`` +packages to facilitate linking +to higher level libraries and host models that have CMake build systems. + +A minimal ``CMakeLists.txt`` file designed to link the ``musica_fortran`` library +to a Fortran program ``demo_f.f90`` is exhibited below + + .. literalinclude:: ../../../fortran/test/tutorial/CMakeLists.txt + :language: cmake + +These `CMake` directives are essentially equivalent to compilation on the command line via + +.. code-block:: bash + + gfortran -o demo_f demo_f.f90 -I/include -L/lib -lmusica-fortran -lmusica -lstdc++ + +```` is the full path of the MUSICA installation directory, +specified by the option ``CMAKE_INSTALL_PREFIX`` +during the `cmake` configuration process. + +Common practice is to create a ``build`` subdir (relative to the top level ``CMakeLists.txt`` file, say). + +.. code-block:: bash + + mkdir build + cd build + +The ``cmake`` could then be invoked with: + +.. code-block:: bash + + cmake -DMUSICA_INSTALL_DIR .. + cmake --build . + diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst new file mode 100644 index 00000000..519ffa20 --- /dev/null +++ b/docs/source/tutorial/chapter2.rst @@ -0,0 +1,65 @@ +Chapter 2 +========= + +An MICM Box Model Fortran Example +--------------------------------- + +In this next MUSICA Fortran example, +we will setup a MICM solver, starting with a set of MICM configuration files, +and run the solver for a single integration time step. + +The MICM configuration is specified in a top-level ``config.json`` file, +which simply lists the chemical species configuration file followed by +the reactions configuration file. + + .. literalinclude:: ../../../configs/analytical/config.json + :language: json + +For this example, we will have a system of three chemical species +`A`, `B`, and `C`, defined in the JSON file ``species.json`` as follows: + + .. literalinclude:: ../../../configs/analytical/species.json + :language: json + +The ``reactions.json`` specifies a mechanism, or a set of reactions for the system. +Here, we will introduce two Arrhenius type reactions, the first +with `B` evolving to `C`, and specifying all five reaction parameters, +and the second reaction with `A` evolving to `B` and using only two reaction parameters. +The mechanism configuration might then be set up as: + + .. literalinclude:: ../../../configs/analytical/reactions.json + :language: json + +More information on MICM configurations and reactions can be found in the MICM documentation +at `https://ncar.github.io/micm/user_guide/`_ + +The Fortran example code is shown below in full: + + .. literalinclude:: ../../../fortran/test/fetch_content_integration/test_micm_box_model.F90 + :language: f90 + +From the ``musica_util`` module we need the Fortran types +``error_t``, ``string_t``, and ``mapping_t``. +A pointer to a ``musica_micm::micm_t`` will serve as the interface to the MICM solver +(in the example the pointer name is ``micm``). +Note that the ``config_path`` in the code sample has been set to ``configs/analytical``, +so that subdir should be created relative to the main program and contain +the MICM JSON configuration files, +or otherwise the ``config_path`` should be modified appropriately. +The initial species concentrations are initialized in the ``concentrations`` array, +which is an argument to the MICM solver. + +Finally, a single time step solution is obtained through a call to ``micm%solve``, +after which the updated concentrations may be displayed. + +.. code-block:: bash + + $ ./test_micm_box_model + Creating MICM solver... + Species Name:A, Index: 1 + Species Name:B, Index: 2 + Species Name:C, Index: 3 + Solving starts... + After solving, concentrations 0.38 1.61E-009 2.62 + $ + diff --git a/docs/source/tutorial/tutorial.rst b/docs/source/tutorial/tutorial.rst index e4206e3d..d6a250c7 100644 --- a/docs/source/tutorial/tutorial.rst +++ b/docs/source/tutorial/tutorial.rst @@ -6,4 +6,6 @@ Tutorial :maxdepth: 1 :caption: Contents: + chapter0.rst chapter1.rst + chapter2.rst diff --git a/fortran/CMakeLists.txt b/fortran/CMakeLists.txt index 3dfbe4c2..979867ed 100644 --- a/fortran/CMakeLists.txt +++ b/fortran/CMakeLists.txt @@ -63,10 +63,7 @@ if (MUSICA_ENABLE_MICM) ) endif() if (MUSICA_ENABLE_TUVX) - target_sources(musica-fortran - PRIVATE - tuvx.F90 - ) + add_subdirectory(tuvx) endif() # Add flags for gfortran diff --git a/fortran/micm.F90 b/fortran/micm.F90 index 854a4db8..dc35145b 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -3,436 +3,448 @@ ! module musica_micm #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - use iso_c_binding, only: c_ptr, c_char, c_int, c_int64_t, c_bool, c_double, c_null_char, & - c_size_t, c_f_pointer, c_funptr, c_null_ptr, c_associated - use iso_fortran_env, only: int64 - use musica_util, only: assert, mapping_t, string_t, string_t_c - implicit none - - public :: micm_t, solver_stats_t, get_micm_version - private - - !> Wrapper for c solver stats - type, bind(c) :: solver_stats_t_c - integer(c_int64_t) :: function_calls_ = 0_c_int64_t - integer(c_int64_t) :: jacobian_updates_ = 0_c_int64_t - integer(c_int64_t) :: number_of_steps_ = 0_c_int64_t - integer(c_int64_t) :: accepted_ = 0_c_int64_t - integer(c_int64_t) :: rejected_ = 0_c_int64_t - integer(c_int64_t) :: decompositions_ = 0_c_int64_t - integer(c_int64_t) :: solves_ = 0_c_int64_t - integer(c_int64_t) :: singular_ = 0_c_int64_t - real(c_double) :: final_time_ = 0._c_double - end type solver_stats_t_c - - interface - function create_micm_c(config_path, error) bind(C, name="CreateMicm") - use musica_util, only: error_t_c - import c_ptr, c_int, c_char - character(kind=c_char), intent(in) :: config_path(*) - type(error_t_c), intent(inout) :: error - type(c_ptr) :: create_micm_c - end function create_micm_c - - subroutine delete_micm_c(micm, error) bind(C, name="DeleteMicm") - use musica_util, only: error_t_c - import c_ptr - type(c_ptr), value, intent(in) :: micm - type(error_t_c), intent(inout) :: error - end subroutine delete_micm_c - - subroutine micm_solve_c(micm, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) & - bind(C, name="MicmSolve") - use musica_util, only: string_t_c, error_t_c - import c_ptr, c_double, c_int, solver_stats_t_c - type(c_ptr), value, intent(in) :: micm - real(kind=c_double), value, intent(in) :: time_step - real(kind=c_double), value, intent(in) :: temperature - real(kind=c_double), value, intent(in) :: pressure - real(kind=c_double), value, intent(in) :: air_density - integer(kind=c_int), value, intent(in) :: num_concentrations - real(kind=c_double), intent(inout) :: concentrations(num_concentrations) - integer(kind=c_int), value, intent(in) :: num_user_defined_reaction_rates - real(kind=c_double), intent(inout) :: user_defined_reaction_rates(num_user_defined_reaction_rates) - type(string_t_c), intent(out) :: solver_state - type(solver_stats_t_c), intent(out) :: solver_stats - type(error_t_c), intent(inout) :: error - end subroutine micm_solve_c - - function get_micm_version_c() bind(C, name="MicmVersion") - use musica_util, only: string_t_c - type(string_t_c) :: get_micm_version_c - end function get_micm_version_c - - function get_species_property_string_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyString") - use musica_util, only: error_t_c, string_t_c - import c_ptr, c_char - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - type(string_t_c) :: get_species_property_string_c - end function get_species_property_string_c - - function get_species_property_double_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyDouble") - use musica_util, only: error_t_c - import c_ptr, c_char, c_double - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - real(kind=c_double) :: get_species_property_double_c - end function get_species_property_double_c - - function get_species_property_int_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyInt") - use musica_util, only: error_t_c - import c_ptr, c_char, c_int - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - integer(kind=c_int) :: get_species_property_int_c - end function get_species_property_int_c - - function get_species_property_bool_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyBool") - use musica_util, only: error_t_c - import c_ptr, c_char, c_bool - type(c_ptr), value, intent(in) :: micm - character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) - type(error_t_c), intent(inout) :: error - logical(kind=c_bool) :: get_species_property_bool_c - end function get_species_property_bool_c - - type(c_ptr) function get_species_ordering_c(micm, array_size, error) bind(c, name="GetSpeciesOrdering") - use musica_util, only: error_t_c - import c_ptr, c_size_t - type(c_ptr), value, intent(in) :: micm - integer(kind=c_size_t), intent(out) :: array_size - type(error_t_c), intent(inout) :: error - end function get_species_ordering_c - - type(c_ptr) function get_user_defined_reaction_rates_ordering_c(micm, array_size, error) & - bind(c, name="GetUserDefinedReactionRatesOrdering") - use musica_util, only: error_t_c - import c_ptr, c_size_t - type(c_ptr), value, intent(in) :: micm - integer(kind=c_size_t), intent(out) :: array_size - type(error_t_c), intent(inout) :: error - end function get_user_defined_reaction_rates_ordering_c - - subroutine delete_mappings_c(mappings, array_size) bind(C, name="DeleteMappings") - import c_ptr, c_size_t - type(c_ptr), value, intent(in) :: mappings - integer(kind=c_size_t), value, intent(in) :: array_size - end subroutine delete_mappings_c - end interface - - type :: micm_t - type(mapping_t), allocatable :: species_ordering(:) - type(mapping_t), allocatable :: user_defined_reaction_rates(:) - type(c_ptr), private :: ptr = c_null_ptr - contains - ! Solve the chemical system - procedure :: solve - ! Get species properties - procedure :: get_species_property_string - procedure :: get_species_property_double - procedure :: get_species_property_int - procedure :: get_species_property_bool - ! Deallocate the micm instance - final :: finalize - end type micm_t - - interface micm_t - procedure constructor - end interface micm_t - - !> Solver stats type - type :: solver_stats_t - integer(int64) :: function_calls_ - integer(int64) :: jacobian_updates_ - integer(int64) :: number_of_steps_ - integer(int64) :: accepted_ - integer(int64) :: rejected_ - integer(int64) :: decompositions_ - integer(int64) :: solves_ - integer(int64) :: singular_ - real :: final_time_ - contains - procedure :: function_calls => solver_stats_t_function_calls - procedure :: jacobian_updates => solver_stats_t_jacobian_updates - procedure :: number_of_steps => solver_stats_t_number_of_steps - procedure :: accepted => solver_stats_t_accepted - procedure :: rejected => solver_stats_t_rejected - procedure :: decompositions => solver_stats_t_decompositions - procedure :: solves => solver_stats_t_solves - procedure :: singular => solver_stats_t_singular - procedure :: final_time => solver_stats_t_final_time - end type solver_stats_t - - interface solver_stats_t - procedure solver_stats_t_constructor - end interface solver_stats_t + use iso_c_binding, only: c_ptr, c_char, c_int, c_int64_t, c_bool, c_double, c_null_char, & + c_size_t, c_f_pointer, c_funptr, c_null_ptr, c_associated + use iso_fortran_env, only: int64 + use musica_util, only: assert, mapping_t, string_t, string_t_c + implicit none + + public :: micm_t, solver_stats_t, get_micm_version + public :: Rosenbrock, RosenbrockStandardOrder + private + + !> Wrapper for c solver stats + type, bind(c) :: solver_stats_t_c + integer(c_int64_t) :: function_calls_ = 0_c_int64_t + integer(c_int64_t) :: jacobian_updates_ = 0_c_int64_t + integer(c_int64_t) :: number_of_steps_ = 0_c_int64_t + integer(c_int64_t) :: accepted_ = 0_c_int64_t + integer(c_int64_t) :: rejected_ = 0_c_int64_t + integer(c_int64_t) :: decompositions_ = 0_c_int64_t + integer(c_int64_t) :: solves_ = 0_c_int64_t + integer(c_int64_t) :: singular_ = 0_c_int64_t + real(c_double) :: final_time_ = 0._c_double + end type solver_stats_t_c + + ! We could use Fortran 2023 enum type feature if Fortran 2023 is supported + ! https://fortran-lang.discourse.group/t/enumerator-type-in-bind-c-derived-type-best-practice/5947/2 + enum, bind(c) + enumerator :: Rosenbrock = 1 + enumerator :: RosenbrockStandardOrder = 2 + end enum + + interface + function create_micm_c(config_path, solver_type, num_grid_cells, error) bind(C, name="CreateMicm") + use musica_util, only: error_t_c + import c_ptr, c_int, c_char + character(kind=c_char), intent(in) :: config_path(*) + integer(kind=c_int), value, intent(in) :: solver_type + integer(kind=c_int), value, intent(in) :: num_grid_cells + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_micm_c + end function create_micm_c + + subroutine delete_micm_c(micm, error) bind(C, name="DeleteMicm") + use musica_util, only: error_t_c + import c_ptr + type(c_ptr), value, intent(in) :: micm + type(error_t_c), intent(inout) :: error + end subroutine delete_micm_c + + subroutine micm_solve_c(micm, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) & + bind(C, name="MicmSolve") + use musica_util, only: string_t_c, error_t_c + import c_ptr, c_double, c_int, solver_stats_t_c + type(c_ptr), value, intent(in) :: micm + real(kind=c_double), value, intent(in) :: time_step + real(kind=c_double), value, intent(in) :: temperature + real(kind=c_double), value, intent(in) :: pressure + real(kind=c_double), value, intent(in) :: air_density + integer(kind=c_int), value, intent(in) :: num_concentrations + real(kind=c_double), intent(inout) :: concentrations(num_concentrations) + integer(kind=c_int), value, intent(in) :: num_user_defined_reaction_rates + real(kind=c_double), intent(inout) :: user_defined_reaction_rates(num_user_defined_reaction_rates) + type(string_t_c), intent(out) :: solver_state + type(solver_stats_t_c), intent(out) :: solver_stats + type(error_t_c), intent(inout) :: error + end subroutine micm_solve_c + + function get_micm_version_c() bind(C, name="MicmVersion") + use musica_util, only: string_t_c + type(string_t_c) :: get_micm_version_c + end function get_micm_version_c + + function get_species_property_string_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyString") + use musica_util, only: error_t_c, string_t_c + import c_ptr, c_char + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + type(string_t_c) :: get_species_property_string_c + end function get_species_property_string_c + + function get_species_property_double_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyDouble") + use musica_util, only: error_t_c + import c_ptr, c_char, c_double + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + real(kind=c_double) :: get_species_property_double_c + end function get_species_property_double_c + + function get_species_property_int_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyInt") + use musica_util, only: error_t_c + import c_ptr, c_char, c_int + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + integer(kind=c_int) :: get_species_property_int_c + end function get_species_property_int_c + + function get_species_property_bool_c(micm, species_name, property_name, error) bind(c, name="GetSpeciesPropertyBool") + use musica_util, only: error_t_c + import c_ptr, c_char, c_bool + type(c_ptr), value, intent(in) :: micm + character(len=1, kind=c_char), intent(in) :: species_name(*), property_name(*) + type(error_t_c), intent(inout) :: error + logical(kind=c_bool) :: get_species_property_bool_c + end function get_species_property_bool_c + + type(c_ptr) function get_species_ordering_c(micm, array_size, error) bind(c, name="GetSpeciesOrdering") + use musica_util, only: error_t_c + import c_ptr, c_size_t + type(c_ptr), value, intent(in) :: micm + integer(kind=c_size_t), intent(out) :: array_size + type(error_t_c), intent(inout) :: error + end function get_species_ordering_c + + type(c_ptr) function get_user_defined_reaction_rates_ordering_c(micm, array_size, error) & + bind(c, name="GetUserDefinedReactionRatesOrdering") + use musica_util, only: error_t_c + import c_ptr, c_size_t + type(c_ptr), value, intent(in) :: micm + integer(kind=c_size_t), intent(out) :: array_size + type(error_t_c), intent(inout) :: error + end function get_user_defined_reaction_rates_ordering_c + + subroutine delete_mappings_c(mappings, array_size) bind(C, name="DeleteMappings") + import c_ptr, c_size_t + type(c_ptr), value, intent(in) :: mappings + integer(kind=c_size_t), value, intent(in) :: array_size + end subroutine delete_mappings_c + end interface + + type :: micm_t + type(mapping_t), allocatable :: species_ordering(:) + type(mapping_t), allocatable :: user_defined_reaction_rates(:) + type(c_ptr), private :: ptr = c_null_ptr + contains + ! Solve the chemical system + procedure :: solve + ! Get species properties + procedure :: get_species_property_string + procedure :: get_species_property_double + procedure :: get_species_property_int + procedure :: get_species_property_bool + ! Deallocate the micm instance + final :: finalize + end type micm_t + + interface micm_t + procedure constructor + end interface micm_t + + !> Solver stats type + type :: solver_stats_t + integer(int64) :: function_calls_ + integer(int64) :: jacobian_updates_ + integer(int64) :: number_of_steps_ + integer(int64) :: accepted_ + integer(int64) :: rejected_ + integer(int64) :: decompositions_ + integer(int64) :: solves_ + integer(int64) :: singular_ + real :: final_time_ + contains + procedure :: function_calls => solver_stats_t_function_calls + procedure :: jacobian_updates => solver_stats_t_jacobian_updates + procedure :: number_of_steps => solver_stats_t_number_of_steps + procedure :: accepted => solver_stats_t_accepted + procedure :: rejected => solver_stats_t_rejected + procedure :: decompositions => solver_stats_t_decompositions + procedure :: solves => solver_stats_t_solves + procedure :: singular => solver_stats_t_singular + procedure :: final_time => solver_stats_t_final_time + end type solver_stats_t + + interface solver_stats_t + procedure solver_stats_t_constructor + end interface solver_stats_t contains - function get_micm_version() result(value) - use musica_util, only: string_t, string_t_c - type(string_t) :: value - type(string_t_c) :: string_c - string_c = get_micm_version_c() - value = string_t(string_c) - end function get_micm_version - - function constructor(config_path, error) result( this ) - use musica_util, only: error_t_c, error_t, copy_mappings - type(micm_t), pointer :: this - character(len=*), intent(in) :: config_path - type(error_t), intent(inout) :: error - character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) - integer :: n, i - type(c_ptr) :: mappings_ptr - integer(c_size_t) :: mappings_length - type(error_t_c) :: error_c - - allocate( this ) - - n = len_trim(config_path) - do i = 1, n - c_config_path(i) = config_path(i:i) - end do - c_config_path(n+1) = c_null_char - - this%ptr = create_micm_c(c_config_path, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - - mappings_ptr = get_species_ordering_c(this%ptr, mappings_length, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - this%species_ordering = copy_mappings(mappings_ptr, mappings_length) - call delete_mappings_c(mappings_ptr, mappings_length) - - mappings_ptr = get_user_defined_reaction_rates_ordering_c(this%ptr, & - mappings_length, error_c) - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - this%user_defined_reaction_rates = copy_mappings(mappings_ptr, mappings_length) - call delete_mappings_c(mappings_ptr, mappings_length) - - end function constructor - - subroutine solve(this, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) - use musica_util, only: string_t, string_t_c, error_t_c, error_t - class(micm_t) :: this - real(c_double), intent(in) :: time_step - real(c_double), intent(in) :: temperature - real(c_double), intent(in) :: pressure - real(c_double), intent(in) :: air_density - integer(c_int), intent(in) :: num_concentrations - real(c_double), intent(inout) :: concentrations(*) - integer(c_int), intent(in) :: num_user_defined_reaction_rates - real(c_double), intent(inout) :: user_defined_reaction_rates(*) - type(string_t), intent(out) :: solver_state - type(solver_stats_t), intent(out) :: solver_stats - type(error_t), intent(out) :: error - - type(string_t_c) :: solver_state_c - type(solver_stats_t_c) :: solver_stats_c - type(error_t_c) :: error_c - - call micm_solve_c(this%ptr, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & - num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state_c, solver_stats_c, error_c) - - solver_state = string_t(solver_state_c) - solver_stats = solver_stats_t(solver_stats_c) - error = error_t(error_c) - - end subroutine solve - - !> Constructor for solver_stats_t object that takes ownership of solver_stats_t_c - function solver_stats_t_constructor( c_solver_stats ) result( new_solver_stats ) - use iso_fortran_env, only: int64 - use musica_util, only: string_t - type(solver_stats_t_c), intent(inout) :: c_solver_stats - type(solver_stats_t) :: new_solver_stats - - new_solver_stats%function_calls_ = c_solver_stats%function_calls_ - new_solver_stats%jacobian_updates_ = c_solver_stats%jacobian_updates_ - new_solver_stats%number_of_steps_ = c_solver_stats%number_of_steps_ - new_solver_stats%accepted_ = c_solver_stats%accepted_ - new_solver_stats%rejected_ = c_solver_stats%rejected_ - new_solver_stats%decompositions_ = c_solver_stats%decompositions_ - new_solver_stats%solves_ = c_solver_stats%solves_ - new_solver_stats%singular_ = c_solver_stats%singular_ - new_solver_stats%final_time_ = real( c_solver_stats%final_time_ ) - - end function solver_stats_t_constructor - - !> Get the number of forcing function calls - function solver_stats_t_function_calls( this ) result( function_calls ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: function_calls - - function_calls = this%function_calls_ - - end function solver_stats_t_function_calls - - !> Get the number of jacobian function calls - function solver_stats_t_jacobian_updates( this ) result( jacobian_updates ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: jacobian_updates - - jacobian_updates = this%jacobian_updates_ - - end function solver_stats_t_jacobian_updates - - !> Get the total number of internal time steps taken - function solver_stats_t_number_of_steps( this ) result( number_of_steps ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: number_of_steps - - number_of_steps = this%number_of_steps_ - - end function solver_stats_t_number_of_steps - - !> Get the number of accepted integrations - function solver_stats_t_accepted( this ) result( accepted ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: accepted - - accepted = this%accepted_ - - end function solver_stats_t_accepted - - !> Get the number of rejected integrations - function solver_stats_t_rejected( this ) result( rejected ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: rejected - - rejected = this%rejected_ - - end function solver_stats_t_rejected - - !> Get the number of LU decompositions - function solver_stats_t_decompositions( this ) result( decompositions ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: decompositions - - decompositions = this%decompositions_ - - end function solver_stats_t_decompositions - - !> Get the number of linear solves - function solver_stats_t_solves( this ) result( solves ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: solves - - solves = this%solves_ - - end function solver_stats_t_solves - - !> Get the number of times a singular matrix is detected - function solver_stats_t_singular( this ) result( singular ) - use iso_fortran_env, only: int64 - class(solver_stats_t), intent(in) :: this - integer(int64) :: singular - - singular = this%function_calls_ - - end function solver_stats_t_singular - - !> Get the final time the solver iterated to - function solver_stats_t_final_time( this ) result( final_time ) - class(solver_stats_t), intent(in) :: this - real :: final_time - - final_time = this%final_time_ - - end function solver_stats_t_final_time - - function get_species_property_string(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, string_t, string_t_c, to_c_string - class(micm_t), intent(inout) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - type(string_t) :: value - - type(error_t_c) :: error_c - type(string_t_c) :: string_c - string_c = get_species_property_string_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - value = string_t(string_c) - error = error_t(error_c) - end function get_species_property_string - - function get_species_property_double(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, to_c_string - class(micm_t) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - real(c_double) :: value - - type(error_t_c) :: error_c - value = get_species_property_double_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - error = error_t(error_c) - end function get_species_property_double - - function get_species_property_int(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, to_c_string - class(micm_t) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - integer(c_int) :: value - - type(error_t_c) :: error_c - value = get_species_property_int_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - error = error_t(error_c) - end function get_species_property_int - - function get_species_property_bool(this, species_name, property_name, error) result(value) - use musica_util, only: error_t_c, error_t, to_c_string - class(micm_t) :: this - character(len=*), intent(in) :: species_name, property_name - type(error_t), intent(inout) :: error - logical :: value - - type(error_t_c) :: error_c - value = get_species_property_bool_c(this%ptr, & - to_c_string(species_name), to_c_string(property_name), error_c) - error = error_t(error_c) - end function get_species_property_bool - - subroutine finalize(this) - use musica_util, only: error_t, error_t_c - type(micm_t), intent(inout) :: this - - type(error_t_c) :: error_c - type(error_t) :: error - call delete_micm_c(this%ptr, error_c) - this%ptr = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end subroutine finalize + function get_micm_version() result(value) + use musica_util, only: string_t, string_t_c + type(string_t) :: value + type(string_t_c) :: string_c + string_c = get_micm_version_c() + value = string_t(string_c) + end function get_micm_version + + function constructor(config_path, solver_type, num_grid_cells, error) result( this ) + use musica_util, only: error_t_c, error_t, copy_mappings + type(micm_t), pointer :: this + character(len=*), intent(in) :: config_path + integer(c_int), intent(in) :: solver_type + integer(c_int), intent(in) :: num_grid_cells + type(error_t), intent(inout) :: error + character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) + integer :: n, i + type(c_ptr) :: mappings_ptr + integer(c_size_t) :: mappings_length + type(error_t_c) :: error_c + + allocate( this ) + + n = len_trim(config_path) + do i = 1, n + c_config_path(i) = config_path(i:i) + end do + c_config_path(n+1) = c_null_char + + this%ptr = create_micm_c(c_config_path, solver_type, num_grid_cells, error_c) + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + + mappings_ptr = get_species_ordering_c(this%ptr, mappings_length, error_c) + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + this%species_ordering = copy_mappings(mappings_ptr, mappings_length) + call delete_mappings_c(mappings_ptr, mappings_length) + + mappings_ptr = get_user_defined_reaction_rates_ordering_c(this%ptr, & + mappings_length, error_c) + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + this%user_defined_reaction_rates = copy_mappings(mappings_ptr, mappings_length) + call delete_mappings_c(mappings_ptr, mappings_length) + + end function constructor + + subroutine solve(this, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) + use musica_util, only: string_t, string_t_c, error_t_c, error_t + class(micm_t) :: this + real(c_double), intent(in) :: time_step + real(c_double), intent(in) :: temperature + real(c_double), intent(in) :: pressure + real(c_double), intent(in) :: air_density + integer(c_int), intent(in) :: num_concentrations + real(c_double), intent(inout) :: concentrations(*) + integer(c_int), intent(in) :: num_user_defined_reaction_rates + real(c_double), intent(inout) :: user_defined_reaction_rates(*) + type(string_t), intent(out) :: solver_state + type(solver_stats_t), intent(out) :: solver_stats + type(error_t), intent(out) :: error + + type(string_t_c) :: solver_state_c + type(solver_stats_t_c) :: solver_stats_c + type(error_t_c) :: error_c + + call micm_solve_c(this%ptr, time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state_c, solver_stats_c, error_c) + + solver_state = string_t(solver_state_c) + solver_stats = solver_stats_t(solver_stats_c) + error = error_t(error_c) + + end subroutine solve + + !> Constructor for solver_stats_t object that takes ownership of solver_stats_t_c + function solver_stats_t_constructor( c_solver_stats ) result( new_solver_stats ) + use iso_fortran_env, only: int64 + use musica_util, only: string_t + type(solver_stats_t_c), intent(inout) :: c_solver_stats + type(solver_stats_t) :: new_solver_stats + + new_solver_stats%function_calls_ = c_solver_stats%function_calls_ + new_solver_stats%jacobian_updates_ = c_solver_stats%jacobian_updates_ + new_solver_stats%number_of_steps_ = c_solver_stats%number_of_steps_ + new_solver_stats%accepted_ = c_solver_stats%accepted_ + new_solver_stats%rejected_ = c_solver_stats%rejected_ + new_solver_stats%decompositions_ = c_solver_stats%decompositions_ + new_solver_stats%solves_ = c_solver_stats%solves_ + new_solver_stats%singular_ = c_solver_stats%singular_ + new_solver_stats%final_time_ = real( c_solver_stats%final_time_ ) + + end function solver_stats_t_constructor + + !> Get the number of forcing function calls + function solver_stats_t_function_calls( this ) result( function_calls ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: function_calls + + function_calls = this%function_calls_ + + end function solver_stats_t_function_calls + + !> Get the number of jacobian function calls + function solver_stats_t_jacobian_updates( this ) result( jacobian_updates ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: jacobian_updates + + jacobian_updates = this%jacobian_updates_ + + end function solver_stats_t_jacobian_updates + + !> Get the total number of internal time steps taken + function solver_stats_t_number_of_steps( this ) result( number_of_steps ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: number_of_steps + + number_of_steps = this%number_of_steps_ + + end function solver_stats_t_number_of_steps + + !> Get the number of accepted integrations + function solver_stats_t_accepted( this ) result( accepted ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: accepted + + accepted = this%accepted_ + + end function solver_stats_t_accepted + + !> Get the number of rejected integrations + function solver_stats_t_rejected( this ) result( rejected ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: rejected + + rejected = this%rejected_ + + end function solver_stats_t_rejected + + !> Get the number of LU decompositions + function solver_stats_t_decompositions( this ) result( decompositions ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: decompositions + + decompositions = this%decompositions_ + + end function solver_stats_t_decompositions + + !> Get the number of linear solves + function solver_stats_t_solves( this ) result( solves ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: solves + + solves = this%solves_ + + end function solver_stats_t_solves + + !> Get the number of times a singular matrix is detected + function solver_stats_t_singular( this ) result( singular ) + use iso_fortran_env, only: int64 + class(solver_stats_t), intent(in) :: this + integer(int64) :: singular + + singular = this%function_calls_ + + end function solver_stats_t_singular + + !> Get the final time the solver iterated to + function solver_stats_t_final_time( this ) result( final_time ) + class(solver_stats_t), intent(in) :: this + real :: final_time + + final_time = this%final_time_ + + end function solver_stats_t_final_time + + function get_species_property_string(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, string_t, string_t_c, to_c_string + class(micm_t), intent(inout) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + type(string_t) :: value + + type(error_t_c) :: error_c + type(string_t_c) :: string_c + string_c = get_species_property_string_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + value = string_t(string_c) + error = error_t(error_c) + end function get_species_property_string + + function get_species_property_double(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, to_c_string + class(micm_t) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + real(c_double) :: value + + type(error_t_c) :: error_c + value = get_species_property_double_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + error = error_t(error_c) + end function get_species_property_double + + function get_species_property_int(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, to_c_string + class(micm_t) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + integer(c_int) :: value + + type(error_t_c) :: error_c + value = get_species_property_int_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + error = error_t(error_c) + end function get_species_property_int + + function get_species_property_bool(this, species_name, property_name, error) result(value) + use musica_util, only: error_t_c, error_t, to_c_string + class(micm_t) :: this + character(len=*), intent(in) :: species_name, property_name + type(error_t), intent(inout) :: error + logical :: value + + type(error_t_c) :: error_c + value = get_species_property_bool_c(this%ptr, & + to_c_string(species_name), to_c_string(property_name), error_c) + error = error_t(error_c) + end function get_species_property_bool + + subroutine finalize(this) + use musica_util, only: error_t, error_t_c + type(micm_t), intent(inout) :: this + + type(error_t_c) :: error_c + type(error_t) :: error + call delete_micm_c(this%ptr, error_c) + this%ptr = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end subroutine finalize end module musica_micm \ No newline at end of file diff --git a/fortran/packaging/CMakeLists.txt b/fortran/packaging/CMakeLists.txt index 865654f5..cfe72370 100644 --- a/fortran/packaging/CMakeLists.txt +++ b/fortran/packaging/CMakeLists.txt @@ -4,7 +4,7 @@ install( TARGETS musica-fortran EXPORT - musica_fortran_Exports + musica-fortran_Exports LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} ) @@ -24,7 +24,7 @@ set(cmake_config_install_location "${CMAKE_INSTALL_LIBDIR}/cmake/musica") install( EXPORT - musica_fortran_Exports + musica-fortran_Exports DESTINATION ${cmake_config_install_location} NAMESPACE musica:: @@ -32,21 +32,21 @@ install( configure_package_config_file( "${MUSICA_PROJECT_SRC_DIR}/cmake/musicaConfig.cmake.in" - "${PROJECT_BINARY_DIR}/musica_fortranConfig.cmake" + "${PROJECT_BINARY_DIR}/musica-fortranConfig.cmake" INSTALL_DESTINATION ${cmake_config_install_location} ) write_basic_package_version_file( - "${PROJECT_BINARY_DIR}/musica_fortranConfigVersion.cmake" + "${PROJECT_BINARY_DIR}/musica-fortranConfigVersion.cmake" VERSION ${PROJECT_VERSION} COMPATIBILITY SameMajorVersion ) install( FILES - ${PROJECT_BINARY_DIR}/musica_fortranConfig.cmake - ${PROJECT_BINARY_DIR}/musica_fortranConfigVersion.cmake + ${PROJECT_BINARY_DIR}/musica-fortranConfig.cmake + ${PROJECT_BINARY_DIR}/musica-fortranConfigVersion.cmake DESTINATION ${cmake_config_install_location} ) diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 603b7f86..d0707f7b 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -36,6 +36,7 @@ enable_testing() if (MUSICA_ENABLE_MICM) add_executable(test_micm_fortran_api test_micm_api.F90) add_executable(test_get_micm_version test_get_micm_version.F90) + add_executable(test_micm_box_model test_micm_box_model.F90) target_link_libraries(test_micm_fortran_api PRIVATE @@ -68,6 +69,22 @@ if (MUSICA_ENABLE_MICM) COMMAND $ WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} ) + + target_link_libraries(test_micm_box_model + PRIVATE + musica::musica-fortran + ) + + set_target_properties(test_micm_box_model + PROPERTIES + LINKER_LANGUAGE Fortran + ) + + add_test( + NAME test_micm_box_model + COMMAND $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + ) endif() # API Test @@ -99,4 +116,4 @@ if (MUSICA_ENABLE_TUVX) copy_tuvx_data_dir ALL ${CMAKE_COMMAND} -E copy_directory ${CMAKE_CURRENT_SOURCE_DIR}/../../../build/_deps/tuvx-src/data ${CMAKE_BINARY_DIR}/data ) -endif() +endif() \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/test_get_micm_version.F90 b/fortran/test/fetch_content_integration/test_get_micm_version.F90 index 299411bc..98e30f3e 100644 --- a/fortran/test/fetch_content_integration/test_get_micm_version.F90 +++ b/fortran/test/fetch_content_integration/test_get_micm_version.F90 @@ -1,8 +1,8 @@ program demo - use musica_util, only: string_t - use musica_micm, only: get_micm_version - implicit none - type(string_t) :: micm_version - micm_version = get_micm_version() - print *, "MICM version ", micm_version%get_char_array() + use musica_util, only: string_t + use musica_micm, only: get_micm_version + implicit none + type(string_t) :: micm_version + micm_version = get_micm_version() + print *, "MICM version ", micm_version%get_char_array() end program demo diff --git a/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index c98eca9d..6450850f 100644 --- a/fortran/test/fetch_content_integration/test_micm_api.F90 +++ b/fortran/test/fetch_content_integration/test_micm_api.F90 @@ -6,6 +6,7 @@ program test_micm_api use, intrinsic :: iso_c_binding use, intrinsic :: ieee_arithmetic use musica_micm, only: micm_t, solver_stats_t, get_micm_version + use musica_micm, only: Rosenbrock, RosenbrockStandardOrder use musica_util, only: assert, error_t, mapping_t, string_t #include "micm/util/error.hpp" @@ -29,9 +30,11 @@ subroutine test_api() real(c_double) :: pressure real(c_double) :: air_density integer(c_int) :: num_concentrations, num_user_defined_reaction_rates - real(c_double), dimension(5) :: concentrations + real(c_double), dimension(4) :: concentrations real(c_double), dimension(3) :: user_defined_reaction_rates character(len=256) :: config_path + integer(c_int) :: solver_type + integer(c_int) :: num_grid_cells character(len=:), allocatable :: string_value real(c_double) :: double_value integer(c_int) :: int_value @@ -42,13 +45,15 @@ subroutine test_api() real(c_double), parameter :: GAS_CONSTANT = 8.31446261815324_c_double ! J mol-1 K-1 integer :: i + config_path = "configs/chapman" + solver_type = Rosenbrock + num_grid_cells = 1 time_step = 200 temperature = 272.5 pressure = 101253.4 air_density = pressure / ( GAS_CONSTANT * temperature ) - num_concentrations = 5 - concentrations = (/ 0.75, 0.4, 0.8, 0.01, 0.02 /) - config_path = "configs/chapman" + num_concentrations = 4 + concentrations = (/ 0.4, 0.8, 0.01, 0.02 /) num_user_defined_reaction_rates = 3 user_defined_reaction_rates = (/ 0.1, 0.2, 0.3 /) @@ -56,7 +61,7 @@ subroutine test_api() print *, "[test micm fort api] MICM version ", micm_version%get_char_array() write(*,*) "[test micm fort api] Creating MICM solver..." - micm => micm_t(config_path, error) + micm => micm_t(config_path, solver_type, num_grid_cells, error) ASSERT( error%is_success() ) do i = 1, size( micm%species_ordering ) @@ -104,21 +109,16 @@ subroutine test_api() ASSERT( logical( bool_value ) ) string_value = micm%get_species_property_string( "O3", "missing property", error ) - ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, \ - MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) + ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) double_value = micm%get_species_property_double( "O3", "missing property", error ) - ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, \ - MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) + ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) int_value = micm%get_species_property_int( "O3", "missing property", error ) - ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, \ - MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) + ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) bool_value = micm%get_species_property_bool( "O3", "missing property", error ) - ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, \ - MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) + ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) deallocate( micm ) - micm => micm_t( "configs/invalid", error ) - ASSERT( error%is_error( MICM_ERROR_CATEGORY_CONFIGURATION, \ - MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH ) ) + micm => micm_t( "configs/invalid", solver_type, num_grid_cells, error ) + ASSERT( error%is_error( MICM_ERROR_CATEGORY_CONFIGURATION, MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH ) ) ASSERT( .not. associated( micm ) ) write(*,*) "[test micm fort api] Finished." diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 new file mode 100644 index 00000000..2af6aae9 --- /dev/null +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -0,0 +1,74 @@ +program test_micm_box_model + + use, intrinsic :: iso_c_binding + use, intrinsic :: ieee_arithmetic + + use musica_util, only: error_t, string_t, mapping_t + use musica_micm, only: micm_t, solver_stats_t + use musica_micm, only: Rosenbrock, RosenbrockStandardOrder + + implicit none + + call box_model() + +contains + + subroutine box_model() + + character(len=256) :: config_path + integer(c_int) :: solver_type + integer(c_int) :: num_grid_cells + + real(c_double), parameter :: GAS_CONSTANT = 8.31446261815324_c_double ! J mol-1 K-1 + + real(c_double) :: time_step + real(c_double) :: temperature + real(c_double) :: pressure + real(c_double) :: air_density + + integer(c_int) :: num_concentrations = 3 + real(c_double), dimension(3) :: concentrations + + integer(c_int) :: num_user_defined_reaction_rates = 0 + real(c_double), dimension(:), allocatable :: user_defined_reaction_rates + + type(string_t) :: solver_state + type(solver_stats_t) :: solver_stats + type(error_t) :: error + + type(micm_t), pointer :: micm + + integer :: i + + config_path = "configs/analytical" + solver_type = RosenbrockStandardOrder + num_grid_cells = 1 + + time_step = 200 + temperature = 273.0 + pressure = 1.0e5 + air_density = pressure / (GAS_CONSTANT * temperature) + + concentrations = (/ 1.0, 1.0, 1.0 /) + + write(*,*) "Creating MICM solver..." + micm => micm_t(config_path, solver_type, num_grid_cells, error) + + do i = 1, size( micm%species_ordering ) + associate(the_mapping => micm%species_ordering(i)) + print *, "Species Name:", the_mapping%name(), ", Index:", the_mapping%index() + end associate + end do + + write(*,*) "Solving starts..." + ! call micm%solve(time_step, temperature, pressure, num_concentrations, concentrations, & + ! num_user_defined_reaction_rates, user_defined_reaction_rates, error) + call micm%solve(time_step, temperature, pressure, air_density, num_concentrations, concentrations, & + num_user_defined_reaction_rates, user_defined_reaction_rates, solver_state, solver_stats, error) + write(*,*) "After solving, concentrations", concentrations + + deallocate( micm ) + + end subroutine box_model + +end program test_micm_box_model diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 6d57abcc..7dfdddff 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -3,7 +3,8 @@ ! program combined_tuvx_tests use iso_c_binding - use musica_tuvx, only: tuvx_t, grid_map_t, grid_t + use musica_tuvx, only: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & + radiator_map_t, radiator_t use musica_util, only: assert, error_t implicit none @@ -55,37 +56,418 @@ end subroutine test_tuvx_api_invalid_config subroutine test_tuvx_solve() - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t) :: grids - character(len=256) :: config_path - type(grid_t), pointer :: grid - ! type(profile_map_t) :: profiles - ! type(radiator_map_t) :: radiators - real*8, dimension(5) :: edges - real*8, dimension(4) :: midpoints + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + character(len=256) :: config_path + type(grid_map_t), pointer :: grids + type(grid_t), pointer :: grid, height_grid, wavelength_grid + type(profile_map_t), pointer :: profiles + type(profile_t), pointer :: profile, profile_copy + type(radiator_map_t), pointer :: radiators + type(radiator_t), pointer :: radiator, radiator_copy + real*8, dimension(5), target :: edges, edge_values, temp_edge + real*8, dimension(4), target :: midpoints, midpoint_values, layer_densities, temp_midpoint + real*8 :: temp_real + integer :: num_vertical_layers, num_wavelength_bins + real*8, dimension(3,2), target :: optical_depths, temp_od + real*8, dimension(3,2), target :: single_scattering_albedos, temp_ssa + real*8, dimension(3,2,1), target :: asymmetry_factors, temp_asym edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) - midpoints = (/ 1.5, 2.5, 3.5, 4.5 /) + midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) + edge_values = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + midpoint_values = (/ 15.0, 25.0, 35.0, 45.0 /) + layer_densities = (/ 2.0, 4.0, 1.0, 7.0 /) + num_vertical_layers = 3 + num_wavelength_bins = 2 + optical_depths(:,1) = (/ 30.0, 20.0, 10.0 /) + optical_depths(:,2) = (/ 70.0, 80.0, 90.0 /) + single_scattering_albedos(:,1) = (/ 300.0, 200.0, 100.0 /) + single_scattering_albedos(:,2) = (/ 700.0, 800.0, 900.0 /) + asymmetry_factors(:,1,1) = (/ 3.0, 2.0, 1.0 /) + asymmetry_factors(:,2,1) = (/ 7.0, 8.0, 9.0 /) config_path = "examples/ts1_tsmlt.json" tuvx => tuvx_t( config_path, error ) ASSERT( error%is_success() ) - grids = tuvx%get_grids( error ) + grids => tuvx%get_grids( error ) ASSERT( error%is_success() ) grid => grids%get( "height", "km", error ) + ASSERT( .not. error%is_success() ) ! non-accessible grid + deallocate( grid ) + deallocate( grids ) + + grids => grid_map_t( error ) + ASSERT( error%is_success() ) + + grid => grid_t( "foo", "bars", 4, error ) ASSERT( error%is_success() ) call grid%set_edges( edges, error ) ASSERT( error%is_success() ) + call grid%get_edges( temp_edge, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_edge(1), 1.0 ) + ASSERT_EQ( temp_edge(2), 2.0 ) + ASSERT_EQ( temp_edge(3), 3.0 ) + ASSERT_EQ( temp_edge(4), 4.0 ) + ASSERT_EQ( temp_edge(5), 5.0 ) + + edges = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + + call grid%set_edges( edges, error ) + ASSERT( error%is_success() ) call grid%set_midpoints( midpoints, error ) ASSERT( error%is_success() ) - - deallocate( tuvx ) + + call grid%get_edges( temp_edge, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_edge(1), 10.0 ) + ASSERT_EQ( temp_edge(2), 20.0 ) + ASSERT_EQ( temp_edge(3), 30.0 ) + ASSERT_EQ( temp_edge(4), 40.0 ) + ASSERT_EQ( temp_edge(5), 50.0 ) + + call grid%get_midpoints( temp_midpoint, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_midpoint(1), 15.0 ) + ASSERT_EQ( temp_midpoint(2), 25.0 ) + ASSERT_EQ( temp_midpoint(3), 35.0 ) + ASSERT_EQ( temp_midpoint(4), 45.0 ) + + call grids%add( grid, error ) + + edges(:) = 0.0 + midpoints(:) = 0.0 + + call grid%get_edges( edges, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( edges(1), 10.0 ) + ASSERT_EQ( edges(2), 20.0 ) + ASSERT_EQ( edges(3), 30.0 ) + ASSERT_EQ( edges(4), 40.0 ) + ASSERT_EQ( edges(5), 50.0 ) + + call grid%get_midpoints( midpoints, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( midpoints(1), 15.0 ) + ASSERT_EQ( midpoints(2), 25.0 ) + ASSERT_EQ( midpoints(3), 35.0 ) + ASSERT_EQ( midpoints(4), 45.0 ) + + edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) + midpoints = (/ 1.5, 2.5, 3.5, 4.5 /) + + call grid%set_edges( edges, error ) + ASSERT( error%is_success() ) + call grid%set_midpoints( midpoints, error ) + ASSERT( error%is_success() ) + + edges(:) = 0.0 + midpoints(:) = 0.0 + + call grid%get_edges( edges, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( edges(1), 1.0 ) + ASSERT_EQ( edges(2), 2.0 ) + ASSERT_EQ( edges(3), 3.0 ) + ASSERT_EQ( edges(4), 4.0 ) + ASSERT_EQ( edges(5), 5.0 ) + + call grid%get_midpoints( midpoints, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( midpoints(1), 1.5 ) + ASSERT_EQ( midpoints(2), 2.5 ) + ASSERT_EQ( midpoints(3), 3.5 ) + ASSERT_EQ( midpoints(4), 4.5 ) + + deallocate( grid ) + + grid => grids%get( "foo", "bars", error ) + ASSERT( error%is_success() ) + + edges(:) = 0.0 + midpoints(:) = 0.0 + + call grid%get_edges( edges, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( edges(1), 1.0 ) + ASSERT_EQ( edges(2), 2.0 ) + ASSERT_EQ( edges(3), 3.0 ) + ASSERT_EQ( edges(4), 4.0 ) + ASSERT_EQ( edges(5), 5.0 ) + + call grid%get_midpoints( midpoints, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( midpoints(1), 1.5 ) + ASSERT_EQ( midpoints(2), 2.5 ) + ASSERT_EQ( midpoints(3), 3.5 ) + ASSERT_EQ( midpoints(4), 4.5 ) + + edges = (/ 10.0, 20.0, 30.0, 40.0, 50.0 /) + midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) + + call grid%set_edges( edges, error ) + call grid%set_midpoints( midpoints, error ) + ASSERT( error%is_success() ) + + edges(:) = 0.0 + midpoints(:) = 0.0 + + call grid%get_edges( edges, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( edges(1), 10.0 ) + ASSERT_EQ( edges(2), 20.0 ) + ASSERT_EQ( edges(3), 30.0 ) + ASSERT_EQ( edges(4), 40.0 ) + ASSERT_EQ( edges(5), 50.0 ) + + call grid%get_midpoints( midpoints, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( midpoints(1), 15.0 ) + ASSERT_EQ( midpoints(2), 25.0 ) + ASSERT_EQ( midpoints(3), 35.0 ) + ASSERT_EQ( midpoints(4), 45.0 ) + + profiles => tuvx%get_profiles( error ) + ASSERT( error%is_success() ) + + profile => profiles%get( "temperature", "K", error ) + ASSERT( .not. error%is_success() ) ! non-accessible profile + deallocate( profile ) + deallocate( profiles ) + + profiles => profile_map_t( error ) + ASSERT( error%is_success() ) + + profile => profile_t( "baz", "qux", grid, error ) + ASSERT( error%is_success() ) + + call profile%set_edge_values( edge_values, error ) + ASSERT( error%is_success() ) + + call profile%get_edge_values( temp_edge, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_edge(1), 10.0 ) + ASSERT_EQ( temp_edge(2), 20.0 ) + ASSERT_EQ( temp_edge(3), 30.0 ) + ASSERT_EQ( temp_edge(4), 40.0 ) + ASSERT_EQ( temp_edge(5), 50.0 ) + + call profile%set_midpoint_values( midpoint_values, error ) + ASSERT( error%is_success() ) + + call profile%get_midpoint_values( temp_midpoint, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_midpoint(1), 15.0 ) + ASSERT_EQ( temp_midpoint(2), 25.0 ) + ASSERT_EQ( temp_midpoint(3), 35.0 ) + ASSERT_EQ( temp_midpoint(4), 45.0 ) + + call profile%set_layer_densities( layer_densities, error ) + ASSERT( error%is_success() ) + + call profile%get_layer_densities( temp_midpoint, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_midpoint(1), 2.0 ) + ASSERT_EQ( temp_midpoint(2), 4.0 ) + ASSERT_EQ( temp_midpoint(3), 1.0 ) + ASSERT_EQ( temp_midpoint(4), 7.0 ) + + call profile%set_exo_layer_density( 1.0d0, error ) + ASSERT( error%is_success() ) + + temp_real = profile%get_exo_layer_density( error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_real, 1.0 ) + + call profile%get_layer_densities( temp_midpoint, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_midpoint(1), 2.0 ) + ASSERT_EQ( temp_midpoint(2), 4.0 ) + ASSERT_EQ( temp_midpoint(3), 1.0 ) + ASSERT_EQ( temp_midpoint(4), 7.0 + 1.0 ) + + call profile%calculate_exo_layer_density( 10.0d0, error ) + ASSERT( error%is_success() ) + + temp_real = profile%get_exo_layer_density( error ) + ASSERT( error%is_success() ) + ! Revisit this after non-SI units are converted in the TUV-x internal functions + ASSERT_EQ( temp_real, 10.0 * 7.0 * 100.0 ) + + call profile%get_layer_densities( temp_midpoint, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_midpoint(1), 2.0 ) + ASSERT_EQ( temp_midpoint(2), 4.0 ) + ASSERT_EQ( temp_midpoint(3), 1.0 ) + ASSERT_EQ( temp_midpoint(4), 7.0 + 10.0 * 7.0 * 100.0 ) + + call profiles%add( profile, error ) + profile_copy => profiles%get( "baz", "qux", error ) + + call profile_copy%get_edge_values( temp_edge, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_edge(1), 10.0 ) + ASSERT_EQ( temp_edge(2), 20.0 ) + ASSERT_EQ( temp_edge(3), 30.0 ) + ASSERT_EQ( temp_edge(4), 40.0 ) + ASSERT_EQ( temp_edge(5), 50.0 ) + + edge_values = (/ 32.0, 34.0, 36.0, 38.0, 40.0 /) + call profile_copy%set_edge_values( edge_values, error ) + + call profile%get_edge_values( temp_edge, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_edge(1), 32.0 ) + ASSERT_EQ( temp_edge(2), 34.0 ) + ASSERT_EQ( temp_edge(3), 36.0 ) + ASSERT_EQ( temp_edge(4), 38.0 ) + ASSERT_EQ( temp_edge(5), 40.0 ) + + radiators => tuvx%get_radiators( error ) + ASSERT( error%is_success() ) + + radiator => radiators%get( "foo_radiator", error ) + ASSERT( .not. error%is_success() ) + deallocate( radiator ) + deallocate( radiators ) + + radiators =>radiator_map_t( error ) + ASSERT( error%is_success() ) + + height_grid => grid_t( "height", "km", num_vertical_layers, error ) + wavelength_grid => grid_t( "wavelength", "nm", num_wavelength_bins, error ) + radiator => radiator_t( "foo_radiator", height_grid, wavelength_grid, error ) + ASSERT( error%is_success() ) + + call radiator%set_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + + call radiator%get_optical_depths( temp_od, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_od(1,1), 30.0 ) + ASSERT_EQ( temp_od(2,1), 20.0 ) + ASSERT_EQ( temp_od(3,1), 10.0 ) + ASSERT_EQ( temp_od(1,2), 70.0 ) + ASSERT_EQ( temp_od(2,2), 80.0 ) + ASSERT_EQ( temp_od(3,2), 90.0 ) + + call radiator%set_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + + call radiator%get_single_scattering_albedos( temp_ssa, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_ssa(1,1), 300.0 ) + ASSERT_EQ( temp_ssa(2,1), 200.0 ) + ASSERT_EQ( temp_ssa(3,1), 100.0 ) + ASSERT_EQ( temp_ssa(1,2), 700.0 ) + ASSERT_EQ( temp_ssa(2,2), 800.0 ) + ASSERT_EQ( temp_ssa(3,2), 900.0 ) + + call radiator%set_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + + call radiator%get_asymmetry_factors( temp_asym, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( temp_asym(1,1,1), 3.0 ) + ASSERT_EQ( temp_asym(2,1,1), 2.0 ) + ASSERT_EQ( temp_asym(3,1,1), 1.0 ) + ASSERT_EQ( temp_asym(1,2,1), 7.0 ) + ASSERT_EQ( temp_asym(2,2,1), 8.0 ) + ASSERT_EQ( temp_asym(3,2,1), 9.0 ) +! + call radiators%add( radiator, error ) + radiator_copy => radiators%get( "foo_radiator", error ) + + optical_depths(:,:) = 0.0 + single_scattering_albedos(:,:) = 0.0 + asymmetry_factors(:,:,:) = 0.0 + + call radiator_copy%get_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(1,1), 30.0 ) + ASSERT_EQ( optical_depths(2,1), 20.0 ) + ASSERT_EQ( optical_depths(3,1), 10.0 ) + ASSERT_EQ( optical_depths(1,2), 70.0 ) + ASSERT_EQ( optical_depths(2,2), 80.0 ) + ASSERT_EQ( optical_depths(3,2), 90.0 ) + + call radiator_copy%get_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(1,1), 300.0 ) + ASSERT_EQ( single_scattering_albedos(2,1), 200.0 ) + ASSERT_EQ( single_scattering_albedos(3,1), 100.0 ) + ASSERT_EQ( single_scattering_albedos(1,2), 700.0 ) + ASSERT_EQ( single_scattering_albedos(2,2), 800.0 ) + ASSERT_EQ( single_scattering_albedos(3,2), 900.0 ) + + call radiator_copy%get_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(1,1,1), 3.0 ) + ASSERT_EQ( asymmetry_factors(2,1,1), 2.0 ) + ASSERT_EQ( asymmetry_factors(3,1,1), 1.0 ) + ASSERT_EQ( asymmetry_factors(1,2,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(3,2,1), 9.0 ) + + optical_depths(:,1) = (/ 90.0, 80.0, 70.0 /) + optical_depths(:,2) = (/ 75.0, 85.0, 95.0 /) + single_scattering_albedos(:,1) = (/ 900.0, 800.0, 700.0 /) + single_scattering_albedos(:,2) = (/ 750.0, 850.0, 950.0 /) + asymmetry_factors(:,1,1) = (/ 9.0, 8.0, 7.0 /) + asymmetry_factors(:,2,1) = (/ 5.0, 4.0, 3.0 /) + + call radiator_copy%set_optical_depths( optical_depths, error ) + call radiator_copy%set_single_scattering_albedos( single_scattering_albedos, error ) + call radiator_copy%set_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + + optical_depths(:,:) = 0.0 + single_scattering_albedos(:,:) = 0.0 + asymmetry_factors(:,:,:) = 0.0 + + call radiator%get_optical_depths( optical_depths, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( optical_depths(1,1), 90.0 ) + ASSERT_EQ( optical_depths(2,1), 80.0 ) + ASSERT_EQ( optical_depths(3,1), 70.0 ) + ASSERT_EQ( optical_depths(1,2), 75.0 ) + ASSERT_EQ( optical_depths(2,2), 85.0 ) + ASSERT_EQ( optical_depths(3,2), 95.0 ) + + call radiator%get_single_scattering_albedos( single_scattering_albedos, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( single_scattering_albedos(1,1), 900.0 ) + ASSERT_EQ( single_scattering_albedos(2,1), 800.0 ) + ASSERT_EQ( single_scattering_albedos(3,1), 700.0 ) + ASSERT_EQ( single_scattering_albedos(1,2), 750.0 ) + ASSERT_EQ( single_scattering_albedos(2,2), 850.0 ) + ASSERT_EQ( single_scattering_albedos(3,2), 950.0 ) + + call radiator%get_asymmetry_factors( asymmetry_factors, error ) + ASSERT( error%is_success() ) + ASSERT_EQ( asymmetry_factors(1,1,1), 9.0 ) + ASSERT_EQ( asymmetry_factors(2,1,1), 8.0 ) + ASSERT_EQ( asymmetry_factors(3,1,1), 7.0 ) + ASSERT_EQ( asymmetry_factors(1,2,1), 5.0 ) + ASSERT_EQ( asymmetry_factors(2,2,1), 4.0 ) + ASSERT_EQ( asymmetry_factors(3,2,1), 3.0 ) + deallocate( grid ) + deallocate( grids ) + deallocate( profile ) + deallocate( profile_copy ) + deallocate( profiles ) + deallocate( radiator_copy ) + deallocate( radiator ) + deallocate( radiators ) + deallocate( height_grid ) + deallocate( wavelength_grid ) + deallocate( tuvx ) end subroutine test_tuvx_solve diff --git a/fortran/test/tutorial/CMakeLists.txt b/fortran/test/tutorial/CMakeLists.txt new file mode 100644 index 00000000..aae019eb --- /dev/null +++ b/fortran/test/tutorial/CMakeLists.txt @@ -0,0 +1,23 @@ +cmake_minimum_required(VERSION 3.21) + +project( + musica-demo + VERSION 0.1 + LANGUAGES CXX C Fortran +) + +# mkdir build +# cd build +# cmake -DMUSICA_INSTALL_DIR= .. + +set(MUSICA_INCLUDE_DIR "${MUSICA_INSTALL_DIR}/include") +set(MUSICA_LIB_DIR "${MUSICA_INSTALL_DIR}/lib") + +message(STATUS "${MUSICA_INCLUDE_DIR}") +message(STATUS "${MUSICA_LIB_DIR}") + +add_executable(demo_f demo.f90) + +target_include_directories(demo_f PUBLIC ${MUSICA_INCLUDE_DIR}) +target_link_directories(demo_f PUBLIC ${MUSICA_LIB_DIR}) +target_link_libraries(demo_f musica-fortran musica stdc++) diff --git a/fortran/test/tutorial/demo.f90 b/fortran/test/tutorial/demo.f90 new file mode 100644 index 00000000..299411bc --- /dev/null +++ b/fortran/test/tutorial/demo.f90 @@ -0,0 +1,8 @@ +program demo + use musica_util, only: string_t + use musica_micm, only: get_micm_version + implicit none + type(string_t) :: micm_version + micm_version = get_micm_version() + print *, "MICM version ", micm_version%get_char_array() +end program demo diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 2d5e274a..c2946b08 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -5,6 +5,8 @@ create_standard_test_fortran(NAME fortran_util SOURCES util.F90) if (MUSICA_ENABLE_MICM) create_standard_test_fortran(NAME micm_fortran_api SOURCES ../fetch_content_integration/test_micm_api.F90) create_standard_test_fortran(NAME get_micm_version SOURCES ../fetch_content_integration/test_get_micm_version.F90) + create_standard_test_fortran(NAME micm_box_model SOURCES ../fetch_content_integration/test_micm_box_model.F90) + create_standard_test_fortran(NAME demo_fortran SOURCES ../tutorial/demo.f90) endif() if (MUSICA_ENABLE_TUVX) diff --git a/fortran/tuvx.F90 b/fortran/tuvx.F90 deleted file mode 100644 index d4b61127..00000000 --- a/fortran/tuvx.F90 +++ /dev/null @@ -1,337 +0,0 @@ -! Copyright (C) 2023-2024 National Center for Atmospheric Research -! SPDX-License-Identifier: Apache-2.0 -! -module musica_tuvx - use iso_c_binding, only: c_ptr, c_char, c_int, c_bool, c_double, c_null_char, c_size_t, c_f_pointer, c_null_ptr - use musica_util, only: assert - - implicit none - -#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - - public :: tuvx_t, grid_map_t, grid_t - private - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - interface - function create_tuvx_c(config_path, error) bind(C, name="CreateTuvx") - use musica_util, only: error_t_c - import c_ptr, c_int, c_char - character(len=1, kind=c_char), intent(in) :: config_path(*) - type(error_t_c), intent(inout) :: error - type(c_ptr) :: create_tuvx_c - end function create_tuvx_c - - subroutine delete_tuvx_c(tuvx, error) bind(C, name="DeleteTuvx") - use musica_util, only: error_t_c - import c_ptr - type(c_ptr), value, intent(in) :: tuvx - type(error_t_c), intent(inout) :: error - end subroutine delete_tuvx_c - - function get_grid_map_c(tuvx, error) bind(C, name="GetGridMap") - use musica_util, only: error_t_c - import c_ptr - type(c_ptr), value, intent(in) :: tuvx - type(error_t_c), intent(inout) :: error - type(c_ptr) :: get_grid_map_c - end function get_grid_map_c - - function get_grid_c(grid_map, grid_name, grid_units, error) bind(C, name="GetGrid") - use musica_util, only: error_t_c - import c_ptr, c_char - type(c_ptr), value, intent(in) :: grid_map - character(len=1, kind=c_char), intent(in) :: grid_name(*), grid_units(*) - type(error_t_c), intent(inout) :: error - type(c_ptr) :: get_grid_c - end function get_grid_c - - subroutine set_edges_c(grid, edges, n_edges, error) bind(C, name="SetEdges") - use musica_util, only: error_t_c - import c_ptr, c_double, c_size_t - type(c_ptr), value, intent(in) :: grid - real(c_double), dimension(*), intent(in) :: edges - integer(c_size_t), value :: n_edges - type(error_t_c), intent(inout) :: error - end subroutine set_edges_c - - subroutine set_midpoints_c(grid, midpoints, n_midpoints, error) bind(C, name="SetMidpoints") - use musica_util, only: error_t_c - import c_ptr, c_double, c_size_t - type(c_ptr), value, intent(in) :: grid - real(c_double), dimension(*), intent(in) :: midpoints - integer(c_size_t), value :: n_midpoints - type(error_t_c), intent(inout) :: error - end subroutine set_midpoints_c - - end interface - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Data types - - type :: tuvx_t - type(c_ptr), private :: ptr = c_null_ptr - contains - ! Create a grid map - procedure :: get_grids - ! Deallocate the tuvx instance - final :: finalize - end type tuvx_t - - interface tuvx_t - procedure constructor - end interface tuvx_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: grid_map_t - type(c_ptr) :: ptr = c_null_ptr - contains - procedure :: get - ! Deallocate the tuvx instance - final :: finalize_grid_map_t - end type grid_map_t - - interface grid_map_t - procedure grid_map_t_constructor - end interface grid_map_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type :: grid_t - type(c_ptr), private :: ptr = c_null_ptr - contains - ! Set grid edges - procedure :: set_edges - ! Set the grid midpoints - procedure :: set_midpoints - ! Deallocate the tuvx instance - final :: finalize_grid_t - end type grid_t - - interface grid_t - procedure grid_t_constructor - end interface grid_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Grid map type - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Construct a grid map instance - function grid_map_t_constructor() result(this) - ! Return value - type(grid_map_t) :: this - - this%ptr = c_null_ptr - end function grid_map_t_constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Get a grid given its name and units - function get(this, grid_name, grid_units, error) result(grid) - use musica_util, only: error_t, error_t_c, to_c_string - - ! Arguments - class(grid_map_t), intent(in) :: this - character(len=*), intent(in) :: grid_name - character(len=*), intent(in) :: grid_units - type(error_t), intent(inout) :: error - - ! Local variables - type(error_t_c) :: error_c - character(len=1, kind=c_char) :: c_grid_name(len_trim(grid_name)+1) - character(len=1, kind=c_char) :: c_grid_units(len_trim(grid_name)+1) - - ! Return value - type(grid_t), pointer :: grid - - grid => grid_t() - grid%ptr = get_grid_c(this%ptr, to_c_string(grid_name), to_c_string(grid_units), error_c) - - error = error_t(error_c) - - end function get - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Deallocate the grid map instance - subroutine finalize_grid_map_t(this) - use musica_util, only: error_t, error_t_c - - ! Arguments - type(grid_map_t), intent(inout) :: this - - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error - - ! The pointer doesn't need to be deallocated because it is owned by the tuvx instance - this%ptr = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - - end subroutine finalize_grid_map_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Grid type - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Construct a grid map instance - function grid_t_constructor() result(this) - ! Return value - type(grid_t), pointer :: this - - allocate( this ) - - end function grid_t_constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine set_edges(this, edges, error) - use musica_util, only: error_t, error_t_c - - ! Arguments - class(grid_t), intent(inout) :: this - real(c_double), dimension(:), intent(in) :: edges - type(error_t), intent(inout) :: error - - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_edges - - n_edges = size(edges) - - call set_edges_c(this%ptr, edges, n_edges, error_c) - error = error_t(error_c) - - end subroutine set_edges - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine set_midpoints(this, midpoints, error) - use musica_util, only: error_t, error_t_c - - ! Arguments - class(grid_t), intent(inout) :: this - real(c_double), dimension(:), intent(in) :: midpoints - type(error_t), intent(inout) :: error - - ! Local variables - type(error_t_c) :: error_c - integer(kind=c_size_t) :: n_midpoints - - n_midpoints = size(midpoints) - - call set_midpoints_c(this%ptr, midpoints, n_midpoints, error_c) - error = error_t(error_c) - - end subroutine set_midpoints - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Deallocate the grid instance - subroutine finalize_grid_t(this) - use musica_util, only: error_t, error_t_c - - ! Arguments - type(grid_t), intent(inout) :: this - - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error - - ! The pointer doesn't need to be deallocated because it is owned by the tuvx instance - this%ptr = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - end subroutine finalize_grid_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! tuvx type - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Construct a tuvx instance - function constructor(config_path, error) result( this ) - use musica_util, only: error_t_c, error_t - - ! Arguments - type(error_t), intent(inout) :: error - character(len=*), intent(in) :: config_path - - ! Local variables - character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) - integer :: n, i - type(error_t_c) :: error_c - - ! Return value - type(tuvx_t), pointer :: this - - allocate( this ) - - n = len_trim(config_path) - do i = 1, n - c_config_path(i) = config_path(i:i) - end do - c_config_path(n+1) = c_null_char - - this%ptr = create_tuvx_c(c_config_path, error_c) - - error = error_t(error_c) - if (.not. error%is_success()) then - deallocate(this) - nullify(this) - return - end if - end function constructor - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Get the grid map - function get_grids(this, error) result(grid_map) - use musica_util, only: error_t, error_t_c - - ! Arguments - class(tuvx_t), intent(inout) :: this - type(error_t), intent(inout) :: error - - ! Local variables - type(error_t_c) :: error_c - - ! Return value - type(grid_map_t) :: grid_map - - grid_map = grid_map_t() - grid_map%ptr = get_grid_map_c(this%ptr, error_c) - - error = error_t(error_c) - - end function get_grids - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !> Deallocate the tuvx instance - subroutine finalize(this) - use musica_util, only: error_t, error_t_c - - ! Arguments - type(tuvx_t), intent(inout) :: this - - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error - - call delete_tuvx_c(this%ptr, error_c) - this%ptr = c_null_ptr - error = error_t(error_c) - ASSERT(error%is_success()) - - end subroutine finalize - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -end module musica_tuvx diff --git a/fortran/tuvx/CMakeLists.txt b/fortran/tuvx/CMakeLists.txt new file mode 100644 index 00000000..68e400c9 --- /dev/null +++ b/fortran/tuvx/CMakeLists.txt @@ -0,0 +1,10 @@ +target_sources(musica-fortran + PRIVATE + grid.F90 + grid_map.F90 + profile.F90 + profile_map.F90 + radiator.F90 + radiator_map.F90 + tuvx.F90 +) \ No newline at end of file diff --git a/fortran/tuvx/grid.F90 b/fortran/tuvx/grid.F90 new file mode 100644 index 00000000..202b1b94 --- /dev/null +++ b/fortran/tuvx/grid.F90 @@ -0,0 +1,256 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_grid + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: grid_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_grid_c(grid_name, grid_units, number_of_sections, error) & + bind(C, name="CreateGrid") + use iso_c_binding, only : c_ptr, c_size_t, c_char + use musica_util, only: error_t_c + character(len=1, kind=c_char), intent(in) :: grid_name(*) + character(len=1, kind=c_char), intent(in) :: grid_units(*) + integer(c_size_t), value, intent(in) :: number_of_sections + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_grid_c + end function create_grid_c + + subroutine delete_grid_c(grid, error) bind(C, name="DeleteGrid") + use iso_c_binding, only : c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(error_t_c), intent(inout) :: error + end subroutine delete_grid_c + + subroutine set_grid_edges_c(grid, edges, n_edges, error) & + bind(C, name="SetGridEdges") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: edges + integer(c_size_t), value, intent(in) :: n_edges + type(error_t_c), intent(inout) :: error + end subroutine set_grid_edges_c + + subroutine get_grid_edges_c(grid, edges, n_edges, error) & + bind(C, name="GetGridEdges") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: edges + integer(c_size_t), value, intent(in) :: n_edges + type(error_t_c), intent(inout) :: error + end subroutine get_grid_edges_c + + subroutine set_grid_midpoints_c(grid, midpoints, n_midpoints, error) & + bind(C, name="SetGridMidpoints") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: midpoints + integer(c_size_t), value, intent(in) :: n_midpoints + type(error_t_c), intent(inout) :: error + end subroutine set_grid_midpoints_c + + subroutine get_grid_midpoints_c(grid, midpoints, n_midpoints, error) & + bind(C, name="GetGridMidpoints") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid + type(c_ptr), value, intent(in) :: midpoints + integer(c_size_t), value, intent(in) :: n_midpoints + type(error_t_c), intent(inout) :: error + end subroutine get_grid_midpoints_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: grid_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Set grid edges + procedure :: set_edges + ! Get grid edges + procedure :: get_edges + ! Set the grid midpoints + procedure :: set_midpoints + ! Get the grid midpoints + procedure :: get_midpoints + ! Deallocate the grid instance + final :: finalize_grid_t + end type grid_t + + interface grid_t + procedure grid_t_ptr_constructor + procedure grid_t_constructor + end interface grid_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a grid instance that wraps an existing TUV-x grid + function grid_t_ptr_constructor(grid_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: grid_c_ptr + + ! Return value + type(grid_t), pointer :: this + + allocate( this ) + this%ptr_ = grid_c_ptr + + end function grid_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a grid instance that allocates a new TUV-x grid + function grid_t_constructor(grid_name, grid_units, number_of_sections, error) & + result(this) + use iso_c_binding, only: c_size_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + character(len=*), intent(in) :: grid_name + character(len=*), intent(in) :: grid_units + integer, intent(in) :: number_of_sections + type(error_t), intent(inout) :: error + + ! Return value + type(grid_t), pointer :: this + + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_grid_c(to_c_string(grid_name), to_c_string(grid_units), & + int(number_of_sections, kind=c_size_t), error_c) + error = error_t(error_c) + + end function grid_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_edges(this, edges, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(grid_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: edges + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges + + n_edges = size(edges) + + call set_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) + + end subroutine set_edges + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_edges(this, edges, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(grid_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: edges + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges + + n_edges = size(edges) + + call get_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) + + end subroutine get_edges + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_midpoints(this, midpoints, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(grid_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: midpoints + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints + + n_midpoints = size(midpoints) + + call set_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) + + end subroutine set_midpoints + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_midpoints(this, midpoints, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(grid_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: midpoints + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints + + n_midpoints = size(midpoints) + + call get_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) + + end subroutine get_midpoints + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocate the grid instance + subroutine finalize_grid_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(grid_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_grid_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_grid_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_grid \ No newline at end of file diff --git a/fortran/tuvx/grid_map.F90 b/fortran/tuvx/grid_map.F90 new file mode 100644 index 00000000..2b79410c --- /dev/null +++ b/fortran/tuvx/grid_map.F90 @@ -0,0 +1,179 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_grid_map + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: grid_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_grid_map_c(error) bind(C, name="CreateGridMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_grid_map_c + end function create_grid_map_c + + subroutine delete_grid_map_c(grid_map, error) bind(C, name="DeleteGridMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid_map + type(error_t_c), intent(inout) :: error + end subroutine delete_grid_map_c + + subroutine add_grid_c(grid_map, grid, error) bind(C, name="AddGrid") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: grid_map + type(c_ptr), value, intent(in) :: grid + type(error_t_c), intent(inout) :: error + end subroutine add_grid_c + + function get_grid_c(grid_map, grid_name, grid_units, error) & + bind(C, name="GetGrid") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_char + type(c_ptr), value, intent(in) :: grid_map + character(len=1, kind=c_char), intent(in) :: grid_name(*), grid_units(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_grid_c + end function get_grid_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: grid_map_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Adds a grid to the grid map + procedure :: add => add_grid + ! Get a grid given its name and units + procedure :: get => get_grid + ! Deallocate the grid map instance + final :: finalize_grid_map_t + end type grid_map_t + + interface grid_map_t + procedure grid_map_t_ptr_constructor + procedure grid_map_t_constructor + end interface grid_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Wraps an existing grid map + function grid_map_t_ptr_constructor(grid_map_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: grid_map_c_ptr + ! Return value + type(grid_map_t), pointer :: this + + allocate( this ) + this%ptr_ = grid_map_c_ptr + + end function grid_map_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Creates a new grid map + function grid_map_t_constructor(error) result(this) + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(error_t), intent(inout) :: error + + ! Return value + type(grid_map_t), pointer :: this + + ! Local variables + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_grid_map_c(error_c) + error = error_t(error_c) + + end function grid_map_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a grid to a grid map + subroutine add_grid(this, grid, error) + use musica_tuvx_grid, only: grid_t + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + class(grid_map_t), intent(inout) :: this + type(grid_t), intent(in) :: grid + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + call add_grid_c(this%ptr_, grid%ptr_, error_c) + error = error_t(error_c) + + end subroutine add_grid + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a grid given its name and units + function get_grid(this, grid_name, grid_units, error) result(grid) + use iso_c_binding, only: c_char + use musica_tuvx_grid, only : grid_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + class(grid_map_t), intent(in) :: this + character(len=*), intent(in) :: grid_name + character(len=*), intent(in) :: grid_units + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(grid_t), pointer :: grid + + grid => grid_t(get_grid_c(this%ptr_, to_c_string(grid_name), & + to_c_string(grid_units), error_c)) + + error = error_t(error_c) + + end function get_grid + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocates the grid map instance + subroutine finalize_grid_map_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(grid_map_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_grid_map_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_grid_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_grid_map diff --git a/fortran/tuvx/profile.F90 b/fortran/tuvx/profile.F90 new file mode 100644 index 00000000..757a08fc --- /dev/null +++ b/fortran/tuvx/profile.F90 @@ -0,0 +1,426 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_profile + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: profile_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_profile_c(profile_name, profile_units, grid, error) & + bind(C, name="CreateProfile") + use iso_c_binding, only: c_ptr, c_char + use musica_util, only: error_t_c + character(len=1, kind=c_char), intent(in) :: profile_name(*) + character(len=1, kind=c_char), intent(in) :: profile_units(*) + type(c_ptr), value, intent(in) :: grid + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_profile_c + end function create_profile_c + + subroutine delete_profile_c(profile, error) bind(C, name="DeleteProfile") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(error_t_c), intent(inout) :: error + end subroutine delete_profile_c + + subroutine set_profile_edge_values_c(profile, edge_values, n_edge_values, & + error) bind(C, name="SetProfileEdgeValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: edge_values + integer(c_size_t), value, intent(in) :: n_edge_values + type(error_t_c), intent(inout) :: error + end subroutine set_profile_edge_values_c + + subroutine get_profile_edge_values_c(profile, edge_values, n_edge_values, & + error) bind(C, name="GetProfileEdgeValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: edge_values + integer(c_size_t), value, intent(in) :: n_edge_values + type(error_t_c), intent(inout) :: error + end subroutine get_profile_edge_values_c + + subroutine set_profile_midpoint_values_c(profile, midpoint_values, & + n_midpoint_values, error) bind(C, name="SetProfileMidpointValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: midpoint_values + integer(c_size_t), value, intent(in) :: n_midpoint_values + type(error_t_c), intent(inout) :: error + end subroutine set_profile_midpoint_values_c + + subroutine get_profile_midpoint_values_c(profile, midpoint_values, & + n_midpoint_values, error) bind(C, name="GetProfileMidpointValues") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: midpoint_values + integer(c_size_t), value, intent(in) :: n_midpoint_values + type(error_t_c), intent(inout) :: error + end subroutine get_profile_midpoint_values_c + + subroutine set_profile_layer_densities_c(profile, layer_densities, & + n_layer_densities, error) bind(C, name="SetProfileLayerDensities") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: layer_densities + integer(c_size_t), value, intent(in) :: n_layer_densities + type(error_t_c), intent(inout) :: error + end subroutine set_profile_layer_densities_c + + subroutine get_profile_layer_densities_c(profile, layer_densities, & + n_layer_densities, error) bind(C, name="GetProfileLayerDensities") + use iso_c_binding, only: c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(c_ptr), value, intent(in) :: layer_densities + integer(c_size_t), value, intent(in) :: n_layer_densities + type(error_t_c), intent(inout) :: error + end subroutine get_profile_layer_densities_c + + subroutine set_profile_exo_layer_density_c(profile, exo_layer_density, & + error) bind(C, name="SetProfileExoLayerDensity") + use iso_c_binding, only: c_ptr, c_double + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + real(c_double), value, intent(in) :: exo_layer_density + type(error_t_c), intent(inout) :: error + end subroutine set_profile_exo_layer_density_c + + subroutine calculate_profile_exo_layer_density(profile, scale_height, & + error) bind(C, name="CalculateProfileExoLayerDensity") + use iso_c_binding, only: c_ptr, c_double + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + real(c_double), value, intent(in) :: scale_height + type(error_t_c), intent(inout) :: error + end subroutine calculate_profile_exo_layer_density + + function get_profile_exo_layer_density_c(profile, error) & + bind(C, name="GetProfileExoLayerDensity") + use iso_c_binding, only: c_ptr, c_double + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile + type(error_t_c), intent(inout) :: error + real(c_double) :: get_profile_exo_layer_density_c + end function get_profile_exo_layer_density_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: profile_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Set profile edge values + procedure :: set_edge_values + ! Get profile edge values + procedure :: get_edge_values + ! Set the profile midpoint values + procedure :: set_midpoint_values + ! Get the profile midpoint values + procedure :: get_midpoint_values + ! Set the profile layer densities + procedure :: set_layer_densities + ! Get the profile layer densities + procedure :: get_layer_densities + ! Set the profile exo layer density + procedure :: set_exo_layer_density + ! Calculate the profile exo layer density + procedure :: calculate_exo_layer_density + ! Get the profile exo layer density + procedure :: get_exo_layer_density + ! Finalize the profile + final :: finalize_profile + end type profile_t + + interface profile_t + procedure profile_t_ptr_constructor + procedure profile_t_constructor + end interface profile_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Construct a profile instance + function profile_t_ptr_constructor(profile_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: profile_c_ptr + + ! Return value + type(profile_t), pointer :: this + + allocate( this ) + this%ptr_ = profile_c_ptr + + end function profile_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Construct a profile instance that allocates a new TUV-x profile + function profile_t_constructor(profile_name, profile_units, grid, error) & + result(this) + use musica_tuvx_grid, only: grid_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + character(len=*), intent(in) :: profile_name + character(len=*), intent(in) :: profile_units + type(grid_t), intent(in) :: grid + type(error_t), intent(inout) :: error + + ! Return value + type(profile_t), pointer :: this + + ! Local variables + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_profile_c(to_c_string(profile_name), & + to_c_string(profile_units), grid%ptr_, error_c) + error = error_t(error_c) + + end function profile_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_edge_values(this, edge_values, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: edge_values + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edge_values + + n_edge_values = size(edge_values) + + call set_profile_edge_values_c(this%ptr_, c_loc(edge_values), & + n_edge_values, error_c) + error = error_t(error_c) + + end subroutine set_edge_values + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_edge_values(this, edge_values, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: edge_values + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edge_values + + n_edge_values = size(edge_values) + + call get_profile_edge_values_c(this%ptr_, c_loc(edge_values), & + n_edge_values, error_c) + error = error_t(error_c) + + end subroutine get_edge_values + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_midpoint_values(this, midpoint_values, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: midpoint_values + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoint_values + + n_midpoint_values = size(midpoint_values) + + call set_profile_midpoint_values_c(this%ptr_, c_loc(midpoint_values), & + n_midpoint_values, error_c) + error = error_t(error_c) + + end subroutine set_midpoint_values + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_midpoint_values(this, midpoint_values, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: midpoint_values + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoint_values + + n_midpoint_values = size(midpoint_values) + + call get_profile_midpoint_values_c(this%ptr_, c_loc(midpoint_values), & + n_midpoint_values, error_c) + error = error_t(error_c) + + end subroutine get_midpoint_values + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_layer_densities(this, layer_densities, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(in) :: layer_densities + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_layer_densities + + n_layer_densities = size(layer_densities) + + call set_profile_layer_densities_c(this%ptr_, c_loc(layer_densities), & + n_layer_densities, error_c) + error = error_t(error_c) + + end subroutine set_layer_densities + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_layer_densities(this, layer_densities, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), target, dimension(:), intent(inout) :: layer_densities + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_layer_densities + + n_layer_densities = size(layer_densities) + + call get_profile_layer_densities_c(this%ptr_, c_loc(layer_densities), & + n_layer_densities, error_c) + error = error_t(error_c) + + end subroutine get_layer_densities + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_exo_layer_density(this, exo_layer_density, error) + use iso_c_binding, only: c_double, c_size_t + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), intent(in) :: exo_layer_density + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + call set_profile_exo_layer_density_c(this%ptr_, & + real(exo_layer_density, kind=c_double), error_c) + error = error_t(error_c) + + end subroutine set_exo_layer_density + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine calculate_exo_layer_density(this, scale_height, error) + use iso_c_binding, only: c_double, c_size_t + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + real(dk), intent(in) :: scale_height + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + call calculate_profile_exo_layer_density(this%ptr_, & + real(scale_height, kind=dk), error_c) + error = error_t(error_c) + + end subroutine calculate_exo_layer_density + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function get_exo_layer_density(this, error) result(exo_layer_density) + use iso_c_binding, only: c_size_t + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(profile_t), intent(inout) :: this + type(error_t), intent(inout) :: error + + ! Return value + real(dk) :: exo_layer_density + + ! Local variables + type(error_t_c) :: error_c + + exo_layer_density = & + real(get_profile_exo_layer_density_c(this%ptr_, error_c), kind=dk) + error = error_t(error_c) + + end function get_exo_layer_density + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocate the profile instance + subroutine finalize_profile(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(profile_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_profile_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_profile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_profile diff --git a/fortran/tuvx/profile_map.F90 b/fortran/tuvx/profile_map.F90 new file mode 100644 index 00000000..53fd7072 --- /dev/null +++ b/fortran/tuvx/profile_map.F90 @@ -0,0 +1,182 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_profile_map + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: profile_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_profile_map_c(error) bind(C, name="CreateProfileMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_profile_map_c + end function create_profile_map_c + + subroutine delete_profile_map_c(profile_map, error) & + bind(C, name="DeleteProfileMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile_map + type(error_t_c), intent(inout) :: error + end subroutine delete_profile_map_c + + subroutine add_profile_c(profile_map, profile, error) & + bind(C, name="AddProfile") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: profile_map + type(c_ptr), value, intent(in) :: profile + type(error_t_c), intent(inout) :: error + end subroutine add_profile_c + + function get_profile_c(profile_map, profile_name, profile_units, error) & + bind(C, name="GetProfile") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_char + type(c_ptr), value, intent(in) :: profile_map + character(len=1, kind=c_char), intent(in) :: profile_name(*), & + profile_units(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_profile_c + end function get_profile_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: profile_map_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Adds a profile to the profile map + procedure :: add => add_profile + ! Get a profile given its name and units + procedure :: get => get_profile + ! Deallocate the profile map instance + final :: finalize_profile_map_t + end type profile_map_t + + interface profile_map_t + procedure profile_map_t_ptr_constructor + procedure profile_map_t_constructor + end interface profile_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Construct a profile map instance + function profile_map_t_ptr_constructor(profile_map_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: profile_map_c_ptr + ! Return value + type(profile_map_t), pointer :: this + + allocate( this ) + this%ptr_ = profile_map_c_ptr + + end function profile_map_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Create a new profile map + function profile_map_t_constructor(error) result(this) + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(error_t), intent(inout) :: error + + ! Return value + type(profile_map_t), pointer :: this + + ! Local variables + type(error_t_c) error_c + + allocate( this ) + this%ptr_ = create_profile_map_c(error_c) + error = error_t(error_c) + + end function profile_map_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a profile to the profile map + subroutine add_profile(this, profile, error) + use musica_tuvx_profile, only: profile_t + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + class(profile_map_t), intent(inout) :: this + type(profile_t), intent(in) :: profile + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + call add_profile_c(this%ptr_, profile%ptr_, error_c) + error = error_t(error_c) + + end subroutine add_profile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a profile given its name and units + function get_profile(this, profile_name, profile_units, error) result(profile) + use iso_c_binding, only: c_char + use musica_tuvx_profile, only: profile_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + class(profile_map_t), intent(in) :: this + character(len=*), intent(in) :: profile_name + character(len=*), intent(in) :: profile_units + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(profile_t), pointer :: profile + + profile => profile_t(get_profile_c(this%ptr_, to_c_string(profile_name), & + to_c_string(profile_units), error_c)) + + error = error_t(error_c) + + end function get_profile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocates the profile map instance + subroutine finalize_profile_map_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(profile_map_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_profile_map_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_profile_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_profile_map diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 new file mode 100644 index 00000000..60a79ee6 --- /dev/null +++ b/fortran/tuvx/radiator.F90 @@ -0,0 +1,361 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_radiator + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_radiator_c(radiator_name, height_grid, wavelength_grid, error) & + bind(C, name="CreateRadiator") + use iso_c_binding, only : c_ptr, c_char + use musica_util, only: error_t_c + character(len=1, kind=c_char), intent(in) :: radiator_name(*) + type(c_ptr), value, intent(in) :: height_grid + type(c_ptr), value, intent(in) :: wavelength_grid + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_radiator_c + end function create_radiator_c + + subroutine delete_radiator_c(radiator, error) bind(C, name="DeleteRadiator") + use iso_c_binding, only : c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(error_t_c), intent(inout) :: error + end subroutine delete_radiator_c + + subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & + num_wavelength_bins, error) bind(C, name="SetRadiatorOpticalDepths") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: optical_depths + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine set_optical_depths_c + + subroutine get_optical_depths_c(radiator, optical_depths, num_vertical_layers, & + num_wavelength_bins, error) bind(C, name="GetRadiatorOpticalDepths") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: optical_depths + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine get_optical_depths_c + + subroutine set_single_scattering_albedos_c(radiator, single_scattering_albedos, & + num_vertical_layers, num_wavelength_bins, error) & + bind(C, name="SetRadiatorSingleScatteringAlbedos") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine set_single_scattering_albedos_c + + subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, & + num_vertical_layers, num_wavelength_bins, error) & + bind(C, name="GetRadiatorSingleScatteringAlbedos") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + type(error_t_c), intent(inout) :: error + end subroutine get_single_scattering_albedos_c + + subroutine set_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="SetRadiatorAsymmetryFactors") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: asymmetry_factors + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + integer(c_size_t), value, intent(in) :: num_streams + type(error_t_c), intent(inout) :: error + end subroutine set_asymmetry_factors_c + + subroutine get_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="GetRadiatorAsymmetryFactors") + use iso_c_binding, only : c_ptr, c_size_t + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator + type(c_ptr), value, intent(in) :: asymmetry_factors + integer(c_size_t), value, intent(in) :: num_vertical_layers + integer(c_size_t), value, intent(in) :: num_wavelength_bins + integer(c_size_t), value, intent(in) :: num_streams + type(error_t_c), intent(inout) :: error + end subroutine get_asymmetry_factors_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: radiator_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Set radiator optical depths + procedure :: set_optical_depths + ! Get radiator optical depths + procedure :: get_optical_depths + ! Set radiator single scattering albedos + procedure :: set_single_scattering_albedos + ! Get radiator single scattering albedos + procedure :: get_single_scattering_albedos + ! Set radiator asymmetry_factors + procedure :: set_asymmetry_factors + ! Get radiator asymmetry factors + procedure :: get_asymmetry_factors + ! Deallocate radiator instance + final :: finalize_radiator_t + end type radiator_t + + interface radiator_t + procedure radiator_t_ptr_constructor + procedure radiator_t_constructor + end interface radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a radiator instance that wraps an existing TUV-x radiator + function radiator_t_ptr_constructor(radiator_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: radiator_c_ptr + + ! Return value + type(radiator_t), pointer :: this + + allocate( this ) + this%ptr_ = radiator_c_ptr + + end function radiator_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Constructs a radiator instance that allocates a new TUV-x radiator + function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, & + error) result(this) + use musica_tuvx_grid, only: grid_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + character(len=*), intent(in) :: radiator_name + type(grid_t), intent(in) :: height_grid + type(grid_t), intent(in) :: wavelength_grid + type(error_t), intent(inout) :: error + + ! Return value + type(radiator_t), pointer :: this + + ! Local variables + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_radiator_c(to_c_string(radiator_name), height_grid%ptr_, & + wavelength_grid%ptr_, error_c) + error = error_t(error_c) + + end function radiator_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_optical_depths(this, optical_depths, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: optical_depths + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + + num_vertical_layers = size(optical_depths, 1) + num_wavelength_bins = size(optical_depths, 2) + + call set_optical_depths_c(this%ptr_, c_loc(optical_depths), & + num_vertical_layers, num_wavelength_bins, error_c) + error = error_t(error_c) + + end subroutine set_optical_depths + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_optical_depths(this, optical_depths, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: optical_depths + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + + num_vertical_layers = size(optical_depths, 1) + num_wavelength_bins = size(optical_depths, 2) + + call get_optical_depths_c(this%ptr_, c_loc(optical_depths), & + num_vertical_layers, num_wavelength_bins, error_c) + error = error_t(error_c) + + end subroutine get_optical_depths + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_single_scattering_albedos(this, single_scattering_albedos, & + error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) + + call set_single_scattering_albedos_c(this%ptr_, & + c_loc(single_scattering_albedos), num_vertical_layers, & + num_wavelength_bins, error_c) + error = error_t(error_c) + + end subroutine set_single_scattering_albedos + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_single_scattering_albedos(this, single_scattering_albedos, & + error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) + + call get_single_scattering_albedos_c(this%ptr_, & + c_loc(single_scattering_albedos), num_vertical_layers, & + num_wavelength_bins, error_c) + error = error_t(error_c) + + end subroutine get_single_scattering_albedos + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_asymmetry_factors(this, asymmetry_factors, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + integer(kind=c_size_t) :: num_streams + + num_vertical_layers = size(asymmetry_factors, 1) + num_wavelength_bins = size(asymmetry_factors, 2) + num_streams = size(asymmetry_factors, 3) + + call set_asymmetry_factors_c(this%ptr_, c_loc(asymmetry_factors), & + num_vertical_layers, num_wavelength_bins, num_streams, error_c) + error = error_t(error_c) + +end subroutine set_asymmetry_factors + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine get_asymmetry_factors(this, asymmetry_factors, error) + use iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, dk => musica_dk + + ! Arguments + class(radiator_t), intent(inout) :: this + real(dk), target, dimension(:,:,:), intent(in) :: asymmetry_factors + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins + integer(kind=c_size_t) :: num_streams + + num_vertical_layers = size(asymmetry_factors, 1) + num_wavelength_bins = size(asymmetry_factors, 2) + num_streams = size(asymmetry_factors, 3) + + call get_asymmetry_factors_c(this%ptr_, c_loc(asymmetry_factors), & + num_vertical_layers, num_wavelength_bins, num_streams, error_c) + error = error_t(error_c) + + end subroutine get_asymmetry_factors + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocate the radiator instance + subroutine finalize_radiator_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(radiator_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_radiator_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_radiator \ No newline at end of file diff --git a/fortran/tuvx/radiator_map.F90 b/fortran/tuvx/radiator_map.F90 new file mode 100644 index 00000000..f9cbdd61 --- /dev/null +++ b/fortran/tuvx/radiator_map.F90 @@ -0,0 +1,180 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx_radiator_map + use iso_c_binding, only: c_ptr, c_null_ptr + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: radiator_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_radiator_map_c(error) bind(C, name="CreateRadiatorMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_radiator_map_c + end function create_radiator_map_c + + subroutine delete_radiator_map_c(radiator_map, error) & + bind(C, name="DeleteRadiatorMap") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator_map + type(error_t_c), intent(inout) :: error + end subroutine delete_radiator_map_c + + subroutine add_radiator_c(radiator_map, radiator, error) & + bind(C, name="AddRadiator") + use iso_c_binding, only: c_ptr + use musica_util, only: error_t_c + type(c_ptr), value, intent(in) :: radiator_map + type(c_ptr), value, intent(in) :: radiator + type(error_t_c), intent(inout) :: error + end subroutine add_radiator_c + + function get_radiator_c(radiator_map, radiator_name, error) & + bind(C, name="GetRadiator") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_char + type(c_ptr), value, intent(in) :: radiator_map + character(len=1, kind=c_char), intent(in) :: radiator_name(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_radiator_c + end function get_radiator_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: radiator_map_t + type(c_ptr) :: ptr_ = c_null_ptr + contains + ! Adds a radiator to the radiator map + procedure :: add => add_radiator + ! Get a radiator given its name + procedure :: get => get_radiator + ! Deallocate the radiator map instance + final :: finalize_radiator_map_t + end type radiator_map_t + + interface radiator_map_t + procedure radiator_map_t_ptr_constructor + procedure radiator_map_t_constructor + end interface radiator_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Wraps an existing radiator map + function radiator_map_t_ptr_constructor(radiator_map_c_ptr) result(this) + ! Arguments + type(c_ptr), intent(in) :: radiator_map_c_ptr + ! Return value + type(radiator_map_t), pointer :: this + + allocate( this ) + this%ptr_ = radiator_map_c_ptr + + end function radiator_map_t_ptr_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Creates a new radiator map + function radiator_map_t_constructor(error) result(this) + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(error_t), intent(inout) :: error + + ! Return value + type(radiator_map_t), pointer :: this + + ! Local variables + type(error_t_c) :: error_c + + allocate( this ) + this%ptr_ = create_radiator_map_c(error_c) + error = error_t(error_c) + + end function radiator_map_t_constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Adds a radiator to a radiator map + subroutine add_radiator(this, radiator, error) + use musica_tuvx_radiator, only: radiator_t + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + class(radiator_map_t), intent(inout) :: this + type(radiator_t), intent(in) :: radiator + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + call add_radiator_c(this%ptr_, radiator%ptr_, error_c) + error = error_t(error_c) + + end subroutine add_radiator + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Gets a radiator given its name + function get_radiator(this, radiator_name, error) result(radiator) + use iso_c_binding, only: c_char + use musica_tuvx_radiator, only : radiator_t + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + class(radiator_map_t), intent(in) :: this + character(len=*), intent(in) :: radiator_name + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(radiator_t), pointer :: radiator + + radiator => radiator_t(get_radiator_c(this%ptr_, to_c_string(radiator_name), & + error_c)) + + error = error_t(error_c) + + end function get_radiator + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocates the radiator map instance + subroutine finalize_radiator_map_t(this) + use iso_c_binding, only: c_associated + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(radiator_map_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + if (c_associated(this%ptr_)) then + call delete_radiator_map_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + end if + + end subroutine finalize_radiator_map_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx_radiator_map diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 new file mode 100644 index 00000000..36a58d79 --- /dev/null +++ b/fortran/tuvx/tuvx.F90 @@ -0,0 +1,212 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module musica_tuvx + use iso_c_binding, only: c_ptr, c_null_ptr + use musica_tuvx_grid, only : grid_t + use musica_tuvx_grid_map, only : grid_map_t + use musica_tuvx_profile, only : profile_t + use musica_tuvx_profile_map, only : profile_map_t + use musica_tuvx_radiator, only : radiator_t + use musica_tuvx_radiator_map, only : radiator_map_t + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & + radiator_map_t, radiator_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + interface + function create_tuvx_c(config_path, error) bind(C, name="CreateTuvx") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr, c_int, c_char + character(len=1, kind=c_char), intent(in) :: config_path(*) + type(error_t_c), intent(inout) :: error + type(c_ptr) :: create_tuvx_c + end function create_tuvx_c + + subroutine delete_tuvx_c(tuvx, error) bind(C, name="DeleteTuvx") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr + type(c_ptr), value, intent(in) :: tuvx + type(error_t_c), intent(inout) :: error + end subroutine delete_tuvx_c + + function get_grid_map_c(tuvx, error) bind(C, name="GetGridMap") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr + type(c_ptr), value, intent(in) :: tuvx + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_grid_map_c + end function get_grid_map_c + + function get_profile_map_c(tuvx, error) bind(C, name="GetProfileMap") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr + type(c_ptr), value, intent(in) :: tuvx + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_profile_map_c + end function get_profile_map_c + + function get_radiator_map_c(tuvx, error) bind(C, name="GetRadiatorMap") + use musica_util, only: error_t_c + use iso_c_binding, only: c_ptr + type(c_ptr), value, intent(in) :: tuvx + type(error_t_c), intent(inout) :: error + type(c_ptr) :: get_radiator_map_c + end function get_radiator_map_c + end interface + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + type :: tuvx_t + type(c_ptr), private :: ptr_ = c_null_ptr + contains + ! Create a grid map + procedure :: get_grids + ! Create a profile map + procedure :: get_profiles + ! Create a radiator map + procedure :: get_radiators + ! Deallocate the tuvx instance + final :: finalize + end type tuvx_t + + interface tuvx_t + procedure constructor + end interface tuvx_t + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Construct a tuvx instance + function constructor(config_path, error) result( this ) + use iso_c_binding, only: c_char, c_null_char + use musica_util, only: error_t_c, error_t + + ! Arguments + type(error_t), intent(inout) :: error + character(len=*), intent(in) :: config_path + + ! Local variables + character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) + integer :: n, i + type(error_t_c) :: error_c + + ! Return value + type(tuvx_t), pointer :: this + + allocate( this ) + + n = len_trim(config_path) + do i = 1, n + c_config_path(i) = config_path(i:i) + end do + c_config_path(n+1) = c_null_char + + this%ptr_ = create_tuvx_c(c_config_path, error_c) + + error = error_t(error_c) + if (.not. error%is_success()) then + deallocate(this) + nullify(this) + return + end if + end function constructor + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Get the grid map + function get_grids(this, error) result(grid_map) + use musica_util, only: error_t, error_t_c + + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(grid_map_t), pointer :: grid_map + + grid_map => grid_map_t(get_grid_map_c(this%ptr_, error_c)) + + error = error_t(error_c) + + end function get_grids + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Get the profile map + function get_profiles(this, error) result(profile_map) + use musica_util, only: error_t, error_t_c + + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(profile_map_t), pointer :: profile_map + + profile_map => profile_map_t(get_profile_map_c(this%ptr_, error_c)) + + error = error_t(error_c) + + end function get_profiles + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Get the radiator map + function get_radiators(this, error) result(radiator_map) + use musica_util, only: error_t, error_t_c + + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error + + ! Local variables + type(error_t_c) :: error_c + + ! Return value + type(radiator_map_t), pointer :: radiator_map + + radiator_map => radiator_map_t(get_radiator_map_c(this%ptr_, error_c)) + + error = error_t(error_c) + + end function get_radiators + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> Deallocate the tuvx instance + subroutine finalize(this) + use musica_util, only: error_t, error_t_c, assert + + ! Arguments + type(tuvx_t), intent(inout) :: this + + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error + + call delete_tuvx_c(this%ptr_, error_c) + this%ptr_ = c_null_ptr + error = error_t(error_c) + ASSERT(error%is_success()) + + end subroutine finalize + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module musica_tuvx diff --git a/fortran/util.F90 b/fortran/util.F90 index 963f038f..42faf459 100644 --- a/fortran/util.F90 +++ b/fortran/util.F90 @@ -10,7 +10,14 @@ module musica_util private public :: string_t_c, string_t, error_t_c, error_t, mapping_t_c, mapping_t, & - to_c_string, to_f_string, assert, copy_mappings, delete_string_c, create_string_c + to_c_string, to_f_string, assert, copy_mappings, delete_string_c, & + create_string_c, musica_rk, musica_dk + + !> Single precision kind + integer, parameter :: musica_rk = kind(0.0) + + !> Double precision kind + integer, parameter :: musica_dk = kind(0.d0) !> Wrapper for a c string type, bind(c) :: string_t_c diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index c4b10075..e475fb7f 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -12,13 +12,21 @@ #include #include #include +#include #include +#include +#include #include +#include #include #include #include +#ifndef MICM_VECTOR_MATRIX_SIZE + #define MICM_VECTOR_MATRIX_SIZE 1 +#endif + namespace musica { @@ -28,6 +36,12 @@ namespace musica extern "C" { #endif + /// @brief Types of MICM solver + enum MICMSolver + { + Rosenbrock = 1, // Vector-ordered Rosenbrock solver + RosenbrockStandardOrder, // Standard-ordered Rosenbrock solver + }; struct SolverResultStats { @@ -87,7 +101,12 @@ namespace musica } }; - MICM *CreateMicm(const char *config_path, Error *error); + /// @brief Create a MICM object by specifying solver type to use + /// @param config_path Path to configuration file or directory containing configuration file + /// @param solver_type Type of MICMSolver + /// @param num_grid_cells Number of grid cells + /// @param error Error struct to indicate success or failure + MICM *CreateMicm(const char *config_path, MICMSolver solver_type, int num_grid_cells, Error *error); void DeleteMicm(const MICM *micm, Error *error); void MicmSolve( MICM *micm, @@ -116,12 +135,18 @@ namespace musica class MICM { public: - /// @brief Create a solver by reading and parsing configuration file + /// @brief Create a Rosenbrock solver of vector-ordered matrix type by reading and parsing configuration file + /// @param config_path Path to configuration file or directory containing configuration file + /// @param error Error struct to indicate success or failure + void CreateRosenbrock(const std::string &config_path, Error *error); + + /// @brief Create a Rosenbrock solver of standard-ordered matrix type by reading and parsing configuration file /// @param config_path Path to configuration file or directory containing configuration file /// @param error Error struct to indicate success or failure - void Create(const std::string &config_path, Error *error); + void CreateRosenbrockStandardOrder(const std::string &config_path, Error *error); /// @brief Solve the system + /// @param solver Pointer to solver /// @param time_step Time [s] to advance the state by /// @param temperature Temperature [K] /// @param pressure Pressure [Pa] @@ -132,6 +157,7 @@ namespace musica /// @param custom_rate_parameters Array of custom rate parameters /// @param error Error struct to indicate success or failure void Solve( + auto &solver, double time_step, double temperature, double pressure, @@ -144,15 +170,34 @@ namespace musica SolverResultStats *solver_stats, Error *error); + /// @brief Set solver type + /// @param MICMSolver Type of MICMSolver + void SetSolverType(MICMSolver solver_type) + { + solver_type_ = solver_type; + } + + /// @brief Set number of grid cells + /// @param num_grid_cells Number of grid cells + void SetNumGridCells(int num_grid_cells) + { + num_grid_cells_ = num_grid_cells; + } + /// @brief Get the ordering of species + /// @param solver Pointer to solver /// @param error Error struct to indicate success or failure /// @return Map of species names to their indices - std::map GetSpeciesOrdering(Error *error); + // std::map GetSpeciesOrdering(auto &solver, Error *error); + template + std::map GetSpeciesOrdering(T &solver, Error *error); /// @brief Get the ordering of user-defined reaction rates + /// @param solver Pointer to solver /// @param error Error struct to indicate success or failure /// @return Map of reaction rate names to their indices - std::map GetUserDefinedReactionRatesOrdering(Error *error); + template + std::map GetUserDefinedReactionRatesOrdering(T &solver, Error *error); /// @brief Get a property for a chemical species /// @param species_name Name of the species @@ -162,20 +207,68 @@ namespace musica template T GetSpeciesProperty(const std::string &species_name, const std::string &property_name, Error *error); - static constexpr std::size_t NUM_GRID_CELLS = 1; + public: + MICMSolver solver_type_; - private: - using DenseMatrixPolicy = micm::Matrix; - using SparseMatrixPolicy = micm::SparseMatrix; - using SolverPolicy = typename micm::RosenbrockSolverParameters:: - template SolverType>; - using Rosenbrock = micm::Solver>; + /// @brief Vector-ordered Rosenbrock solver type + using DenseMatrixVector = micm::VectorMatrix; + using SparseMatrixVector = micm::SparseMatrix>; + using RosenbrockVectorType = typename micm::RosenbrockSolverParameters:: + template SolverType>; + using Rosenbrock = micm::Solver>; + using VectorState = micm::State; + std::unique_ptr rosenbrock_; - std::unique_ptr solver_; + /// @brief Standard-ordered Rosenbrock solver type + using DenseMatrixStandard = micm::Matrix; + using SparseMatrixStandard = micm::SparseMatrix; + using RosenbrockStandardType = typename micm::RosenbrockSolverParameters:: + template SolverType>; + using RosenbrockStandard = micm::Solver>; + using StandardState = micm::State; + std::unique_ptr rosenbrock_standard_; + private: + int num_grid_cells_; std::unique_ptr solver_parameters_; }; + template + inline std::map MICM::GetSpeciesOrdering(T &solver, Error *error) + { + try + { + micm::State state = solver->GetState(); + DeleteError(error); + *error = NoError(); + return state.variable_map_; + } + catch (const std::system_error &e) + { + DeleteError(error); + *error = ToError(e); + return std::map(); + } + } + + template + inline std::map MICM::GetUserDefinedReactionRatesOrdering(T &solver, Error *error) + { + try + { + micm::State state = solver->GetState(); + DeleteError(error); + *error = NoError(); + return state.custom_rate_parameter_map_; + } + catch (const std::system_error &e) + { + DeleteError(error); + *error = ToError(e); + return std::map(); + } + } + template inline T MICM::GetSpeciesProperty(const std::string &species_name, const std::string &property_name, Error *error) { @@ -201,4 +294,4 @@ namespace musica *error = ToError(MUSICA_ERROR_CATEGORY, MUSICA_ERROR_CODE_SPECIES_NOT_FOUND, msg.c_str()); return T(); } -} // namespace musica +} // namespace musica \ No newline at end of file diff --git a/include/musica/tuvx.hpp b/include/musica/tuvx.hpp deleted file mode 100644 index 249ec6ec..00000000 --- a/include/musica/tuvx.hpp +++ /dev/null @@ -1,123 +0,0 @@ -// Copyright (C) 2023-2024 National Center for Atmospheric Research -// SPDX-License-Identifier: Apache-2.0 -// -// This file contains the defintion of the TUVX class, which represents a photolysis calculator. -// It also includes functions for creating and deleting TUVX instances with c binding. -#pragma once - -#include - -#include -#include -#include - -namespace musica -{ - - /// @brief A grid struct used to access grid information in tuvx - struct Grid - { - Grid(void *grid) - : grid_(grid) - { - } - ~Grid(); - - /// @brief Set the edges of the grid - /// @param edges The edges of the grid - /// @param num_edges the number of edges - /// @param error the error struct to indicate success or failure - void SetEdges(double edges[], std::size_t num_edges, Error *error); - - /// @brief Set the midpoints of the grid - /// @param midpoints The midpoints of the grid - /// @param num_midpoints the number of midpoints - /// @param error the error struct to indicate success or failure - void SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); - - private: - void *grid_; - }; - - /// @brief A grid map struct used to access grid information in tuvx - struct GridMap - { - GridMap(void *grid_map) - : grid_map_(grid_map) - { - } - ~GridMap(); - - /// @brief Returns a grid. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on to - /// be transparent to downstream projects - /// @param grid_name The name of the grid we want - /// @param grid_units The units of the grid we want - /// @param error The error struct to indicate success or failure - /// @return a grid pointer - Grid *GetGrid(const char *grid_name, const char *grid_units, Error *error); - - private: - void *grid_map_; - std::vector> grids_; - }; - - class TUVX; - -#ifdef __cplusplus - extern "C" - { -#endif - - // The external C API for TUVX - // callable by external Fortran models - TUVX *CreateTuvx(const char *config_path, Error *error); - void DeleteTuvx(const TUVX *tuvx, Error *error); - GridMap *GetGridMap(TUVX *tuvx, Error *error); - Grid *GetGrid(GridMap *grid_map, const char *grid_name, const char *grid_units, Error *error); - void SetEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error); - void SetMidpoints(Grid *grid, double midpoints[], std::size_t num_midpoints, Error *error); - - // for use by musica interanlly. If tuvx ever gets rewritten in C++, these functions will - // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will - // not need to change - void *InternalCreateTuvx(const char *config_path, std::size_t config_path_length, int *error_code); - void InternalDeleteTuvx(void *tuvx, int *error_code); - void *InternalGetGridMap(void *tuvx, int *error_code); - void *InternalGetGrid( - void *grid_map, - const char *grid_name, - std::size_t grid_name_length, - const char *grid_units, - std::size_t grid_units_length, - int *error_code); - void InternalDeleteGrid(void *grid, int *error_code); - void InternalSetEdges(void *grid, double edges[], std::size_t num_edges, int *error_code); - void InternalSetMidpoints(void *grid, double midpoints[], std::size_t num_midpoints, int *error_code); - -#ifdef __cplusplus - } -#endif - - class TUVX - { - public: - TUVX(); - - /// @brief Create an instance of tuvx from a configuration file - /// @param config_path Path to configuration file or directory containing configuration file - /// @param error Error struct to indicate success or failure - void Create(const char *config_path, Error *error); - - /// @brief Create a grid map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on - /// to be transparent to downstream projects - /// @param error The error struct to indicate success or failure - /// @return a grid map pointer - GridMap *CreateGridMap(Error *error); - - ~TUVX(); - - private: - void *tuvx_; - std::unique_ptr grid_map_; - }; -} // namespace musica diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp new file mode 100644 index 00000000..bd7a6d3b --- /dev/null +++ b/include/musica/tuvx/grid.hpp @@ -0,0 +1,143 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include + +#include +#include +#include + +namespace musica +{ + class GridMap; + class Profile; + class Radiator; + + /// @brief A grid class used to access grid information in tuvx + class Grid + { + public: + /// @brief Creates a grid instance + /// @param grid_name The name of the grid + /// @param units The units of the grid + /// @param num_sections The number of sections in the grid + /// @param error The error struct to indicate success or failure + Grid(const char *grid_name, const char *units, std::size_t num_sections, Error *error); + + ~Grid(); + + /// @brief Set the edges of the grid + /// @param edges The edges of the grid + /// @param num_edges the number of edges + /// @param error the error struct to indicate success or failure + void SetEdges(double edges[], std::size_t num_edges, Error *error); + + /// @brief Get the edges of the grid + /// @param edges The edges of the grid + /// @param num_edges the number of edges + /// @param error the error struct to indicate success or failure + void GetEdges(double edges[], std::size_t num_edges, Error *error); + + /// @brief Set the midpoints of the grid + /// @param midpoints The midpoints of the grid + /// @param num_midpoints the number of midpoints + /// @param error the error struct to indicate success or failure + void SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + + /// @brief Get the midpoints of the grid + /// @param midpoints The midpoints of the grid + /// @param num_midpoints the number of midpoints + /// @param error the error struct to indicate success or failure + void GetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + + private: + void *grid_; // A valid pointer to a grid instance indicates ownership by this wrapper + void *updater_; + + friend class GridMap; + friend class Profile; + friend class Radiator; + + /// @brief Wraps an existing grid instance. Used by GridMap + /// @param updater The updater for the grid + Grid(void *updater) + : grid_(nullptr), + updater_(updater) + { + } + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates a TUV-x grid instance + /// @param grid_name The name of the grid + /// @param units The units of the grid + /// @param num_sections The number of sections in the grid + /// @param error The error struct to indicate success or failure + Grid *CreateGrid(const char *grid_name, const char *units, std::size_t num_sections, Error *error); + + /// @brief Deletes a TUV-x grid instance + /// @param grid The grid to delete + /// @param error The error struct to indicate success or failure + void DeleteGrid(Grid *grid, Error *error); + + /// @brief Sets the values of the edges of the grid + /// @param grid The grid to set the edges of + /// @param edges The edge values to set for the grid + /// @param num_edges The number of edges + /// @param error The error struct to indicate success or failure + void SetGridEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error); + + /// @brief Gets the values of the edges of the grid + /// @param grid The grid to get the edges of + /// @param edges The edge values to get for the grid + /// @param num_edges The number of edges + /// @param error The error struct to indicate success or failure + void GetGridEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error); + + /// @brief Sets the values of the midpoints of the grid + /// @param grid The grid to set the midpoints of + /// @param midpoints The midpoint values to set for the grid + /// @param num_midpoints The number of midpoints + /// @param error The error struct to indicate success or failure + void SetGridMidpoints(Grid *grid, double midpoints[], std::size_t num_midpoints, Error *error); + + /// @brief Gets the values of the midpoints of the grid + /// @param grid The grid to get the midpoints of + /// @param midpoints The midpoint values to get for the grid + /// @param num_midpoints The number of midpoints + /// @param error The error struct to indicate success or failure + void GetGridMidpoints(Grid *grid, double midpoints[], std::size_t num_midpoints, Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateGrid( + const char *grid_name, + std::size_t grid_name_length, + const char *units, + std::size_t units_length, + std::size_t num_sections, + int *error_code); + void InternalDeleteGrid(void *grid, int *error_code); + void *InternalGetGridUpdater(void *grid, int *error_code); + void InternalDeleteGridUpdater(void *updater, int *error_code); + std::string InternalGetGridName(void *grid, int *error_code); + std::string InternalGetGridUnits(void *grid, int *error_code); + void InternalSetEdges(void *grid, double edges[], std::size_t num_edges, int *error_code); + void InternalGetEdges(void *grid, double edges[], std::size_t num_edges, int *error_code); + void InternalSetMidpoints(void *grid, double midpoints[], std::size_t num_midpoints, int *error_code); + void InternalGetMidpoints(void *grid, double midpoints[], std::size_t num_midpoints, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/include/musica/tuvx/grid_map.hpp b/include/musica/tuvx/grid_map.hpp new file mode 100644 index 00000000..50686593 --- /dev/null +++ b/include/musica/tuvx/grid_map.hpp @@ -0,0 +1,100 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include + +#include +#include +#include + +namespace musica +{ + + /// @brief A grid map class used to access grid information in tuvx + class GridMap + { + public: + GridMap(void *grid_map) + : grid_map_(grid_map), + owns_grid_map_(false) + { + } + + /// @brief @brief Creates a grid map instance + /// @param error The error struct to indicate success or failure + GridMap(Error *error); + + ~GridMap(); + + /// @brief Adds a grid to the grid map + /// @param grid The grid to add + /// @param error The error struct to indicate success or failure + void AddGrid(Grid *grid, Error *error); + + /// @brief Returns a grid. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on to + /// be transparent to downstream projects + /// @param grid_name The name of the grid we want + /// @param grid_units The units of the grid we want + /// @param error The error struct to indicate success or failure + /// @return a grid pointer + Grid *GetGrid(const char *grid_name, const char *grid_units, Error *error); + + private: + void *grid_map_; + bool owns_grid_map_; + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates a grid map instance + /// @param error The error struct to indicate success or failure + /// @return a pointer to the grid map + GridMap *CreateGridMap(Error *error); + + /// @brief Deletes a grid map instance + /// @param grid_map The grid map to delete + /// @param error The error struct to indicate success or failure + void DeleteGridMap(GridMap *grid_map, Error *error); + + /// @brief Adds a grid to the grid map + /// @param grid_map The grid map to add the grid to + /// @param grid The grid to add + /// @param error The error struct to indicate success or failure + void AddGrid(GridMap *grid_map, Grid *grid, Error *error); + + /// @brief Returns a grid from the grid map + /// @param grid_map The grid map to get the grid from + /// @param grid_name The name of the grid we want + /// @param grid_units The units of the grid we want + /// @param error The error struct to indicate success or failure + /// @return The grid pointer, or nullptr if the grid is not found + Grid *GetGrid(GridMap *grid_map, const char *grid_name, const char *grid_units, Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateGridMap(int *error_code); + void InternalDeleteGridMap(void *grid_map, int *error_code); + void InternalAddGrid(void *grid_map, void *grid, int *error_code); + void *InternalGetGrid( + void *grid_map, + const char *grid_name, + std::size_t grid_name_length, + const char *grid_units, + std::size_t grid_units_length, + int *error_code); + void *InternalGetGridUpdaterFromMap(void *grid_map, void *grid, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/include/musica/tuvx/profile.hpp b/include/musica/tuvx/profile.hpp new file mode 100644 index 00000000..309f9bbc --- /dev/null +++ b/include/musica/tuvx/profile.hpp @@ -0,0 +1,205 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include +#include + +#include +#include +#include + +namespace musica +{ + class ProfileMap; + + /// @brief A class used to interact with TUV-x profiles (properties with values on a grid) + class Profile + { + public: + /// @brief Creates a profile instance + /// @param profile_name The name of the profile + /// @param units The units of the profile + /// @param grid The grid to use for the profile + /// @param error The error struct to indicate success or failure + Profile(const char *profile_name, const char *units, Grid *grid, Error *error); + + ~Profile(); + + /// @brief Sets the profile values at the edges of the grid + /// @param edge_values The values at the edges of the grid + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void SetEdgeValues(double edge_values[], std::size_t num_values, Error *error); + + /// @brief Gets the profile values at the edges of the grid + /// @param edge_values The values at the edges of the grid + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void GetEdgeValues(double edge_values[], std::size_t num_values, Error *error); + + /// @brief Sets the profile values at the midpoints of the grid + /// @param midpoint_values The values at the midpoints of the grid + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void SetMidpointValues(double midpoint_values[], std::size_t num_values, Error *error); + + /// @brief Gets the profile values at the midpoints of the grid + /// @param midpoint_values The values at the midpoints of the grid + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void GetMidpointValues(double midpoint_values[], std::size_t num_values, Error *error); + + /// @brief Sets the layer densities for each grid section + /// @param layer_densities The layer densities + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void SetLayerDensities(double layer_densities[], std::size_t num_values, Error *error); + + /// @brief Gets the layer densities for each grid section + /// @param layer_densities The layer densities + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void GetLayerDensities(double layer_densities[], std::size_t num_values, Error *error); + + /// @brief Sets the layer density above the top of the grid + /// @param exo_layer_density The layer density above the top of the grid + /// @param error The error struct to indicate success or failure + void SetExoLayerDensity(double exo_layer_density, Error *error); + + /// @brief Calculates an exo layer density based on a provided scale height + /// @param scale_height The scale height to use in the calculation + /// @param error The error struct to indicate success or failure + void CalculateExoLayerDensity(double scale_height, Error *error); + + /// @brief Gets the layer density above the top of the grid + /// @param error The error struct to indicate success or failure + /// @return The layer density above the top of the grid + double GetExoLayerDensity(Error *error); + + private: + void *profile_; // A valid pointer to a profile instance indicates ownership by this wrapper + void *updater_; + + friend class ProfileMap; + + /// @brief Wraps an existing profile instance + /// @param updater The updater for the profile + Profile(void *updater) + : profile_(nullptr), + updater_(updater) + { + } + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates a new profile instance + /// @param profile_name The name of the profile + /// @param units The units of the profile + /// @param grid The grid to use for the profile + /// @param error The error struct to indicate success or failure + Profile *CreateProfile(const char *profile_name, const char *units, Grid *grid, Error *error); + + /// @brief Deletes a profile instance + /// @param profile The profile to delete + /// @param error The error struct to indicate success or failure + void DeleteProfile(Profile *profile, Error *error); + + /// @brief Sets the values at edges of the profile grid + /// @param profile The profile to set the edge values of + /// @param edge_values The edge values to set for the profile + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void SetProfileEdgeValues(Profile *profile, double edge_values[], std::size_t num_values, Error *error); + + /// @brief Gets the values at edges of the profile grid + /// @param profile The profile to get the edge values of + /// @param edge_values The edge values to get for the profile + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void GetProfileEdgeValues(Profile *profile, double edge_values[], std::size_t num_values, Error *error); + + /// @brief Sets the values at midpoints of the profile grid + /// @param profile The profile to set the midpoint values of + /// @param midpoint_values The midpoint values to set for the profile + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void SetProfileMidpointValues(Profile *profile, double midpoint_values[], std::size_t num_values, Error *error); + + /// @brief Gets the values at midpoints of the profile grid + /// @param profile The profile to get the midpoint values of + /// @param midpoint_values The midpoint values to get for the profile + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void GetProfileMidpointValues(Profile *profile, double midpoint_values[], std::size_t num_values, Error *error); + + /// @brief Sets the layer densities for each grid section of the profile + /// @param profile The profile to set the layer densities of + /// @param layer_densities The layer densities to set for the profile + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void SetProfileLayerDensities(Profile *profile, double layer_densities[], std::size_t num_values, Error *error); + + /// @brief Gets the layer densities for each grid section of the profile + /// @param profile The profile to get the layer densities of + /// @param layer_densities The layer densities to get for the profile + /// @param num_values The number of values + /// @param error The error struct to indicate success or failure + void GetProfileLayerDensities(Profile *profile, double layer_densities[], std::size_t num_values, Error *error); + + /// @brief Sets the layer density above the top of the profile grid + /// @param profile The profile to set the exo layer density of + /// @param exo_layer_density The exo layer density to set for the profile + /// @param error The error struct to indicate success or failure + void SetProfileExoLayerDensity(Profile *profile, double exo_layer_density, Error *error); + + /// @brief Calculates an exo layer density based on a provided scale height + /// @param profile The profile to calculate the exo layer density of + /// @param scale_height The scale height to use in the calculation + /// @param error The error struct to indicate success or failure + void CalculateProfileExoLayerDensity(Profile *profile, double scale_height, Error *error); + + /// @brief Gets the density above the top of the profile grid + /// @param profile The profile to get the exo layer density of + /// @param error The error struct to indicate success or failure + /// @return The exo layer density + double GetProfileExoLayerDensity(Profile *profile, Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateProfile( + const char *profile_name, + std::size_t profile_name_length, + const char *units, + std::size_t units_length, + void *grid, + int *error_code); + void InternalDeleteProfile(void *profile, int *error_code); + void *InternalGetProfileUpdater(void *profile, int *error_code); + void InternalDeleteProfileUpdater(void *updater, int *error_code); + std::string InternalGetProfileName(void *profile, int *error_code); + std::string InternalGetProfileUnits(void *profile, int *error_code); + void InternalSetEdgeValues(void *profile, double edge_values[], std::size_t num_values, int *error_code); + void InternalGetEdgeValues(void *profile, double edge_values[], std::size_t num_values, int *error_code); + void InternalSetMidpointValues(void *profile, double midpoint_values[], std::size_t num_values, int *error_code); + void InternalGetMidpointValues(void *profile, double midpoint_values[], std::size_t num_values, int *error_code); + void InternalSetLayerDensities(void *profile, double layer_densities[], std::size_t num_values, int *error_code); + void InternalGetLayerDensities(void *profile, double layer_densities[], std::size_t num_values, int *error_code); + void InternalSetExoLayerDensity(void *profile, double exo_layer_density, int *error_code); + void InternalCalculateExoLayerDensity(void *profile, double scale_height, int *error_code); + double InternalGetExoLayerDensity(void *profile, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/include/musica/tuvx/profile_map.hpp b/include/musica/tuvx/profile_map.hpp new file mode 100644 index 00000000..0b5ee6fe --- /dev/null +++ b/include/musica/tuvx/profile_map.hpp @@ -0,0 +1,101 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include +#include + +#include +#include +#include + +namespace musica +{ + + /// @brief A class used to store a collection of profiles + class ProfileMap + { + public: + ProfileMap(void *profile_map) + : profile_map_(profile_map), + owns_profile_map_(false) + { + } + + /// @brief Creates a profile map instance + /// @param error The error struct to indicate success or failure + ProfileMap(Error *error); + + ~ProfileMap(); + + /// @brief Adds a profile to the profile map + /// @param profile The profile to add + /// @param error The error struct to indicate success or failure + void AddProfile(Profile *profile, Error *error); + + /// @brief Returns a profile. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on + /// to be transparent to downstream projects + /// @param profile_name The name of the profile we want + /// @param profile_units The units of the profile we want + /// @param error The error struct to indicate success or failure + /// @return a profile pointer + Profile *GetProfile(const char *profile_name, const char *profile_units, Error *error); + + private: + void *profile_map_; + bool owns_profile_map_; + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates a profile map instance + /// @param error The error struct to indicate success or failure + /// @return a pointer to the profile map + ProfileMap *CreateProfileMap(Error *error); + + /// @brief Deletes a profile map instance + /// @param profile_map The profile map to delete + /// @param error The error struct to indicate success or failure + void DeleteProfileMap(ProfileMap *profile_map, Error *error); + + /// @brief Adds a profile to the profile map + /// @param profile_map The profile map to add the profile to + /// @param profile The profile to add + /// @param error The error struct to indicate success or failure + void AddProfile(ProfileMap *profile_map, Profile *profile, Error *error); + + /// @brief Returns a profile from the profile map + /// @param profile_map The profile map to get the profile from + /// @param profile_name The name of the profile we want + /// @param profile_units The units of the profile we want + /// @param error The error struct to indicate success or failure + /// @return a profile pointer, or nullptr if the profile is not found + Profile *GetProfile(ProfileMap *profile_map, const char *profile_name, const char *profile_units, Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateProfileMap(int *error_code); + void InternalDeleteProfileMap(void *profile_map, int *error_code); + void InternalAddProfile(void *profile_map, void *profile, int *error_code); + void *InternalGetProfile( + void *profile_map, + const char *profile_name, + std::size_t profile_name_length, + const char *profile_units, + std::size_t profile_units_length, + int *error_code); + void *InternalGetProfileUpdaterFromMap(void *profile_map, void *profile, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp new file mode 100644 index 00000000..f08b9b33 --- /dev/null +++ b/include/musica/tuvx/radiator.hpp @@ -0,0 +1,263 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include + +#include + +namespace musica +{ + class RadiatorMap; + + /// @brief Radiator class used to access radiator information in tuvx + class Radiator + { + public: + /// @brief Creates radiator + /// @param radiator_name Radiator name + /// @param height_grid Height grid + /// @param wavelength_grid Wavelength grid + /// @param error Error to indicate success or failure + Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + + ~Radiator(); + + /// @brief Sets optical depth values + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void + SetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); + + /// @brief Gets optical depth values + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void + GetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); + + /// @brief Sets single scattering albedos values + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void SetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets single scattering albedos values + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void GetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets asymmetry factor values + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure + void SetAsymmetryFactors( + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + + /// @brief Gets asymmetry factor values + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure + void GetAsymmetryFactors( + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + + private: + void *radiator_; // A valid pointer to a radiator instance indicates ownership by this wrapper + void *updater_; + + friend class RadiatorMap; + + /// @brief Wraps an existing radiator instance. Used by RadiatorMap + /// @param updater The updater for the radiator + Radiator(void *updater) + : radiator_(nullptr), + updater_(updater) + { + } + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates radiator + /// @param radiator_name Radiator name + /// @param height_grid Height grid + /// @param wavelength_grid Wavelength grid + /// @param error Error to indicate success or failure + Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + + /// @brief Deletes radiator + /// @param radiator Radiator + /// @param error Error to indicate success or failure + void DeleteRadiator(Radiator *radiator, Error *error); + + /// @brief Sets optical depth values + /// @param radiator Radiator + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void SetRadiatorOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets optical depth values + /// @param radiator Radiator + /// @param optical_depths 2D array of optical depth values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void GetRadiatorOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets single scattering albedos values + /// @param radiator Radiator + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void SetRadiatorSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets single scattering albedos values + /// @param radiator Radiator + /// @param single_scattering_albedos 2D array of single scattering albedos values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param error Error to indicate success or failure + void GetRadiatorSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets asymmetry factor values + /// @param radiator Radiator + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure + void SetRadiatorAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + + /// @brief Gets asymmetry factor values + /// @param radiator Radiator + /// @param asymmetry_factor 3D array of asymmetery factor values + /// @param num_vertical_layers Number of vertical layers + /// @param num_wavelength_bins Number of wavelength bins + /// @param num_streams Number of streams + /// @param error Error to indicate success or failure + void GetRadiatorAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factor, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateRadiator( + const char *radiator_name, + std::size_t radiator_name_length, + void *height_grid, + void *wavelength_grid, + int *error_code); + void InternalDeleteRadiator(void *radiator, int *error_code); + void *InternalGetRadiatorUpdater(void *radiator, int *error_code); + void InternalDeleteRadiatorUpdater(void *updater, int *error_code); + void InternalSetOpticalDepths( + void *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalGetOpticalDepths( + void *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalSetSingleScatteringAlbedos( + void *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalGetSingleScatteringAlbedos( + void *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + void InternalSetAsymmetryFactors( + void *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + int *error_code); + void InternalGetAsymmetryFactors( + void *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica \ No newline at end of file diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp new file mode 100644 index 00000000..c998c9ac --- /dev/null +++ b/include/musica/tuvx/radiator_map.hpp @@ -0,0 +1,93 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include + +#include +#include +#include + +namespace musica +{ + + /// @brief Radiator map used to access radiator information in tuvx + class RadiatorMap + { + public: + RadiatorMap(void *radiator_map) + : radiator_map_(radiator_map), + owns_radiator_map_(false) + { + } + + /// @brief Creates radiator map + /// @param error Error to indicate success or failure + RadiatorMap(Error *error); + + ~RadiatorMap(); + + /// @brief Adds a radiator to the radiator map + /// @param radiator Radiator to add + /// @param error Error to indicate success or failure + void AddRadiator(Radiator *radiator, Error *error); + + /// @brief Returns a radiator. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later + /// on to be transparent to downstream projects + /// @param radiator_name Radiator name + /// @param error Error to indicate success or failure + /// @return Radiator + Radiator *GetRadiator(const char *radiator_name, Error *error); + + private: + void *radiator_map_; + bool owns_radiator_map_; + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + + /// @brief Creates radiator map + /// @param error Error to indicate success or failure + /// @return Radiator map + RadiatorMap *CreateRadiatorMap(Error *error); + + /// @brief Deletes radiator map + /// @param radiator_map Radiator map to delete + /// @param error Error to indicate success or failure + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error); + + /// @brief Adds a radiator to the radiator map + /// @param radiator_map Radiator map to add the radiator to + /// @param radiator Radiator to add + /// @param error Error to indicate success or failure + void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error); + + /// @brief Returns a radiator from the radiator map + /// @param radiator_map Radiator map to get the radiator from + /// @param radiator_name Radiator name + /// @param error Error to indicate success or failure + /// @return The radiator pointer, or nullptr if the radiator is not found + Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error); + + // INTERNAL USE. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateRadiatorMap(int *error_code); + void InternalDeleteRadiatorMap(void *radiator_map, int *error_code); + void InternalAddRadiator(void *radiator_map, void *radiator, int *error_code); + void * + InternalGetRadiator(void *radiator_map, const char *radiator_name, std::size_t radiator_name_length, int *error_code); + void *InternalGetRadiatorUpdaterFromMap(void *radiator_map, void *radiator, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/include/musica/tuvx/tuvx.hpp b/include/musica/tuvx/tuvx.hpp new file mode 100644 index 00000000..bd862fde --- /dev/null +++ b/include/musica/tuvx/tuvx.hpp @@ -0,0 +1,80 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +// +// This file contains the defintion of the TUVX class, which represents a photolysis calculator. +// It also includes functions for creating and deleting TUVX instances with c binding. +#pragma once + +#include +#include +#include +#include + +#include +#include +#include + +namespace musica +{ + + class TUVX + { + public: + TUVX(); + + /// @brief Create an instance of tuvx from a configuration file + /// @param config_path Path to configuration file + /// @param error Error struct to indicate success or failure + void Create(const char *config_path, Error *error); + + /// @brief Create a grid map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later on + /// to be transparent to downstream projects + /// @param error The error struct to indicate success or failure + /// @return a grid map pointer + GridMap *CreateGridMap(Error *error); + + /// @brief Create a profile map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ later + /// on to be transparent to downstream projects + /// @param error The error struct to indicate success or failure + /// @return a profile map pointer + ProfileMap *CreateProfileMap(Error *error); + + /// @brief Create a radiator map. For now, this calls the interal tuvx fortran api, but will allow the change to c++ + /// later on to be transparent to downstream projects + /// @param error The error struct to indicate success or failure + /// @return a radiator map pointer + RadiatorMap *CreateRadiatorMap(Error *error); + + ~TUVX(); + + private: + void *tuvx_; + }; + +#ifdef __cplusplus + extern "C" + { +#endif + + // The external C API for TUVX + // callable by wrappers in other languages + TUVX *CreateTuvx(const char *config_path, Error *error); + void DeleteTuvx(const TUVX *tuvx, Error *error); + GridMap *GetGridMap(TUVX *tuvx, Error *error); + ProfileMap *GetProfileMap(TUVX *tuvx, Error *error); + RadiatorMap *GetRadiatorMap(TUVX *tuvx, Error *error); + + // for use by musica interanlly. If tuvx ever gets rewritten in C++, these functions will + // go away but the C API will remain the same and downstream projects (like CAM-SIMA) will + // not need to change + void *InternalCreateTuvx(const char *config_path, std::size_t config_path_length, int *error_code); + void InternalDeleteTuvx(void *tuvx, int *error_code); + void *InternalGetGridMap(void *tuvx, int *error_code); + void *InternalGetProfileMap(void *tuvx, int *error_code); + void *InternalGetRadiatorMap(void *tuvx, int *error_code); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/include/musica/util.hpp b/include/musica/util.hpp index e6f3f0c6..aaca47b0 100644 --- a/include/musica/util.hpp +++ b/include/musica/util.hpp @@ -4,8 +4,9 @@ #include -#define MUSICA_ERROR_CATEGORY "MUSICA Error" -#define MUSICA_ERROR_CODE_SPECIES_NOT_FOUND 1 +#define MUSICA_ERROR_CATEGORY "MUSICA Error" +#define MUSICA_ERROR_CODE_SPECIES_NOT_FOUND 1 +#define MUSICA_ERROR_CODE_SOLVER_TYPE_NOT_FOUND 2 #ifdef __cplusplus #include diff --git a/pyproject.toml b/pyproject.toml index d1fe56ba..0feccafd 100644 --- a/pyproject.toml +++ b/pyproject.toml @@ -47,4 +47,7 @@ regex = 'musica-distribution VERSION\s+(?P[0-9.]+)' path = "musica/_version.py" template = ''' version = "${version}" -''' \ No newline at end of file +''' + +[tool.cibuildwheel.macos.environment] +MACOSX_DEPLOYMENT_TARGET = "10.15" diff --git a/python/test/test_analytical.py b/python/test/test_analytical.py index 6f973847..fc46bd8a 100644 --- a/python/test/test_analytical.py +++ b/python/test/test_analytical.py @@ -5,14 +5,17 @@ class TestAnalyticalSimulation(unittest.TestCase): def test_simulation(self): + num_grid_cells = 1 time_step = 200.0 temperature = 272.5 pressure = 101253.3 GAS_CONSTANT = 8.31446261815324 air_density = pressure / (GAS_CONSTANT * temperature) - solver = musica.create_solver("configs/analytical") - + solver = musica.create_solver( + "configs/analytical", + musica.micmsolver.rosenbrock, + num_grid_cells) rates = musica.user_defined_reaction_rates(solver) ordering = musica.species_ordering(solver) diff --git a/python/test/test_chapman.py b/python/test/test_chapman.py index 90e93acf..ed1de5e4 100644 --- a/python/test/test_chapman.py +++ b/python/test/test_chapman.py @@ -4,14 +4,18 @@ class TestChapman(unittest.TestCase): def test_micm_solve(self): + num_grid_cells = 1 time_step = 200.0 temperature = 272.5 pressure = 101253.3 GAS_CONSTANT = 8.31446261815324 air_density = pressure / (GAS_CONSTANT * temperature) - concentrations = [0.75, 0.4, 0.8, 0.01, 0.02] + concentrations = [0.4, 0.8, 0.01, 0.02] - solver = musica.create_solver("configs/chapman") + solver = musica.create_solver( + "configs/chapman", + musica.micmsolver.rosenbrock, + num_grid_cells) rate_constant_ordering = musica.user_defined_reaction_rates(solver) ordering = musica.species_ordering(solver) @@ -37,16 +41,15 @@ def test_micm_solve(self): self.assertEqual( ordering, { - 'M': 0, 'O': 2, 'O1D': 1, 'O2': 3, 'O3': 4}) + 'O': 1, 'O1D': 0, 'O2': 2, 'O3': 3}) self.assertEqual( rate_constant_ordering, { 'PHOTO.R1': 0, 'PHOTO.R3': 1, 'PHOTO.R5': 2}) - self.assertEqual(concentrations[0], 0.75) - self.assertNotEqual(concentrations[1], 0.4) - self.assertNotEqual(concentrations[2], 0.8) - self.assertNotEqual(concentrations[3], 0.01) - self.assertNotEqual(concentrations[4], 0.02) + self.assertNotEqual(concentrations[0], 0.4) + self.assertNotEqual(concentrations[1], 0.8) + self.assertNotEqual(concentrations[2], 0.01) + self.assertNotEqual(concentrations[3], 0.02) if __name__ == '__main__': diff --git a/python/wrapper.cpp b/python/wrapper.cpp index 7310baf9..390d8cbc 100644 --- a/python/wrapper.cpp +++ b/python/wrapper.cpp @@ -10,18 +10,20 @@ namespace py = pybind11; // Wraps micm.cpp PYBIND11_MODULE(musica, m) { - py::class_(m, "MICM") + py::class_(m, "micm") .def(py::init<>()) - .def("create", &musica::MICM::Create) - .def("solve", &musica::MICM::Solve) .def("__del__", [](musica::MICM &micm) {}); + py::enum_(m, "micmsolver") + .value("rosenbrock", musica::MICMSolver::Rosenbrock) + .value("rosenbrock_standard_order", musica::MICMSolver::RosenbrockStandardOrder); + m.def( "create_solver", - [](const char *config_path) + [](const char *config_path, musica::MICMSolver solver_type, int num_grid_cells) { musica::Error error; - musica::MICM *micm = musica::CreateMicm(config_path, &error); + musica::MICM *micm = musica::CreateMicm(config_path, solver_type, num_grid_cells, &error); if (!musica::IsSuccess(error)) { std::string message = "Error creating solver: " + std::string(error.message_.value_); @@ -76,6 +78,12 @@ PYBIND11_MODULE(musica, m) &solver_state, &solver_stats, &error); + if (!musica::IsSuccess(error)) + { + std::string message = "Error solving system: " + std::string(error.message_.value_); + DeleteError(&error); + throw std::runtime_error(message); + } // Update the concentrations list after solving for (std::size_t i = 0; i < concentrations_cpp.size(); ++i) @@ -90,7 +98,18 @@ PYBIND11_MODULE(musica, m) [](musica::MICM *micm) { musica::Error error; - return micm->GetSpeciesOrdering(&error); + std::map map; + + if (micm->solver_type_ == musica::MICMSolver::Rosenbrock) + { + map = micm->GetSpeciesOrdering(micm->rosenbrock_, &error); + } + else if (micm->solver_type_ == musica::MICMSolver::RosenbrockStandardOrder) + { + map = micm->GetSpeciesOrdering(micm->rosenbrock_standard_, &error); + } + + return map; }, "Return map of get_species_ordering rates"); @@ -99,7 +118,18 @@ PYBIND11_MODULE(musica, m) [](musica::MICM *micm) { musica::Error error; - return micm->GetUserDefinedReactionRatesOrdering(&error); + std::map map; + + if (micm->solver_type_ == musica::MICMSolver::Rosenbrock) + { + map = micm->GetUserDefinedReactionRatesOrdering(micm->rosenbrock_, &error); + } + else if (micm->solver_type_ == musica::MICMSolver::RosenbrockStandardOrder) + { + map = micm->GetUserDefinedReactionRatesOrdering(micm->rosenbrock_standard_, &error); + } + + return map; }, "Return map of reaction rates"); } \ No newline at end of file diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index e8c7a849..54a5f60f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -17,6 +17,8 @@ message (STATUS "CMake build configuration for ${PROJECT_NAME} (${CMAKE_BUILD_TY add_library(musica) add_library(musica::musica ALIAS musica) +target_compile_definitions(musica PUBLIC MICM_VECTOR_MATRIX_SIZE=${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) + # set the c++ standard for musica target_compile_features(musica PUBLIC cxx_std_20) diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index 7d03038e..6ab7f00f 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -5,6 +5,7 @@ // multi-component reactive transport model. It also includes functions for // creating and deleting MICM instances, creating solvers, and solving the model. #include +#include #include #include @@ -14,20 +15,41 @@ #include #include #include -#include +#include +#include namespace musica { - MICM *CreateMicm(const char *config_path, Error *error) + + MICM *CreateMicm(const char *config_path, MICMSolver solver_type, int num_grid_cells, Error *error) { DeleteError(error); MICM *micm = new MICM(); - micm->Create(std::string(config_path), error); + micm->SetNumGridCells(num_grid_cells); + + if (solver_type == MICMSolver::Rosenbrock) + { + micm->SetSolverType(MICMSolver::Rosenbrock); + micm->CreateRosenbrock(std::string(config_path), error); + } + else if (solver_type == MICMSolver::RosenbrockStandardOrder) + { + micm->SetSolverType(MICMSolver::RosenbrockStandardOrder); + micm->CreateRosenbrockStandardOrder(std::string(config_path), error); + } + else + { + std::string msg = "Solver type '" + std::to_string(solver_type) + "' not found"; + *error = ToError(MUSICA_ERROR_CATEGORY, MUSICA_ERROR_CODE_SOLVER_TYPE_NOT_FOUND, msg.c_str()); + delete micm; + return nullptr; + } if (!IsSuccess(*error)) { delete micm; return nullptr; } + return micm; } @@ -65,19 +87,40 @@ namespace musica Error *error) { DeleteError(error); - micm->Solve( - time_step, - temperature, - pressure, - air_density, - num_concentrations, - concentrations, - num_custom_rate_parameters, - custom_rate_parameters, - solver_state, - solver_stats, - error); - } + + if (micm->solver_type_ == MICMSolver::Rosenbrock) + { + micm->Solve( + micm->rosenbrock_, + time_step, + temperature, + pressure, + air_density, + num_concentrations, + concentrations, + num_custom_rate_parameters, + custom_rate_parameters, + solver_state, + solver_stats, + error); + } + else if (micm->solver_type_ == MICMSolver::RosenbrockStandardOrder) + { + micm->Solve( + micm->rosenbrock_standard_, + time_step, + temperature, + pressure, + air_density, + num_concentrations, + concentrations, + num_custom_rate_parameters, + custom_rate_parameters, + solver_state, + solver_stats, + error); + } + }; String MicmVersion() { @@ -87,11 +130,22 @@ namespace musica Mapping *GetSpeciesOrdering(MICM *micm, std::size_t *array_size, Error *error) { DeleteError(error); - auto map = micm->GetSpeciesOrdering(error); + + std::map map; + + if (micm->solver_type_ == MICMSolver::Rosenbrock) + { + map = micm->GetSpeciesOrdering(micm->rosenbrock_, error); + } + else if (micm->solver_type_ == MICMSolver::RosenbrockStandardOrder) + { + map = micm->GetSpeciesOrdering(micm->rosenbrock_standard_, error); + } if (!IsSuccess(*error)) { return nullptr; } + Mapping *species_ordering = new Mapping[map.size()]; // Copy data from the map to the array of structs @@ -110,11 +164,22 @@ namespace musica Mapping *GetUserDefinedReactionRatesOrdering(MICM *micm, std::size_t *array_size, Error *error) { DeleteError(error); - auto map = micm->GetUserDefinedReactionRatesOrdering(error); + + std::map map; + + if (micm->solver_type_ == MICMSolver::Rosenbrock) + { + map = micm->GetUserDefinedReactionRatesOrdering(micm->rosenbrock_, error); + } + else if (micm->solver_type_ == MICMSolver::RosenbrockStandardOrder) + { + map = micm->GetUserDefinedReactionRatesOrdering(micm->rosenbrock_standard_, error); + } if (!IsSuccess(*error)) { return nullptr; } + Mapping *reactionRates = new Mapping[map.size()]; // Copy data from the map to the array of structs @@ -167,7 +232,7 @@ namespace musica return micm->GetSpeciesProperty(species_name_str, property_name_str, error); } - void MICM::Create(const std::string &config_path, Error *error) + void MICM::CreateRosenbrock(const std::string &config_path, Error *error) { try { @@ -175,13 +240,48 @@ namespace musica solver_config.ReadAndParse(std::filesystem::path(config_path)); solver_parameters_ = std::make_unique(solver_config.GetSolverParams()); - solver_ = std::make_unique(micm::CpuSolverBuilder( - micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) - .SetSystem(solver_parameters_->system_) - .SetReactions(solver_parameters_->processes_) - .SetNumberOfGridCells(NUM_GRID_CELLS) - .SetIgnoreUnusedSpecies(true) - .Build()); + rosenbrock_ = std::make_unique( + micm::SolverBuilder< + micm::RosenbrockSolverParameters, + micm::VectorMatrix, + micm::SparseMatrix>, + micm::ProcessSet, + micm::LinearSolver< + micm::SparseMatrix>, + micm::LuDecomposition>, + VectorState>(micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) + .SetSystem(solver_parameters_->system_) + .SetReactions(solver_parameters_->processes_) + .SetNumberOfGridCells(num_grid_cells_) + .SetIgnoreUnusedSpecies(true) + .Build()); + + DeleteError(error); + *error = NoError(); + } + catch (const std::system_error &e) + { + DeleteError(error); + *error = ToError(e); + } + } + + void MICM::CreateRosenbrockStandardOrder(const std::string &config_path, Error *error) + { + try + { + micm::SolverConfig<> solver_config; + solver_config.ReadAndParse(std::filesystem::path(config_path)); + solver_parameters_ = std::make_unique(solver_config.GetSolverParams()); + + rosenbrock_standard_ = + std::make_unique(micm::CpuSolverBuilder( + micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) + .SetSystem(solver_parameters_->system_) + .SetReactions(solver_parameters_->processes_) + .SetNumberOfGridCells(num_grid_cells_) + .SetIgnoreUnusedSpecies(true) + .Build()); DeleteError(error); *error = NoError(); @@ -194,6 +294,7 @@ namespace musica } void MICM::Solve( + auto &solver, double time_step, double temperature, double pressure, @@ -208,13 +309,13 @@ namespace musica { try { - micm::State state = solver_->GetState(); + micm::State state = solver->GetState(); - for (std::size_t i{}; i < NUM_GRID_CELLS; i++) + for (int cell{}; cell < num_grid_cells_; cell++) { - state.conditions_[i].temperature_ = temperature; - state.conditions_[i].pressure_ = pressure; - state.conditions_[i].air_density_ = air_density; + state.conditions_[cell].temperature_ = temperature; + state.conditions_[cell].pressure_ = pressure; + state.conditions_[cell].air_density_ = air_density; } state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); @@ -222,8 +323,8 @@ namespace musica state.custom_rate_parameters_.AsVector().assign( custom_rate_parameters, custom_rate_parameters + num_custom_rate_parameters); - solver_->CalculateRateConstants(state); - auto result = solver_->Solve(time_step, state); + solver->CalculateRateConstants(state); + auto result = solver->Solve(time_step, state); *solver_state = CreateString(micm::SolverStateToString(result.state_).c_str()); @@ -253,38 +354,4 @@ namespace musica } } - std::map MICM::GetSpeciesOrdering(Error *error) - { - try - { - micm::State state = solver_->GetState(); - DeleteError(error); - *error = NoError(); - return state.variable_map_; - } - catch (const std::system_error &e) - { - DeleteError(error); - *error = ToError(e); - return std::map(); - } - } - - std::map MICM::GetUserDefinedReactionRatesOrdering(Error *error) - { - try - { - micm::State state = solver_->GetState(); - DeleteError(error); - *error = NoError(); - return state.custom_rate_parameter_map_; - } - catch (const std::system_error &e) - { - DeleteError(error); - *error = ToError(e); - return std::map(); - } - } - } // namespace musica diff --git a/src/packaging/CMakeLists.txt b/src/packaging/CMakeLists.txt index 2df3a57c..9d04933f 100644 --- a/src/packaging/CMakeLists.txt +++ b/src/packaging/CMakeLists.txt @@ -72,7 +72,13 @@ if (MUSICA_ENABLE_TUVX) ) install( FILES - ${MUSICA_FORTRAN_SRC_DIR}/tuvx.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/grid.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/grid_map.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/profile.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/profile_map.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/radiator.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/radiator_map.F90 + ${MUSICA_FORTRAN_SRC_DIR}/tuvx/tuvx.F90 DESTINATION ${MUSICA_INSTALL_INCLUDE_DIR}/musica/fortran ) diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 3821ceb8..90a17387 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -15,12 +15,13 @@ class MicmCApiTest : public ::testing::Test protected: MICM* micm; const char* config_path = "configs/chapman"; + int num_grid_cells = 1; void SetUp() override { micm = nullptr; Error error; - micm = CreateMicm(config_path, &error); + micm = CreateMicm(config_path, MICMSolver::Rosenbrock, num_grid_cells, &error); ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); @@ -38,13 +39,26 @@ class MicmCApiTest : public ::testing::Test // Test case for bad configuration file path TEST_F(MicmCApiTest, BadConfigurationFilePath) { + int num_grid_cells = 1; Error error = NoError(); - auto micm_bad_config = CreateMicm("bad config path", &error); + auto micm_bad_config = CreateMicm("bad config path", MICMSolver::Rosenbrock, num_grid_cells, &error); ASSERT_EQ(micm_bad_config, nullptr); ASSERT_TRUE(IsError(error, MICM_ERROR_CATEGORY_CONFIGURATION, MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH)); DeleteError(&error); } +// Test case for bad input for solver type +TEST_F(MicmCApiTest, BadSolverType) +{ + short solver_type = 999; + int num_grid_cells = 1; + Error error = NoError(); + auto micm_bad_solver_type = CreateMicm("configs/chapman", static_cast(solver_type), num_grid_cells, &error); + ASSERT_EQ(micm_bad_solver_type, nullptr); + ASSERT_TRUE(IsError(error, MUSICA_ERROR_CATEGORY, MUSICA_ERROR_CODE_SOLVER_TYPE_NOT_FOUND)); + DeleteError(&error); +} + // Test case for missing species property TEST_F(MicmCApiTest, MissingSpeciesProperty) { @@ -83,7 +97,7 @@ TEST_F(MicmCApiTest, GetSpeciesOrdering) Mapping* species_ordering = GetSpeciesOrdering(micm, &array_size, &error); ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); - ASSERT_EQ(array_size, 5); + ASSERT_EQ(array_size, 4); bool found = false; for (std::size_t i = 0; i < array_size; i++) { @@ -116,16 +130,6 @@ TEST_F(MicmCApiTest, GetSpeciesOrdering) ASSERT_TRUE(found); found = false; for (std::size_t i = 0; i < array_size; i++) - { - if (strcmp(species_ordering[i].name_.value_, "M") == 0) - { - found = true; - break; - } - } - ASSERT_TRUE(found); - found = false; - for (std::size_t i = 0; i < array_size; i++) { if (strcmp(species_ordering[i].name_.value_, "O1D") == 0) { @@ -179,28 +183,29 @@ TEST_F(MicmCApiTest, GetUserDefinedReactionRatesOrdering) DeleteMappings(reaction_rates_ordering, array_size); } -// Test case for solving the MICM instance -TEST_F(MicmCApiTest, SolveMicmInstance) +// Test case for solving system using vector-ordered Rosenbrock solver +TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) { double time_step = 200.0; double temperature = 272.5; double pressure = 101253.3; constexpr double GAS_CONSTANT = 8.31446261815324; // J mol-1 K-1 double air_density = pressure / (GAS_CONSTANT * temperature); - int num_concentrations = 5; - double concentrations[] = { 0.75, 0.4, 0.8, 0.01, 0.02 }; + int num_concentrations = 4; + double concentrations[] = { 0.4, 0.8, 0.01, 0.02 }; + std::size_t num_user_defined_reaction_rates = 3; + double user_defined_reaction_rates[] = { 0.1, 0.2, 0.3 }; String solver_state; SolverResultStats solver_stats; Error error; - auto ordering = micm->GetUserDefinedReactionRatesOrdering(&error); + Mapping* ordering = GetUserDefinedReactionRatesOrdering(micm, &num_user_defined_reaction_rates, &error); ASSERT_TRUE(IsSuccess(error)); - int num_custom_rate_parameters = ordering.size(); - std::vector custom_rate_parameters(num_custom_rate_parameters, 0.0); - for (auto& entry : ordering) + std::vector custom_rate_parameters(num_user_defined_reaction_rates, 0.0); + for (std::size_t i = 0; i < num_user_defined_reaction_rates; i++) { - custom_rate_parameters[entry.second] = 0.0; + custom_rate_parameters[ordering[i].index_] = 0.0; } MicmSolve( @@ -219,15 +224,79 @@ TEST_F(MicmCApiTest, SolveMicmInstance) ASSERT_TRUE(IsSuccess(error)); // Add assertions to check the solved concentrations - ASSERT_EQ(concentrations[0], 0.75); - ASSERT_NE(concentrations[1], 0.4); - ASSERT_NE(concentrations[2], 0.8); - ASSERT_NE(concentrations[3], 0.01); - ASSERT_NE(concentrations[4], 0.02); + ASSERT_NE(concentrations[0], 0.4); + ASSERT_NE(concentrations[1], 0.8); + ASSERT_NE(concentrations[2], 0.01); + ASSERT_NE(concentrations[3], 0.02); + + std::cout << "Solver state: " << solver_state.value_ << std::endl; + std::cout << "Function Calls: " << solver_stats.function_calls_ << std::endl; + std::cout << "Jacobian updates: " << solver_stats.jacobian_updates_ << std::endl; + std::cout << "Number of steps: " << solver_stats.number_of_steps_ << std::endl; + std::cout << "Accepted: " << solver_stats.accepted_ << std::endl; + std::cout << "Rejected: " << solver_stats.rejected_ << std::endl; + std::cout << "Decompositions: " << solver_stats.decompositions_ << std::endl; + std::cout << "Solves: " << solver_stats.solves_ << std::endl; + std::cout << "Singular: " << solver_stats.singular_ << std::endl; + std::cout << "Final time: " << solver_stats.final_time_ << std::endl; + + DeleteMappings(ordering, num_user_defined_reaction_rates); + DeleteString(&solver_state); + DeleteError(&error); +} + +// Test case for solving system using standard-ordered Rosenbrock solver +TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) +{ + const char* config_path = "configs/chapman"; + int num_grid_cells = 1; + Error error; + MICM* micm = CreateMicm(config_path, MICMSolver::RosenbrockStandardOrder, num_grid_cells, &error); + + double time_step = 200.0; + double temperature = 272.5; + double pressure = 101253.3; + constexpr double GAS_CONSTANT = 8.31446261815324; // J mol-1 K-1 + double air_density = pressure / (GAS_CONSTANT * temperature); + int num_concentrations = 4; + double concentrations[] = { 0.4, 0.8, 0.01, 0.02 }; + std::size_t num_user_defined_reaction_rates = 3; + double user_defined_reaction_rates[] = { 0.1, 0.2, 0.3 }; + String solver_state; + SolverResultStats solver_stats; + + Mapping* ordering = GetUserDefinedReactionRatesOrdering(micm, &num_user_defined_reaction_rates, &error); + ASSERT_TRUE(IsSuccess(error)); + + std::vector custom_rate_parameters(num_user_defined_reaction_rates, 0.0); + for (std::size_t i = 0; i < num_user_defined_reaction_rates; i++) + { + custom_rate_parameters[ordering[i].index_] = 0.0; + } + + MicmSolve( + micm, + time_step, + temperature, + pressure, + air_density, + num_concentrations, + concentrations, + custom_rate_parameters.size(), + custom_rate_parameters.data(), + &solver_state, + &solver_stats, + &error); + ASSERT_TRUE(IsSuccess(error)); + + ASSERT_NE(concentrations[0], 0.4); + ASSERT_NE(concentrations[1], 0.8); + ASSERT_NE(concentrations[2], 0.01); + ASSERT_NE(concentrations[3], 0.02); std::cout << "Solver state: " << solver_state.value_ << std::endl; std::cout << "Function Calls: " << solver_stats.function_calls_ << std::endl; - std::cout << "Jacobian updates:" << solver_stats.jacobian_updates_ << std::endl; + std::cout << "Jacobian updates: " << solver_stats.jacobian_updates_ << std::endl; std::cout << "Number of steps: " << solver_stats.number_of_steps_ << std::endl; std::cout << "Accepted: " << solver_stats.accepted_ << std::endl; std::cout << "Rejected: " << solver_stats.rejected_ << std::endl; @@ -236,7 +305,10 @@ TEST_F(MicmCApiTest, SolveMicmInstance) std::cout << "Singular: " << solver_stats.singular_ << std::endl; std::cout << "Final time: " << solver_stats.final_time_ << std::endl; + DeleteMappings(ordering, num_user_defined_reaction_rates); DeleteString(&solver_state); + DeleteMicm(micm, &error); + ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); } diff --git a/src/test/unit/tuvx/tuvx_c_api.cpp b/src/test/unit/tuvx/tuvx_c_api.cpp index c91c1ebe..91dbbc93 100644 --- a/src/test/unit/tuvx/tuvx_c_api.cpp +++ b/src/test/unit/tuvx/tuvx_c_api.cpp @@ -1,4 +1,4 @@ -#include +#include #include @@ -65,7 +65,7 @@ TEST_F(TuvxCApiTest, DetectsNonexistentConfigFile) DeleteError(&error); } -TEST_F(TuvxCApiTest, CanGetGrid) +TEST_F(TuvxCApiTest, CannotGetConfiguredGrid) { const char* yaml_config_path = "examples/ts1_tsmlt.yml"; SetUp(yaml_config_path); @@ -74,11 +74,651 @@ TEST_F(TuvxCApiTest, CanGetGrid) ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(grid_map, nullptr); Grid* grid = GetGrid(grid_map, "height", "km", &error); + ASSERT_FALSE(IsSuccess(error)); // non-host grid + ASSERT_EQ(grid, nullptr); + DeleteGridMap(grid_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CanCreateGrid) +{ + Error error; + Grid* grid = CreateGrid("foo", "m", 2, &error); ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(grid, nullptr); - std::vector edges = { 0.0, 1.0, 2.0 }; - ASSERT_NO_THROW(SetEdges(grid, edges.data(), edges.size(), &error);); - std::vector midpoints = { 0.5, 1.5 }; - ASSERT_NO_THROW(SetMidpoints(grid, midpoints.data(), midpoints.size(), &error);); + std::vector edges = { 0.0, 100.0, 200.0 }; + SetGridEdges(grid, edges.data(), edges.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& edge : edges) + { + edge = -100.0; + } + GetGridEdges(grid, edges.data(), edges.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edges[0], 0.0); + ASSERT_EQ(edges[1], 100.0); + ASSERT_EQ(edges[2], 200.0); + std::vector midpoints = { 50.0, 150.0 }; + SetGridMidpoints(grid, midpoints.data(), midpoints.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& midpoint : midpoints) + { + midpoint = -100.0; + } + GetGridMidpoints(grid, midpoints.data(), midpoints.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoints[0], 50.0); + ASSERT_EQ(midpoints[1], 150.0); + DeleteGrid(grid, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CanCreateGridMap) +{ + Error error; + GridMap* grid_map = CreateGridMap(&error); + ASSERT_TRUE(IsSuccess(error)); + Grid* foo_grid = CreateGrid("foo", "m", 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_grid, nullptr); + AddGrid(grid_map, foo_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + Grid* bar_grid = CreateGrid("bar", "m", 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(bar_grid, nullptr); + AddGrid(grid_map, bar_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(grid_map, nullptr); + double edge_values[] = { 0.0, 1.0, 2.0 }; + double midpoint_values[] = { 0.5, 1.5 }; + SetGridEdges(foo_grid, edge_values, 3, &error); + SetGridMidpoints(foo_grid, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& edge : edge_values) + { + edge = -100.0; + } + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetGridEdges(foo_grid, edge_values, 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 0.0); + ASSERT_EQ(edge_values[1], 1.0); + ASSERT_EQ(edge_values[2], 2.0); + GetGridMidpoints(foo_grid, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 0.5); + ASSERT_EQ(midpoint_values[1], 1.5); + Grid* foo_copy = GetGrid(grid_map, "foo", "m", &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_copy, nullptr); + for (auto& edge : edge_values) + { + edge = -100.0; + } + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetGridEdges(foo_copy, edge_values, 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 0.0); + ASSERT_EQ(edge_values[1], 1.0); + ASSERT_EQ(edge_values[2], 2.0); + GetGridMidpoints(foo_copy, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 0.5); + ASSERT_EQ(midpoint_values[1], 1.5); + DeleteGrid(foo_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(bar_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(foo_copy, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGridMap(grid_map, &error); + ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); } + +TEST_F(TuvxCApiTest, CannotGetConfiguredProfile) +{ + const char* yaml_config_path = "examples/ts1_tsmlt.yml"; + SetUp(yaml_config_path); + Error error; + ProfileMap* profile_map = GetProfileMap(tuvx, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(profile_map, nullptr); + Profile* profile = GetProfile(profile_map, "air", "molecule cm-3", &error); + ASSERT_FALSE(IsSuccess(error)); // non-host profile + ASSERT_EQ(profile, nullptr); + DeleteProfileMap(profile_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CanCreateProfile) +{ + Error error; + Grid* grid = CreateGrid("foo", "m", 2, &error); + ASSERT_TRUE(IsSuccess(error)); + Profile* profile = CreateProfile("bar", "molecule cm-3", grid, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(profile, nullptr); + std::vector edge_values = { 0.0, 1.0, 2.0 }; + SetProfileEdgeValues(profile, edge_values.data(), edge_values.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& edge : edge_values) + { + edge = -100.0; + } + GetProfileEdgeValues(profile, edge_values.data(), edge_values.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 0.0); + ASSERT_EQ(edge_values[1], 1.0); + ASSERT_EQ(edge_values[2], 2.0); + std::vector midpoint_values = { 0.5, 1.5 }; + SetProfileMidpointValues(profile, midpoint_values.data(), midpoint_values.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetProfileMidpointValues(profile, midpoint_values.data(), midpoint_values.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 0.5); + ASSERT_EQ(midpoint_values[1], 1.5); + std::vector densities = { 1.0, 2.0 }; + SetProfileLayerDensities(profile, densities.data(), densities.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& density : densities) + { + density = -100.0; + } + GetProfileLayerDensities(profile, densities.data(), densities.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(densities[0], 1.0); + ASSERT_EQ(densities[1], 2.0); + SetProfileExoLayerDensity(profile, 3.0, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(GetProfileExoLayerDensity(profile, &error), 3.0); + GetProfileLayerDensities(profile, densities.data(), densities.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(densities[0], 1.0); + ASSERT_EQ(densities[1], 2.0 + 3.0); + CalculateProfileExoLayerDensity(profile, 1.0, &error); + ASSERT_TRUE(IsSuccess(error)); + // This should be updated once we do all conversions to/from non-SI units + // in the internal TUV-x functions + ASSERT_EQ(GetProfileExoLayerDensity(profile, &error), 200.0); + GetProfileLayerDensities(profile, densities.data(), densities.size(), &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(densities[0], 1.0); + // This should be updated once we do all conversions to/from non-SI units + // in the internal TUV-x functions + ASSERT_EQ(densities[1], 2.0 + 200.0); + DeleteProfile(profile, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(grid, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CanCreateProfileMap) +{ + Error error; + ProfileMap* profile_map = CreateProfileMap(&error); + ASSERT_TRUE(IsSuccess(error)); + Grid* foo_grid = CreateGrid("foo", "m", 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_grid, nullptr); + Profile* foo_profile = CreateProfile("foo", "molecule cm-3", foo_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_profile, nullptr); + AddProfile(profile_map, foo_profile, &error); + ASSERT_TRUE(IsSuccess(error)); + Grid* bar_grid = CreateGrid("bar", "m", 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(bar_grid, nullptr); + Profile* bar_profile = CreateProfile("bar", "molecule cm-3", bar_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(bar_profile, nullptr); + AddProfile(profile_map, bar_profile, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(profile_map, nullptr); + double edge_values[] = { 0.0, 1.0, 2.0 }; + double midpoint_values[] = { 0.5, 1.5 }; + SetProfileEdgeValues(foo_profile, edge_values, 3, &error); + SetProfileMidpointValues(foo_profile, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& edge : edge_values) + { + edge = -100.0; + } + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetProfileEdgeValues(foo_profile, edge_values, 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 0.0); + ASSERT_EQ(edge_values[1], 1.0); + ASSERT_EQ(edge_values[2], 2.0); + GetProfileMidpointValues(foo_profile, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 0.5); + ASSERT_EQ(midpoint_values[1], 1.5); + Profile* foo_copy = GetProfile(profile_map, "foo", "molecule cm-3", &error); + for (auto& edge : edge_values) + { + edge = -100.0; + } + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetProfileEdgeValues(foo_copy, edge_values, 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 0.0); + ASSERT_EQ(edge_values[1], 1.0); + ASSERT_EQ(edge_values[2], 2.0); + GetProfileMidpointValues(foo_copy, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 0.5); + ASSERT_EQ(midpoint_values[1], 1.5); + edge_values[0] = 5.0; + edge_values[1] = 10.0; + edge_values[2] = 20.0; + midpoint_values[0] = 7.5; + midpoint_values[1] = 15.0; + SetProfileEdgeValues(foo_copy, edge_values, 3, &error); + SetProfileMidpointValues(foo_copy, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + for (auto& edge : edge_values) + { + edge = -100.0; + } + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetProfileEdgeValues(foo_copy, edge_values, 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 5.0); + ASSERT_EQ(edge_values[1], 10.0); + ASSERT_EQ(edge_values[2], 20.0); + GetProfileMidpointValues(foo_copy, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 7.5); + ASSERT_EQ(midpoint_values[1], 15.0); + for (auto& edge : edge_values) + { + edge = -100.0; + } + for (auto& midpoint : midpoint_values) + { + midpoint = -100.0; + } + GetProfileEdgeValues(foo_profile, edge_values, 3, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(edge_values[0], 5.0); + ASSERT_EQ(edge_values[1], 10.0); + ASSERT_EQ(edge_values[2], 20.0); + GetProfileMidpointValues(foo_profile, midpoint_values, 2, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(midpoint_values[0], 7.5); + ASSERT_EQ(midpoint_values[1], 15.0); + DeleteProfile(foo_profile, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteProfile(bar_profile, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteProfile(foo_copy, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(foo_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(bar_grid, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteProfileMap(profile_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CannotGetConfiguredRadiator) +{ + const char* yaml_config_path = "examples/ts1_tsmlt.yml"; + SetUp(yaml_config_path); + Error error; + RadiatorMap* radiator_map = GetRadiatorMap(tuvx, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator_map, nullptr); + Radiator* radiator = GetRadiator(radiator_map, "foo", &error); + ASSERT_FALSE(IsSuccess(error)); // non-host grid + ASSERT_EQ(radiator, nullptr); + DeleteRadiatorMap(radiator_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); +} + +TEST_F(TuvxCApiTest, CanCreateRadiator) +{ + Error error; + Grid* height = CreateGrid("height", "km", 3, &error); + Grid* wavelength = CreateGrid("wavelength", "nm", 2, &error); + Radiator* radiator = CreateRadiator("foo", height, wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator, nullptr); + + // Test for optical depths + std::size_t num_vertical_layers = 3; + std::size_t num_wavelength_bins = 2; + // Allocate array as 1D + double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; + // Allocate an array of pointers to each row + double** optical_depths = new double*[num_vertical_layers]; + // Fill in the pointers to the rows + for (int row = 0; row < num_vertical_layers; row++) + { + optical_depths[row] = &optical_depths_1D[row * num_wavelength_bins]; + } + int i = 1; + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + optical_depths[row][col] = 10 * i; + i++; + } + } + SetRadiatorOpticalDepths(radiator, optical_depths[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + optical_depths[row][col] = -999.0; + } + } + GetRadiatorOpticalDepths(radiator, optical_depths[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(optical_depths[0][0], 10.0); + ASSERT_EQ(optical_depths[0][1], 20.0); + ASSERT_EQ(optical_depths[1][0], 30.0); + ASSERT_EQ(optical_depths[1][1], 40.0); + ASSERT_EQ(optical_depths[2][0], 50.0); + ASSERT_EQ(optical_depths[2][1], 60.0); + + // Test for single scattering albedos + double* albedos_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** albedos = new double*[num_vertical_layers]; + for (int row = 0; row < num_vertical_layers; row++) + { + albedos[row] = &albedos_1D[row * num_wavelength_bins]; + } + i = 1; + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + albedos[row][col] = 100 * i; + i++; + } + } + SetRadiatorSingleScatteringAlbedos(radiator, albedos[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + albedos[row][col] = -999.0; + } + } + GetRadiatorSingleScatteringAlbedos(radiator, albedos[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(albedos[0][0], 100.0); + ASSERT_EQ(albedos[0][1], 200.0); + ASSERT_EQ(albedos[1][0], 300.0); + ASSERT_EQ(albedos[1][1], 400.0); + ASSERT_EQ(albedos[2][0], 500.0); + ASSERT_EQ(albedos[2][1], 600.0); + + // Test for asymmetery factors + double* factors_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** factors = new double*[num_vertical_layers]; + for (int row = 0; row < num_vertical_layers; row++) + { + factors[row] = &factors_1D[row * num_wavelength_bins]; + } + i = 1; + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + factors[row][col] = 1 * i; + i++; + } + } + std::size_t num_streams = 1; + SetRadiatorAsymmetryFactors(radiator, factors[0], num_vertical_layers, num_wavelength_bins, num_streams, &error); + ASSERT_TRUE(IsSuccess(error)); + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + factors[row][col] = -999.0; + } + } + GetRadiatorAsymmetryFactors(radiator, factors[0], num_vertical_layers, num_wavelength_bins, num_streams, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(factors[0][0], 1); + ASSERT_EQ(factors[0][1], 2); + ASSERT_EQ(factors[1][0], 3); + ASSERT_EQ(factors[1][1], 4); + ASSERT_EQ(factors[2][0], 5); + ASSERT_EQ(factors[2][1], 6); + + // Clean up + DeleteRadiator(radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(height, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); + delete[] optical_depths; + delete[] optical_depths_1D; + delete[] albedos; + delete[] albedos_1D; + delete[] factors; + delete[] factors_1D; +} + +TEST_F(TuvxCApiTest, CanCreateRadiatorMap) +{ + Error error; + RadiatorMap* radiator_map = CreateRadiatorMap(&error); + ASSERT_TRUE(IsSuccess(error)); + Grid* height = CreateGrid("height", "km", 3, &error); + Grid* wavelength = CreateGrid("wavelength", "nm", 2, &error); + Radiator* foo_radiator = CreateRadiator("foo", height, wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_radiator, nullptr); + AddRadiator(radiator_map, foo_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator_map, nullptr); + Grid* bar_height = CreateGrid("bar_height", "km", 3, &error); + Grid* bar_wavelength = CreateGrid("bar_wavelength", "nm", 2, &error); + Radiator* bar_radiator = CreateRadiator("bar", bar_height, bar_wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(bar_radiator, nullptr); + AddRadiator(radiator_map, bar_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(radiator_map, nullptr); + + // Test for optical depths + std::size_t num_vertical_layers = 3; + std::size_t num_wavelength_bins = 2; + double* optical_depths_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** optical_depths = new double*[num_vertical_layers]; + for (int row = 0; row < num_vertical_layers; row++) + { + optical_depths[row] = &optical_depths_1D[row * num_wavelength_bins]; + } + int i = 1; + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + optical_depths[row][col] = 10 * i; + i++; + } + } + SetRadiatorOpticalDepths(foo_radiator, optical_depths[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + + // Test for single scattering albedos + double* albedos_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** albedos = new double*[num_vertical_layers]; + for (int row = 0; row < num_vertical_layers; row++) + { + albedos[row] = &albedos_1D[row * num_wavelength_bins]; + } + i = 1; + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + albedos[row][col] = 100 * i; + i++; + } + } + SetRadiatorSingleScatteringAlbedos(foo_radiator, albedos[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + + // Test for asymmetery factors + std::size_t num_streams = 1; + double* factors_1D = new double[num_wavelength_bins * num_vertical_layers]; + double** factors = new double*[num_vertical_layers]; + for (int row = 0; row < num_vertical_layers; row++) + { + factors[row] = &factors_1D[row * num_wavelength_bins]; + } + i = 1; + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + factors[row][col] = 1 * i; + i++; + } + } + SetRadiatorAsymmetryFactors(foo_radiator, factors[0], num_vertical_layers, num_wavelength_bins, num_streams, &error); + ASSERT_TRUE(IsSuccess(error)); + + // Test for optical depths + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + optical_depths[row][col] = -999.0; + } + } + GetRadiatorOpticalDepths(foo_radiator, optical_depths[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(optical_depths[0][0], 10.0); + ASSERT_EQ(optical_depths[0][1], 20.0); + ASSERT_EQ(optical_depths[1][0], 30.0); + ASSERT_EQ(optical_depths[1][1], 40.0); + ASSERT_EQ(optical_depths[2][0], 50.0); + ASSERT_EQ(optical_depths[2][1], 60.0); + + // Test for single scattering albedos + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + albedos[row][col] = -999.0; + } + } + GetRadiatorSingleScatteringAlbedos(foo_radiator, albedos[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(albedos[0][0], 100.0); + ASSERT_EQ(albedos[0][1], 200.0); + ASSERT_EQ(albedos[1][0], 300.0); + ASSERT_EQ(albedos[1][1], 400.0); + ASSERT_EQ(albedos[2][0], 500.0); + ASSERT_EQ(albedos[2][1], 600.0); + + // Test for asymmetry factors + for (int row = 0; row < num_vertical_layers; row++) + { + for (int col = 0; col < num_wavelength_bins; col++) + { + factors[row][col] = -999.0; + } + } + GetRadiatorAsymmetryFactors(foo_radiator, factors[0], num_vertical_layers, num_wavelength_bins, num_streams, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(factors[0][0], 1); + ASSERT_EQ(factors[0][1], 2); + ASSERT_EQ(factors[1][0], 3); + ASSERT_EQ(factors[1][1], 4); + ASSERT_EQ(factors[2][0], 5); + ASSERT_EQ(factors[2][1], 6); + + // Test copy for radiator map + Radiator* foo_copy = GetRadiator(radiator_map, "foo", &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_NE(foo_copy, nullptr); + GetRadiatorOpticalDepths(foo_copy, optical_depths[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(optical_depths[0][0], 10.0); + ASSERT_EQ(optical_depths[0][1], 20.0); + ASSERT_EQ(optical_depths[1][0], 30.0); + ASSERT_EQ(optical_depths[1][1], 40.0); + ASSERT_EQ(optical_depths[2][0], 50.0); + ASSERT_EQ(optical_depths[2][1], 60.0); + GetRadiatorSingleScatteringAlbedos(foo_copy, albedos[0], num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(albedos[0][0], 100.0); + ASSERT_EQ(albedos[0][1], 200.0); + ASSERT_EQ(albedos[1][0], 300.0); + ASSERT_EQ(albedos[1][1], 400.0); + ASSERT_EQ(albedos[2][0], 500.0); + ASSERT_EQ(albedos[2][1], 600.0); + GetRadiatorAsymmetryFactors(foo_copy, factors[0], num_vertical_layers, num_wavelength_bins, 1, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(factors[0][0], 1); + ASSERT_EQ(factors[0][1], 2); + ASSERT_EQ(factors[1][0], 3); + ASSERT_EQ(factors[1][1], 4); + ASSERT_EQ(factors[2][0], 5); + ASSERT_EQ(factors[2][1], 6); + + // Clean up + DeleteRadiator(foo_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteRadiator(bar_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteRadiator(foo_copy, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteRadiatorMap(radiator_map, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(height, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(bar_height, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteGrid(bar_wavelength, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); + delete[] optical_depths; + delete[] optical_depths_1D; + delete[] albedos; + delete[] albedos_1D; + delete[] factors; + delete[] factors_1D; +} \ No newline at end of file diff --git a/src/tuvx/CMakeLists.txt b/src/tuvx/CMakeLists.txt index 9df87adb..46fa14bc 100644 --- a/src/tuvx/CMakeLists.txt +++ b/src/tuvx/CMakeLists.txt @@ -1,6 +1,18 @@ target_sources(musica PRIVATE interface.F90 + interface_grid.F90 + interface_grid_map.F90 + interface_profile.F90 + interface_profile_map.F90 + interface_radiator.F90 + interface_radiator_map.F90 + grid.cpp + grid_map.cpp + profile.cpp + profile_map.cpp + radiator.cpp + radiator_map.cpp tuvx.cpp tuvx_util.F90 ) \ No newline at end of file diff --git a/src/tuvx/grid.cpp b/src/tuvx/grid.cpp new file mode 100644 index 00000000..4815f0e2 --- /dev/null +++ b/src/tuvx/grid.cpp @@ -0,0 +1,159 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include + +#include +#include +#include + +namespace musica +{ + + // Grid external C API functions + + Grid *CreateGrid(const char *grid_name, const char *units, std::size_t num_sections, Error *error) + { + DeleteError(error); + return new Grid(grid_name, units, num_sections, error); + } + + void DeleteGrid(Grid *grid, Error *error) + { + DeleteError(error); + try + { + delete grid; + } + catch (const std::system_error &e) + { + *error = ToError(e); + return; + } + *error = NoError(); + } + + void SetGridEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error) + { + DeleteError(error); + grid->SetEdges(edges, num_edges, error); + } + + void GetGridEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error) + { + DeleteError(error); + grid->GetEdges(edges, num_edges, error); + } + + void SetGridMidpoints(Grid *grid, double midpoints[], std::size_t num_midpoints, Error *error) + { + DeleteError(error); + grid->SetMidpoints(midpoints, num_midpoints, error); + } + + void GetGridMidpoints(Grid *grid, double midpoints[], std::size_t num_midpoints, Error *error) + { + DeleteError(error); + grid->GetMidpoints(midpoints, num_midpoints, error); + } + + // Grid class functions + + Grid::Grid(const char *grid_name, const char *units, std::size_t num_sections, Error *error) + { + int error_code = 0; + grid_ = InternalCreateGrid(grid_name, strlen(grid_name), units, strlen(units), num_sections, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create grid") }; + return; + } + updater_ = InternalGetGridUpdater(grid_, &error_code); + if (error_code != 0) + { + InternalDeleteGrid(grid_, &error_code); + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get updater") }; + return; + } + *error = NoError(); + } + + Grid::~Grid() + { + int error_code = 0; + if (grid_ != nullptr) + InternalDeleteGrid(grid_, &error_code); + if (updater_ != nullptr) + InternalDeleteGridUpdater(updater_, &error_code); + grid_ = nullptr; + updater_ = nullptr; + } + + void Grid::SetEdges(double edges[], std::size_t num_edges, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid is not updatable") }; + return; + } + InternalSetEdges(updater_, edges, num_edges, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set edges") }; + return; + } + *error = NoError(); + } + + void Grid::GetEdges(double edges[], std::size_t num_edges, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid is not accessible") }; + return; + } + InternalGetEdges(updater_, edges, num_edges, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get edges") }; + return; + } + *error = NoError(); + } + + void Grid::SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid is not updatable") }; + return; + } + InternalSetMidpoints(updater_, midpoints, num_midpoints, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set midpoints") }; + return; + } + *error = NoError(); + } + + void Grid::GetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid is not accessible") }; + return; + } + InternalGetMidpoints(updater_, midpoints, num_midpoints, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get midpoints") }; + return; + } + *error = NoError(); + } + +} // namespace musica diff --git a/src/tuvx/grid_map.cpp b/src/tuvx/grid_map.cpp new file mode 100644 index 00000000..bfe5c04b --- /dev/null +++ b/src/tuvx/grid_map.cpp @@ -0,0 +1,180 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include + +#include +#include +#include + +namespace musica +{ + + // GridMap external C API functions + + GridMap *CreateGridMap(Error *error) + { + DeleteError(error); + return new GridMap(error); + } + + void DeleteGridMap(GridMap *grid_map, Error *error) + { + DeleteError(error); + try + { + delete grid_map; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + *error = NoError(); + } + + void AddGrid(GridMap *grid_map, Grid *grid, Error *error) + { + DeleteError(error); + grid_map->AddGrid(grid, error); + } + + Grid *GetGrid(GridMap *grid_map, const char *grid_name, const char *grid_units, Error *error) + { + DeleteError(error); + return grid_map->GetGrid(grid_name, grid_units, error); + } + + // GridMap class functions + + GridMap::GridMap(Error *error) + { + int error_code = 0; + grid_map_ = InternalCreateGridMap(&error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create grid map") }; + } + owns_grid_map_ = true; + *error = NoError(); + } + + GridMap::~GridMap() + { + int error_code = 0; + if (grid_map_ != nullptr && owns_grid_map_) + { + InternalDeleteGridMap(grid_map_, &error_code); + } + grid_map_ = nullptr; + owns_grid_map_ = false; + } + + void GridMap::AddGrid(Grid *grid, Error *error) + { + if (grid_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid map is null") }; + return; + } + if (grid->grid_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add unowned grid to grid map") }; + return; + } + if (grid->updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add grid in invalid state") }; + return; + } + + int error_code = 0; + + try + { + InternalAddGrid(grid_map_, grid->grid_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to add grid to grid map") }; + } + InternalDeleteGridUpdater(grid->updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete updater after transfer of ownership to grid map") }; + } + grid->updater_ = InternalGetGridUpdaterFromMap(grid_map_, grid->grid_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to get updater after transfer of ownership to grid map") }; + } + InternalDeleteGrid(grid->grid_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete grid during transfer of ownership to grid map") }; + } + grid->grid_ = nullptr; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Internal error adding grid") }; + } + *error = NoError(); + } + + Grid *GridMap::GetGrid(const char *grid_name, const char *grid_units, Error *error) + { + if (grid_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid map is null") }; + return nullptr; + } + + Grid *grid = nullptr; + + try + { + int error_code = 0; + void *grid_ptr = InternalGetGrid(grid_map_, grid_name, strlen(grid_name), grid_units, strlen(grid_units), &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get grid from grid map") }; + return nullptr; + } + void *updater_ptr = InternalGetGridUpdaterFromMap(grid_map_, grid_ptr, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get updater") }; + InternalDeleteGrid(grid_ptr, &error_code); + return nullptr; + } + InternalDeleteGrid(grid_ptr, &error_code); + if (error_code != 0) + { + *error = + Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to delete grid after getting updater") }; + InternalDeleteGridUpdater(updater_ptr, &error_code); + return nullptr; + } + grid = new Grid(updater_ptr); + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Internal error getting grid") }; + } + *error = NoError(); + return grid; + } + +} // namespace musica diff --git a/src/tuvx/interface.F90 b/src/tuvx/interface.F90 index 952667e2..48ca85db 100644 --- a/src/tuvx/interface.F90 +++ b/src/tuvx/interface.F90 @@ -3,199 +3,145 @@ ! module tuvx_interface - use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char - use tuvx_core, only : core_t - use tuvx_grid_warehouse, only : grid_warehouse_t - use tuvx_grid, only : grid_t - use musica_tuvx_util, only : to_f_string, string_t_c - use musica_string, only : string_t - use tuvx_grid_warehouse, only : grid_warehouse_t +use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char +use tuvx_core, only : core_t +use tuvx_grid_warehouse, only : grid_warehouse_t +use tuvx_profile_warehouse, only : profile_warehouse_t +use tuvx_radiator_warehouse, only : radiator_warehouse_t +use musica_tuvx_util, only : to_f_string, string_t_c +use musica_string, only : string_t - implicit none +implicit none - private +private - contains +contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_tuvx(c_config_path, config_path_length, error_code) bind(C, name="InternalCreateTuvx") - use iso_c_binding, only: c_ptr, c_f_pointer + function internal_create_tuvx(c_config_path, config_path_length, error_code) & + bind(C, name="InternalCreateTuvx") + use iso_c_binding, only: c_ptr, c_f_pointer - ! arguments - character(kind=c_char), dimension(*), intent(in) :: c_config_path - integer(kind=c_size_t), value :: config_path_length - integer(kind=c_int), intent(out) :: error_code + ! arguments + character(kind=c_char), dimension(*), intent(in) :: c_config_path + integer(kind=c_size_t), value :: config_path_length + integer(kind=c_int), intent(out) :: error_code - ! local variables - character(len=:), allocatable :: f_config_path - type(c_ptr) :: internal_create_tuvx - type(core_t), pointer :: core - type(string_t) :: musica_config_path - integer :: i + ! local variables + character(len=:), allocatable :: f_config_path + type(c_ptr) :: internal_create_tuvx + type(core_t), pointer :: core + type(string_t) :: musica_config_path + integer :: i - allocate(character(len=config_path_length) :: f_config_path) - do i = 1, config_path_length - f_config_path(i:i) = c_config_path(i) - end do + allocate(character(len=config_path_length) :: f_config_path) + do i = 1, config_path_length + f_config_path(i:i) = c_config_path(i) + end do - musica_config_path = string_t(f_config_path) + musica_config_path = string_t(f_config_path) - core => core_t(musica_config_path) + core => core_t(musica_config_path) - deallocate(f_config_path) - error_code = 0 + deallocate(f_config_path) + error_code = 0 - internal_create_tuvx = c_loc(core) + internal_create_tuvx = c_loc(core) - end function internal_create_tuvx + end function internal_create_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_delete_tuvx(tuvx, error_code) bind(C, name="InternalDeleteTuvx") - use iso_c_binding, only: c_ptr, c_f_pointer + subroutine internal_delete_tuvx(tuvx, error_code) & + bind(C, name="InternalDeleteTuvx") + use iso_c_binding, only: c_ptr, c_f_pointer - ! arguments - type(c_ptr), value, intent(in) :: tuvx - integer(kind=c_int), intent(out) :: error_code + ! arguments + type(c_ptr), value, intent(in) :: tuvx + integer(kind=c_int), intent(out) :: error_code - ! local variables - type(core_t), pointer :: core - - call c_f_pointer(tuvx, core) - if (associated(core)) then - deallocate(core) - end if - end subroutine internal_delete_tuvx + ! local variables + type(core_t), pointer :: core + + call c_f_pointer(tuvx, core) + if (associated(core)) then + deallocate(core) + end if + end subroutine internal_delete_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) bind(C, name="InternalGetGridMap") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int - - ! arguments - type(c_ptr), intent(in), value :: tuvx - integer(kind=c_int), intent(out) :: error_code - - ! result - type(c_ptr) :: grid_map_ptr - - ! variables - type(core_t), pointer :: core - type(grid_warehouse_t), pointer :: grid_warehouse - - call c_f_pointer(tuvx, core) - grid_warehouse => core%get_grid_warehouse() - - grid_map_ptr = c_loc(grid_warehouse) - - end function internal_get_grid_map + function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) & + bind(C, name="InternalGetGridMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), value, intent(in) :: tuvx + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: grid_map_ptr + + ! variables + type(core_t), pointer :: core + type(grid_warehouse_t), pointer :: grid_warehouse + + call c_f_pointer(tuvx, core) + grid_warehouse => core%get_grid_warehouse() + + grid_map_ptr = c_loc(grid_warehouse) + + end function internal_get_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function interal_get_grid(grid_map, c_grid_name, c_grid_name_length, c_grid_units, c_grid_units_length, error_code) & - result(grid_ptr) bind(C, name="InternalGetGrid") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t - - ! arguments - type(c_ptr), intent(in), value :: grid_map - character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_name - integer(kind=c_size_t), value :: c_grid_name_length - character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_units - integer(kind=c_size_t), value :: c_grid_units_length - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_t), pointer :: grid - type(grid_warehouse_t), pointer :: grid_warehouse - character(len=:), allocatable :: f_grid_name - character(len=:), allocatable :: f_grid_units - integer :: i - - ! result - type(c_ptr) :: grid_ptr - - allocate(character(len=c_grid_name_length) :: f_grid_name) - do i = 1, c_grid_name_length - f_grid_name(i:i) = c_grid_name(i) - end do - - allocate(character(len=c_grid_units_length) :: f_grid_units) - do i = 1, c_grid_units_length - f_grid_units(i:i) = c_grid_units(i) - end do - - call c_f_pointer(grid_map, grid_warehouse) + function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) & + bind(C, name="InternalGetProfileMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int - grid => grid_warehouse%get_grid(f_grid_name, f_grid_units) - - grid_ptr = c_loc(grid) - - end function interal_get_grid + ! arguments + type(c_ptr), value, intent(in) :: tuvx + integer(kind=c_int), intent(out) :: error_code -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! result + type(c_ptr) :: profile_map_ptr - subroutine internal_delete_grid(grid, error_code) bind(C, name="InternalDeleteGrid") - use iso_c_binding, only: c_ptr, c_f_pointer - - ! arguments - type(c_ptr), value, intent(in) :: grid - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_t), pointer :: f_grid - - call c_f_pointer(grid, f_grid) - if (associated(f_grid)) then - deallocate(f_grid) - end if - - end subroutine internal_delete_grid + ! variables + type(core_t), pointer :: core + type(profile_warehouse_t), pointer :: profile_warehouse -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine internal_set_edges(grid, edges, num_edges, error_code) bind(C, name="InternalSetEdges") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t - - ! arguments - type(c_ptr), value, intent(in) :: grid - real(kind=c_double), intent(in), dimension(*) :: edges - integer(kind=c_size_t), intent(in), value :: num_edges - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_t), pointer :: f_grid + call c_f_pointer(tuvx, core) + profile_warehouse => core%get_profile_warehouse() - call c_f_pointer(grid, f_grid) + profile_map_ptr = c_loc(profile_warehouse) - f_grid%edge_ = edges(1:num_edges) + end function internal_get_profile_map - f_grid%delta_ = edges(2:num_edges) - edges(1:num_edges-1) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - f_grid%ncells_ = num_edges - 1 + function internal_get_radiator_map(tuvx, error_code) result(radiator_map_ptr) & + bind(C, name="InternalGetRadiatorMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int - end subroutine internal_set_edges + ! arguments + type(c_ptr), value, intent(in) :: tuvx + integer(kind=c_int), intent(out) :: error_code -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! result + type(c_ptr) :: radiator_map_ptr - subroutine internal_set_midpoints(grid, midpoints, num_midpoints, error_code) bind(C, name="InternalSetMidpoints") - use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double - - ! arguments - type(c_ptr), value, intent(in) :: grid - real(kind=c_double), intent(in), dimension(*) :: midpoints - integer(kind=c_int), intent(in), value :: num_midpoints - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(grid_t), pointer :: f_grid - - call c_f_pointer(grid, f_grid) + ! variables + type(core_t), pointer :: core + type(radiator_warehouse_t), pointer :: radiator_warehouse + + call c_f_pointer(tuvx, core) + radiator_warehouse => core%get_radiator_warehouse() - f_grid%mid_ = midpoints(1:num_midpoints) + radiator_map_ptr = c_loc(radiator_warehouse) - end subroutine internal_set_midpoints + end function internal_get_radiator_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module tuvx_interface +end module tuvx_interface \ No newline at end of file diff --git a/src/tuvx/interface_grid.F90 b/src/tuvx/interface_grid.F90 new file mode 100644 index 00000000..6e211695 --- /dev/null +++ b/src/tuvx/interface_grid.F90 @@ -0,0 +1,236 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_grid + + use tuvx_grid, only : grid_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_grid(grid_name, grid_name_length, units, & + units_length, num_sections, error_code) & + bind(C, name="InternalCreateGrid") result(grid) + use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int + use musica_tuvx_util, only: to_f_string + use musica_string, only: string_t + use tuvx_grid_from_host, only: grid_from_host_t + + ! arguments + type(c_ptr) :: grid + character(kind=c_char, len=1), dimension(*), intent(in) :: grid_name + integer(kind=c_size_t), intent(in), value :: grid_name_length + character(kind=c_char, len=1), dimension(*), intent(in) :: units + integer(kind=c_size_t), intent(in), value :: units_length + integer(kind=c_size_t), intent(in), value :: num_sections + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_from_host_t), pointer :: f_grid + type(string_t) :: f_name, f_units + integer :: i + + allocate(character(len=grid_name_length) :: f_name%val_) + do i = 1, grid_name_length + f_name%val_(i:i) = grid_name(i) + end do + + allocate(character(len=units_length) :: f_units%val_) + do i = 1, units_length + f_units%val_(i:i) = units(i) + end do + + f_grid => grid_from_host_t(f_name, f_units, int(num_sections)) + grid = c_loc(f_grid) + + end function internal_create_grid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_grid(grid, error_code) & + bind(C, name="InternalDeleteGrid") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), value, intent(in) :: grid + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_t), pointer :: f_grid + + call c_f_pointer(grid, f_grid) + if (associated(f_grid)) then + deallocate(f_grid) + end if + + end subroutine internal_delete_grid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_grid_updater(grid, error_code) & + bind(C, name="InternalGetGridUpdater") result(updater) + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int + use tuvx_grid_from_host, only: grid_from_host_t, grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(grid_from_host_t), pointer :: f_grid + type(grid_updater_t), pointer :: f_updater + + call c_f_pointer(grid, f_grid) + allocate(f_updater, source = grid_updater_t(f_grid)) + updater = c_loc(f_updater) + + end function internal_get_grid_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_grid_updater(updater, error_code) & + bind(C, name="InternalDeleteGridUpdater") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: updater + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + + call c_f_pointer(updater, f_updater) + if (associated(f_updater)) then + deallocate(f_updater) + end if + + end subroutine internal_delete_grid_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_edges(grid_updater, edges, num_edges, error_code) & + bind(C, name="InternalSetEdges") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: edges + integer(kind=c_size_t), intent(in), value :: num_edges + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_edges(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(edges, f_edges, [num_edges]) + + if (size(f_updater%grid_%edge_) /= num_edges) then + error_code = 1 + return + end if + f_updater%grid_%edge_(:) = f_edges(:) + + end subroutine internal_set_edges + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_edges(grid_updater, edges, num_edges, error_code) & + bind(C, name="InternalGetEdges") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: edges + integer(kind=c_size_t), intent(in), value :: num_edges + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_edges(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(edges, f_edges, [num_edges]) + + if (size(f_updater%grid_%edge_) /= num_edges) then + error_code = 1 + return + end if + f_edges(:) = f_updater%grid_%edge_(:) + + end subroutine internal_get_edges + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_midpoints(grid_updater, midpoints, num_midpoints, & + error_code) bind(C, name="InternalSetMidpoints") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: midpoints + integer(kind=c_int), intent(in), value :: num_midpoints + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_midpoints(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(midpoints, f_midpoints, [num_midpoints]) + + if (size(f_updater%grid_%mid_) /= num_midpoints) then + error_code = 1 + return + end if + f_updater%grid_%mid_(:) = f_midpoints(:) + + end subroutine internal_set_midpoints + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_midpoints(grid_updater, midpoints, num_midpoints, & + error_code) bind(C, name="InternalGetMidpoints") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: grid_updater + type(c_ptr), value, intent(in) :: midpoints + integer(kind=c_int), intent(in), value :: num_midpoints + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_midpoints(:) + + call c_f_pointer(grid_updater, f_updater) + call c_f_pointer(midpoints, f_midpoints, [num_midpoints]) + + if (size(f_updater%grid_%mid_) /= num_midpoints) then + error_code = 1 + return + end if + f_midpoints(:) = f_updater%grid_%mid_(:) + + end subroutine internal_get_midpoints + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_grid \ No newline at end of file diff --git a/src/tuvx/interface_grid_map.F90 b/src/tuvx/interface_grid_map.F90 new file mode 100644 index 00000000..c0eaf250 --- /dev/null +++ b/src/tuvx/interface_grid_map.F90 @@ -0,0 +1,177 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_grid_map + + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use tuvx_grid_warehouse, only : grid_warehouse_t + use tuvx_grid, only : grid_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_grid_map(error_code) result(grid_map) & + bind(C, name="InternalCreateGridMap") + use iso_c_binding, only: c_ptr, c_int, c_null_ptr + use tuvx_grid_warehouse, only: grid_warehouse_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: grid_map + + ! variables + class(grid_warehouse_t), pointer :: f_grid_warehouse + + f_grid_warehouse => grid_warehouse_t() + select type(f_grid_warehouse) + type is(grid_warehouse_t) + grid_map = c_loc(f_grid_warehouse) + error_code = 0 + class default + error_code = 1 + grid_map = c_null_ptr + end select + + end function internal_create_grid_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_grid_map(grid_map, error_code) & + bind(C, name="InternalDeleteGridMap") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_grid_warehouse, only: grid_warehouse_t + + ! arguments + type(c_ptr), intent(in), value :: grid_map + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_warehouse_t), pointer :: f_grid_warehouse + + call c_f_pointer(grid_map, f_grid_warehouse) + deallocate(f_grid_warehouse) + error_code = 0 + + end subroutine internal_delete_grid_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_add_grid(grid_map, grid, error_code) & + bind(C, name="InternalAddGrid") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_grid_warehouse, only: grid_warehouse_t + use tuvx_grid_from_host, only: grid_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: grid_map + type(c_ptr), intent(in), value :: grid + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_warehouse_t), pointer :: f_grid_warehouse + type(grid_from_host_t), pointer :: f_grid + + call c_f_pointer(grid_map, f_grid_warehouse) + call c_f_pointer(grid, f_grid) + + error_code = 0 + call f_grid_warehouse%add(f_grid) + + end subroutine internal_add_grid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function interal_get_grid(grid_map, c_grid_name, c_grid_name_length, & + c_grid_units, c_grid_units_length, error_code) & + result(grid_ptr) bind(C, name="InternalGetGrid") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & + c_null_ptr, c_loc + use tuvx_grid_from_host, only: grid_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: grid_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_name + integer(kind=c_size_t), value :: c_grid_name_length + character(len=1, kind=c_char), dimension(*), intent(in) :: c_grid_units + integer(kind=c_size_t), value :: c_grid_units_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + class(grid_t), pointer :: f_grid + type(grid_warehouse_t), pointer :: grid_warehouse + character(len=:), allocatable :: f_grid_name + character(len=:), allocatable :: f_grid_units + integer :: i + + ! result + type(c_ptr) :: grid_ptr + + allocate(character(len=c_grid_name_length) :: f_grid_name) + do i = 1, c_grid_name_length + f_grid_name(i:i) = c_grid_name(i) + end do + + allocate(character(len=c_grid_units_length) :: f_grid_units) + do i = 1, c_grid_units_length + f_grid_units(i:i) = c_grid_units(i) + end do + + call c_f_pointer(grid_map, grid_warehouse) + + f_grid => grid_warehouse%get_grid(f_grid_name, f_grid_units) + + select type(f_grid) + type is(grid_from_host_t) + error_code = 0 + grid_ptr = c_loc(f_grid) + class default + error_code = 1 + deallocate(f_grid) + grid_ptr = c_null_ptr + end select + + end function interal_get_grid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_grid_updater_from_map(grid_map, grid, error_code) & + result(updater) bind(C, name="InternalGetGridUpdaterFromMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc + use tuvx_grid_warehouse, only: grid_warehouse_t + use tuvx_grid_from_host, only: grid_from_host_t, grid_updater_t + + ! arguments + type(c_ptr), intent(in), value :: grid_map + type(c_ptr), intent(in), value :: grid + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(grid_warehouse_t), pointer :: f_grid_warehouse + type(grid_from_host_t), pointer :: f_grid + type(grid_updater_t), pointer :: f_updater + + call c_f_pointer(grid_map, f_grid_warehouse) + call c_f_pointer(grid, f_grid) + + error_code = 0 + allocate(f_updater) + f_updater = f_grid_warehouse%get_updater(f_grid) + updater = c_loc(f_updater) + + end function internal_get_grid_updater_from_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_grid_map diff --git a/src/tuvx/interface_profile.F90 b/src/tuvx/interface_profile.F90 new file mode 100644 index 00000000..b0d1d713 --- /dev/null +++ b/src/tuvx/interface_profile.F90 @@ -0,0 +1,384 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_profile + + use tuvx_profile, only : profile_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_profile(profile_name, profile_name_length, units, & + units_length, grid_updater_c, error_code) & + bind(C, name="InternalCreateProfile") result(profile) + use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int + use musica_tuvx_util, only: to_f_string + use musica_string, only: string_t + use tuvx_grid_from_host, only: grid_updater_t + use tuvx_profile_from_host, only: profile_from_host_t + + ! arguments + type(c_ptr) :: profile + character(kind=c_char, len=1), dimension(*), intent(in) :: profile_name + integer(kind=c_size_t), intent(in), value :: profile_name_length + character(kind=c_char, len=1), dimension(*), intent(in) :: units + integer(kind=c_size_t), intent(in), value :: units_length + type(c_ptr), intent(in), value :: grid_updater_c + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(grid_updater_t), pointer :: f_grid_updater + type(profile_from_host_t), pointer :: f_profile + type(string_t) :: f_name, f_units + integer :: i + + allocate(character(len=profile_name_length) :: f_name%val_) + do i = 1, profile_name_length + f_name%val_(i:i) = profile_name(i) + end do + + allocate(character(len=units_length) :: f_units%val_) + do i = 1, units_length + f_units%val_(i:i) = units(i) + end do + + call c_f_pointer(grid_updater_c, f_grid_updater) + f_profile => profile_from_host_t(f_name, f_units, & + f_grid_updater%grid_%size()) + profile = c_loc(f_profile) + + end function internal_create_profile + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_profile_updater(profile, error_code) & + bind(C, name="InternalGetProfileUpdater") result(updater) + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int + use tuvx_profile_from_host, only: profile_from_host_t, profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(profile_from_host_t), pointer :: f_profile + type(profile_updater_t), pointer :: f_updater + + call c_f_pointer(profile, f_profile) + allocate(f_updater, source = profile_updater_t(f_profile)) + updater = c_loc(f_updater) + + end function internal_get_profile_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_profile(profile, error_code) & + bind(C, name="InternalDeleteProfile") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), value, intent(in) :: profile + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_t), pointer :: f_profile + + call c_f_pointer(profile, f_profile) + if (associated(f_profile)) then + deallocate(f_profile) + end if + + end subroutine internal_delete_profile + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_profile_updater(updater, error_code) & + bind(C, name="InternalDeleteProfileUpdater") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: updater + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + + call c_f_pointer(updater, f_updater) + if (associated(f_updater)) then + deallocate(f_updater) + end if + + end subroutine internal_delete_profile_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_edge_values(profile_updater, edge_values, & + num_edge_values, error_code) bind(C, name="InternalSetEdgeValues") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + type(c_ptr), value, intent(in) :: edge_values + integer(kind=c_size_t), intent(in), value :: num_edge_values + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_edge_values(:) + + call c_f_pointer(profile_updater, f_updater) + call c_f_pointer(edge_values, f_edge_values, [num_edge_values]) + + if (size(f_updater%profile_%edge_val_) /= num_edge_values) then + error_code = 1 + return + end if + f_updater%profile_%edge_val_(:) = f_edge_values(:) + + end subroutine internal_set_edge_values + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_edge_values(profile_updater, edge_values, & + num_edge_values, error_code) bind(C, name="InternalGetEdgeValues") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + type(c_ptr), value, intent(in) :: edge_values + integer(kind=c_size_t), intent(in), value :: num_edge_values + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_edge_values(:) + + call c_f_pointer(profile_updater, f_updater) + call c_f_pointer(edge_values, f_edge_values, [num_edge_values]) + + if (size(f_updater%profile_%edge_val_) /= num_edge_values) then + error_code = 1 + return + end if + f_edge_values(:) = f_updater%profile_%edge_val_(:) + + end subroutine internal_get_edge_values + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_midpoint_values(profile_updater, midpoint_values, & + num_midpoint_values, error_code) bind(C, name="InternalSetMidpointValues") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + type(c_ptr), value, intent(in) :: midpoint_values + integer(kind=c_size_t), intent(in), value :: num_midpoint_values + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_midpoint_values(:) + + call c_f_pointer(profile_updater, f_updater) + call c_f_pointer(midpoint_values, f_midpoint_values, [num_midpoint_values]) + + if (size(f_updater%profile_%mid_val_) /= num_midpoint_values) then + error_code = 1 + return + end if + f_updater%profile_%mid_val_(:) = f_midpoint_values(:) + + end subroutine internal_set_midpoint_values + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_midpoint_values(profile_updater, midpoint_values, & + num_midpoint_values, error_code) bind(C, name="InternalGetMidpointValues") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + type(c_ptr), value, intent(in) :: midpoint_values + integer(kind=c_size_t), intent(in), value :: num_midpoint_values + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_midpoint_values(:) + + call c_f_pointer(profile_updater, f_updater) + call c_f_pointer(midpoint_values, f_midpoint_values, [num_midpoint_values]) + + if (size(f_updater%profile_%mid_val_) /= num_midpoint_values) then + error_code = 1 + return + end if + f_midpoint_values(:) = f_updater%profile_%mid_val_(:) + + end subroutine internal_get_midpoint_values + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_layer_densities(profile_updater, layer_densities, & + num_layer_densities, error_code) bind(C, name="InternalSetLayerDensities") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + type(c_ptr), value, intent(in) :: layer_densities + integer(kind=c_size_t), intent(in), value :: num_layer_densities + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_layer_densities(:) + + call c_f_pointer(profile_updater, f_updater) + call c_f_pointer(layer_densities, f_layer_densities, [num_layer_densities]) + + if (size(f_updater%profile_%layer_dens_) /= num_layer_densities) then + error_code = 1 + return + end if + + f_updater%profile_%layer_dens_(:) = f_layer_densities(:) + f_updater%profile_%exo_layer_dens_(1:num_layer_densities) = & + f_layer_densities(:) + f_updater%profile_%layer_dens_(num_layer_densities) = & + f_updater%profile_%layer_dens_(num_layer_densities) + & + f_updater%profile_%exo_layer_dens_(num_layer_densities+1) + + end subroutine internal_set_layer_densities + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_layer_densities(profile_updater, layer_densities, & + num_layer_densities, error_code) bind(C, name="InternalGetLayerDensities") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + type(c_ptr), value, intent(in) :: layer_densities + integer(kind=c_size_t), intent(in), value :: num_layer_densities + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_layer_densities(:) + + call c_f_pointer(profile_updater, f_updater) + call c_f_pointer(layer_densities, f_layer_densities, [num_layer_densities]) + + if (size(f_updater%profile_%layer_dens_) /= num_layer_densities) then + error_code = 1 + return + end if + f_layer_densities(:) = f_updater%profile_%layer_dens_(:) + + end subroutine internal_get_layer_densities + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_exo_layer_density(profile_updater, & + exo_layer_density, error_code) bind(C, name="InternalSetExoLayerDensity") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + real(kind=c_double), value, intent(in) :: exo_layer_density + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + + call c_f_pointer(profile_updater, f_updater) + + associate(ld => f_updater%profile_%layer_dens_, & + eld => f_updater%profile_%exo_layer_dens_) + eld(size(eld)) = real(exo_layer_density, kind=dk) + ld(size(ld)) = eld(size(ld)) + real(exo_layer_density, kind=dk) + end associate + + end subroutine internal_set_exo_layer_density + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_calculate_exo_layer_density(profile_updater, & + scale_height, error_code) bind(C, name="InternalCalculateExoLayerDensity") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + real(kind=c_double), value, intent(in) :: scale_height ! [m] + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_updater_t), pointer :: f_updater + real(kind=dk) :: exo_layer_density + + call c_f_pointer(profile_updater, f_updater) + + associate(ld => f_updater%profile_%layer_dens_, & + eld => f_updater%profile_%exo_layer_dens_) + exo_layer_density = & + eld(size(ld)) * real(scale_height, kind=dk) * 100.0_dk ! m to cm + eld(size(eld)) = exo_layer_density + ld(size(ld)) = eld(size(ld)) + exo_layer_density + end associate + + end subroutine internal_calculate_exo_layer_density + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_exo_layer_density(profile_updater, error_code) & + bind(C, name="InternalGetExoLayerDensity") result(exo_layer_density) + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_double + use musica_constants, only: dk => musica_dk + use tuvx_profile_from_host, only: profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_updater + integer(kind=c_int), intent(out) :: error_code + + ! output + real(kind=c_double) :: exo_layer_density + + ! variables + type(profile_updater_t), pointer :: f_updater + + call c_f_pointer(profile_updater, f_updater) + associate(eld => f_updater%profile_%exo_layer_dens_) + exo_layer_density = real(eld(size(eld)), kind=c_double) + end associate + + end function internal_get_exo_layer_density + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_profile diff --git a/src/tuvx/interface_profile_map.F90 b/src/tuvx/interface_profile_map.F90 new file mode 100644 index 00000000..47e9cba7 --- /dev/null +++ b/src/tuvx/interface_profile_map.F90 @@ -0,0 +1,178 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_profile_map + + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use tuvx_profile, only : profile_t + use tuvx_profile_warehouse, only : profile_warehouse_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_profile_map(error_code) result(profile_map) & + bind(C, name="InternalCreateProfileMap") + use iso_c_binding, only: c_ptr, c_int, c_null_ptr + use tuvx_profile_warehouse, only: profile_warehouse_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: profile_map + + ! variables + class(profile_warehouse_t), pointer :: f_profile_warehouse + + f_profile_warehouse => profile_warehouse_t() + select type(f_profile_warehouse) + type is(profile_warehouse_t) + profile_map = c_loc(f_profile_warehouse) + error_code = 0 + class default + error_code = 1 + profile_map = c_null_ptr + end select + + end function internal_create_profile_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_profile_map(profile_map, error_code) & + bind(C, name="InternalDeleteProfileMap") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_profile_warehouse, only: profile_warehouse_t + + ! arguments + type(c_ptr), intent(in), value :: profile_map + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_warehouse_t), pointer :: f_profile_warehouse + + call c_f_pointer(profile_map, f_profile_warehouse) + deallocate(f_profile_warehouse) + error_code = 0 + + end subroutine internal_delete_profile_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_add_profile(profile_map, profile, error_code) & + bind(C, name="InternalAddProfile") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_profile_warehouse, only: profile_warehouse_t + use tuvx_profile_from_host, only: profile_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: profile_map + type(c_ptr), intent(in), value :: profile + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(profile_warehouse_t), pointer :: f_profile_warehouse + type(profile_from_host_t), pointer :: f_profile + + call c_f_pointer(profile_map, f_profile_warehouse) + call c_f_pointer(profile, f_profile) + + error_code = 0 + call f_profile_warehouse%add(f_profile) + + end subroutine internal_add_profile + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_profile(profile_map, c_profile_name, & + c_profile_name_length, c_profile_units, c_profile_units_length, & + error_code) result(profile_ptr) bind(C, name="InternalGetProfile") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & + c_null_ptr, c_loc + use tuvx_profile_from_host, only: profile_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: profile_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_profile_name + integer(kind=c_size_t), value :: c_profile_name_length + character(len=1, kind=c_char), dimension(*), intent(in) :: c_profile_units + integer(kind=c_size_t), value :: c_profile_units_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + class(profile_t), pointer :: f_profile + type(profile_warehouse_t), pointer :: profile_warehouse + character(len=:), allocatable :: f_profile_name + character(len=:), allocatable :: f_profile_units + integer :: i + + ! result + type(c_ptr) :: profile_ptr + + allocate(character(len=c_profile_name_length) :: f_profile_name) + do i = 1, c_profile_name_length + f_profile_name(i:i) = c_profile_name(i) + end do + + allocate(character(len=c_profile_units_length) :: f_profile_units) + do i = 1, c_profile_units_length + f_profile_units(i:i) = c_profile_units(i) + end do + + call c_f_pointer(profile_map, profile_warehouse) + + f_profile => profile_warehouse%get_profile(f_profile_name, f_profile_units) + + select type(f_profile) + type is(profile_from_host_t) + profile_ptr = c_loc(f_profile) + error_code = 0 + class default + error_code = 1 + deallocate(f_profile) + profile_ptr = c_null_ptr + end select + + end function internal_get_profile + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_profile_updater_from_map(profile_map, profile, & + error_code) result(updater) & + bind(C, name="InternalGetProfileUpdaterFromMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_profile_warehouse, only: profile_warehouse_t + use tuvx_profile_from_host, only: profile_from_host_t, profile_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: profile_map + type(c_ptr), value, intent(in) :: profile + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(profile_warehouse_t), pointer :: f_profile_warehouse + type(profile_from_host_t), pointer :: f_profile + type(profile_updater_t), pointer :: f_updater + + call c_f_pointer(profile_map, f_profile_warehouse) + call c_f_pointer(profile, f_profile) + + error_code = 0 + allocate(f_updater) + f_updater = f_profile_warehouse%get_updater(f_profile) + updater = c_loc(f_updater) + + end function internal_get_profile_updater_from_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_profile_map diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 new file mode 100644 index 00000000..6bfd06a6 --- /dev/null +++ b/src/tuvx/interface_radiator.F90 @@ -0,0 +1,324 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_radiator + use tuvx_radiator, only : radiator_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_radiator(radiator_name, radiator_name_length, & + height_grid_updater_c, wavelength_grid_updater_c, error_code) & + result(radiator) bind(C, name="InternalCreateRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_char, c_loc, c_size_t, c_int + use musica_string, only: string_t + use tuvx_radiator_from_host, only: radiator_from_host_t + use tuvx_grid_from_host, only: grid_updater_t + + ! arguments + type(c_ptr) :: radiator + character(kind=c_char, len=1), dimension(*), intent(in) :: radiator_name + integer(kind=c_size_t), value, intent(in) :: radiator_name_length + type(c_ptr), value, intent(in) :: height_grid_updater_c + type(c_ptr), value, intent(in) :: wavelength_grid_updater_c + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_from_host_t), pointer :: f_radiator + type(string_t) :: f_name + type(grid_updater_t), pointer :: f_height_grid_updater + type(grid_updater_t), pointer :: f_wavelength_grid_updater + integer :: i + + allocate(character(len=radiator_name_length) :: f_name%val_) + do i = 1, radiator_name_length + f_name%val_(i:i) = radiator_name(i) + end do + + call c_f_pointer(height_grid_updater_c, f_height_grid_updater) + call c_f_pointer(wavelength_grid_updater_c, f_wavelength_grid_updater) + f_radiator => radiator_from_host_t(f_name, f_height_grid_updater%grid_, & + f_wavelength_grid_updater%grid_) + radiator = c_loc(f_radiator) + + end function internal_create_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator(radiator, error_code) & + bind(C, name="InternalDeleteRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + + ! arguments + type(c_ptr), value, intent(in) :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_t), pointer :: f_radiator + + call c_f_pointer(radiator, f_radiator) + if (associated(f_radiator)) then + deallocate(f_radiator) + end if + + end subroutine internal_delete_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator_updater(radiator, error_code) & + bind(C, name="InternalGetRadiatorUpdater") result(updater) + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc, c_int + use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(radiator_from_host_t), pointer :: f_radiator + type(radiator_updater_t), pointer :: f_updater + + call c_f_pointer(radiator, f_radiator) + allocate(f_updater, source = radiator_updater_t(f_radiator)) + updater = c_loc(f_updater) + + end function internal_get_radiator_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator_updater(updater, error_code) & + bind(C, name="InternalDeleteRadiatorUpdater") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: updater + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + + call c_f_pointer(updater, f_updater) + if (associated(f_updater)) then + deallocate(f_updater) + end if + + end subroutine internal_delete_radiator_updater + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_optical_depths(radiator_updater, optical_depths, & + num_vertical_layers, num_wavelength_bins, error_code) & + bind(C, name="InternalSetOpticalDepths") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: optical_depths + integer(kind=c_size_t), value, intent(in) :: num_vertical_layers + integer(kind=c_size_t), value, intent(in) :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_optical_depths(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(optical_depths, f_optical_depths, & + [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) & + then + error_code = 1 + return + end if + f_updater%radiator_%state_%layer_OD_(:,:) = f_optical_depths(:,:) + + end subroutine internal_set_optical_depths + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_optical_depths(radiator_updater, optical_depths, & + num_vertical_layers, num_wavelength_bins, error_code) & + bind(C, name="InternalGetOpticalDepths") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: optical_depths + integer(kind=c_size_t), value, intent(in) :: num_vertical_layers + integer(kind=c_size_t), value, intent(in) :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_optical_depths(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(optical_depths, f_optical_depths, & + [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) & + then + error_code = 1 + return + end if + f_optical_depths(:,:) = f_updater%radiator_%state_%layer_OD_(:,:) + + end subroutine internal_get_optical_depths + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_single_scattering_albedos(radiator_updater, & + single_scattering_albedos, num_vertical_layers, num_wavelength_bins, & + error_code) bind(C, name="InternalSetSingleScatteringAlbedos") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(kind=c_size_t), value, intent(in) :: num_vertical_layers + integer(kind=c_size_t), value, intent(in) :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & + [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) & + then + error_code = 1 + return + end if + f_updater%radiator_%state_%layer_SSA_(:,:) = f_single_scattering_albedos(:,:) + + end subroutine internal_set_single_scattering_albedos + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_single_scattering_albedos(radiator_updater, & + single_scattering_albedos, num_vertical_layers, num_wavelength_bins, & + error_code) bind(C, name="InternalGetSingleScatteringAlbedos") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: single_scattering_albedos + integer(kind=c_size_t), value, intent(in) :: num_vertical_layers + integer(kind=c_size_t), value, intent(in) :: num_wavelength_bins + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(single_scattering_albedos, f_single_scattering_albedos, & + [num_vertical_layers, num_wavelength_bins]) + + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins)) & + then + error_code = 1 + return + end if + f_single_scattering_albedos(:,:) = f_updater%radiator_%state_%layer_SSA_(:,:) + + end subroutine internal_get_single_scattering_albedos + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_set_asymmetry_factors(radiator_updater, & + asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, & + error_code) bind(C, name="InternalSetAsymmetryFactors") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: asymmetry_factors + integer(kind=c_size_t), value, intent(in) :: num_vertical_layers + integer(kind=c_size_t), value, intent(in) :: num_wavelength_bins + integer(kind=c_size_t), value, intent(in) :: num_streams + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & + [num_vertical_layers, num_wavelength_bins, num_streams]) + + if ((size(f_updater%radiator_%state_%layer_G_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_G_, 2) /= num_wavelength_bins) & + .or. (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then + error_code = 1 + return + end if + f_updater%radiator_%state_%layer_G_(:,:,:) = f_asymmetry_factors(:,:,:) + + end subroutine internal_set_asymmetry_factors + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_get_asymmetry_factors(radiator_updater, & + asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, & + error_code) bind(C, name="InternalGetAsymmetryFactors") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_size_t + use musica_constants, only: dk => musica_dk + use tuvx_radiator_from_host, only: radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_updater + type(c_ptr), value, intent(in) :: asymmetry_factors + integer(kind=c_size_t), value, intent(in) :: num_vertical_layers + integer(kind=c_size_t), value, intent(in) :: num_wavelength_bins + integer(kind=c_size_t), value, intent(in) :: num_streams + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & + [num_vertical_layers, num_wavelength_bins, num_streams]) + + if ((size(f_updater%radiator_%state_%layer_G_, 1) /= num_vertical_layers) & + .or. (size(f_updater%radiator_%state_%layer_G_, 2) /= num_wavelength_bins) & + .or. (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then + error_code = 1 + return + end if + f_asymmetry_factors(:,:,:) = f_updater%radiator_%state_%layer_G_(:,:,:) + +end subroutine internal_get_asymmetry_factors + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_radiator \ No newline at end of file diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 new file mode 100644 index 00000000..2ddea28e --- /dev/null +++ b/src/tuvx/interface_radiator_map.F90 @@ -0,0 +1,177 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +module tuvx_interface_radiator_map + + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use tuvx_radiator, only : radiator_t + use tuvx_radiator_warehouse, only : radiator_warehouse_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t + + implicit none + + private + + contains + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_create_radiator_map(error_code) result(radiator_map) & + bind(C, name="InternalCreateRadiatorMap") + use iso_c_binding, only: c_ptr, c_int, c_null_ptr + use tuvx_radiator_warehouse, only: radiator_warehouse_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: radiator_map + + ! variables + class(radiator_warehouse_t), pointer :: f_radiator_warehouse + + f_radiator_warehouse => radiator_warehouse_t() + select type(f_radiator_warehouse) + type is(radiator_warehouse_t) + radiator_map = c_loc(f_radiator_warehouse) + error_code = 0 + class default + error_code = 1 + radiator_map = c_null_ptr + end select + + end function internal_create_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_delete_radiator_map(radiator_map, error_code) & + bind(C, name="InternalDeleteRadiatorMap") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_radiator_warehouse, only: radiator_warehouse_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_map + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + + call c_f_pointer(radiator_map, f_radiator_warehouse) + deallocate(f_radiator_warehouse) + error_code = 0 + +end subroutine internal_delete_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine internal_add_radiator(radiator_map, radiator, error_code) & + bind(C, name="InternalAddRadiator") + use iso_c_binding, only: c_ptr, c_int, c_f_pointer + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiator_from_host, only: radiator_from_host_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_map + type(c_ptr), value, intent(in) :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiator_from_host_t), pointer :: f_radiator + + call c_f_pointer(radiator_map, f_radiator_warehouse) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + call f_radiator_warehouse%add(f_radiator) + + end subroutine internal_add_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator(radiator_map, c_radiator_name, & + c_radiator_name_length, error_code) & + result(radiator_ptr) bind(C, name="InternalGetRadiator") + use iso_c_binding, only: c_ptr, c_f_pointer, c_int, c_char, c_size_t, & + c_null_ptr, c_loc + use tuvx_radiator_from_host, only: radiator_from_host_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name + integer(kind=c_size_t), value, intent(in) :: c_radiator_name_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + class(radiator_t), pointer :: f_radiator + class(radiator_t), pointer :: f_radiator_ptr + type(radiator_warehouse_t), pointer :: radiator_warehouse + character(len=:), allocatable :: f_radiator_name + integer :: i + + ! result + type(c_ptr) :: radiator_ptr + + allocate(character(len=c_radiator_name_length) :: f_radiator_name) + do i = 1, c_radiator_name_length + f_radiator_name(i:i) = c_radiator_name(i) + end do + + call c_f_pointer(radiator_map, radiator_warehouse) + + if (.not. radiator_warehouse%exists(f_radiator_name)) then + error_code = 1 + radiator_ptr = c_null_ptr + else + f_radiator_ptr => radiator_warehouse%get_radiator(f_radiator_name) + allocate(f_radiator, source = f_radiator_ptr) + nullify(f_radiator_ptr) + + select type(f_radiator) + type is(radiator_from_host_t) + error_code = 0 + radiator_ptr = c_loc(f_radiator) + class default + error_code = 1 + deallocate(f_radiator) + radiator_ptr = c_null_ptr + end select + end if + + end function internal_get_radiator + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function internal_get_radiator_updater_from_map(radiator_map, radiator, error_code) & + result(updater) bind(C, name="InternalGetRadiatorUpdaterFromMap") + use iso_c_binding, only: c_ptr, c_f_pointer, c_loc + use tuvx_radiator_warehouse, only: radiator_warehouse_t + use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t + + ! arguments + type(c_ptr), value, intent(in) :: radiator_map + type(c_ptr), value, intent(in) :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiator_from_host_t), pointer :: f_radiator + type(radiator_updater_t), pointer :: f_updater + + call c_f_pointer(radiator_map, f_radiator_warehouse) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + allocate(f_updater) + f_updater = f_radiator_warehouse%get_updater(f_radiator) + updater = c_loc(f_updater) + + end function internal_get_radiator_updater_from_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface_radiator_map \ No newline at end of file diff --git a/src/tuvx/profile.cpp b/src/tuvx/profile.cpp new file mode 100644 index 00000000..c9b26c23 --- /dev/null +++ b/src/tuvx/profile.cpp @@ -0,0 +1,276 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include +#include + +#include +#include +#include + +namespace musica +{ + + // Profile external C API functions + + Profile *CreateProfile(const char *profile_name, const char *units, Grid *grid, Error *error) + { + DeleteError(error); + return new Profile(profile_name, units, grid, error); + } + + void DeleteProfile(Profile *profile, Error *error) + { + DeleteError(error); + try + { + delete profile; + } + catch (const std::system_error &e) + { + *error = ToError(e); + return; + } + *error = NoError(); + } + + void SetProfileEdgeValues(Profile *profile, double edge_values[], std::size_t num_values, Error *error) + { + DeleteError(error); + profile->SetEdgeValues(edge_values, num_values, error); + } + + void GetProfileEdgeValues(Profile *profile, double edge_values[], std::size_t num_values, Error *error) + { + DeleteError(error); + profile->GetEdgeValues(edge_values, num_values, error); + } + + void SetProfileMidpointValues(Profile *profile, double midpoint_values[], std::size_t num_values, Error *error) + { + DeleteError(error); + profile->SetMidpointValues(midpoint_values, num_values, error); + } + + void GetProfileMidpointValues(Profile *profile, double midpoint_values[], std::size_t num_values, Error *error) + { + DeleteError(error); + profile->GetMidpointValues(midpoint_values, num_values, error); + } + + void SetProfileLayerDensities(Profile *profile, double layer_densities[], std::size_t num_values, Error *error) + { + DeleteError(error); + profile->SetLayerDensities(layer_densities, num_values, error); + } + + void GetProfileLayerDensities(Profile *profile, double layer_densities[], std::size_t num_values, Error *error) + { + DeleteError(error); + profile->GetLayerDensities(layer_densities, num_values, error); + } + + void SetProfileExoLayerDensity(Profile *profile, double exo_layer_density, Error *error) + { + DeleteError(error); + profile->SetExoLayerDensity(exo_layer_density, error); + } + + void CalculateProfileExoLayerDensity(Profile *profile, double scale_height, Error *error) + { + DeleteError(error); + profile->CalculateExoLayerDensity(scale_height, error); + } + + double GetProfileExoLayerDensity(Profile *profile, Error *error) + { + DeleteError(error); + return profile->GetExoLayerDensity(error); + } + + // Profile class functions + + Profile::Profile(const char *profile_name, const char *units, Grid *grid, Error *error) + { + int error_code = 0; + profile_ = InternalCreateProfile(profile_name, strlen(profile_name), units, strlen(units), grid->updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create profile") }; + return; + } + updater_ = InternalGetProfileUpdater(profile_, &error_code); + if (error_code != 0) + { + InternalDeleteProfile(profile_, &error_code); + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get updater") }; + return; + } + *error = NoError(); + } + + Profile::~Profile() + { + int error_code = 0; + if (profile_ != nullptr) + InternalDeleteProfile(profile_, &error_code); + if (updater_ != nullptr) + InternalDeleteProfileUpdater(updater_, &error_code); + profile_ = nullptr; + updater_ = nullptr; + } + + void Profile::SetEdgeValues(double edge_values[], std::size_t num_values, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not updatable") }; + return; + } + InternalSetEdgeValues(updater_, edge_values, num_values, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set edge values") }; + return; + } + *error = NoError(); + } + + void Profile::GetEdgeValues(double edge_values[], std::size_t num_values, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not accessible") }; + return; + } + InternalGetEdgeValues(updater_, edge_values, num_values, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get edge values") }; + return; + } + *error = NoError(); + } + + void Profile::SetMidpointValues(double midpoint_values[], std::size_t num_values, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not updatable") }; + return; + } + InternalSetMidpointValues(updater_, midpoint_values, num_values, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set midpoint values") }; + return; + } + *error = NoError(); + } + + void Profile::GetMidpointValues(double midpoint_values[], std::size_t num_values, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not accessible") }; + return; + } + InternalGetMidpointValues(updater_, midpoint_values, num_values, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get midpoint values") }; + return; + } + *error = NoError(); + } + + void Profile::SetLayerDensities(double layer_densities[], std::size_t num_values, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not updatable") }; + return; + } + InternalSetLayerDensities(updater_, layer_densities, num_values, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set layer densities") }; + return; + } + *error = NoError(); + } + + void Profile::GetLayerDensities(double layer_densities[], std::size_t num_values, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not accessible") }; + return; + } + InternalGetLayerDensities(updater_, layer_densities, num_values, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get layer densities") }; + return; + } + *error = NoError(); + } + + void Profile::SetExoLayerDensity(double exo_layer_density, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not updatable") }; + return; + } + InternalSetExoLayerDensity(updater_, exo_layer_density, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set exo layer density") }; + return; + } + *error = NoError(); + } + + void Profile::CalculateExoLayerDensity(double scale_height, Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not accessible") }; + return; + } + InternalCalculateExoLayerDensity(updater_, scale_height, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to calculate exo layer density") }; + return; + } + *error = NoError(); + } + + double Profile::GetExoLayerDensity(Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile is not accessible") }; + return 0.0; + } + double exo_layer_density = InternalGetExoLayerDensity(updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get exo layer density") }; + return 0.0; + } + *error = NoError(); + return exo_layer_density; + } + +} // namespace musica diff --git a/src/tuvx/profile_map.cpp b/src/tuvx/profile_map.cpp new file mode 100644 index 00000000..57241eca --- /dev/null +++ b/src/tuvx/profile_map.cpp @@ -0,0 +1,178 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include + +#include +#include +#include + +namespace musica +{ + + // ProfileMap external C API functions + + ProfileMap *CreateProfileMap(Error *error) + { + DeleteError(error); + return new ProfileMap(error); + } + + void DeleteProfileMap(ProfileMap *profile_map, Error *error) + { + DeleteError(error); + try + { + delete profile_map; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + *error = NoError(); + } + + void AddProfile(ProfileMap *profile_map, Profile *profile, Error *error) + { + DeleteError(error); + profile_map->AddProfile(profile, error); + } + + Profile *GetProfile(ProfileMap *profile_map, const char *profile_name, const char *profile_units, Error *error) + { + DeleteError(error); + return profile_map->GetProfile(profile_name, profile_units, error); + } + + // ProfileMap class functions + + ProfileMap::ProfileMap(Error *error) + { + int error_code = 0; + profile_map_ = InternalCreateProfileMap(&error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create profile map") }; + } + owns_profile_map_ = true; + *error = NoError(); + } + + ProfileMap::~ProfileMap() + { + int error_code = 0; + if (profile_map_ != nullptr && owns_profile_map_) + { + InternalDeleteProfileMap(profile_map_, &error_code); + } + profile_map_ = nullptr; + owns_profile_map_ = false; + } + + void ProfileMap::AddProfile(Profile *profile, Error *error) + { + if (profile_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile map is null") }; + return; + } + if (profile->profile_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add unowned profile") }; + return; + } + if (profile->updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add profile in invalid state") }; + return; + } + + int error_code = 0; + + try + { + InternalAddProfile(profile_map_, profile->profile_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to add profile") }; + } + InternalDeleteProfileUpdater(profile->updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to delete profile updater") }; + } + profile->updater_ = InternalGetProfileUpdaterFromMap(profile_map_, profile->profile_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get profile updater from map") }; + } + InternalDeleteProfile(profile->profile_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete profile after transfer of ownership to profile map") }; + } + profile->profile_ = nullptr; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to add profile") }; + } + *error = NoError(); + } + + Profile *ProfileMap::GetProfile(const char *profile_name, const char *profile_units, Error *error) + { + if (profile_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Profile map is null") }; + return nullptr; + } + + Profile *profile = nullptr; + + try + { + int error_code = 0; + void *profile_ptr = InternalGetProfile( + profile_map_, profile_name, strlen(profile_name), profile_units, strlen(profile_units), &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get profile") }; + return nullptr; + } + void *updater_ptr = InternalGetProfileUpdaterFromMap(profile_map_, profile_ptr, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get updater") }; + InternalDeleteProfile(profile_ptr, &error_code); + return nullptr; + } + InternalDeleteProfile(profile_ptr, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete profile during transfer of ownership to profile map") }; + InternalDeleteProfileUpdater(updater_ptr, &error_code); + return nullptr; + } + profile = new Profile(updater_ptr); + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create profile") }; + } + *error = NoError(); + return profile; + } + +} // namespace musica diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp new file mode 100644 index 00000000..57271029 --- /dev/null +++ b/src/tuvx/radiator.cpp @@ -0,0 +1,268 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include + +#include +#include +#include + +namespace musica +{ + + // Radiator external C API functions + + Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) + { + DeleteError(error); + return new Radiator(radiator_name, height_grid, wavelength_grid, error); + } + + void DeleteRadiator(Radiator *radiator, Error *error) + { + DeleteError(error); + try + { + delete radiator; + } + catch (const std::system_error &e) + { + *error = ToError(e); + return; + } + *error = NoError(); + } + + void SetRadiatorOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + DeleteError(error); + radiator->SetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); + } + + void GetRadiatorOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + DeleteError(error); + radiator->GetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); + } + + void SetRadiatorSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + DeleteError(error); + radiator->SetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); + } + + void GetRadiatorSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + DeleteError(error); + radiator->GetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); + } + + void SetRadiatorAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error) + { + DeleteError(error); + radiator->SetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); + } + + void GetRadiatorAsymmetryFactors( + Radiator *radiator, + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error) + { + DeleteError(error); + radiator->GetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); + } + + // Radiation class functions + + Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) + { + int error_code = 0; + radiator_ = InternalCreateRadiator( + radiator_name, strlen(radiator_name), height_grid->updater_, wavelength_grid->updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; + return; + } + updater_ = InternalGetRadiatorUpdater(radiator_, &error_code); + if (error_code != 0) + { + InternalDeleteRadiator(radiator_, &error_code); + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get radiator updater") }; + return; + } + *error = NoError(); + } + + Radiator::~Radiator() + { + int error_code = 0; + if (radiator_ != nullptr) + InternalDeleteRadiator(radiator_, &error_code); + if (updater_ != nullptr) + InternalDeleteRadiatorUpdater(updater_, &error_code); + radiator_ = nullptr; + updater_ = nullptr; + } + + void Radiator::SetOpticalDepths( + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalSetOpticalDepths(updater_, optical_depths, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set optical depths") }; + return; + } + *error = NoError(); + } + + void Radiator::GetOpticalDepths( + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalGetOpticalDepths(updater_, optical_depths, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get optical depths") }; + return; + } + *error = NoError(); + } + + void Radiator::SetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalSetSingleScatteringAlbedos( + updater_, single_scattering_albedos, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set single scattering albedos") }; + return; + } + *error = NoError(); + } + + void Radiator::GetSingleScatteringAlbedos( + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalGetSingleScatteringAlbedos( + updater_, single_scattering_albedos, num_vertical_layers, num_wavelength_bins, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get single scattering albedos") }; + return; + } + *error = NoError(); + } + + void Radiator::SetAsymmetryFactors( + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalSetAsymmetryFactors( + updater_, asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set asymmetry factors") }; + return; + } + *error = NoError(); + } + + void Radiator::GetAsymmetryFactors( + double *asymmetry_factors, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + std::size_t num_streams, + Error *error) + { + int error_code = 0; + if (updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator is not updatable") }; + return; + } + InternalGetAsymmetryFactors( + updater_, asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get asymmetry factors") }; + return; + } + *error = NoError(); + } + +} // namespace musica \ No newline at end of file diff --git a/src/tuvx/radiator_map.cpp b/src/tuvx/radiator_map.cpp new file mode 100644 index 00000000..92263dda --- /dev/null +++ b/src/tuvx/radiator_map.cpp @@ -0,0 +1,180 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include + +#include +#include +#include + +namespace musica +{ + + // RadiatordMap external C API functions + + RadiatorMap *CreateRadiatorMap(Error *error) + { + DeleteError(error); + return new RadiatorMap(error); + } + + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error) + { + DeleteError(error); + try + { + delete radiator_map; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + *error = NoError(); + } + + void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error) + { + DeleteError(error); + radiator_map->AddRadiator(radiator, error); + } + + Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error) + { + DeleteError(error); + return radiator_map->GetRadiator(radiator_name, error); + } + + // RadiatordMap class functions + + RadiatorMap::RadiatorMap(Error *error) + { + int error_code = 0; + radiator_map_ = InternalCreateRadiatorMap(&error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator map") }; + } + owns_radiator_map_ = true; + *error = NoError(); + } + + RadiatorMap::~RadiatorMap() + { + int error_code = 0; + if (radiator_map_ != nullptr && owns_radiator_map_) + { + InternalDeleteRadiatorMap(radiator_map_, &error_code); + } + radiator_map_ = nullptr; + owns_radiator_map_ = false; + } + + void RadiatorMap::AddRadiator(Radiator *radiator, Error *error) + { + if (radiator_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator map is null") }; + return; + } + if (radiator->radiator_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add unowned radiator to radiator map") }; + return; + } + if (radiator->updater_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Cannot add radiator in invalid state") }; + return; + } + + int error_code = 0; + + try + { + InternalAddRadiator(radiator_map_, radiator->radiator_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to add radiator to radiator map") }; + } + InternalDeleteRadiatorUpdater(radiator->updater_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete updater after transfer of ownership to radiator map") }; + } + radiator->updater_ = InternalGetRadiatorUpdaterFromMap(radiator_map_, radiator->radiator_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to get updater after transfer of ownership to radiator map") }; + } + InternalDeleteRadiator(radiator->radiator_, &error_code); + if (error_code != 0) + { + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete radiator during transfer of ownership to radiator map") }; + } + radiator->radiator_ = nullptr; + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Internal error adding radiator") }; + } + *error = NoError(); + } + + Radiator *RadiatorMap::GetRadiator(const char *radiator_name, Error *error) + { + if (radiator_map_ == nullptr) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Radiator map is null") }; + return nullptr; + } + + Radiator *radiator = nullptr; + + try + { + int error_code = 0; + void *radiator_ptr = InternalGetRadiator(radiator_map_, radiator_name, strlen(radiator_name), &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get radiator from radiator map") }; + return nullptr; + } + void *updater_ptr = InternalGetRadiatorUpdaterFromMap(radiator_map_, radiator_ptr, &error_code); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to get radiator updater") }; + InternalDeleteRadiator(radiator_ptr, &error_code); + return nullptr; + } + InternalDeleteRadiator(radiator_ptr, &error_code); + if (error_code != 0) + { + *error = + Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to delete radiator after getting updater") }; + InternalDeleteRadiatorUpdater(updater_ptr, &error_code); + return nullptr; + } + radiator = new Radiator(updater_ptr); + } + catch (const std::system_error &e) + { + *error = ToError(e); + } + catch (...) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Internal error getting radiator") }; + } + *error = NoError(); + return radiator; + } + +} // namespace musica \ No newline at end of file diff --git a/src/tuvx/tuvx.cpp b/src/tuvx/tuvx.cpp index 924054c2..9abd977d 100644 --- a/src/tuvx/tuvx.cpp +++ b/src/tuvx/tuvx.cpp @@ -3,7 +3,7 @@ // // This file contains the implementation of the TUVX class, which represents a multi-component // reactive transport model. It also includes functions for creating and deleting TUVX instances. -#include +#include #include #include @@ -12,6 +12,8 @@ namespace musica { + // TUVX external C API functions + TUVX *CreateTuvx(const char *config_path, Error *error) { DeleteError(error); @@ -50,53 +52,22 @@ namespace musica return tuvx->CreateGridMap(error); } - void DeleteGridMap(GridMap *grid_map, Error *error) - { - *error = NoError(); - try - { - delete grid_map; - } - catch (const std::system_error &e) - { - *error = ToError(e); - } - } - - Grid *GetGrid(GridMap *grid_map, const char *grid_name, const char *grid_units, Error *error) + ProfileMap *GetProfileMap(TUVX *tuvx, Error *error) { DeleteError(error); - return grid_map->GetGrid(grid_name, grid_units, error); - } - - void DeleteGrid(Grid *grid, Error *error) - { - *error = NoError(); - try - { - delete grid; - } - catch (const std::system_error &e) - { - *error = ToError(e); - } + return tuvx->CreateProfileMap(error); } - void SetEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error) + RadiatorMap *GetRadiatorMap(TUVX *tuvx, Error *error) { DeleteError(error); - grid->SetEdges(edges, num_edges, error); + return tuvx->CreateRadiatorMap(error); } - void SetMidpoints(Grid *grid, double midpoints[], std::size_t num_midpoints, Error *error) - { - DeleteError(error); - grid->SetMidpoints(midpoints, num_midpoints, error); - } + // TUVX class functions TUVX::TUVX() - : tuvx_(), - grid_map_(nullptr) + : tuvx_() { } @@ -142,94 +113,41 @@ namespace musica GridMap *TUVX::CreateGridMap(Error *error) { - int error_code = 0; - grid_map_ = std::make_unique(InternalGetGridMap(tuvx_, &error_code)); *error = NoError(); + int error_code = 0; + GridMap *grid_map = new GridMap(InternalGetGridMap(tuvx_, &error_code)); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create grid map") }; return nullptr; } - return grid_map_.get(); + return grid_map; } - GridMap::~GridMap() + ProfileMap *TUVX::CreateProfileMap(Error *error) { - // At the time of writing, the grid map pointer is owned by fortran memory - // in the tuvx core and should not be deleted here. It will be deleted when - // the tuvx instance is deleted + *error = NoError(); int error_code = 0; - grid_map_ = nullptr; - } - - Grid *GridMap::GetGrid(const char *grid_name, const char *grid_units, Error *error) - { - if (grid_map_ == nullptr) + ProfileMap *profile_map = new ProfileMap(InternalGetProfileMap(tuvx_, &error_code)); + if (error_code != 0) { - *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Grid map is null") }; + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create profile map") }; return nullptr; } - - int error_code = 0; - Grid *grid = nullptr; - - try - { - *error = NoError(); - - grid = new Grid(InternalGetGrid(grid_map_, grid_name, strlen(grid_name), grid_units, strlen(grid_units), &error_code)); - - if (error_code != 0) - { - delete grid; - grid = nullptr; - *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create grid map") }; - } - else - { - grids_.push_back(std::unique_ptr(grid)); - } - } - catch (const std::system_error &e) - { - *error = ToError(e); - } - catch (...) - { - *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create grid") }; - } - - return grid; + return profile_map; } - Grid::~Grid() + RadiatorMap *TUVX::CreateRadiatorMap(Error *error) { - int error_code = 0; - if (grid_ != nullptr) - InternalDeleteGrid(grid_, &error_code); - grid_ = nullptr; - } - - void Grid::SetEdges(double edges[], std::size_t num_edges, Error *error) - { - int error_code = 0; - InternalSetEdges(grid_, edges, num_edges, &error_code); *error = NoError(); - if (error_code != 0) - { - *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set edges") }; - } - } - - void Grid::SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error) - { int error_code = 0; - InternalSetMidpoints(grid_, midpoints, num_midpoints, &error_code); - *error = NoError(); + RadiatorMap *radiator_map = new RadiatorMap(InternalGetRadiatorMap(tuvx_, &error_code)); if (error_code != 0) { - *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to set midpoints") }; + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator map") }; + return nullptr; } + return radiator_map; } } // namespace musica