From e9b7bc6c83b531c06ca2280a012fd30039263572 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Tue, 4 Jun 2024 14:08:39 -0600 Subject: [PATCH 001/117] Start on test_micm_box_model.F90. --- .../fetch_content_integration/CMakeLists.txt | 16 ++++++++++++++++ .../test_micm_box_model.F90 | 8 ++++++++ fortran/test/unit/CMakeLists.txt | 1 + 3 files changed, 25 insertions(+) create mode 100644 fortran/test/fetch_content_integration/test_micm_box_model.F90 diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index f9a32dbc..cf039bbc 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -65,6 +65,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 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..cfcc6506 --- /dev/null +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -0,0 +1,8 @@ +program test_micm_box_model + 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 test_micm_box_model diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 2d5e274a..27b0de76 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -5,6 +5,7 @@ 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) endif() if (MUSICA_ENABLE_TUVX) From 4a3c9bd29764f5d90aef2a2e5d73e918fa92e4d4 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Tue, 4 Jun 2024 14:45:17 -0600 Subject: [PATCH 002/117] Start on test_micm_box_model.F90. --- .../test_micm_box_model.F90 | 27 +++++++++++++++---- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index cfcc6506..c60ce9d3 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -1,8 +1,25 @@ program test_micm_box_model - use musica_util, only: string_t - use musica_micm, only: get_micm_version + + use, intrinsic :: iso_c_binding + use, intrinsic :: ieee_arithmetic + + use musica_micm, only: micm_t + use musica_util, only: error_t, string_t, mapping_t + implicit none - type(string_t) :: micm_version - micm_version = get_micm_version() - print *, "MICM version ", micm_version%get_char_array() + + call box_model() + +contains + + subroutine box_model() + + real(c_double) :: time_step + real(c_double) :: temperature + real(c_double) :: pressure + + real(c_double), dimension(3) :: concentrations + + end subroutine box_model + end program test_micm_box_model From 66d509132d0a4eaa9dc9c890e5f0d758a89d6efd Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Tue, 4 Jun 2024 14:56:39 -0600 Subject: [PATCH 003/117] In test_micm_box_model, create micm_t solver. --- .../test_micm_box_model.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index c60ce9d3..737fc3ed 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -3,8 +3,8 @@ program test_micm_box_model use, intrinsic :: iso_c_binding use, intrinsic :: ieee_arithmetic - use musica_micm, only: micm_t use musica_util, only: error_t, string_t, mapping_t + use musica_micm, only: micm_t implicit none @@ -14,12 +14,23 @@ program test_micm_box_model subroutine box_model() + character(len=256) :: config_path + real(c_double) :: time_step real(c_double) :: temperature real(c_double) :: pressure real(c_double), dimension(3) :: concentrations + type(error_t) :: error + + type(micm_t), pointer :: micm + + config_path = "" + + write(*,*) "Creating MICM solver..." + micm => micm_t(config_path, error) + end subroutine box_model end program test_micm_box_model From 73f997d9b345f2180f17a54921fefe289807f632 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Tue, 4 Jun 2024 17:49:47 -0600 Subject: [PATCH 004/117] Initialize some variables. --- .../fetch_content_integration/test_micm_box_model.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index 737fc3ed..f883bf5d 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -20,14 +20,20 @@ subroutine box_model() real(c_double) :: temperature real(c_double) :: pressure + integer(c_int) :: num_concentrations = 3 real(c_double), dimension(3) :: concentrations type(error_t) :: error - type(micm_t), pointer :: micm + integer :: i + config_path = "" + time_step = 200 + temperature = 273.0 + pressure = 1.0e5 + write(*,*) "Creating MICM solver..." micm => micm_t(config_path, error) From de422c2ff56ff5e2d2987626e7060807d729646c Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 09:18:27 -0600 Subject: [PATCH 005/117] Use configs/analytical. --- .../fetch_content_integration/test_micm_box_model.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index f883bf5d..e84d3737 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -28,7 +28,7 @@ subroutine box_model() integer :: i - config_path = "" + config_path = "configs/analytical" time_step = 200 temperature = 273.0 @@ -37,6 +37,12 @@ subroutine box_model() write(*,*) "Creating MICM solver..." micm => micm_t(config_path, 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 + end subroutine box_model end program test_micm_box_model From 5e097cc3dc1a0e497a95fc4153a4cf08ff45e550 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 09:38:22 -0600 Subject: [PATCH 006/117] Use configs/analytical. --- .../test/fetch_content_integration/test_micm_box_model.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index e84d3737..7c437d32 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -23,12 +23,16 @@ subroutine box_model() integer(c_int) :: num_concentrations = 3 real(c_double), dimension(3) :: concentrations + integer(c_int) :: num_user_defined_reaction_rates = 3 + real(c_double), dimension(3) :: user_defined_reaction_rates + type(error_t) :: error type(micm_t), pointer :: micm integer :: i config_path = "configs/analytical" + user_defined_reaction_rates = (/ 0.1, 0.2, 0.3 /) time_step = 200 temperature = 273.0 From 1ecd9ba7181b77b0b4f46f66d61c9c09c6456481 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 09:59:31 -0600 Subject: [PATCH 007/117] Added micm solve. --- .../test_micm_box_model.F90 | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index 7c437d32..ca05de18 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -23,8 +23,8 @@ subroutine box_model() integer(c_int) :: num_concentrations = 3 real(c_double), dimension(3) :: concentrations - integer(c_int) :: num_user_defined_reaction_rates = 3 - real(c_double), dimension(3) :: user_defined_reaction_rates + integer(c_int) :: num_user_defined_reaction_rates = 0 + real(c_double), dimension(:), allocatable :: user_defined_reaction_rates type(error_t) :: error type(micm_t), pointer :: micm @@ -32,12 +32,14 @@ subroutine box_model() integer :: i config_path = "configs/analytical" - user_defined_reaction_rates = (/ 0.1, 0.2, 0.3 /) + ! user_defined_reaction_rates = (/ 0.1, 0.2, 0.3 /) time_step = 200 temperature = 273.0 pressure = 1.0e5 + concentrations = (/ 1.0, 1.0, 1.0 /) + write(*,*) "Creating MICM solver..." micm => micm_t(config_path, error) @@ -47,6 +49,11 @@ subroutine box_model() 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) + write(*,*) "After solving, concentrations", concentrations + end subroutine box_model end program test_micm_box_model From 10ac01b49fe9fcc4ae0d38738adf231b09bb640c Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 10:15:27 -0600 Subject: [PATCH 008/117] Start on Chapter 2. --- docs/source/tutorial/chapter2.rst | 9 +++++++++ docs/source/tutorial/tutorial.rst | 1 + 2 files changed, 10 insertions(+) create mode 100644 docs/source/tutorial/chapter2.rst diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst new file mode 100644 index 00000000..642bb60d --- /dev/null +++ b/docs/source/tutorial/chapter2.rst @@ -0,0 +1,9 @@ +Chapter 2 +========= + +An ABC MICM Fortran Example +--------------------------- +.. code-block:: f90 + + program micm_abc + end program micm_abc diff --git a/docs/source/tutorial/tutorial.rst b/docs/source/tutorial/tutorial.rst index e4206e3d..7d22728a 100644 --- a/docs/source/tutorial/tutorial.rst +++ b/docs/source/tutorial/tutorial.rst @@ -7,3 +7,4 @@ Tutorial :caption: Contents: chapter1.rst + chapter2.rst From b30c177958c579aa94489d1307a8245ef58bbc51 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 11:35:36 -0600 Subject: [PATCH 009/117] Literal include for test_micm_box_model. --- docs/source/tutorial/chapter2.rst | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index 642bb60d..19939b29 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -3,7 +3,6 @@ Chapter 2 An ABC MICM Fortran Example --------------------------- -.. code-block:: f90 - program micm_abc - end program micm_abc + .. literalinclude:: ../../../fortran/test/fetch_content_integration/test_micm_box_model.F90 + :language: f90 From fba18d3824b8f7c7e331cab6a1356c556e7461aa Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 11:43:03 -0600 Subject: [PATCH 010/117] Literal include json configs. --- docs/source/tutorial/chapter2.rst | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index 19939b29..5ebec9b0 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -4,5 +4,14 @@ Chapter 2 An ABC MICM Fortran Example --------------------------- + .. literalinclude:: ../../../configs/analytical/config.json + :language: json + + .. literalinclude:: ../../../configs/analytical/species.json + :language: json + + .. literalinclude:: ../../../configs/analytical/reactions.json + :language: json + .. literalinclude:: ../../../fortran/test/fetch_content_integration/test_micm_box_model.F90 :language: f90 From 76d90f27253f5599011406c5dca422e3a3489bbf Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 15:02:28 -0600 Subject: [PATCH 011/117] Updated CMakeLists.txt. --- docs/source/tutorial/chapter2.rst | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index 5ebec9b0..22d31a13 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -4,9 +4,20 @@ Chapter 2 An ABC MICM 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 From a1276238ae4e2259b5204aa8c7529daf1b3ba793 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 15:16:18 -0600 Subject: [PATCH 012/117] Add config file description. --- docs/source/tutorial/chapter2.rst | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index 22d31a13..c8091cef 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -21,6 +21,12 @@ For this example, we will have a system of three chemical species .. 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 B evolving to C and using only two reaction parameters. +The reactions configuration might then be: + .. literalinclude:: ../../../configs/analytical/reactions.json :language: json From c9bb25b6d6a78bb2b220778056cc631ddb561b90 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 15:47:48 -0600 Subject: [PATCH 013/117] Tutorial Chapter 2. --- docs/source/tutorial/chapter2.rst | 22 ++++++++++++++++--- .../test_micm_box_model.F90 | 1 - 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index c8091cef..adf5cbf9 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -1,8 +1,8 @@ Chapter 2 ========= -An ABC MICM Fortran Example ---------------------------- +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, @@ -25,10 +25,26 @@ The ``reactions.json`` specifies a mechanism, or a set of reactions for the syst 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 B evolving to C and using only two reaction parameters. -The reactions configuration might then be: +The mechanism configuration might then be set up as: .. literalinclude:: ../../../configs/analytical/reactions.json :language: json +The Fortran example code is shown 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. diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index ca05de18..1056b6a0 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -32,7 +32,6 @@ subroutine box_model() integer :: i config_path = "configs/analytical" - ! user_defined_reaction_rates = (/ 0.1, 0.2, 0.3 /) time_step = 200 temperature = 273.0 From c482ec9a9b0c10f0fa3880e180f21e2e05b5e505 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 15:49:19 -0600 Subject: [PATCH 014/117] Tutorial Chapter 2. --- docs/source/tutorial/chapter2.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index adf5cbf9..b10142a7 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -35,7 +35,7 @@ The Fortran example code is shown 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 +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``). From 4d2a500729795a9b22fd7baa8b165616b7058e78 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 15:51:00 -0600 Subject: [PATCH 015/117] Minor formatting. --- docs/source/tutorial/chapter2.rst | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index b10142a7..a1d8ec6d 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -23,8 +23,8 @@ For this example, we will have a system of three chemical species 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 B evolving to C and using only two reaction parameters. +with `B` evolving to `C`, and specifying all five reaction parameters, +and the second reaction with `B` evolving to `C` and using only two reaction parameters. The mechanism configuration might then be set up as: .. literalinclude:: ../../../configs/analytical/reactions.json From 00416172996192589bba4ef8e9294640f880e75c Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 5 Jun 2024 15:52:07 -0600 Subject: [PATCH 016/117] Minor formatting. --- docs/source/tutorial/chapter2.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index a1d8ec6d..8cc27059 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -24,7 +24,7 @@ For this example, we will have a system of three chemical species 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 `B` evolving to `C` and using only two 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 From 6e38172974c85c8a95ceaff7350a179d020a1d7e Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Tue, 18 Jun 2024 09:26:45 -0600 Subject: [PATCH 017/117] Added link to MICM docs, test program output. --- docs/source/tutorial/chapter2.rst | 17 ++++++++++++++++- src/micm/micm.cpp | 1 + 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/docs/source/tutorial/chapter2.rst b/docs/source/tutorial/chapter2.rst index 8cc27059..519ffa20 100644 --- a/docs/source/tutorial/chapter2.rst +++ b/docs/source/tutorial/chapter2.rst @@ -30,7 +30,10 @@ The mechanism configuration might then be set up as: .. literalinclude:: ../../../configs/analytical/reactions.json :language: json -The Fortran example code is shown in full: +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 @@ -48,3 +51,15 @@ 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/src/micm/micm.cpp b/src/micm/micm.cpp index be4daaaa..6538d700 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -9,6 +9,7 @@ #include #include + #include #include From f03ee82486d3d1ad086849519d56b50a36d35d5e Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sat, 22 Jun 2024 17:22:58 -0600 Subject: [PATCH 018/117] Start on tutorial CMakeLists.txt. --- tutorial/CMakeLists.txt | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 tutorial/CMakeLists.txt diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt new file mode 100644 index 00000000..2dfca2a4 --- /dev/null +++ b/tutorial/CMakeLists.txt @@ -0,0 +1,6 @@ +cmake_minimum_required(VERSION 3.21) + +project( + musica-demo + VERSION 0.1 +) From 8caf007bc9a48eda7b6d72bfcd2358ba0903db2e Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 09:42:17 -0600 Subject: [PATCH 019/117] Created MUSICA/tutorial subdir. --- tutorial/CMakeLists.txt | 3 +++ tutorial/demo.cpp | 10 ++++++++++ 2 files changed, 13 insertions(+) create mode 100644 tutorial/demo.cpp diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 2dfca2a4..14869727 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -4,3 +4,6 @@ project( musica-demo VERSION 0.1 ) + +message(STATUS "${PROJECT_SOURCE_DIR}") +message(STATUS "${PROJECT_BINARY_DIR}") diff --git a/tutorial/demo.cpp b/tutorial/demo.cpp new file mode 100644 index 00000000..cd80307e --- /dev/null +++ b/tutorial/demo.cpp @@ -0,0 +1,10 @@ +#include +#include +#include + +using namespace musica; + +void main(int argc, char* argv[]) { + + return 0; +} From e2c5bb6fd35da8e9910fd72fc032285252c9b867 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 11:36:35 -0600 Subject: [PATCH 020/117] Added MUSICA_INCLUDE_DIR and MUSICA_LIBRARY_DIR. --- tutorial/CMakeLists.txt | 12 ++++++++++-- tutorial/demo.cpp | 1 - 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 14869727..c37020e4 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -5,5 +5,13 @@ project( VERSION 0.1 ) -message(STATUS "${PROJECT_SOURCE_DIR}") -message(STATUS "${PROJECT_BINARY_DIR}") +option(TEST_OPTION "test option" ON) + +set(MUSICA_INCLUDE_DIR "${PROJECT_SOURCE_DIR}/../include") +set(MUSICA_LIBRARY_DIR "${PROJECT_SOURCE_DIR}") + +message(STATUS "${MUSICA_INCLUDE_DIR}") +message(STATUS "${MUSICA_LIBRARY_DIR}") + +add_executable(demo demo.cpp) +target_include_directories(demo PUBLIC "${MUSICA_INCLUDE_DIR}") diff --git a/tutorial/demo.cpp b/tutorial/demo.cpp index cd80307e..d0a5b522 100644 --- a/tutorial/demo.cpp +++ b/tutorial/demo.cpp @@ -1,6 +1,5 @@ #include #include -#include using namespace musica; From 4943543d90380c66dd785f0c7d8936a417c447b9 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 11:43:59 -0600 Subject: [PATCH 021/117] Switch to MUSICA_INSTALL_DIR/include /lib. --- tutorial/CMakeLists.txt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index c37020e4..ac8849d6 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -7,11 +7,11 @@ project( option(TEST_OPTION "test option" ON) -set(MUSICA_INCLUDE_DIR "${PROJECT_SOURCE_DIR}/../include") -set(MUSICA_LIBRARY_DIR "${PROJECT_SOURCE_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_LIBRARY_DIR}") +message(STATUS "${MUSICA_LIB_DIR}") add_executable(demo demo.cpp) target_include_directories(demo PUBLIC "${MUSICA_INCLUDE_DIR}") From 416971e2748e8b0f8c0f8791b9addeffed41cf13 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 12:25:12 -0600 Subject: [PATCH 022/117] Include musicaConfig.cmake. --- tutorial/CMakeLists.txt | 4 +++- tutorial/demo.c | 3 +++ tutorial/demo.cpp | 9 --------- 3 files changed, 6 insertions(+), 10 deletions(-) create mode 100644 tutorial/demo.c delete mode 100644 tutorial/demo.cpp diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index ac8849d6..ae2a3b7f 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -13,5 +13,7 @@ set(MUSICA_LIB_DIR "${MUSICA_INSTALL_DIR}/lib") message(STATUS "${MUSICA_INCLUDE_DIR}") message(STATUS "${MUSICA_LIB_DIR}") -add_executable(demo demo.cpp) +include("${MUSICA_LIB_DIR}/cmake/musica/musicaConfig.cmake") + +add_executable(demo demo.c) target_include_directories(demo PUBLIC "${MUSICA_INCLUDE_DIR}") diff --git a/tutorial/demo.c b/tutorial/demo.c new file mode 100644 index 00000000..553e50f6 --- /dev/null +++ b/tutorial/demo.c @@ -0,0 +1,3 @@ +void main(int argc, char* argv[]) { + +} diff --git a/tutorial/demo.cpp b/tutorial/demo.cpp deleted file mode 100644 index d0a5b522..00000000 --- a/tutorial/demo.cpp +++ /dev/null @@ -1,9 +0,0 @@ -#include -#include - -using namespace musica; - -void main(int argc, char* argv[]) { - - return 0; -} From bf7bf0206e4216a17045fab05b21d723594a67ab Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 12:34:55 -0600 Subject: [PATCH 023/117] Include addtional cmake files. --- tutorial/CMakeLists.txt | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index ae2a3b7f..0fdc73d5 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -14,6 +14,13 @@ message(STATUS "${MUSICA_INCLUDE_DIR}") message(STATUS "${MUSICA_LIB_DIR}") include("${MUSICA_LIB_DIR}/cmake/musica/musicaConfig.cmake") +include("${MUSICA_LIB_DIR}/cmake/musica/musicaConfigVersion.cmake") +include("${MUSICA_LIB_DIR}/cmake/musica/musica_Exports.cmake") +include("${MUSICA_LIB_DIR}/cmake/musica/musica_Exports-release.cmake") +# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortranConfig.cmake") +# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortranConfigVersion.cmake") +# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortran_Exports.cmake") +# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortran_Exports-release.cmake") -add_executable(demo demo.c) -target_include_directories(demo PUBLIC "${MUSICA_INCLUDE_DIR}") +add_executable(demo_c demo.c) +target_include_directories(demo_c PUBLIC "${MUSICA_INCLUDE_DIR}") From bbbb96832e81088e54e6a3d15e3c2e12be6d70ec Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 12:57:19 -0600 Subject: [PATCH 024/117] Added Fortran to CMakeList LANGUAGES. --- tutorial/CMakeLists.txt | 4 ++++ tutorial/demo.f90 | 8 ++++++++ 2 files changed, 12 insertions(+) create mode 100644 tutorial/demo.f90 diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 0fdc73d5..c82cf1dd 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -3,6 +3,7 @@ cmake_minimum_required(VERSION 3.21) project( musica-demo VERSION 0.1 + LANGUAGES CXX C Fortran ) option(TEST_OPTION "test option" ON) @@ -23,4 +24,7 @@ include("${MUSICA_LIB_DIR}/cmake/musica/musica_Exports-release.cmake") # include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortran_Exports-release.cmake") add_executable(demo_c demo.c) +add_executable(demo_f demo.f90) + target_include_directories(demo_c PUBLIC "${MUSICA_INCLUDE_DIR}") +target_include_directories(demo_f PUBLIC "${MUSICA_INCLUDE_DIR}") diff --git a/tutorial/demo.f90 b/tutorial/demo.f90 new file mode 100644 index 00000000..299411bc --- /dev/null +++ b/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 From de2bf0b6afc538ecc789074338a74356d4818d48 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 13:13:49 -0600 Subject: [PATCH 025/117] Added target_link_directories and libraries. --- tutorial/CMakeLists.txt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index c82cf1dd..5064c67b 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -26,5 +26,9 @@ include("${MUSICA_LIB_DIR}/cmake/musica/musica_Exports-release.cmake") add_executable(demo_c demo.c) add_executable(demo_f demo.f90) -target_include_directories(demo_c PUBLIC "${MUSICA_INCLUDE_DIR}") -target_include_directories(demo_f PUBLIC "${MUSICA_INCLUDE_DIR}") +target_include_directories(demo_c PUBLIC ${MUSICA_INCLUDE_DIR}) +target_link_directories(demo_c PUBLIC ${MUSICA_LIB_DIR}) + +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++) From de57722bed076d732432fcaa4e68ab780fa7d992 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 18:41:04 -0600 Subject: [PATCH 026/117] Added find_package(musica). --- tutorial/CMakeLists.txt | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 5064c67b..edac3670 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -8,21 +8,17 @@ project( option(TEST_OPTION "test option" ON) +# cmake -DMUSICA_INSTALL_DIR -Dmusica_DIR +find_package(musica) + +# set(MUSICA_INCLUDE_DIR ${musica_INCLUDE_DIRS}) + 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}") -include("${MUSICA_LIB_DIR}/cmake/musica/musicaConfig.cmake") -include("${MUSICA_LIB_DIR}/cmake/musica/musicaConfigVersion.cmake") -include("${MUSICA_LIB_DIR}/cmake/musica/musica_Exports.cmake") -include("${MUSICA_LIB_DIR}/cmake/musica/musica_Exports-release.cmake") -# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortranConfig.cmake") -# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortranConfigVersion.cmake") -# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortran_Exports.cmake") -# include("${MUSICA_LIB_DIR}/cmake/musica/musica_fortran_Exports-release.cmake") - add_executable(demo_c demo.c) add_executable(demo_f demo.f90) From 423fdfefb6307ae77452d9d66bfaf97173df4d6c Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 18:46:38 -0600 Subject: [PATCH 027/117] Comment use_package(musica_fortran), not working. --- tutorial/CMakeLists.txt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index edac3670..22005045 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -9,7 +9,9 @@ project( option(TEST_OPTION "test option" ON) # cmake -DMUSICA_INSTALL_DIR -Dmusica_DIR +# -Dmusica_fortran_DIR find_package(musica) +# find_package(musica_fortran) # set(MUSICA_INCLUDE_DIR ${musica_INCLUDE_DIRS}) From bba0498edcd3842203d90889292dbf916ba0bab2 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 18:55:03 -0600 Subject: [PATCH 028/117] Added cmake usage comments. --- tutorial/CMakeLists.txt | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 22005045..238e4f43 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -6,14 +6,16 @@ project( LANGUAGES CXX C Fortran ) -option(TEST_OPTION "test option" ON) - -# cmake -DMUSICA_INSTALL_DIR -Dmusica_DIR -# -Dmusica_fortran_DIR -find_package(musica) +# mkdir build +# cd build +# cmake -Dmusica_DIR +# -Dmusica_fortran_DIR .. +# find_package(musica) # find_package(musica_fortran) -# set(MUSICA_INCLUDE_DIR ${musica_INCLUDE_DIRS}) +# mkdir build +# cd build +# cmake -DMUSICA_INSTALL_DIR .. set(MUSICA_INCLUDE_DIR "${MUSICA_INSTALL_DIR}/include") set(MUSICA_LIB_DIR "${MUSICA_INSTALL_DIR}/lib") From b3a08966a6f72e9e4a16f0c1296a9f622266e595 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Sun, 23 Jun 2024 19:45:43 -0600 Subject: [PATCH 029/117] Restored find_package for musica and musica_fortran. --- tutorial/CMakeLists.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 238e4f43..77357700 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -10,8 +10,8 @@ project( # cd build # cmake -Dmusica_DIR # -Dmusica_fortran_DIR .. -# find_package(musica) -# find_package(musica_fortran) +find_package(musica) +find_package(musica_fortran) # mkdir build # cd build From 03eb3044b13b72e0e53e2315a80dcb845aaec7bb Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 24 Jun 2024 08:46:10 -0600 Subject: [PATCH 030/117] Start on Tutorial Chapter 0 text. --- docs/source/tutorial/chapter0.rst | 6 ++++++ docs/source/tutorial/tutorial.rst | 1 + 2 files changed, 7 insertions(+) create mode 100644 docs/source/tutorial/chapter0.rst diff --git a/docs/source/tutorial/chapter0.rst b/docs/source/tutorial/chapter0.rst new file mode 100644 index 00000000..726dfcbe --- /dev/null +++ b/docs/source/tutorial/chapter0.rst @@ -0,0 +1,6 @@ +Chapter 0 +========= + +The MUSICA CMake Package +------------------------ + diff --git a/docs/source/tutorial/tutorial.rst b/docs/source/tutorial/tutorial.rst index e4206e3d..c81795ab 100644 --- a/docs/source/tutorial/tutorial.rst +++ b/docs/source/tutorial/tutorial.rst @@ -6,4 +6,5 @@ Tutorial :maxdepth: 1 :caption: Contents: + chapter0.rst chapter1.rst From 908a0bcfcab4e9be1e06056a525bb1643bc84965 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 24 Jun 2024 08:56:09 -0600 Subject: [PATCH 031/117] Added literal include of Ch 0 CMakeLists.txt. --- docs/source/tutorial/chapter0.rst | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docs/source/tutorial/chapter0.rst b/docs/source/tutorial/chapter0.rst index 726dfcbe..01291093 100644 --- a/docs/source/tutorial/chapter0.rst +++ b/docs/source/tutorial/chapter0.rst @@ -4,3 +4,5 @@ Chapter 0 The MUSICA CMake Package ------------------------ + .. literalinclude:: ../../../tutorial/CMakeLists.txt + :language: cmake From af6a2e882c07828be70b65c470f4c6462a56b8d9 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 24 Jun 2024 09:10:05 -0600 Subject: [PATCH 032/117] Chapter 0 intro. --- docs/source/tutorial/chapter0.rst | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/docs/source/tutorial/chapter0.rst b/docs/source/tutorial/chapter0.rst index 01291093..bab3d426 100644 --- a/docs/source/tutorial/chapter0.rst +++ b/docs/source/tutorial/chapter0.rst @@ -4,5 +4,12 @@ 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:: ../../../tutorial/CMakeLists.txt :language: cmake From 9976b606cfaacb3fab499eccb31bf28d88687638 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 24 Jun 2024 09:43:19 -0600 Subject: [PATCH 033/117] Tutorial Chapter 0. --- docs/source/tutorial/chapter0.rst | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/docs/source/tutorial/chapter0.rst b/docs/source/tutorial/chapter0.rst index bab3d426..6fdf096d 100644 --- a/docs/source/tutorial/chapter0.rst +++ b/docs/source/tutorial/chapter0.rst @@ -4,7 +4,7 @@ Chapter 0 The MUSICA CMake Package ------------------------ -The MUSICA library installs with CMake ``musica`` and ``musica_fortran`` +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. @@ -13,3 +13,28 @@ to a Fortran program ``demo_f.f90`` is exhibited below .. literalinclude:: ../../../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 . + From 4ac0fab7a499be6c0fa5c2df743bc70735d81f9b Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 24 Jun 2024 14:31:47 -0600 Subject: [PATCH 034/117] update cmake options --- docker/Dockerfile.fortran-gcc | 2 +- docker/Dockerfile.fortran-intel | 2 +- docker/Dockerfile.memcheck | 4 +++- docker/Dockerfile.mpi | 8 +++++--- docker/Dockerfile.mpi_openmp | 10 ++++++---- docker/Dockerfile.openmp | 4 +++- docker/Dockerfile.python | 4 +++- 7 files changed, 22 insertions(+), 12 deletions(-) diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index 7e6410c9..d21acb7e 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 \ diff --git a/docker/Dockerfile.fortran-intel b/docker/Dockerfile.fortran-intel index d6f2fe61..1a724f4a 100644 --- a/docker/Dockerfile.fortran-intel +++ b/docker/Dockerfile.fortran-intel @@ -50,7 +50,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 diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index 25c61637..70ff8934 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Release + RUN dnf -y update \ && dnf -y install \ cmake \ @@ -22,7 +24,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..6d220bd2 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Release + RUN dnf -y update \ && dnf install -y sudo \ && adduser test_user \ @@ -38,9 +40,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..07f11249 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Release + RUN dnf -y update \ && dnf install -y sudo \ && adduser test_user \ @@ -38,10 +40,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..8c9ef4ac 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Release + RUN dnf -y update \ && dnf install -y sudo \ && adduser test_user \ @@ -37,7 +39,7 @@ RUN sudo chown -R test_user.test_user musica RUN cd musica \ && cmake -S . \ -B build \ - -D CMAKE_BUILD_TYPE=debug \ + -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ -D ENABLE_OPENMP:BOOL=TRUE \ -D ENABLE_TESTS=ON \ -D CMAKE_Fortran_COMPILER=/usr/lib64/openmpi/bin/mpif90 \ diff --git a/docker/Dockerfile.python b/docker/Dockerfile.python index 1648d612..a75dfec6 100644 --- a/docker/Dockerfile.python +++ b/docker/Dockerfile.python @@ -1,5 +1,7 @@ FROM fedora:35 +ARG BUILD_TYPE=Release + RUN dnf -y update \ && dnf -y install \ cmake \ @@ -23,7 +25,7 @@ RUN pip install -r musica/python/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 \ From e27634b5eae0a668b05844a26f2896140206692c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 24 Jun 2024 17:23:11 -0600 Subject: [PATCH 035/117] set vector matrix dimension --- CMakeLists.txt | 1 + cmake/dependencies.cmake | 2 ++ 2 files changed, 3 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 817051b0..1673fe56 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -31,6 +31,7 @@ option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) 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 "4" 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/cmake/dependencies.cmake b/cmake/dependencies.cmake index 8ec51940..13969b29 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -60,6 +60,8 @@ 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}) + message(STATUS "MICM vector-ordered matrix dimension: ${MICM_DEFAULT_VECTOR_MATRIX_SIZE}") FetchContent_MakeAvailable(micm) endif() From 12691b64273f34a13238bb15834a22e3686c2f0b Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Thu, 27 Jun 2024 09:25:17 -0600 Subject: [PATCH 036/117] Use music-fortran instead of musica_fortran. --- fortran/packaging/CMakeLists.txt | 12 ++++++------ tutorial/CMakeLists.txt | 8 ++++---- 2 files changed, 10 insertions(+), 10 deletions(-) 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/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 77357700..823efbea 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -8,14 +8,14 @@ project( # mkdir build # cd build -# cmake -Dmusica_DIR -# -Dmusica_fortran_DIR .. +# cmake -Dmusica_DIR= +# -Dmusica-fortran_DIR= .. find_package(musica) -find_package(musica_fortran) +find_package(musica-fortran) # mkdir build # cd build -# cmake -DMUSICA_INSTALL_DIR .. +# cmake -DMUSICA_INSTALL_DIR= .. set(MUSICA_INCLUDE_DIR "${MUSICA_INSTALL_DIR}/include") set(MUSICA_LIB_DIR "${MUSICA_INSTALL_DIR}/lib") From d63422f18686c4a18dc287e3590cd18df085730d Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Thu, 27 Jun 2024 11:17:05 -0600 Subject: [PATCH 037/117] Added test_micm_box_model executable. --- fortran/test/fetch_content_integration/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index e43df186..6739d6bc 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 From 498d34cb74d998b83f1118f69a829b264b4b30b7 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Thu, 27 Jun 2024 11:34:09 -0600 Subject: [PATCH 038/117] Updated test_micm_box_model with new micm solve. --- .../test_micm_box_model.F90 | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index 1056b6a0..41cac1d9 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -4,7 +4,7 @@ program test_micm_box_model use, intrinsic :: ieee_arithmetic use musica_util, only: error_t, string_t, mapping_t - use musica_micm, only: micm_t + use musica_micm, only: micm_t, solver_stats_t implicit none @@ -16,9 +16,12 @@ subroutine box_model() character(len=256) :: config_path + 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 @@ -26,7 +29,10 @@ subroutine box_model() integer(c_int) :: num_user_defined_reaction_rates = 0 real(c_double), dimension(:), allocatable :: user_defined_reaction_rates - type(error_t) :: error + type(string_t) :: solver_state + type(solver_stats_t) :: solver_stats + type(error_t) :: error + type(micm_t), pointer :: micm integer :: i @@ -36,6 +42,7 @@ subroutine box_model() time_step = 200 temperature = 273.0 pressure = 1.0e5 + air_density = pressure / (GAS_CONSTANT * temperature) concentrations = (/ 1.0, 1.0, 1.0 /) @@ -49,8 +56,10 @@ subroutine box_model() 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, 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 end subroutine box_model From 156e2cc3019593e2165a9d052d49ba19505d8615 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Thu, 27 Jun 2024 11:44:55 -0600 Subject: [PATCH 039/117] Added deallocate( micm ) in test_micm_box_model. --- fortran/test/fetch_content_integration/test_micm_box_model.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index 41cac1d9..dfdc5aab 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -62,6 +62,8 @@ subroutine box_model() 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 From 4a2e1a54eb463981b86a6d54b4b77cab27aedd07 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 27 Jun 2024 10:54:55 -0700 Subject: [PATCH 040/117] Auto-format code using Clang-Format (#170) Co-authored-by: GitHub Actions --- src/micm/micm.cpp | 1 - 1 file changed, 1 deletion(-) diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index af8cfc55..7d03038e 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -6,7 +6,6 @@ // creating and deleting MICM instances, creating solvers, and solving the model. #include -#include #include #include #include From 3b4199e400dad436fcdb88dfddb0bdbcb69b00ca Mon Sep 17 00:00:00 2001 From: Kyle Shores Date: Fri, 28 Jun 2024 14:36:28 -0500 Subject: [PATCH 041/117] pypi version badge --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 48267493..78410382 100644 --- a/README.md +++ b/README.md @@ -7,6 +7,7 @@ [![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) Multi-Scale Infrastructure for Chemistry and Aerosols From 59a57b8ef441c534976f520f81fe5d4e69f18325 Mon Sep 17 00:00:00 2001 From: Kyle Shores Date: Fri, 28 Jun 2024 15:01:31 -0500 Subject: [PATCH 042/117] fair software checklist badge --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 78410382..76377770 100644 --- a/README.md +++ b/README.md @@ -8,6 +8,7 @@ [![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 From d114885e9ae611da05f69f519246846ce01395d7 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 2 Jul 2024 22:15:28 -0600 Subject: [PATCH 043/117] compilation flag for grid cells, vector matrix dimension --- CMakeLists.txt | 11 +++++++++-- src/CMakeLists.txt | 3 +++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 1673fe56..7ae15f9b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -30,8 +30,15 @@ option(MUSICA_ENABLE_OPENMP "Enable OpemMP support" OFF) option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) 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 "4" CACHE STRING "Set MICM vector-ordered matrix dimension") +option(MUSICA_ENABLE_TUVX "Enable TUV-x" OFF) + +set(MUSICA_SET_MICM_NUM_GRID_CELLS "1" CACHE STRING "Set the number of grid cells for MICM Solver") +set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "2" CACHE STRING "Set MICM vector-ordered matrix dimension") + +if(${MUSICA_SET_MICM_NUM_GRID_CELLS} LESS ${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) + set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE ${MUSICA_SET_MICM_NUM_GRID_CELLS}) + message(STATUS "MICM vector matrix dimension must be less than or equal to the number of grid cells") +endif() 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/src/CMakeLists.txt b/src/CMakeLists.txt index e8c7a849..18fce6a1 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -17,6 +17,9 @@ 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_NUM_GRID_CELLS=${MUSICA_SET_MICM_NUM_GRID_CELLS}) +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) From 6d2bc7d533432ca3dc838bd35c116793346cc27f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 3 Jul 2024 13:56:12 -0600 Subject: [PATCH 044/117] c api for vector ordered matrix --- CMakeLists.txt | 1 + cmake/dependencies.cmake | 3 +- include/musica/micm.hpp | 177 +++++++++++++++++++++++-- src/micm/micm.cpp | 210 +++++++++++++++--------------- src/test/unit/micm/micm_c_api.cpp | 19 +-- 5 files changed, 282 insertions(+), 128 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7ae15f9b..6c6aba0b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -38,6 +38,7 @@ set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "2" CACHE STRING "Set MICM vector-ordered if(${MUSICA_SET_MICM_NUM_GRID_CELLS} LESS ${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE ${MUSICA_SET_MICM_NUM_GRID_CELLS}) message(STATUS "MICM vector matrix dimension must be less than or equal to the number of grid cells") + message(STATUS "MICM vector matrix dimension: " ${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) endif() cmake_dependent_option( diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 13969b29..53a3285a 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -51,7 +51,8 @@ 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 401add1bb3d0db9cd13464ed0566dc2599f02ca9) + # set_git_default(MICM_GIT_TAG 401add1bb3d0db9cd13464ed0566dc2599f02ca9) + set_git_default(MICM_GIT_TAG musica-vector-ordered-rosenbrock) FetchContent_Declare(micm GIT_REPOSITORY ${MICM_GIT_REPOSITORY} diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index c4b10075..78f533ee 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -12,13 +12,23 @@ #include #include #include +#include #include +#include +#include #include #include #include #include +#ifndef MICM_NUM_GRID_CELLS + #define MICM_NUM_GRID_CELLS 1 +#endif +#ifndef MICM_VECTOR_MATRIX_SIZE + #define MICM_VECTOR_MATRIX_SIZE 1 +#endif + namespace musica { @@ -28,6 +38,11 @@ namespace musica extern "C" { #endif + enum MICMSolver + { + Rosenbrock = 1, + RosenbrockStandardOrder, + }; struct SolverResultStats { @@ -87,7 +102,13 @@ namespace musica } }; - MICM *CreateMicm(const char *config_path, Error *error); + /// @brief Create a MICM object by specifying the solver type to use + /// @param config_path Path to configuration file or directory containing configuration file + /// @param solver_type Integer value representing solver type + /// 1 : Vector-ordered Rosenbrock solver + /// 2 : Standard-ordered Rosenbrock solver + /// @param error Error struct to indicate success or failure + MICM *CreateMicm(const char *config_path, short solver_type, Error *error); void DeleteMicm(const MICM *micm, Error *error); void MicmSolve( MICM *micm, @@ -116,12 +137,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 Create(const std::string &config_path, Error *error); + 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 CreateRosenbrockStandard(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] @@ -131,7 +158,9 @@ namespace musica /// @param num_custom_rate_parameters The size of the custom_rate_parameters array /// @param custom_rate_parameters Array of custom rate parameters /// @param error Error struct to indicate success or failure + template void Solve( + std::unique_ptr &solver, double time_step, double temperature, double pressure, @@ -144,15 +173,26 @@ namespace musica SolverResultStats *solver_stats, Error *error); + /// @brief Set solver type + /// @param solver_type Integer value representing solver type + void SetSolverType(short solver_type) + { + solver_type_ = solver_type; + } + /// @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); + template + std::map GetSpeciesOrdering(std::unique_ptr &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(std::unique_ptr &solver, Error *error); /// @brief Get a property for a chemical species /// @param species_name Name of the species @@ -162,20 +202,129 @@ 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: + short 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>; + 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>; + std::unique_ptr rosenbrock_standard_; + private: std::unique_ptr solver_parameters_; }; + template + inline void MICM::Solve( + std::unique_ptr &solver, + double time_step, + double temperature, + double pressure, + double air_density, + int num_concentrations, + double *concentrations, + int num_custom_rate_parameters, + double *custom_rate_parameters, + String *solver_state, + SolverResultStats *solver_stats, + Error *error) + { + try + { + micm::State state = solver->GetState(); + + for (std::size_t i{}; i < MICM_NUM_GRID_CELLS; i++) + { + state.conditions_[i].temperature_ = temperature; + state.conditions_[i].pressure_ = pressure; + state.conditions_[i].air_density_ = air_density; + } + + // + // TODO(jiwon) - set concentrations for vector matrix for more than 1 grid cells + // + state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); + 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_state = CreateString(micm::SolverStateToString(result.state_).c_str()); + + *solver_stats = SolverResultStats( + result.stats_.function_calls_, + result.stats_.jacobian_updates_, + result.stats_.number_of_steps_, + result.stats_.accepted_, + result.stats_.rejected_, + result.stats_.decompositions_, + result.stats_.solves_, + result.stats_.singular_, + result.final_time_); + + for (int i = 0; i < state.variables_.AsVector().size(); i++) + { + concentrations[i] = state.variables_.AsVector()[i]; + } + + DeleteError(error); + *error = NoError(); + } + catch (const std::system_error &e) + { + DeleteError(error); + *error = ToError(e); + } + } + + template + inline std::map MICM::GetSpeciesOrdering(std::unique_ptr &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 + std::map MICM::GetUserDefinedReactionRatesOrdering(std::unique_ptr &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 +350,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/src/micm/micm.cpp b/src/micm/micm.cpp index 7d03038e..aa714519 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -14,20 +14,37 @@ #include #include #include -#include +#include namespace musica { - MICM *CreateMicm(const char *config_path, Error *error) + + MICM *CreateMicm(const char *config_path, short solver_type, Error *error) { DeleteError(error); + if ((solver_type != 1) && (solver_type != 2)) + { + // TODO(jiwon) error msg? + return nullptr; + } + MICM *micm = new MICM(); - micm->Create(std::string(config_path), error); + if (solver_type == 1) + { + micm->SetSolverType(1); + micm->CreateRosenbrock(std::string(config_path), error); + } + else if (solver_type == 2) + { + micm->SetSolverType(2); + micm->CreateRosenbrockStandard(std::string(config_path), error); + } if (!IsSuccess(*error)) { delete micm; return nullptr; } + return micm; } @@ -65,19 +82,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 +125,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 +159,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 +227,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 +235,20 @@ 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>>(micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) + .SetSystem(solver_parameters_->system_) + .SetReactions(solver_parameters_->processes_) + .SetNumberOfGridCells(MICM_NUM_GRID_CELLS) + .SetIgnoreUnusedSpecies(true) + .Build()); DeleteError(error); *error = NoError(); @@ -193,97 +260,30 @@ namespace musica } } - void MICM::Solve( - double time_step, - double temperature, - double pressure, - double air_density, - int num_concentrations, - double *concentrations, - int num_custom_rate_parameters, - double *custom_rate_parameters, - String *solver_state, - SolverResultStats *solver_stats, - Error *error) + void MICM::CreateRosenbrockStandard(const std::string &config_path, Error *error) { try { - micm::State state = solver_->GetState(); - - for (std::size_t i{}; i < NUM_GRID_CELLS; i++) - { - state.conditions_[i].temperature_ = temperature; - state.conditions_[i].pressure_ = pressure; - state.conditions_[i].air_density_ = air_density; - } - - state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); - - 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_state = CreateString(micm::SolverStateToString(result.state_).c_str()); - - *solver_stats = SolverResultStats( - result.stats_.function_calls_, - result.stats_.jacobian_updates_, - result.stats_.number_of_steps_, - result.stats_.accepted_, - result.stats_.rejected_, - result.stats_.decompositions_, - result.stats_.solves_, - result.stats_.singular_, - result.final_time_); - - for (int i = 0; i < state.variables_.AsVector().size(); i++) - { - concentrations[i] = state.variables_.AsVector()[i]; - } - - DeleteError(error); - *error = NoError(); - } - catch (const std::system_error &e) - { - DeleteError(error); - *error = ToError(e); - } - } + micm::SolverConfig<> solver_config; + solver_config.ReadAndParse(std::filesystem::path(config_path)); + solver_parameters_ = std::make_unique(solver_config.GetSolverParams()); - 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(); - } - } + rosenbrock_standard_ = + std::make_unique(micm::CpuSolverBuilder( + micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) + .SetSystem(solver_parameters_->system_) + .SetReactions(solver_parameters_->processes_) + .SetNumberOfGridCells(MICM_NUM_GRID_CELLS) + .SetIgnoreUnusedSpecies(true) + .Build()); - 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(); } } diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 3821ceb8..2dbd6e3d 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -18,9 +18,10 @@ class MicmCApiTest : public ::testing::Test void SetUp() override { + short solver_type = 1; micm = nullptr; Error error; - micm = CreateMicm(config_path, &error); + micm = CreateMicm(config_path, solver_type, &error); ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); @@ -38,8 +39,9 @@ class MicmCApiTest : public ::testing::Test // Test case for bad configuration file path TEST_F(MicmCApiTest, BadConfigurationFilePath) { + short solver_type = 1; Error error = NoError(); - auto micm_bad_config = CreateMicm("bad config path", &error); + auto micm_bad_config = CreateMicm("bad config path", solver_type, &error); ASSERT_EQ(micm_bad_config, nullptr); ASSERT_TRUE(IsError(error, MICM_ERROR_CATEGORY_CONFIGURATION, MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH)); DeleteError(&error); @@ -189,18 +191,19 @@ TEST_F(MicmCApiTest, SolveMicmInstance) double air_density = pressure / (GAS_CONSTANT * temperature); int num_concentrations = 5; double concentrations[] = { 0.75, 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 Date: Wed, 3 Jul 2024 14:37:15 -0600 Subject: [PATCH 045/117] add vector matrix test --- src/test/unit/micm/micm_c_api.cpp | 78 ++++++++++++++++++++++++++++++- 1 file changed, 77 insertions(+), 1 deletion(-) diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 2dbd6e3d..4509d959 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -18,6 +18,7 @@ class MicmCApiTest : public ::testing::Test void SetUp() override { + // if 1, Vector-ordered Rosenbrock solver, else if 2, Standard-ordered Rosenbrock solver short solver_type = 1; micm = nullptr; Error error; @@ -47,6 +48,15 @@ TEST_F(MicmCApiTest, BadConfigurationFilePath) DeleteError(&error); } +// Test case for bad configuration file path +TEST_F(MicmCApiTest, BadSolverType) +{ + short solver_type = 999; + Error error = NoError(); + auto micm_bad_solver_type = CreateMicm("configs/chapman", solver_type, &error); + ASSERT_EQ(micm_bad_solver_type, nullptr); +} + // Test case for missing species property TEST_F(MicmCApiTest, MissingSpeciesProperty) { @@ -182,7 +192,7 @@ TEST_F(MicmCApiTest, GetUserDefinedReactionRatesOrdering) } // Test case for solving the MICM instance -TEST_F(MicmCApiTest, SolveMicmInstance) +TEST_F(MicmCApiTest, SolveMicmVectorMatrixInstance) { double time_step = 200.0; double temperature = 272.5; @@ -243,6 +253,72 @@ TEST_F(MicmCApiTest, SolveMicmInstance) DeleteError(&error); } +// Test case for solving the MICM instance +TEST_F(MicmCApiTest, SolveMicmStandardVectorInstance) +{ + short solver_type = 2; + micm = nullptr; + Error error; + micm = CreateMicm(config_path, solver_type, &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 = 5; + double concentrations[] = { 0.75, 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 Date: Wed, 3 Jul 2024 14:49:37 -0600 Subject: [PATCH 046/117] update fortran api --- fortran/test/fetch_content_integration/test_micm_api.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index c98eca9d..8d6baa11 100644 --- a/fortran/test/fetch_content_integration/test_micm_api.F90 +++ b/fortran/test/fetch_content_integration/test_micm_api.F90 @@ -42,13 +42,14 @@ 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 = 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_user_defined_reaction_rates = 3 user_defined_reaction_rates = (/ 0.1, 0.2, 0.3 /) @@ -56,7 +57,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, error) ASSERT( error%is_success() ) do i = 1, size( micm%species_ordering ) From 4546e4ae0a7c461ca294a7a0042f6c666193d104 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 3 Jul 2024 15:06:59 -0600 Subject: [PATCH 047/117] chage the build type --- cmake/dependencies.cmake | 4 +--- docker/Dockerfile.memcheck | 2 +- docker/Dockerfile.mpi | 2 +- docker/Dockerfile.mpi_openmp | 2 +- docker/Dockerfile.openmp | 2 +- 5 files changed, 5 insertions(+), 7 deletions(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index a03f30a3..0384870c 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -51,8 +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 401add1bb3d0db9cd13464ed0566dc2599f02ca9) - set_git_default(MICM_GIT_TAG musica-vector-ordered-rosenbrock) + set_git_default(MICM_GIT_TAG musica-vector-ordered-rosenbrock) #TODO(jiwon) need to update this FetchContent_Declare(micm GIT_REPOSITORY ${MICM_GIT_REPOSITORY} @@ -62,7 +61,6 @@ 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}) - message(STATUS "MICM vector-ordered matrix dimension: ${MICM_DEFAULT_VECTOR_MATRIX_SIZE}") FetchContent_MakeAvailable(micm) endif() diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index 70ff8934..cd943615 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Release +ARG BUILD_TYPE=Debug RUN dnf -y update \ && dnf -y install \ diff --git a/docker/Dockerfile.mpi b/docker/Dockerfile.mpi index 6d220bd2..fa85b48f 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Release +ARG BUILD_TYPE=Debug RUN dnf -y update \ && dnf install -y sudo \ diff --git a/docker/Dockerfile.mpi_openmp b/docker/Dockerfile.mpi_openmp index 07f11249..f48a4605 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Release +ARG BUILD_TYPE=Debug RUN dnf -y update \ && dnf install -y sudo \ diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index 8c9ef4ac..db379ebd 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Release +ARG BUILD_TYPE=Debug RUN dnf -y update \ && dnf install -y sudo \ From fa8248605f388f49e891d0f0866ce73884433c74 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 10:50:03 -0600 Subject: [PATCH 048/117] update python wrapper --- python/test/test_analytical.py | 3 ++- python/test/test_chapman.py | 3 ++- python/wrapper.cpp | 32 ++++++++++++++++++++++++++------ 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/python/test/test_analytical.py b/python/test/test_analytical.py index 6f973847..2e1257f1 100644 --- a/python/test/test_analytical.py +++ b/python/test/test_analytical.py @@ -11,7 +11,8 @@ def test_simulation(self): GAS_CONSTANT = 8.31446261815324 air_density = pressure / (GAS_CONSTANT * temperature) - solver = musica.create_solver("configs/analytical") + solver_type = 1 + solver = musica.create_solver("configs/analytical", solver_type) 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..8a3204d0 100644 --- a/python/test/test_chapman.py +++ b/python/test/test_chapman.py @@ -11,7 +11,8 @@ def test_micm_solve(self): air_density = pressure / (GAS_CONSTANT * temperature) concentrations = [0.75, 0.4, 0.8, 0.01, 0.02] - solver = musica.create_solver("configs/chapman") + solver_type = 1 + solver = musica.create_solver("configs/chapman", solver_type) rate_constant_ordering = musica.user_defined_reaction_rates(solver) ordering = musica.species_ordering(solver) diff --git a/python/wrapper.cpp b/python/wrapper.cpp index 7310baf9..b938adc8 100644 --- a/python/wrapper.cpp +++ b/python/wrapper.cpp @@ -12,16 +12,14 @@ PYBIND11_MODULE(musica, m) { py::class_(m, "MICM") .def(py::init<>()) - .def("create", &musica::MICM::Create) - .def("solve", &musica::MICM::Solve) .def("__del__", [](musica::MICM &micm) {}); m.def( "create_solver", - [](const char *config_path) + [](const char *config_path, short solver_type) { musica::Error error; - musica::MICM *micm = musica::CreateMicm(config_path, &error); + musica::MICM *micm = musica::CreateMicm(config_path, solver_type, &error); if (!musica::IsSuccess(error)) { std::string message = "Error creating solver: " + std::string(error.message_.value_); @@ -90,7 +88,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 +108,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 From 54ec3e7fcad5c888c94428b54f3ea7069c182c78 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 13:03:44 -0600 Subject: [PATCH 049/117] resolve memory leak --- fortran/micm.F90 | 14 ++++++++------ .../fetch_content_integration/test_micm_api.F90 | 3 ++- .../test_micm_box_model.F90 | 4 +++- src/test/unit/micm/micm_c_api.cpp | 15 +++++++++------ 4 files changed, 22 insertions(+), 14 deletions(-) diff --git a/fortran/micm.F90 b/fortran/micm.F90 index 854a4db8..d6dcdc9c 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -26,12 +26,13 @@ module musica_micm end type solver_stats_t_c interface - function create_micm_c(config_path, error) bind(C, name="CreateMicm") + function create_micm_c(config_path, solver_type, 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 + character(kind=c_char), intent(in) :: config_path(*) + integer(kind=c_int), value, intent(in) :: solver_type + 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") @@ -182,10 +183,11 @@ function get_micm_version() result(value) value = string_t(string_c) end function get_micm_version - function constructor(config_path, error) result( this ) + function constructor(config_path, solver_type, 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 type(error_t), intent(inout) :: error character(len=1, kind=c_char) :: c_config_path(len_trim(config_path)+1) integer :: n, i @@ -201,7 +203,7 @@ function constructor(config_path, error) result( this ) end do c_config_path(n+1) = c_null_char - this%ptr = create_micm_c(c_config_path, error_c) + this%ptr = create_micm_c(c_config_path, solver_type, error_c) error = error_t(error_c) if (.not. error%is_success()) then deallocate(this) diff --git a/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index 8d6baa11..c27de787 100644 --- a/fortran/test/fetch_content_integration/test_micm_api.F90 +++ b/fortran/test/fetch_content_integration/test_micm_api.F90 @@ -32,6 +32,7 @@ subroutine test_api() real(c_double), dimension(5) :: concentrations real(c_double), dimension(3) :: user_defined_reaction_rates character(len=256) :: config_path + integer(c_int) :: solver_type character(len=:), allocatable :: string_value real(c_double) :: double_value integer(c_int) :: int_value @@ -117,7 +118,7 @@ subroutine test_api() ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, \ MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) deallocate( micm ) - micm => micm_t( "configs/invalid", error ) + micm => micm_t( "configs/invalid", solver_type, error ) ASSERT( error%is_error( MICM_ERROR_CATEGORY_CONFIGURATION, \ MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH ) ) ASSERT( .not. associated( micm ) ) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index dfdc5aab..0552b7c8 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -15,6 +15,7 @@ program test_micm_box_model subroutine box_model() character(len=256) :: config_path + integer(c_int) :: solver_type real(c_double), parameter :: GAS_CONSTANT = 8.31446261815324_c_double ! J mol-1 K-1 @@ -38,6 +39,7 @@ subroutine box_model() integer :: i config_path = "configs/analytical" + solver_type = 2 time_step = 200 temperature = 273.0 @@ -47,7 +49,7 @@ subroutine box_model() concentrations = (/ 1.0, 1.0, 1.0 /) write(*,*) "Creating MICM solver..." - micm => micm_t(config_path, error) + micm => micm_t(config_path, solver_type, error) do i = 1, size( micm%species_ordering ) associate(the_mapping => micm%species_ordering(i)) diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 4509d959..67a97a67 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -18,8 +18,7 @@ class MicmCApiTest : public ::testing::Test void SetUp() override { - // if 1, Vector-ordered Rosenbrock solver, else if 2, Standard-ordered Rosenbrock solver - short solver_type = 1; + short solver_type = MICMSolver::Rosenbrock; micm = nullptr; Error error; micm = CreateMicm(config_path, solver_type, &error); @@ -249,17 +248,18 @@ TEST_F(MicmCApiTest, SolveMicmVectorMatrixInstance) 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 the MICM instance -TEST_F(MicmCApiTest, SolveMicmStandardVectorInstance) +TEST(RosenbrockStandardOrder, SolveMicmStandardOrderInstance) { - short solver_type = 2; - micm = nullptr; Error error; - micm = CreateMicm(config_path, solver_type, &error); + const char* config_path = "configs/chapman"; + short solver_type = MICMSolver::RosenbrockStandardOrder; + MICM* micm = CreateMicm(config_path, solver_type, &error); double time_step = 200.0; double temperature = 272.5; @@ -315,7 +315,10 @@ TEST_F(MicmCApiTest, SolveMicmStandardVectorInstance) 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); } From b36233056f794c01b52255a9d21571e72b55bd49 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 14:15:49 -0600 Subject: [PATCH 050/117] fix intel docker --- docker/Dockerfile.fortran-intel | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/docker/Dockerfile.fortran-intel b/docker/Dockerfile.fortran-intel index 1a724f4a..48e28a64 100644 --- a/docker/Dockerfile.fortran-intel +++ b/docker/Dockerfile.fortran-intel @@ -67,6 +67,4 @@ RUN cd musica/fortran/test/fetch_content_integration \ -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ && 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 From 30bfafcf25811dad4df31e34f38a351dd59fa337 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 14:27:57 -0600 Subject: [PATCH 051/117] tuvx on --- CMakeLists.txt | 2 +- include/musica/micm.hpp | 4 ++-- src/micm/micm.cpp | 4 ++-- src/test/unit/micm/micm_c_api.cpp | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9a73933d..c7d2aa50 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -28,7 +28,7 @@ option(MUSICA_ENABLE_OPENMP "Enable OpemMP support" OFF) option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) option(MUSICA_BUILD_DOCS "Build the documentation" OFF) option(MUSICA_ENABLE_MICM "Enable MICM" ON) -option(MUSICA_ENABLE_TUVX "Enable TUV-x" OFF) +option(MUSICA_ENABLE_TUVX "Enable TUV-x" ON) set(MUSICA_SET_MICM_NUM_GRID_CELLS "1" CACHE STRING "Set the number of grid cells for MICM Solver") set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "2" CACHE STRING "Set MICM vector-ordered matrix dimension") diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index 78f533ee..99f1eda7 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -102,7 +102,7 @@ namespace musica } }; - /// @brief Create a MICM object by specifying the solver type to use + /// @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 Integer value representing solver type /// 1 : Vector-ordered Rosenbrock solver @@ -145,7 +145,7 @@ namespace musica /// @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 CreateRosenbrockStandard(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 diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index aa714519..f21cfce7 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -37,7 +37,7 @@ namespace musica else if (solver_type == 2) { micm->SetSolverType(2); - micm->CreateRosenbrockStandard(std::string(config_path), error); + micm->CreateRosenbrockStandardOrder(std::string(config_path), error); } if (!IsSuccess(*error)) { @@ -260,7 +260,7 @@ namespace musica } } - void MICM::CreateRosenbrockStandard(const std::string &config_path, Error *error) + void MICM::CreateRosenbrockStandardOrder(const std::string &config_path, Error *error) { try { diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 67a97a67..22a9c3ab 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -210,7 +210,7 @@ TEST_F(MicmCApiTest, SolveMicmVectorMatrixInstance) ASSERT_TRUE(IsSuccess(error)); std::vector custom_rate_parameters(num_user_defined_reaction_rates, 0.0); - for (std::size_t i=0; i custom_rate_parameters(num_user_defined_reaction_rates, 0.0); - for (std::size_t i=0; i Date: Fri, 5 Jul 2024 14:37:11 -0600 Subject: [PATCH 052/117] micm git tag --- cmake/dependencies.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 0384870c..e2dc2eb4 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 musica-vector-ordered-rosenbrock) #TODO(jiwon) need to update this + set_git_default(MICM_GIT_TAG v3.5.0) FetchContent_Declare(micm GIT_REPOSITORY ${MICM_GIT_REPOSITORY} From b484cfefe276827e64b9284ce7ae3e1a984d8164 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 15:31:17 -0600 Subject: [PATCH 053/117] edit erorr --- include/musica/micm.hpp | 3 --- include/musica/util.hpp | 5 +++-- src/micm/micm.cpp | 7 +++++-- src/test/unit/micm/micm_c_api.cpp | 12 +++++++----- 4 files changed, 15 insertions(+), 12 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index 99f1eda7..fe7bc1d6 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -251,9 +251,6 @@ namespace musica state.conditions_[i].air_density_ = air_density; } - // - // TODO(jiwon) - set concentrations for vector matrix for more than 1 grid cells - // state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); state.custom_rate_parameters_.AsVector().assign( custom_rate_parameters, custom_rate_parameters + num_custom_rate_parameters); 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/src/micm/micm.cpp b/src/micm/micm.cpp index f21cfce7..d43260bc 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,6 +15,7 @@ #include #include #include +#include #include namespace musica @@ -22,9 +24,10 @@ namespace musica MICM *CreateMicm(const char *config_path, short solver_type, Error *error) { DeleteError(error); - if ((solver_type != 1) && (solver_type != 2)) + if ((solver_type != MICMSolver::Rosenbrock) && (solver_type != MICMSolver::RosenbrockStandardOrder)) { - // TODO(jiwon) error msg? + 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()); return nullptr; } diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 22a9c3ab..271aa83d 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -47,13 +47,15 @@ TEST_F(MicmCApiTest, BadConfigurationFilePath) DeleteError(&error); } -// Test case for bad configuration file path +// Test case for bad input for solver type TEST_F(MicmCApiTest, BadSolverType) { short solver_type = 999; Error error = NoError(); auto micm_bad_solver_type = CreateMicm("configs/chapman", solver_type, &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 @@ -190,8 +192,8 @@ TEST_F(MicmCApiTest, GetUserDefinedReactionRatesOrdering) DeleteMappings(reaction_rates_ordering, array_size); } -// Test case for solving the MICM instance -TEST_F(MicmCApiTest, SolveMicmVectorMatrixInstance) +// Test case for solving system with vector-ordered Rosenbrock solver +TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) { double time_step = 200.0; double temperature = 272.5; @@ -253,8 +255,8 @@ TEST_F(MicmCApiTest, SolveMicmVectorMatrixInstance) DeleteError(&error); } -// Test case for solving the MICM instance -TEST(RosenbrockStandardOrder, SolveMicmStandardOrderInstance) +// Test case for solving system with standard-ordered Rosenbrock solver +TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) { Error error; const char* config_path = "configs/chapman"; From 2d503773c6c71272a97ec7b9ae006174ffee6e56 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 15:58:31 -0600 Subject: [PATCH 054/117] opdate the option name for open mp --- docker/Dockerfile.openmp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index db379ebd..efc433b8 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -40,8 +40,8 @@ RUN cd musica \ && cmake -S . \ -B build \ -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ - -D ENABLE_OPENMP:BOOL=TRUE \ - -D ENABLE_TESTS=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/mpic++ \ From f4f65263cbdcea77ceeeee479cf7d6e7aad73e6f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 16:26:53 -0600 Subject: [PATCH 055/117] remove open mp fortran in c tests --- cmake/test_util.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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}") From b8481f6739e63c2b5e1ab17010e6596381fa954c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 5 Jul 2024 16:38:04 -0600 Subject: [PATCH 056/117] edit comment --- src/test/unit/micm/micm_c_api.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 271aa83d..d3f735ff 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -192,7 +192,7 @@ TEST_F(MicmCApiTest, GetUserDefinedReactionRatesOrdering) DeleteMappings(reaction_rates_ordering, array_size); } -// Test case for solving system with vector-ordered Rosenbrock solver +// Test case for solving system using vector-ordered Rosenbrock solver TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) { double time_step = 200.0; @@ -255,7 +255,7 @@ TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) DeleteError(&error); } -// Test case for solving system with standard-ordered Rosenbrock solver +// Test case for solving system using standard-ordered Rosenbrock solver TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) { Error error; From 52a5de272b9a1faf763a9038a4321b1b68dc7436 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 8 Jul 2024 10:24:13 -0600 Subject: [PATCH 057/117] Removed find_package lines in this version. --- tutorial/CMakeLists.txt | 7 ------- 1 file changed, 7 deletions(-) diff --git a/tutorial/CMakeLists.txt b/tutorial/CMakeLists.txt index 823efbea..a7961963 100644 --- a/tutorial/CMakeLists.txt +++ b/tutorial/CMakeLists.txt @@ -6,13 +6,6 @@ project( LANGUAGES CXX C Fortran ) -# mkdir build -# cd build -# cmake -Dmusica_DIR= -# -Dmusica-fortran_DIR= .. -find_package(musica) -find_package(musica-fortran) - # mkdir build # cd build # cmake -DMUSICA_INSTALL_DIR= .. From 5a67815162668db282c96492cdc65d78d9303c17 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 8 Jul 2024 16:03:56 -0600 Subject: [PATCH 058/117] replace unique ptr T to T --- include/musica/micm.hpp | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index fe7bc1d6..9ecaba34 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -160,7 +160,7 @@ namespace musica /// @param error Error struct to indicate success or failure template void Solve( - std::unique_ptr &solver, + T &solver, double time_step, double temperature, double pressure, @@ -185,14 +185,14 @@ namespace musica /// @param error Error struct to indicate success or failure /// @return Map of species names to their indices template - std::map GetSpeciesOrdering(std::unique_ptr &solver, Error *error); + 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 template - std::map GetUserDefinedReactionRatesOrdering(std::unique_ptr &solver, Error *error); + std::map GetUserDefinedReactionRatesOrdering(T &solver, Error *error); /// @brief Get a property for a chemical species /// @param species_name Name of the species @@ -227,7 +227,7 @@ namespace musica template inline void MICM::Solve( - std::unique_ptr &solver, + T &solver, double time_step, double temperature, double pressure, @@ -287,7 +287,7 @@ namespace musica } template - inline std::map MICM::GetSpeciesOrdering(std::unique_ptr &solver, Error *error) + inline std::map MICM::GetSpeciesOrdering(T &solver, Error *error) { try { @@ -305,7 +305,7 @@ namespace musica } template - std::map MICM::GetUserDefinedReactionRatesOrdering(std::unique_ptr &solver, Error *error) + std::map MICM::GetUserDefinedReactionRatesOrdering(T &solver, Error *error) { try { From 983a510125493d2df26988d071c20acea796f40c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 8 Jul 2024 16:25:38 -0600 Subject: [PATCH 059/117] replace tempalte with auto --- include/musica/micm.hpp | 106 ++-------------------------------------- src/micm/micm.cpp | 94 +++++++++++++++++++++++++++++++++++ 2 files changed, 97 insertions(+), 103 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index 9ecaba34..cd355bb4 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -158,9 +158,8 @@ namespace musica /// @param num_custom_rate_parameters The size of the custom_rate_parameters array /// @param custom_rate_parameters Array of custom rate parameters /// @param error Error struct to indicate success or failure - template void Solve( - T &solver, + auto &solver, double time_step, double temperature, double pressure, @@ -184,15 +183,13 @@ namespace musica /// @param solver Pointer to solver /// @param error Error struct to indicate success or failure /// @return Map of species names to their indices - template - std::map GetSpeciesOrdering(T &solver, Error *error); + std::map GetSpeciesOrdering(auto &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 - template - std::map GetUserDefinedReactionRatesOrdering(T &solver, Error *error); + std::map GetUserDefinedReactionRatesOrdering(auto &solver, Error *error); /// @brief Get a property for a chemical species /// @param species_name Name of the species @@ -225,103 +222,6 @@ namespace musica std::unique_ptr solver_parameters_; }; - template - inline void MICM::Solve( - T &solver, - double time_step, - double temperature, - double pressure, - double air_density, - int num_concentrations, - double *concentrations, - int num_custom_rate_parameters, - double *custom_rate_parameters, - String *solver_state, - SolverResultStats *solver_stats, - Error *error) - { - try - { - micm::State state = solver->GetState(); - - for (std::size_t i{}; i < MICM_NUM_GRID_CELLS; i++) - { - state.conditions_[i].temperature_ = temperature; - state.conditions_[i].pressure_ = pressure; - state.conditions_[i].air_density_ = air_density; - } - - state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); - 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_state = CreateString(micm::SolverStateToString(result.state_).c_str()); - - *solver_stats = SolverResultStats( - result.stats_.function_calls_, - result.stats_.jacobian_updates_, - result.stats_.number_of_steps_, - result.stats_.accepted_, - result.stats_.rejected_, - result.stats_.decompositions_, - result.stats_.solves_, - result.stats_.singular_, - result.final_time_); - - for (int i = 0; i < state.variables_.AsVector().size(); i++) - { - concentrations[i] = state.variables_.AsVector()[i]; - } - - DeleteError(error); - *error = NoError(); - } - catch (const std::system_error &e) - { - DeleteError(error); - *error = ToError(e); - } - } - - 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 - 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) { diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index d43260bc..a33b7f2b 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -290,4 +290,98 @@ namespace musica } } + void MICM::Solve( + auto &solver, + double time_step, + double temperature, + double pressure, + double air_density, + int num_concentrations, + double *concentrations, + int num_custom_rate_parameters, + double *custom_rate_parameters, + String *solver_state, + SolverResultStats *solver_stats, + Error *error) + { + try + { + micm::State state = solver->GetState(); + + for (std::size_t i{}; i < MICM_NUM_GRID_CELLS; i++) + { + state.conditions_[i].temperature_ = temperature; + state.conditions_[i].pressure_ = pressure; + state.conditions_[i].air_density_ = air_density; + } + + state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); + 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_state = CreateString(micm::SolverStateToString(result.state_).c_str()); + + *solver_stats = SolverResultStats( + result.stats_.function_calls_, + result.stats_.jacobian_updates_, + result.stats_.number_of_steps_, + result.stats_.accepted_, + result.stats_.rejected_, + result.stats_.decompositions_, + result.stats_.solves_, + result.stats_.singular_, + result.final_time_); + + for (int i = 0; i < state.variables_.AsVector().size(); i++) + { + concentrations[i] = state.variables_.AsVector()[i]; + } + + DeleteError(error); + *error = NoError(); + } + catch (const std::system_error &e) + { + DeleteError(error); + *error = ToError(e); + } + } + + std::map MICM::GetSpeciesOrdering(auto &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(); + } + } + + std::map MICM::GetUserDefinedReactionRatesOrdering(auto &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(); + } + } + } // namespace musica From 583162b40271623168c18205d84062f4116d2ec1 Mon Sep 17 00:00:00 2001 From: Matt Dawson Date: Tue, 9 Jul 2024 08:26:17 -0700 Subject: [PATCH 060/117] Add profiles for TUV-x (#171) * add profiles for TUV-x * update TUV-x commit * split tuvx source into separate headers and modules * split TUV-x interface into separate modules * allow grid creation * fix grid updates * update fortran tuvx wrapper * address cross-compiler issue * fix invalid free * update actions * fix grid map ownership problem * finish profile and profile_map * address review comments --- .github/workflows/ubuntu.yml | 2 +- cmake/dependencies.cmake | 2 +- docker/Dockerfile.fortran-gcc.integration | 1 + docker/Dockerfile.fortran-intel | 2 + docker/Dockerfile.fortran-nvhpc | 1 + fortran/CMakeLists.txt | 5 +- .../test_tuvx_api.F90 | 259 ++++++++++- fortran/tuvx.F90 | 337 -------------- fortran/tuvx/CMakeLists.txt | 8 + fortran/tuvx/grid.F90 | 256 +++++++++++ fortran/tuvx/grid_map.F90 | 179 ++++++++ fortran/tuvx/profile.F90 | 426 ++++++++++++++++++ fortran/tuvx/profile_map.F90 | 182 ++++++++ fortran/tuvx/tuvx.F90 | 177 ++++++++ fortran/util.F90 | 9 +- include/musica/tuvx.hpp | 123 ----- include/musica/tuvx/grid.hpp | 136 ++++++ include/musica/tuvx/grid_map.hpp | 100 ++++ include/musica/tuvx/profile.hpp | 199 ++++++++ include/musica/tuvx/profile_map.hpp | 100 ++++ include/musica/tuvx/tuvx.hpp | 71 +++ src/packaging/CMakeLists.txt | 6 +- src/test/unit/tuvx/tuvx_c_api.cpp | 315 ++++++++++++- src/tuvx/CMakeLists.txt | 8 + src/tuvx/grid.cpp | 159 +++++++ src/tuvx/grid_map.cpp | 173 +++++++ src/tuvx/interface.F90 | 125 +---- src/tuvx/interface_grid.F90 | 237 ++++++++++ src/tuvx/interface_grid_map.F90 | 177 ++++++++ src/tuvx/interface_profile.F90 | 384 ++++++++++++++++ src/tuvx/interface_profile_map.F90 | 178 ++++++++ src/tuvx/profile.cpp | 277 ++++++++++++ src/tuvx/profile_map.cpp | 173 +++++++ src/tuvx/tuvx.cpp | 131 +----- 34 files changed, 4211 insertions(+), 707 deletions(-) delete mode 100644 fortran/tuvx.F90 create mode 100644 fortran/tuvx/CMakeLists.txt create mode 100644 fortran/tuvx/grid.F90 create mode 100644 fortran/tuvx/grid_map.F90 create mode 100644 fortran/tuvx/profile.F90 create mode 100644 fortran/tuvx/profile_map.F90 create mode 100644 fortran/tuvx/tuvx.F90 delete mode 100644 include/musica/tuvx.hpp create mode 100644 include/musica/tuvx/grid.hpp create mode 100644 include/musica/tuvx/grid_map.hpp create mode 100644 include/musica/tuvx/profile.hpp create mode 100644 include/musica/tuvx/profile_map.hpp create mode 100644 include/musica/tuvx/tuvx.hpp create mode 100644 src/tuvx/grid.cpp create mode 100644 src/tuvx/grid_map.cpp create mode 100644 src/tuvx/interface_grid.F90 create mode 100644 src/tuvx/interface_grid_map.F90 create mode 100644 src/tuvx/interface_profile.F90 create mode 100644 src/tuvx/interface_profile_map.F90 create mode 100644 src/tuvx/profile.cpp create mode 100644 src/tuvx/profile_map.cpp 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/cmake/dependencies.cmake b/cmake/dependencies.cmake index ef501863..9b44a537 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -74,7 +74,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 80f896a0fb591987c2a79209377bd6f599b4fb6f) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/docker/Dockerfile.fortran-gcc.integration b/docker/Dockerfile.fortran-gcc.integration index 4df87708..5e7204ca 100644 --- a/docker/Dockerfile.fortran-gcc.integration +++ b/docker/Dockerfile.fortran-gcc.integration @@ -50,6 +50,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..3e0dac02 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 \ @@ -65,6 +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 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/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/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 6d57abcc..54b6e349 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -3,7 +3,7 @@ ! 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 use musica_util, only: assert, error_t implicit none @@ -55,37 +55,270 @@ 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 + type(grid_map_t), pointer :: grids + character(len=256) :: config_path + type(grid_t), pointer :: grid + type(profile_map_t), pointer :: profiles + type(profile_t), pointer :: profile, profile_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 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 /) 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() ) + 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 ) - deallocate( tuvx ) deallocate( grid ) + deallocate( grids ) + deallocate( profile ) + deallocate( profile_copy ) + deallocate( profiles ) + deallocate( tuvx ) end subroutine test_tuvx_solve 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..cb3eeb6c --- /dev/null +++ b/fortran/tuvx/CMakeLists.txt @@ -0,0 +1,8 @@ +target_sources(musica-fortran + PRIVATE + grid.F90 + grid_map.F90 + profile.F90 + profile_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..f53d6190 --- /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 edges and 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 diff --git a/fortran/tuvx/grid_map.F90 b/fortran/tuvx/grid_map.F90 new file mode 100644 index 00000000..c0d5e33f --- /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..a8348fb8 --- /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, c_size_t + 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..707633fe --- /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/tuvx.F90 b/fortran/tuvx/tuvx.F90 new file mode 100644 index 00000000..850f6f14 --- /dev/null +++ b/fortran/tuvx/tuvx.F90 @@ -0,0 +1,177 @@ +! 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 + + implicit none + +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + + private + public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_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 + 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 + ! 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 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> 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/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..34e5ab63 --- /dev/null +++ b/include/musica/tuvx/grid.hpp @@ -0,0 +1,136 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#pragma once + +#include +#include + +#include +#include +#include + +namespace musica +{ + class GridMap; + class Profile; + + /// @brief A grid struct used to access grid information in tuvx + struct Grid + { + + /// @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; + + /// @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..575f8dc6 --- /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 +#include + +namespace musica +{ + + /// @brief A grid map struct used to access grid information in tuvx + struct GridMap + { + 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..adc4402d --- /dev/null +++ b/include/musica/tuvx/profile.hpp @@ -0,0 +1,199 @@ +// 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 struct used to interact with TUV-x profiles (properties with values on a grid) + struct Profile + { + + /// @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..88ad5210 --- /dev/null +++ b/include/musica/tuvx/profile_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 +#include + +namespace musica +{ + + /// @brief A struct used to store a collection of profiles + struct ProfileMap + { + 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/tuvx.hpp b/include/musica/tuvx/tuvx.hpp new file mode 100644 index 00000000..22f79032 --- /dev/null +++ b/include/musica/tuvx/tuvx.hpp @@ -0,0 +1,71 @@ +// 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 + +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); + + ~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); + + // 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); + +#ifdef __cplusplus + } +#endif + +} // namespace musica diff --git a/src/packaging/CMakeLists.txt b/src/packaging/CMakeLists.txt index 2df3a57c..17c27bb3 100644 --- a/src/packaging/CMakeLists.txt +++ b/src/packaging/CMakeLists.txt @@ -72,7 +72,11 @@ 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/tuvx.F90 DESTINATION ${MUSICA_INSTALL_INCLUDE_DIR}/musica/fortran ) diff --git a/src/test/unit/tuvx/tuvx_c_api.cpp b/src/test/unit/tuvx/tuvx_c_api.cpp index c91c1ebe..d7ca87db 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,314 @@ 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); } diff --git a/src/tuvx/CMakeLists.txt b/src/tuvx/CMakeLists.txt index 9df87adb..4d9acdb4 100644 --- a/src/tuvx/CMakeLists.txt +++ b/src/tuvx/CMakeLists.txt @@ -1,6 +1,14 @@ target_sources(musica PRIVATE interface.F90 + interface_grid.F90 + interface_grid_map.F90 + interface_profile.F90 + interface_profile_map.F90 + grid.cpp + grid_map.cpp + profile.cpp + profile_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..3092cc13 --- /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..9b996c89 --- /dev/null +++ b/src/tuvx/grid_map.cpp @@ -0,0 +1,173 @@ +// 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..8c756bf5 100644 --- a/src/tuvx/interface.F90 +++ b/src/tuvx/interface.F90 @@ -3,14 +3,13 @@ ! 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 musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t + implicit none private @@ -93,108 +92,26 @@ 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 + 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 - ! result - type(c_ptr) :: grid_ptr + ! arguments + type(c_ptr), intent(in), value :: tuvx + integer(kind=c_int), intent(out) :: error_code - 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 + ! result + type(c_ptr) :: profile_map_ptr - 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) + ! variables + type(core_t), pointer :: core + type(profile_warehouse_t), pointer :: profile_warehouse - grid => grid_warehouse%get_grid(f_grid_name, f_grid_units) - - grid_ptr = c_loc(grid) + call c_f_pointer(tuvx, core) + profile_warehouse => core%get_profile_warehouse() - end function interal_get_grid - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - 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 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - 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(grid, f_grid) - - f_grid%edge_ = edges(1:num_edges) - - f_grid%delta_ = edges(2:num_edges) - edges(1:num_edges-1) - - f_grid%ncells_ = num_edges - 1 - - end subroutine internal_set_edges - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - 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) - - f_grid%mid_ = midpoints(1:num_midpoints) + profile_map_ptr = c_loc(profile_warehouse) - end subroutine internal_set_midpoints + end function internal_get_profile_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/tuvx/interface_grid.F90 b/src/tuvx/interface_grid.F90 new file mode 100644 index 00000000..62bb09a1 --- /dev/null +++ b/src/tuvx/interface_grid.F90 @@ -0,0 +1,237 @@ +! 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 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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(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 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 diff --git a/src/tuvx/interface_grid_map.F90 b/src/tuvx/interface_grid_map.F90 new file mode 100644 index 00000000..977eca1a --- /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..a6057095 --- /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/profile.cpp b/src/tuvx/profile.cpp new file mode 100644 index 00000000..ed500ad3 --- /dev/null +++ b/src/tuvx/profile.cpp @@ -0,0 +1,277 @@ +// 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..508afd08 --- /dev/null +++ b/src/tuvx/profile_map.cpp @@ -0,0 +1,173 @@ +// 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/tuvx.cpp b/src/tuvx/tuvx.cpp index 924054c2..712e20a9 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,16 @@ 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); + return tuvx->CreateProfileMap(error); } - void DeleteGrid(Grid *grid, Error *error) - { - *error = NoError(); - try - { - delete grid; - } - catch (const std::system_error &e) - { - *error = ToError(e); - } - } - - void SetEdges(Grid *grid, double edges[], std::size_t num_edges, Error *error) - { - DeleteError(error); - grid->SetEdges(edges, num_edges, 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 +107,28 @@ 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 - int error_code = 0; - grid_map_ = nullptr; - } - - 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; - } - - 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; - } - - Grid::~Grid() - { - 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(); + ProfileMap* profile_map = new ProfileMap(InternalGetProfileMap(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 profile map") }; + return nullptr; } + return profile_map; } } // namespace musica From 6e6df7ba55ca26278967af9825d2e60478f96afa Mon Sep 17 00:00:00 2001 From: GitHub Actions Date: Tue, 9 Jul 2024 15:26:46 +0000 Subject: [PATCH 061/117] Auto-format code using Clang-Format --- include/musica/tuvx/grid.hpp | 17 +++++++++++------ include/musica/tuvx/grid_map.hpp | 4 ++-- include/musica/tuvx/profile.hpp | 17 +++++++++++------ include/musica/tuvx/profile_map.hpp | 8 ++++---- include/musica/tuvx/tuvx.hpp | 8 ++++---- src/test/unit/tuvx/tuvx_c_api.cpp | 8 ++++---- src/tuvx/grid.cpp | 2 +- src/tuvx/grid_map.cpp | 21 ++++++++++++++------- src/tuvx/profile.cpp | 5 ++--- src/tuvx/profile_map.cpp | 11 ++++++++--- src/tuvx/tuvx.cpp | 4 ++-- 11 files changed, 63 insertions(+), 42 deletions(-) diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index 34e5ab63..3d52174e 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -2,8 +2,8 @@ // SPDX-License-Identifier: Apache-2.0 #pragma once -#include #include +#include #include #include @@ -17,7 +17,6 @@ namespace musica /// @brief A grid struct used to access grid information in tuvx struct Grid { - /// @brief Creates a grid instance /// @param grid_name The name of the grid /// @param units The units of the grid @@ -52,7 +51,7 @@ namespace musica 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 *grid_; // A valid pointer to a grid instance indicates ownership by this wrapper void *updater_; friend class GridMap; @@ -80,7 +79,7 @@ namespace musica /// @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); + 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 @@ -118,9 +117,15 @@ namespace musica // 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 *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 *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); diff --git a/include/musica/tuvx/grid_map.hpp b/include/musica/tuvx/grid_map.hpp index 575f8dc6..48a02e01 100644 --- a/include/musica/tuvx/grid_map.hpp +++ b/include/musica/tuvx/grid_map.hpp @@ -2,9 +2,9 @@ // SPDX-License-Identifier: Apache-2.0 #pragma once -#include -#include #include +#include +#include #include #include diff --git a/include/musica/tuvx/profile.hpp b/include/musica/tuvx/profile.hpp index adc4402d..147d970a 100644 --- a/include/musica/tuvx/profile.hpp +++ b/include/musica/tuvx/profile.hpp @@ -2,9 +2,9 @@ // SPDX-License-Identifier: Apache-2.0 #pragma once -#include #include #include +#include #include #include @@ -17,7 +17,6 @@ namespace musica /// @brief A struct used to interact with TUV-x profiles (properties with values on a grid) struct Profile { - /// @brief Creates a profile instance /// @param profile_name The name of the profile /// @param units The units of the profile @@ -79,11 +78,11 @@ namespace musica double GetExoLayerDensity(Error *error); private: - void *profile_; // A valid pointer to a profile instance indicates ownership by this wrapper + 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) @@ -176,7 +175,13 @@ namespace musica // 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 *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); @@ -190,7 +195,7 @@ namespace musica 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); + double InternalGetExoLayerDensity(void *profile, int *error_code); #ifdef __cplusplus } diff --git a/include/musica/tuvx/profile_map.hpp b/include/musica/tuvx/profile_map.hpp index 88ad5210..35fc8857 100644 --- a/include/musica/tuvx/profile_map.hpp +++ b/include/musica/tuvx/profile_map.hpp @@ -2,9 +2,9 @@ // SPDX-License-Identifier: Apache-2.0 #pragma once -#include -#include #include +#include +#include #include #include @@ -33,8 +33,8 @@ namespace musica /// @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 + /// @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 diff --git a/include/musica/tuvx/tuvx.hpp b/include/musica/tuvx/tuvx.hpp index 22f79032..e89d7685 100644 --- a/include/musica/tuvx/tuvx.hpp +++ b/include/musica/tuvx/tuvx.hpp @@ -5,9 +5,9 @@ // It also includes functions for creating and deleting TUVX instances with c binding. #pragma once -#include #include #include +#include #include #include @@ -22,7 +22,7 @@ namespace musica TUVX(); /// @brief Create an instance of tuvx from a configuration file - /// @param config_path Path to 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); @@ -32,8 +32,8 @@ namespace musica /// @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 + /// @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); diff --git a/src/test/unit/tuvx/tuvx_c_api.cpp b/src/test/unit/tuvx/tuvx_c_api.cpp index d7ca87db..b91ae930 100644 --- a/src/test/unit/tuvx/tuvx_c_api.cpp +++ b/src/test/unit/tuvx/tuvx_c_api.cpp @@ -74,7 +74,7 @@ TEST_F(TuvxCApiTest, CannotGetConfiguredGrid) 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_FALSE(IsSuccess(error)); // non-host grid ASSERT_EQ(grid, nullptr); DeleteGridMap(grid_map, &error); ASSERT_TRUE(IsSuccess(error)); @@ -153,7 +153,7 @@ TEST_F(TuvxCApiTest, CanCreateGridMap) 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); + Grid* foo_copy = GetGrid(grid_map, "foo", "m", &error); ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(foo_copy, nullptr); for (auto& edge : edge_values) @@ -193,7 +193,7 @@ TEST_F(TuvxCApiTest, CannotGetConfiguredProfile) 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_FALSE(IsSuccess(error)); // non-host profile ASSERT_EQ(profile, nullptr); DeleteProfileMap(profile_map, &error); ASSERT_TRUE(IsSuccess(error)); @@ -311,7 +311,7 @@ TEST_F(TuvxCApiTest, CanCreateProfileMap) 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); + Profile* foo_copy = GetProfile(profile_map, "foo", "molecule cm-3", &error); for (auto& edge : edge_values) { edge = -100.0; diff --git a/src/tuvx/grid.cpp b/src/tuvx/grid.cpp index 3092cc13..4815f0e2 100644 --- a/src/tuvx/grid.cpp +++ b/src/tuvx/grid.cpp @@ -11,7 +11,7 @@ namespace musica // Grid external C API functions - Grid *CreateGrid(const char* grid_name, const char* units, std::size_t num_sections, Error *error) + 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); diff --git a/src/tuvx/grid_map.cpp b/src/tuvx/grid_map.cpp index 9b996c89..bfe5c04b 100644 --- a/src/tuvx/grid_map.cpp +++ b/src/tuvx/grid_map.cpp @@ -16,7 +16,7 @@ namespace musica DeleteError(error); return new GridMap(error); } - + void DeleteGridMap(GridMap *grid_map, Error *error) { DeleteError(error); @@ -98,17 +98,23 @@ namespace musica 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") }; + *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") }; + *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") }; + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete grid during transfer of ownership to grid map") }; } grid->grid_ = nullptr; } @@ -136,13 +142,13 @@ namespace musica try { int error_code = 0; - void* grid_ptr = InternalGetGrid(grid_map_, grid_name, strlen(grid_name), grid_units, strlen(grid_units), &error_code); + 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); + 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") }; @@ -152,7 +158,8 @@ namespace musica InternalDeleteGrid(grid_ptr, &error_code); if (error_code != 0) { - *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to delete grid after getting updater") }; + *error = + Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to delete grid after getting updater") }; InternalDeleteGridUpdater(updater_ptr, &error_code); return nullptr; } diff --git a/src/tuvx/profile.cpp b/src/tuvx/profile.cpp index ed500ad3..c9b26c23 100644 --- a/src/tuvx/profile.cpp +++ b/src/tuvx/profile.cpp @@ -1,7 +1,7 @@ // Copyright (C) 2023-2024 National Center for Atmospheric Research // SPDX-License-Identifier: Apache-2.0 -#include #include +#include #include #include @@ -92,8 +92,7 @@ namespace musica 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); + 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") }; diff --git a/src/tuvx/profile_map.cpp b/src/tuvx/profile_map.cpp index 508afd08..57241eca 100644 --- a/src/tuvx/profile_map.cpp +++ b/src/tuvx/profile_map.cpp @@ -108,7 +108,9 @@ namespace musica 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") }; + *error = Error{ 1, + CreateString(MUSICA_ERROR_CATEGORY), + CreateString("Failed to delete profile after transfer of ownership to profile map") }; } profile->profile_ = nullptr; } @@ -136,7 +138,8 @@ namespace musica try { int error_code = 0; - void* profile_ptr = InternalGetProfile(profile_map_, profile_name, strlen(profile_name), profile_units, strlen(profile_units), &error_code); + 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") }; @@ -152,7 +155,9 @@ namespace musica 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") }; + *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; } diff --git a/src/tuvx/tuvx.cpp b/src/tuvx/tuvx.cpp index 712e20a9..7c17cf02 100644 --- a/src/tuvx/tuvx.cpp +++ b/src/tuvx/tuvx.cpp @@ -109,7 +109,7 @@ namespace musica { *error = NoError(); int error_code = 0; - GridMap* grid_map = new GridMap(InternalGetGridMap(tuvx_, &error_code)); + 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") }; @@ -122,7 +122,7 @@ namespace musica { *error = NoError(); int error_code = 0; - ProfileMap* profile_map = new ProfileMap(InternalGetProfileMap(tuvx_, &error_code)); + ProfileMap *profile_map = new ProfileMap(InternalGetProfileMap(tuvx_, &error_code)); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create profile map") }; From 997038bf17590bedd2cc4d156bfe5981e9da82aa Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 14:15:27 -0600 Subject: [PATCH 062/117] add map header --- include/musica/micm.hpp | 1 + src/micm/micm.cpp | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index cd355bb4..d3522995 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -18,6 +18,7 @@ #include #include +#include #include #include #include diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index a33b7f2b..26907ff4 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -32,14 +32,14 @@ namespace musica } MICM *micm = new MICM(); - if (solver_type == 1) + if (solver_type == MICMSolver::Rosenbrock) { - micm->SetSolverType(1); + micm->SetSolverType(MICMSolver::Rosenbrock); micm->CreateRosenbrock(std::string(config_path), error); } - else if (solver_type == 2) + else if (solver_type == MICMSolver::RosenbrockStandardOrder) { - micm->SetSolverType(2); + micm->SetSolverType(MICMSolver::RosenbrockStandardOrder); micm->CreateRosenbrockStandardOrder(std::string(config_path), error); } if (!IsSuccess(*error)) From 80a0f667befd905b2918efbd0ede9d02cdd5f74b Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 15:17:49 -0600 Subject: [PATCH 063/117] expose solver type enum to python --- python/test/test_analytical.py | 4 +--- python/test/test_chapman.py | 3 +-- python/wrapper.cpp | 6 +++++- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/python/test/test_analytical.py b/python/test/test_analytical.py index 2e1257f1..92230a16 100644 --- a/python/test/test_analytical.py +++ b/python/test/test_analytical.py @@ -11,9 +11,7 @@ def test_simulation(self): GAS_CONSTANT = 8.31446261815324 air_density = pressure / (GAS_CONSTANT * temperature) - solver_type = 1 - solver = musica.create_solver("configs/analytical", solver_type) - + solver = musica.create_solver("configs/analytical", musica.micmsolver.rosenbrock) 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 8a3204d0..7d11eaef 100644 --- a/python/test/test_chapman.py +++ b/python/test/test_chapman.py @@ -11,8 +11,7 @@ def test_micm_solve(self): air_density = pressure / (GAS_CONSTANT * temperature) concentrations = [0.75, 0.4, 0.8, 0.01, 0.02] - solver_type = 1 - solver = musica.create_solver("configs/chapman", solver_type) + solver = musica.create_solver("configs/chapman", musica.micmsolver.rosenbrock) rate_constant_ordering = musica.user_defined_reaction_rates(solver) ordering = musica.species_ordering(solver) diff --git a/python/wrapper.cpp b/python/wrapper.cpp index b938adc8..fb6cccbb 100644 --- a/python/wrapper.cpp +++ b/python/wrapper.cpp @@ -10,10 +10,14 @@ namespace py = pybind11; // Wraps micm.cpp PYBIND11_MODULE(musica, m) { - py::class_(m, "MICM") + py::class_(m, "micm") .def(py::init<>()) .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, short solver_type) From 23889c3231b7d852f2dc1ba523eb036d2c3ef038 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 16:28:14 -0600 Subject: [PATCH 064/117] back to template --- include/musica/micm.hpp | 22 +++++++++++++++++++++- python/wrapper.cpp | 2 +- src/micm/micm.cpp | 32 ++++++++++++++++---------------- 3 files changed, 38 insertions(+), 18 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index d3522995..a36b0bf7 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -184,7 +184,9 @@ namespace musica /// @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(auto &solver, 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 @@ -223,6 +225,24 @@ namespace musica 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 T MICM::GetSpeciesProperty(const std::string &species_name, const std::string &property_name, Error *error) { diff --git a/python/wrapper.cpp b/python/wrapper.cpp index fb6cccbb..6a9608ad 100644 --- a/python/wrapper.cpp +++ b/python/wrapper.cpp @@ -20,7 +20,7 @@ PYBIND11_MODULE(musica, m) m.def( "create_solver", - [](const char *config_path, short solver_type) + [](const char *config_path, musica::MICMSolver solver_type) { musica::Error error; musica::MICM *micm = musica::CreateMicm(config_path, solver_type, &error); diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index 26907ff4..133b0cf0 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -350,22 +350,22 @@ namespace musica } } - std::map MICM::GetSpeciesOrdering(auto &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(); - } - } + // std::map MICM::GetSpeciesOrdering(auto &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(); + // } + // } std::map MICM::GetUserDefinedReactionRatesOrdering(auto &solver, Error *error) { From 276bc8f523ff9839dc642b4b295aaaba1a51bdeb Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 16:36:36 -0600 Subject: [PATCH 065/117] back to template --- include/musica/micm.hpp | 21 ++++++++++++++++++++- src/micm/micm.cpp | 34 ---------------------------------- 2 files changed, 20 insertions(+), 35 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index a36b0bf7..63318a68 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -192,7 +192,8 @@ namespace musica /// @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(auto &solver, 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 @@ -243,6 +244,24 @@ namespace musica } } + 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) { diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index 133b0cf0..512cb9ef 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -350,38 +350,4 @@ namespace musica } } - // std::map MICM::GetSpeciesOrdering(auto &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(); - // } - // } - - std::map MICM::GetUserDefinedReactionRatesOrdering(auto &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(); - } - } - } // namespace musica From 2812b211a1056e5604691ffcc4ce346a788fda93 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 18:23:39 -0600 Subject: [PATCH 066/117] enum for solver type --- include/musica/micm.hpp | 15 +++++++-------- src/micm/micm.cpp | 2 +- src/test/unit/micm/micm_c_api.cpp | 11 ++++------- 3 files changed, 12 insertions(+), 16 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index 63318a68..c19fb08f 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -39,10 +39,11 @@ namespace musica extern "C" { #endif + /// @brief Types of MICM solver enum MICMSolver { - Rosenbrock = 1, - RosenbrockStandardOrder, + Rosenbrock = 1, // Vector-ordered Rosenbrock solver + RosenbrockStandardOrder, // Standard-ordered Rosenbrock solver }; struct SolverResultStats @@ -105,11 +106,9 @@ namespace musica /// @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 Integer value representing solver type - /// 1 : Vector-ordered Rosenbrock solver - /// 2 : Standard-ordered Rosenbrock solver + /// @param solver_type Type of MICMSolver /// @param error Error struct to indicate success or failure - MICM *CreateMicm(const char *config_path, short solver_type, Error *error); + MICM *CreateMicm(const char *config_path, MICMSolver solver_type, Error *error); void DeleteMicm(const MICM *micm, Error *error); void MicmSolve( MICM *micm, @@ -174,8 +173,8 @@ namespace musica Error *error); /// @brief Set solver type - /// @param solver_type Integer value representing solver type - void SetSolverType(short solver_type) + /// @param MICMSolver Type of MICMSolver + void SetSolverType(MICMSolver solver_type) { solver_type_ = solver_type; } diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index 512cb9ef..eb852b0f 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -21,7 +21,7 @@ namespace musica { - MICM *CreateMicm(const char *config_path, short solver_type, Error *error) + MICM *CreateMicm(const char *config_path, MICMSolver solver_type, Error *error) { DeleteError(error); if ((solver_type != MICMSolver::Rosenbrock) && (solver_type != MICMSolver::RosenbrockStandardOrder)) diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index d3f735ff..7a342ddd 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -18,10 +18,9 @@ class MicmCApiTest : public ::testing::Test void SetUp() override { - short solver_type = MICMSolver::Rosenbrock; micm = nullptr; Error error; - micm = CreateMicm(config_path, solver_type, &error); + micm = CreateMicm(config_path, MICMSolver::Rosenbrock, &error); ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); @@ -39,9 +38,8 @@ class MicmCApiTest : public ::testing::Test // Test case for bad configuration file path TEST_F(MicmCApiTest, BadConfigurationFilePath) { - short solver_type = 1; Error error = NoError(); - auto micm_bad_config = CreateMicm("bad config path", solver_type, &error); + auto micm_bad_config = CreateMicm("bad config path", MICMSolver::Rosenbrock, &error); ASSERT_EQ(micm_bad_config, nullptr); ASSERT_TRUE(IsError(error, MICM_ERROR_CATEGORY_CONFIGURATION, MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH)); DeleteError(&error); @@ -52,7 +50,7 @@ TEST_F(MicmCApiTest, BadSolverType) { short solver_type = 999; Error error = NoError(); - auto micm_bad_solver_type = CreateMicm("configs/chapman", solver_type, &error); + auto micm_bad_solver_type = CreateMicm("configs/chapman", static_cast(solver_type), &error); ASSERT_EQ(micm_bad_solver_type, nullptr); ASSERT_TRUE(IsError(error, MUSICA_ERROR_CATEGORY, MUSICA_ERROR_CODE_SOLVER_TYPE_NOT_FOUND)); DeleteError(&error); @@ -260,8 +258,7 @@ TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) { Error error; const char* config_path = "configs/chapman"; - short solver_type = MICMSolver::RosenbrockStandardOrder; - MICM* micm = CreateMicm(config_path, solver_type, &error); + MICM* micm = CreateMicm(config_path, MICMSolver::RosenbrockStandardOrder, &error); double time_step = 200.0; double temperature = 272.5; From 09bf9b88dbaeb3f84931a92c89c060bc1969ddd7 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 19:27:06 -0600 Subject: [PATCH 067/117] enum solver type for fortran --- fortran/micm.F90 | 6 ++++++ .../fetch_content_integration/test_micm_api.F90 | 3 ++- include/musica/micm.hpp | 2 +- src/micm/micm.cpp | 15 ++++++++------- 4 files changed, 17 insertions(+), 9 deletions(-) diff --git a/fortran/micm.F90 b/fortran/micm.F90 index d6dcdc9c..973b2e50 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -10,6 +10,7 @@ module musica_micm implicit none public :: micm_t, solver_stats_t, get_micm_version + public :: Rosenbrock, RosenbrockStandardOrder private !> Wrapper for c solver stats @@ -25,6 +26,11 @@ module musica_micm real(c_double) :: final_time_ = 0._c_double end type solver_stats_t_c + enum, bind(c) + enumerator :: Rosenbrock = 1, & + RosenbrockStandardOrder = 2 + end enum + interface function create_micm_c(config_path, solver_type, error) bind(C, name="CreateMicm") use musica_util, only: error_t_c diff --git a/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index c27de787..f03bb61a 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" @@ -44,7 +45,7 @@ subroutine test_api() integer :: i config_path = "configs/chapman" - solver_type = 1 + solver_type = Rosenbrock time_step = 200 temperature = 272.5 pressure = 101253.4 diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index c19fb08f..79184836 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -203,7 +203,7 @@ namespace musica T GetSpeciesProperty(const std::string &species_name, const std::string &property_name, Error *error); public: - short solver_type_; + MICMSolver solver_type_; /// @brief Vector-ordered Rosenbrock solver type using DenseMatrixVector = micm::VectorMatrix; diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index eb852b0f..6b002d4c 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -24,14 +24,8 @@ namespace musica MICM *CreateMicm(const char *config_path, MICMSolver solver_type, Error *error) { DeleteError(error); - if ((solver_type != MICMSolver::Rosenbrock) && (solver_type != MICMSolver::RosenbrockStandardOrder)) - { - 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()); - return nullptr; - } - MICM *micm = new MICM(); + if (solver_type == MICMSolver::Rosenbrock) { micm->SetSolverType(MICMSolver::Rosenbrock); @@ -42,6 +36,13 @@ namespace musica 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; From 680a2cb950c7497998e26520b95cf16ad060d341 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Tue, 9 Jul 2024 19:30:18 -0600 Subject: [PATCH 068/117] add fortran 2023 feature comment --- fortran/micm.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/fortran/micm.F90 b/fortran/micm.F90 index 973b2e50..72add656 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -26,6 +26,8 @@ module musica_micm 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, & RosenbrockStandardOrder = 2 From 61c87df0cf8c83a101cbc050e515a9ef2db25b1c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 10 Jul 2024 14:47:12 -0600 Subject: [PATCH 069/117] pass num grid cells to constructor --- CMakeLists.txt | 9 +-------- fortran/micm.F90 | 12 +++++++----- .../test_micm_api.F90 | 6 ++++-- .../test_micm_box_model.F90 | 7 +++++-- include/musica/micm.hpp | 11 ++++++++++- python/test/test_analytical.py | 3 ++- python/test/test_chapman.py | 3 ++- python/wrapper.cpp | 4 ++-- src/micm/micm.cpp | 18 ++++++++++-------- src/test/unit/micm/micm_c_api.cpp | 14 +++++++++----- 10 files changed, 52 insertions(+), 35 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index c7d2aa50..175f4b8b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -30,14 +30,7 @@ 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_NUM_GRID_CELLS "1" CACHE STRING "Set the number of grid cells for MICM Solver") -set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "2" CACHE STRING "Set MICM vector-ordered matrix dimension") - -if(${MUSICA_SET_MICM_NUM_GRID_CELLS} LESS ${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) - set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE ${MUSICA_SET_MICM_NUM_GRID_CELLS}) - message(STATUS "MICM vector matrix dimension must be less than or equal to the number of grid cells") - message(STATUS "MICM vector matrix dimension: " ${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) -endif() +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/fortran/micm.F90 b/fortran/micm.F90 index 72add656..db1ab198 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -29,16 +29,17 @@ module musica_micm ! 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, & - RosenbrockStandardOrder = 2 + enumerator :: Rosenbrock = 1 + enumerator :: RosenbrockStandardOrder = 2 end enum interface - function create_micm_c(config_path, solver_type, error) bind(C, name="CreateMicm") + 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 @@ -191,11 +192,12 @@ function get_micm_version() result(value) value = string_t(string_c) end function get_micm_version - function constructor(config_path, solver_type, error) result( this ) + 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 @@ -211,7 +213,7 @@ function constructor(config_path, solver_type, error) result( this ) end do c_config_path(n+1) = c_null_char - this%ptr = create_micm_c(c_config_path, solver_type, error_c) + 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) diff --git a/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index f03bb61a..24d9d31c 100644 --- a/fortran/test/fetch_content_integration/test_micm_api.F90 +++ b/fortran/test/fetch_content_integration/test_micm_api.F90 @@ -34,6 +34,7 @@ subroutine test_api() 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 @@ -46,6 +47,7 @@ subroutine test_api() config_path = "configs/chapman" solver_type = Rosenbrock + num_grid_cells = 1 time_step = 200 temperature = 272.5 pressure = 101253.4 @@ -59,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, solver_type, error) + micm => micm_t(config_path, solver_type, num_grid_cells, error) ASSERT( error%is_success() ) do i = 1, size( micm%species_ordering ) @@ -119,7 +121,7 @@ subroutine test_api() ASSERT( error%is_error( MICM_ERROR_CATEGORY_SPECIES, \ MICM_SPECIES_ERROR_CODE_PROPERTY_NOT_FOUND ) ) deallocate( micm ) - micm => micm_t( "configs/invalid", solver_type, error ) + 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 ) ) diff --git a/fortran/test/fetch_content_integration/test_micm_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index 0552b7c8..b80a4af1 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -5,6 +5,7 @@ program test_micm_box_model 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 @@ -16,6 +17,7 @@ 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 @@ -39,7 +41,8 @@ subroutine box_model() integer :: i config_path = "configs/analytical" - solver_type = 2 + solver_type = RosenbrockStandardOrder + num_grid_cells = 1 time_step = 200 temperature = 273.0 @@ -49,7 +52,7 @@ subroutine box_model() concentrations = (/ 1.0, 1.0, 1.0 /) write(*,*) "Creating MICM solver..." - micm => micm_t(config_path, solver_type, error) + 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)) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index 79184836..0613dce2 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -107,8 +107,9 @@ namespace musica /// @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, Error *error); + 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, @@ -179,6 +180,13 @@ namespace musica 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 @@ -222,6 +230,7 @@ namespace musica std::unique_ptr rosenbrock_standard_; private: + int num_grid_cells_; std::unique_ptr solver_parameters_; }; diff --git a/python/test/test_analytical.py b/python/test/test_analytical.py index 92230a16..d446447f 100644 --- a/python/test/test_analytical.py +++ b/python/test/test_analytical.py @@ -5,13 +5,14 @@ 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", musica.micmsolver.rosenbrock) + 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 7d11eaef..fdfd2745 100644 --- a/python/test/test_chapman.py +++ b/python/test/test_chapman.py @@ -4,6 +4,7 @@ class TestChapman(unittest.TestCase): def test_micm_solve(self): + num_grid_cells = 1 time_step = 200.0 temperature = 272.5 pressure = 101253.3 @@ -11,7 +12,7 @@ def test_micm_solve(self): air_density = pressure / (GAS_CONSTANT * temperature) concentrations = [0.75, 0.4, 0.8, 0.01, 0.02] - solver = musica.create_solver("configs/chapman", musica.micmsolver.rosenbrock) + 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) diff --git a/python/wrapper.cpp b/python/wrapper.cpp index 6a9608ad..8f828f19 100644 --- a/python/wrapper.cpp +++ b/python/wrapper.cpp @@ -20,10 +20,10 @@ PYBIND11_MODULE(musica, m) m.def( "create_solver", - [](const char *config_path, musica::MICMSolver solver_type) + [](const char *config_path, musica::MICMSolver solver_type, int num_grid_cells) { musica::Error error; - musica::MICM *micm = musica::CreateMicm(config_path, solver_type, &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_); diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index 6b002d4c..ff278e29 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -21,10 +21,11 @@ namespace musica { - MICM *CreateMicm(const char *config_path, MICMSolver solver_type, Error *error) + MICM *CreateMicm(const char *config_path, MICMSolver solver_type, int num_grid_cells, Error *error) { DeleteError(error); MICM *micm = new MICM(); + micm->SetNumGridCells(num_grid_cells); if (solver_type == MICMSolver::Rosenbrock) { @@ -250,7 +251,7 @@ namespace musica micm::LuDecomposition>>(micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) .SetSystem(solver_parameters_->system_) .SetReactions(solver_parameters_->processes_) - .SetNumberOfGridCells(MICM_NUM_GRID_CELLS) + .SetNumberOfGridCells(num_grid_cells_) .SetIgnoreUnusedSpecies(true) .Build()); @@ -277,7 +278,7 @@ namespace musica micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) .SetSystem(solver_parameters_->system_) .SetReactions(solver_parameters_->processes_) - .SetNumberOfGridCells(MICM_NUM_GRID_CELLS) + .SetNumberOfGridCells(num_grid_cells_) .SetIgnoreUnusedSpecies(true) .Build()); @@ -309,14 +310,15 @@ namespace musica { micm::State state = solver->GetState(); - for (std::size_t i{}; i < MICM_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); + state.custom_rate_parameters_.AsVector().assign( custom_rate_parameters, custom_rate_parameters + num_custom_rate_parameters); diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 7a342ddd..638b7742 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, MICMSolver::Rosenbrock, &error); + micm = CreateMicm(config_path, MICMSolver::Rosenbrock, num_grid_cells, &error); ASSERT_TRUE(IsSuccess(error)); DeleteError(&error); @@ -38,8 +39,9 @@ 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", MICMSolver::Rosenbrock, &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); @@ -49,8 +51,9 @@ TEST_F(MicmCApiTest, BadConfigurationFilePath) 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), &error); + 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); @@ -256,9 +259,10 @@ TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) // Test case for solving system using standard-ordered Rosenbrock solver TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) { - Error error; const char* config_path = "configs/chapman"; - MICM* micm = CreateMicm(config_path, MICMSolver::RosenbrockStandardOrder, &error); + 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; From 63bf31967982b278b784063e7ee4bbdd5ad9b5d0 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 10 Jul 2024 14:56:11 -0600 Subject: [PATCH 070/117] code clean up --- include/musica/micm.hpp | 3 --- src/CMakeLists.txt | 1 - src/micm/micm.cpp | 2 +- 3 files changed, 1 insertion(+), 5 deletions(-) diff --git a/include/musica/micm.hpp b/include/musica/micm.hpp index 0613dce2..a7356f6e 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -23,9 +23,6 @@ #include #include -#ifndef MICM_NUM_GRID_CELLS - #define MICM_NUM_GRID_CELLS 1 -#endif #ifndef MICM_VECTOR_MATRIX_SIZE #define MICM_VECTOR_MATRIX_SIZE 1 #endif diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 18fce6a1..54a5f60f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -17,7 +17,6 @@ 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_NUM_GRID_CELLS=${MUSICA_SET_MICM_NUM_GRID_CELLS}) target_compile_definitions(musica PUBLIC MICM_VECTOR_MATRIX_SIZE=${MUSICA_SET_MICM_VECTOR_MATRIX_SIZE}) # set the c++ standard for musica diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index ff278e29..dd5b804a 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -316,7 +316,7 @@ namespace musica state.conditions_[cell].pressure_ = pressure; state.conditions_[cell].air_density_ = air_density; } - + state.variables_.AsVector().assign(concentrations, concentrations + num_concentrations); state.custom_rate_parameters_.AsVector().assign( From 92d7db3fd9d3bcf7174ea3d18882dc8f7c4c5808 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 10 Jul 2024 16:35:27 -0600 Subject: [PATCH 071/117] space uniformly --- fortran/micm.F90 | 880 +++++++++--------- .../test_get_micm_version.F90 | 12 +- .../test_micm_box_model.F90 | 96 +- fortran/tuvx/grid.F90 | 412 ++++---- fortran/tuvx/grid_map.F90 | 280 +++--- fortran/tuvx/profile.F90 | 700 +++++++------- fortran/tuvx/profile_map.F90 | 286 +++--- fortran/tuvx/tuvx.F90 | 270 +++--- 8 files changed, 1468 insertions(+), 1468 deletions(-) diff --git a/fortran/micm.F90 b/fortran/micm.F90 index db1ab198..dc35145b 100644 --- a/fortran/micm.F90 +++ b/fortran/micm.F90 @@ -3,448 +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 - 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 + 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, 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 + 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/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_box_model.F90 b/fortran/test/fetch_content_integration/test_micm_box_model.F90 index b80a4af1..2af6aae9 100644 --- a/fortran/test/fetch_content_integration/test_micm_box_model.F90 +++ b/fortran/test/fetch_content_integration/test_micm_box_model.F90 @@ -1,74 +1,74 @@ program test_micm_box_model - use, intrinsic :: iso_c_binding - use, intrinsic :: ieee_arithmetic + 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 + 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 + implicit none - call box_model() + call box_model() contains - subroutine box_model() + subroutine box_model() - character(len=256) :: config_path - integer(c_int) :: solver_type - integer(c_int) :: num_grid_cells + 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), 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 + 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_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 + 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(string_t) :: solver_state + type(solver_stats_t) :: solver_stats + type(error_t) :: error - type(micm_t), pointer :: micm + type(micm_t), pointer :: micm - integer :: i + integer :: i - config_path = "configs/analytical" - solver_type = RosenbrockStandardOrder - num_grid_cells = 1 + 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) + time_step = 200 + temperature = 273.0 + pressure = 1.0e5 + air_density = pressure / (GAS_CONSTANT * temperature) - concentrations = (/ 1.0, 1.0, 1.0 /) + concentrations = (/ 1.0, 1.0, 1.0 /) - write(*,*) "Creating MICM solver..." - micm => micm_t(config_path, solver_type, num_grid_cells, error) + 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 + 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 + 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 ) + deallocate( micm ) - end subroutine box_model + end subroutine box_model end program test_micm_box_model diff --git a/fortran/tuvx/grid.F90 b/fortran/tuvx/grid.F90 index f53d6190..b0a99a04 100644 --- a/fortran/tuvx/grid.F90 +++ b/fortran/tuvx/grid.F90 @@ -2,255 +2,255 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_grid - use iso_c_binding, only: c_ptr, c_null_ptr - - implicit none + 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 edges and 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - + 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 edges and 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 + !> 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 + ! Return value + type(grid_t), pointer :: this - allocate( this ) - this%ptr_ = grid_c_ptr + allocate( this ) + this%ptr_ = grid_c_ptr - end function grid_t_ptr_constructor + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> 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 + ! 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 + ! Return value + type(grid_t), pointer :: this - type(error_t_c) :: error_c + 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) + 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges - n_edges = size(edges) + n_edges = size(edges) - call set_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) - error = error_t(error_c) + call set_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) - end subroutine set_edges + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edges - n_edges = size(edges) + n_edges = size(edges) - call get_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) - error = error_t(error_c) + call get_grid_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + error = error_t(error_c) - end subroutine get_edges - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints - n_midpoints = size(midpoints) + n_midpoints = size(midpoints) - call set_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) - error = error_t(error_c) + call set_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) - end subroutine set_midpoints + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoints - n_midpoints = size(midpoints) + n_midpoints = size(midpoints) - call get_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) - error = error_t(error_c) + call get_grid_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) - end subroutine get_midpoints - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + !> 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 + ! Arguments + type(grid_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! 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 + 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 subroutine finalize_grid_t - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module musica_tuvx_grid +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 index c0d5e33f..2b79410c 100644 --- a/fortran/tuvx/grid_map.F90 +++ b/fortran/tuvx/grid_map.F90 @@ -2,178 +2,178 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_grid_map - use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: c_ptr, c_null_ptr - implicit none + 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + !> 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 + allocate( this ) + this%ptr_ = grid_map_c_ptr - end function grid_map_t_ptr_constructor + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> 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 + ! Arguments + type(error_t), intent(inout) :: error - ! Return value - type(grid_map_t), pointer :: this + ! Return value + type(grid_map_t), pointer :: this - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - allocate( this ) - this%ptr_ = create_grid_map_c(error_c) - error = error_t(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 + 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 + ! 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 + ! 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + !> 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c - ! Return value - type(grid_t), pointer :: grid + ! 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)) + 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) + error = error_t(error_c) - end function get_grid + 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 + !> 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 + ! Arguments + type(grid_map_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! 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 + 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 subroutine finalize_grid_map_t - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx_grid_map diff --git a/fortran/tuvx/profile.F90 b/fortran/tuvx/profile.F90 index a8348fb8..68c8bd6a 100644 --- a/fortran/tuvx/profile.F90 +++ b/fortran/tuvx/profile.F90 @@ -2,425 +2,425 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_profile - use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: c_ptr, c_null_ptr - implicit none + 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, c_size_t - 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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, c_size_t + 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 + !> 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 + ! Return value + type(profile_t), pointer :: this - allocate( this ) - this%ptr_ = profile_c_ptr + allocate( this ) + this%ptr_ = profile_c_ptr - end function profile_t_ptr_constructor + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> 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 + ! 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 + ! 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) + ! 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edge_values - n_edge_values = size(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) + 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 + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_edge_values - n_edge_values = size(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) + 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoint_values - n_midpoint_values = size(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) + 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 + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_midpoint_values - n_midpoint_values = size(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) + 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_layer_densities - n_layer_densities = size(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) + 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 + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c + integer(kind=c_size_t) :: n_layer_densities - n_layer_densities = size(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) + 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + 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 + ! 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 + ! 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) + 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 + 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 + 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 + ! 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 + ! 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) + 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 - end subroutine calculate_exo_layer_density + ! Local variables + type(error_t_c) :: error_c - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - 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 + exo_layer_density = & + real(get_profile_exo_layer_density_c(this%ptr_, error_c), kind=dk) + error = error_t(error_c) - ! Arguments - class(profile_t), intent(inout) :: this - type(error_t), intent(inout) :: error + 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 - ! Return value - real(dk) :: exo_layer_density + ! Arguments + type(profile_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c + type(error_t) :: error - exo_layer_density = & - real(get_profile_exo_layer_density_c(this%ptr_, error_c), kind=dk) + 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 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 subroutine finalize_profile + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx_profile diff --git a/fortran/tuvx/profile_map.F90 b/fortran/tuvx/profile_map.F90 index 707633fe..53fd7072 100644 --- a/fortran/tuvx/profile_map.F90 +++ b/fortran/tuvx/profile_map.F90 @@ -2,181 +2,181 @@ ! SPDX-License-Identifier: Apache-2.0 ! module musica_tuvx_profile_map - use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: c_ptr, c_null_ptr - implicit none + 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 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + !> 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 + allocate( this ) + this%ptr_ = profile_map_c_ptr - end function profile_map_t_ptr_constructor + 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 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> 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 + ! Arguments + type(error_t), intent(inout) :: error - ! Return value - type(profile_map_t), pointer :: this + ! Return value + type(profile_map_t), pointer :: this - ! Local variables - type(error_t_c) error_c + ! Local variables + type(error_t_c) error_c - allocate( this ) - this%ptr_ = create_profile_map_c(error_c) - error = error_t(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 + 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 + ! 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 + ! Local variables + type(error_t_c) :: error_c - call add_profile_c(this%ptr_, profile%ptr_, error_c) - error = error_t(error_c) + call add_profile_c(this%ptr_, profile%ptr_, error_c) + error = error_t(error_c) - end subroutine add_profile - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + 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 + !> 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 + ! 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 + ! 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)) + 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) + error = error_t(error_c) - end function get_profile + 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 + !> 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 + ! Arguments + type(profile_map_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! 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 + 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 subroutine finalize_profile_map_t - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx_profile_map diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index 850f6f14..94e4edd0 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -2,176 +2,176 @@ ! 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 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 - implicit none + implicit none #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - private - public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_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 - 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 - ! Deallocate the tuvx instance - final :: finalize - end type tuvx_t - - interface tuvx_t - procedure constructor - end interface tuvx_t - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + private + public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_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 + 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 + ! 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 + !> 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 + ! 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 + ! 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 + ! Return value + type(tuvx_t), pointer :: this - allocate( 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 + 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) + 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 + 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 + !> 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 + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - ! Return value - type(grid_map_t), pointer :: grid_map + ! 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) + grid_map => grid_map_t(get_grid_map_c(this%ptr_, error_c)) + + error = error_t(error_c) - end function get_grids + 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 + !> 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 + ! Arguments + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error - ! Local variables - type(error_t_c) :: error_c + ! Local variables + type(error_t_c) :: error_c - ! Return value - type(profile_map_t), pointer :: profile_map + ! 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) + profile_map => profile_map_t(get_profile_map_c(this%ptr_, error_c)) + + error = error_t(error_c) - end function get_profiles + end function get_profiles - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !> Deallocate the tuvx instance - subroutine finalize(this) - use musica_util, only: error_t, error_t_c, assert + !> Deallocate the tuvx instance + subroutine finalize(this) + use musica_util, only: error_t, error_t_c, assert - ! Arguments - type(tuvx_t), intent(inout) :: this + ! Arguments + type(tuvx_t), intent(inout) :: this - ! Local variables - type(error_t_c) :: error_c - type(error_t) :: error + ! 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()) + 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 subroutine finalize - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module musica_tuvx From 15ae98873dd828bf60c9f0b6ea2f826a8d90c39d Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Thu, 11 Jul 2024 13:36:10 -0600 Subject: [PATCH 072/117] specify enabled languages in top level cmake --- CMakeLists.txt | 2 +- cmake/dependencies.cmake | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 175f4b8b..7741ceee 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.0 LANGUAGES C CXX Fortran) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH};${PROJECT_SOURCE_DIR}/cmake) set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_MODULE_PATH}/SetDefaults.cmake) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index df84a956..0e614583 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -42,7 +42,7 @@ endif() ################################################################################ # OpenMP if(MUSICA_ENABLE_OPENMP) - find_package(OpenMP REQUIRED) + find_package(OpenMP REQUIRED COMPONENTS C CXX Fortran) endif() ################################################################################ From e53faf221a6d43bd1d64c5f59e2d3081842c7117 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Thu, 11 Jul 2024 14:20:51 -0600 Subject: [PATCH 073/117] comment out the tuvx openmp tests --- CMakeLists.txt | 1 + fortran/test/unit/CMakeLists.txt | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 7741ceee..1e1fad9c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,6 +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.0 LANGUAGES C CXX Fortran) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH};${PROJECT_SOURCE_DIR}/cmake) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 27b0de76..3674dd88 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -12,9 +12,9 @@ if (MUSICA_ENABLE_TUVX) create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) - if (MUSICA_ENABLE_OPENMP) - create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) - endif() + # if (MUSICA_ENABLE_OPENMP) + # create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) + # endif() if (MUSICA_ENABLE_MPI) create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) endif() From 1f548debde37b017ced9b760dc5d34c19418a26c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Thu, 11 Jul 2024 14:27:23 -0600 Subject: [PATCH 074/117] revert back --- CMakeLists.txt | 3 +-- fortran/test/unit/CMakeLists.txt | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 1e1fad9c..175f4b8b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,8 +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.0 LANGUAGES C CXX Fortran) +project(musica-distribution VERSION 0.7.0) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH};${PROJECT_SOURCE_DIR}/cmake) set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_MODULE_PATH}/SetDefaults.cmake) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 3674dd88..27b0de76 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -12,9 +12,9 @@ if (MUSICA_ENABLE_TUVX) create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) - # if (MUSICA_ENABLE_OPENMP) - # create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) - # endif() + if (MUSICA_ENABLE_OPENMP) + create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) + endif() if (MUSICA_ENABLE_MPI) create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) endif() From 830b4266447db5b1d4393351cd25dca7b45b3717 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Thu, 11 Jul 2024 14:35:53 -0600 Subject: [PATCH 075/117] revert back --- cmake/dependencies.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 0e614583..df84a956 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -42,7 +42,7 @@ endif() ################################################################################ # OpenMP if(MUSICA_ENABLE_OPENMP) - find_package(OpenMP REQUIRED COMPONENTS C CXX Fortran) + find_package(OpenMP REQUIRED) endif() ################################################################################ From 7f0e27fcf6a078e9571a0532dd4f542adffeb87a Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 15 Jul 2024 10:57:46 -0600 Subject: [PATCH 076/117] Added tutorial/demo.f90 as a unit test. --- fortran/test/unit/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 27b0de76..55324a7d 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -6,6 +6,7 @@ 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) From d709ab0ded66c8a142a2a714ce8fa2558f607b96 Mon Sep 17 00:00:00 2001 From: GitHub Actions Date: Mon, 15 Jul 2024 20:17:40 +0000 Subject: [PATCH 077/117] Auto-format code using Clang-Format --- python/test/test_analytical.py | 5 ++++- python/test/test_chapman.py | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/python/test/test_analytical.py b/python/test/test_analytical.py index d446447f..fc46bd8a 100644 --- a/python/test/test_analytical.py +++ b/python/test/test_analytical.py @@ -12,7 +12,10 @@ def test_simulation(self): GAS_CONSTANT = 8.31446261815324 air_density = pressure / (GAS_CONSTANT * temperature) - solver = musica.create_solver("configs/analytical", musica.micmsolver.rosenbrock, num_grid_cells) + 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 fdfd2745..f61d79ec 100644 --- a/python/test/test_chapman.py +++ b/python/test/test_chapman.py @@ -12,7 +12,10 @@ def test_micm_solve(self): air_density = pressure / (GAS_CONSTANT * temperature) concentrations = [0.75, 0.4, 0.8, 0.01, 0.02] - solver = musica.create_solver("configs/chapman", musica.micmsolver.rosenbrock, num_grid_cells) + 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) From 0cea90be1c952c29d915812f6fed98962b8c9d80 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Tue, 16 Jul 2024 09:44:15 -0600 Subject: [PATCH 078/117] Set demo.f90 path with PROJECT_SOURCE_DIR. --- fortran/test/unit/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 55324a7d..800492df 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -6,7 +6,7 @@ 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) + create_standard_test_fortran(NAME demo_fortran SOURCES ${PROJECT_SOURCE_DIR}/../tutorial/demo.f90) endif() if (MUSICA_ENABLE_TUVX) From ab16ecd66823cd10415bf0142d268910f1b89177 Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Wed, 17 Jul 2024 10:24:29 -0600 Subject: [PATCH 079/117] Added tutorial dir .dockerignore. --- .dockerignore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.dockerignore b/.dockerignore index 536a22ad..85759380 100644 --- a/.dockerignore +++ b/.dockerignore @@ -13,7 +13,8 @@ !include/ !lib/ !src/ +!tutorial/ !python/ !pyproject.toml !LICENSE -!README.md \ No newline at end of file +!README.md From e6b2c2a7147d622bc209fde29ad4fbb918a62e8e Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 10:55:22 -0600 Subject: [PATCH 080/117] add radiator wrapper --- fortran/tuvx/grid.F90 | 2 +- fortran/tuvx/radiator.F90 | 294 ++++++++++++++++++++++++ fortran/tuvx/radiator_map.F90 | 180 +++++++++++++++ include/musica/tuvx/grid.hpp | 1 - include/musica/tuvx/grid_map.hpp | 1 - include/musica/tuvx/radiator_map.hpp | 95 ++++++++ src/tuvx/interface_grid.F90 | 331 +++++++++++++-------------- src/tuvx/interface_grid_map.F90 | 150 ++++++------ src/tuvx/interface_radiator.F90 | 279 ++++++++++++++++++++++ src/tuvx/interface_radiator_map.F90 | 168 ++++++++++++++ 10 files changed, 1257 insertions(+), 244 deletions(-) create mode 100644 fortran/tuvx/radiator.F90 create mode 100644 fortran/tuvx/radiator_map.F90 create mode 100644 include/musica/tuvx/radiator_map.hpp create mode 100644 src/tuvx/interface_radiator.F90 create mode 100644 src/tuvx/interface_radiator_map.F90 diff --git a/fortran/tuvx/grid.F90 b/fortran/tuvx/grid.F90 index b0a99a04..202b1b94 100644 --- a/fortran/tuvx/grid.F90 +++ b/fortran/tuvx/grid.F90 @@ -82,7 +82,7 @@ end subroutine get_grid_midpoints_c procedure :: set_edges ! Get grid edges procedure :: get_edges - ! Set the grid edges and midpoints + ! Set the grid midpoints procedure :: set_midpoints ! Get the grid midpoints procedure :: get_midpoints diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 new file mode 100644 index 00000000..dc550290 --- /dev/null +++ b/fortran/tuvx/radiator.F90 @@ -0,0 +1,294 @@ +! 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), intent(in) :: height_grid + type(c_ptr), 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="SetOpticalDepths") + 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="GetOpticalDepths") + 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="SetSingleScatteringAlbedos") + 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="GetSingleScatteringAlbedos") + 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_factor_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactor") + 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_factor + 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_factor_c + + subroutine get_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactor") + 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_factor + 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_factor_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 the radiator single scattering albedos + procedure :: set_single_scattering_albedos + ! Get the radiator single scattering albedos + procedure :: get_single_scattering_albedos + ! Set the radiator asymmetry_factor + procedure :: set_asymmetry_factor + ! Get the radiator asymmetry factor + procedure :: get_asymmetry_factor + ! Deallocate the 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 iso_c_binding, only: c_size_t, c_loc + use musica_util, only: error_t, error_t_c, to_c_string + + ! Arguments + character(len=*), intent(in) :: radiator_name + real(dk), target, dimension(:,:), intent(in) :: height_grid + real(dk), target, dimension(:,:), intent(in) :: wavelength_grid + type(error_t), intent(inout) :: error + + ! Return value + type(radiator_t), pointer :: this + + type(error_t_c) :: error_c + + allocate( this ) + !! + !! TODO(jiwon) - is it okay to c_loc() 2d array or should i create a new function + !! that does memory layout conversion + !! + this%ptr_ = create_radiator_c(to_c_string(radiator_name), c_loc(height_grid), & + c_loc(avelength_grid), error_c) + error = error_t(error_c) + + end function radiator_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(radiator_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_radiator_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(radiator_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_radiator_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(radiator_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_radiator_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(radiator_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_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + error = error_t(error_c) + + end subroutine get_midpoints + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !> 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/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index 3d52174e..c8bb4a60 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -2,7 +2,6 @@ // SPDX-License-Identifier: Apache-2.0 #pragma once -#include #include #include diff --git a/include/musica/tuvx/grid_map.hpp b/include/musica/tuvx/grid_map.hpp index 48a02e01..b1d95ae0 100644 --- a/include/musica/tuvx/grid_map.hpp +++ b/include/musica/tuvx/grid_map.hpp @@ -3,7 +3,6 @@ #pragma once #include -#include #include #include diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp new file mode 100644 index 00000000..980b65a7 --- /dev/null +++ b/include/musica/tuvx/radiator_map.hpp @@ -0,0 +1,95 @@ +// 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 radiator map struct used to access radiator information in tuvx + struct RadiatorMap + { + RadiatorMap(void *radiator_map) + : radiator_map_(radiator_map), + owns_radiator_map_(false) + { + } + + /// @brief @brief Creates a radiator map instance + /// @param error The error struct to indicate success or failure + RadiatorMap(Error *error); + + ~RadiatorMap(); + + /// @brief Adds a radiator to the radiator map + /// @param radiator The radiator to add + /// @param error The error struct 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 The name of the radiator + /// @param error The error struct to indicate success or failure + /// @return a radiator pointer + 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 a radiator map instance + /// @param error The error struct to indicate success or failure + /// @return a pointer to the radiator map + RadiatorMap *CreateRadiatorMap(Error *error); + + /// @brief Deletes a radiator map instance + /// @param radiator_map The radiator map to delete + /// @param error The error struct to indicate success or failure + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error); + + /// @brief Adds a radiator to the radiator map + /// @param radiator_map The radiator map to add the radiator to + /// @param radiator The radiator to add + /// @param error The error struct 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 The radiator map to get the radiator from + /// @param radiator_name The name of the radiator + /// @param error The error struct 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 InternalDeleteRadiatordMap(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/src/tuvx/interface_grid.F90 b/src/tuvx/interface_grid.F90 index 62bb09a1..6e211695 100644 --- a/src/tuvx/interface_grid.F90 +++ b/src/tuvx/interface_grid.F90 @@ -16,12 +16,11 @@ module tuvx_interface_grid 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 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 @@ -30,12 +29,12 @@ function internal_create_grid(grid_name, grid_name_length, 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) @@ -48,190 +47,190 @@ function internal_create_grid(grid_name, grid_name_length, units, & 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) - + 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(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 + 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 - 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 + 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_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_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_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 + 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 +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 index 977eca1a..c0eaf250 100644 --- a/src/tuvx/interface_grid_map.F90 +++ b/src/tuvx/interface_grid_map.F90 @@ -17,31 +17,31 @@ module tuvx_interface_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - 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 + 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -90,56 +90,56 @@ 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 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 new file mode 100644 index 00000000..6588a298 --- /dev/null +++ b/src/tuvx/interface_radiator.F90 @@ -0,0 +1,279 @@ +! 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, & + wavelength_grid, 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, only : grid_t + + ! arguments + type(c_ptr) :: radiator + character(kind=c_char, len=1), dimension(*), intent(in) :: radiator_name + integer(kind=c_size_t), intent(in), value :: radiator_name_length + type(c_ptr), intent(in), value :: height_grid + type(c_ptr), intent(in), value :: wavelength_grid + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_from_host_t), pointer :: f_radiator + type(string_t) :: f_name + type(grid_t) :: f_height_grid + type(grid_t) :: f_wavelength_grid + + 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, f_height_grid) + call c_f_pointer(wavelength_grid, f_wavelength_grid) + f_radiator => radiator_from_host_t(f_name, f_height_grid, f_wavelength_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(grid_radiator_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), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: 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), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: 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), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: 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), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: 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_factor(radiator_updater, asymmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error_code) & + bind(C, name="InternalSetAsymmetryFactor") + 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_factor + integer(kind=c_size_t), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_size_t), intent(in), value :: num_streams + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiator_updater_t), pointer :: f_updater + real(kind=dk), pointer :: f_asymmetry_factor(:,:,:) + + call c_f_pointer(radiator_updater, f_updater) + call c_f_pointer(asymmetry_factor, f_asymmetry_factor, [num_vertical_layers, num_wavelength_bins, num_streams]) + + if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & + (size(f_updater%radiator_%state_%layer_SSA_, 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_factor(:,:,:) + + end subroutine internal_set_asymmetry_factor + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +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..1d30e33c --- /dev/null +++ b/src/tuvx/interface_radiator_map.F90 @@ -0,0 +1,168 @@ +! 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_warehouse, only : radiator_warehouse_t + use tuvx_radiator, only : radiator_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), intent(in), value :: 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), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: 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), intent(in), value :: radiator_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name + integer(kind=c_size_t), value :: c_radiator_name_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + class(radiator_t), pointer :: f_radiator + type(radiator_warehouse_t), pointer :: radiator_warehouse + character(len=:), allocatable :: f_radiator_name + + ! 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) + + f_radiator => radiator_warehouse%get_radiator(f_radiator_name) + + 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 function interal_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, gradiator_updater_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: 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 From 63a3fa2532dafa6c6e6cbdf5f8080849611ebd68 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 11:59:33 -0600 Subject: [PATCH 081/117] working-on file of radiator header --- fortran/tuvx/radiator.F90 | 148 ++++++++++++++------ include/musica/tuvx/radiator.hpp | 227 +++++++++++++++++++++++++++++++ 2 files changed, 336 insertions(+), 39 deletions(-) create mode 100644 include/musica/tuvx/radiator.hpp diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index dc550290..1b4523e6 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -78,29 +78,29 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, type(error_t_c), intent(inout) :: error end subroutine get_single_scattering_albedos_c - subroutine set_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & - num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactor") + subroutine set_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") 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_factor + 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_factor_c + end subroutine set_asymmetry_factors_c - subroutine get_asymmetry_factor_c(radiator, symmetry_factor, num_vertical_layers, & - num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactor") + subroutine get_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactors") 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_factor + 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_factor_c + end subroutine get_asymmetry_factors_c end interface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -116,10 +116,10 @@ end subroutine get_asymmetry_factor_c procedure :: set_single_scattering_albedos ! Get the radiator single scattering albedos procedure :: get_single_scattering_albedos - ! Set the radiator asymmetry_factor - procedure :: set_asymmetry_factor - ! Get the radiator asymmetry factor - procedure :: get_asymmetry_factor + ! Set the radiator asymmetry_factors + procedure :: set_asymmetry_factors + ! Get the radiator asymmetry factors + procedure :: get_asymmetry_factors ! Deallocate the radiator instance final :: finalize_radiator_t end type radiator_t @@ -180,94 +180,164 @@ end function radiator_t_constructor !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_edges(this, edges, error) + 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) :: edges - type(error_t), intent(inout) :: error + 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) :: n_edges + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_edges = size(edges) + num_vertical_layers = size(optical_depths, 1) + num_wavelength_bins = size(optical_depths, 2) - call set_radiator_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + 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_edges !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_edges(this, edges, error) + 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(inout) :: edges + 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) :: n_edges + type(error_t_c) :: error_c + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_edges = size(edges) + num_vertical_layers = size(optical_depths, 1) + num_wavelength_bins = size(optical_depths, 2) - call get_radiator_edges_c(this%ptr_, c_loc(edges), n_edges, error_c) + 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_edges + end subroutine get_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_midpoints(this, midpoints, error) + 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) :: midpoints + 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) :: n_midpoints + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_midpoints = size(midpoints) + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) - call set_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + 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_midpoints + end subroutine set_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_midpoints(this, midpoints, error) + 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(inout) :: midpoints + 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) :: n_midpoints + integer(kind=c_size_t) :: num_vertical_layers + integer(kind=c_size_t) :: num_wavelength_bins - n_midpoints = size(midpoints) + num_vertical_layers = size(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) - call get_radiator_midpoints_c(this%ptr_, c_loc(midpoints), n_midpoints, error_c) + 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_midpoints + end subroutine get_single_scattering_albedos + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_asymmetry_factors(this, symmetry_factor, 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(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) + num_streams = size(num_streams, 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, symmetry_factor, 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(single_scattering_albedos, 1) + num_wavelength_bins = size(single_scattering_albedos, 2) + num_streams = size(num_streams, 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_single_scattering_albedos + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !> Deallocate the radiator instance subroutine finalize_radiator_t(this) use iso_c_binding, only: c_associated diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp new file mode 100644 index 00000000..e5ff2ae6 --- /dev/null +++ b/include/musica/tuvx/radiator.hpp @@ -0,0 +1,227 @@ +// 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 RadiatorMap; + class Profile; + + /// @brief A grid struct used to access grid information in tuvx + struct Radiator + { + /// @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 + Radiator(const char *grid_name, const char *units, std::size_t num_sections, Error *error); + + ~Radiator(); + + /// @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 RadiatorMap; + friend class Profile; + + /// @brief Wraps an existing grid instance. Used by RadiatorMap + /// @param updater The updater for the grid + Radiator(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 radiator instance + /// @param radiator_name The name of the radiator + /// @param height_grid The height grid + /// @param wavelength_grid The wavelength grid + /// @param error The error struct to indicate success or failure + Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + + /// @brief Deletes a TUV-x radiator instance + /// @param radiator The radiator to delete + /// @param error The error struct to indicate success or failure + void DeleteRadiator(Radiator *radiator, Error *error); + + /// @brief Sets the values of the optical depths of the radiator + /// @param radiator The radiator to get the optical depths + /// @param optical_depths The optical depths values to get for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void SetOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets the values of the optical depths of the radiator + /// @param radiator The radiator to set the optical depths + /// @param optical_depths The optical depths values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void GetOpticalDepths( + Radiator *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets the values of the single scattering albedos + /// @param radiator The radiator to set the single scattering albedos of + /// @param single_scattering_albedos The single scattering albedos values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void SetSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Gets the values of the single scattering albedos + /// @param radiator The radiator to get the single scattering albedos of + /// @param single_scattering_albedos The single scattering albedos values to get for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct to indicate success or failure + void GetSingleScatteringAlbedos( + Radiator *radiator, + double *single_scattering_albedos, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + Error *error); + + /// @brief Sets the values of the asymmetry factors + /// @param radiator The radiator to set the asymmetery factors of + /// @param single_scattering_albedos The asymmetery factors values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct to indicate success or failure + void SetAsymmetryFactors( + 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 the values of the asymmetry factors + /// @param radiator The radiator to get the asymmetery factors of + /// @param single_scattering_albedos The asymmetery factors values to get for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct to indicate success or failure + void GetAsymmetryFactors( + 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, + Grid *hegiht_grid, + Grid *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 From 42e28173a12f0791a5694c08f259307997b55a81 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 12:09:01 -0600 Subject: [PATCH 082/117] fix typos, and incomplete parts --- fortran/tuvx/radiator.F90 | 4 +- include/musica/tuvx/radiator.hpp | 66 ++++++++++++++++++++++++-------- 2 files changed, 53 insertions(+), 17 deletions(-) diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 1b4523e6..1f7a4a9d 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -78,7 +78,7 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, type(error_t_c), intent(inout) :: error end subroutine get_single_scattering_albedos_c - subroutine set_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + subroutine set_asymmetry_factors_c(radiator, asymmetry_factor, num_vertical_layers, & num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c @@ -201,7 +201,7 @@ subroutine set_optical_depths(this, optical_depths, error) num_vertical_layers, num_wavelength_bins, error_c) error = error_t(error_c) - end subroutine set_edges + end subroutine set_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index e5ff2ae6..c14922a5 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -27,17 +27,21 @@ namespace musica ~Radiator(); - /// @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 Sets the optical_depths + /// @param edges The 2 dimensional optical_depths + /// @param num_vertical_layers The number of vertical layers + /// @param um_wavelength_bins The number of vertical layers + /// @param error The error struct 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 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 Gets the optical_depths + /// @param edges The 2 dimensional optical_depths + /// @param num_vertical_layers The number of vertical layers + /// @param um_wavelength_bins The number of vertical layers + /// @param error The error struct 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 Set the midpoints of the grid /// @param midpoints The midpoints of the grid @@ -45,6 +49,41 @@ namespace musica /// @param error the error struct to indicate success or failure void SetMidpoints(double midpoints[], std::size_t num_midpoints, Error *error); + /// @brief Sets the values of the single scattering albedos + /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct 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 the values of the single scattering albedos + /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param error The error struct 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 Sets the values of the asymmetry factors + /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct 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 Get the midpoints of the grid /// @param midpoints The midpoints of the grid /// @param num_midpoints the number of midpoints @@ -140,8 +179,7 @@ namespace musica Error *error); /// @brief Sets the values of the asymmetry factors - /// @param radiator The radiator to set the asymmetery factors of - /// @param single_scattering_albedos The asymmetery factors values to set for the radiator + /// @param asymmetry_factor The 3 dimensional asymmetery factors values to set for the radiator /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -155,14 +193,12 @@ namespace musica Error *error); /// @brief Gets the values of the asymmetry factors - /// @param radiator The radiator to get the asymmetery factors of - /// @param single_scattering_albedos The asymmetery factors values to get for the radiator + /// @param asymmetry_factor The 3 dimensional asymmetery factors values to get for the radiator /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams /// @param error The error struct to indicate success or failure void GetAsymmetryFactors( - Radiator *radiator, double *asymmetry_factor, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, From 0f4d39af5f078f0740c0a674538d363219be0f1b Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 14:59:43 -0600 Subject: [PATCH 083/117] code clean up --- include/musica/tuvx/radiator.hpp | 65 ++++++++++++++++---------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index c14922a5..a20dc8c0 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -15,40 +15,34 @@ namespace musica class RadiatorMap; class Profile; - /// @brief A grid struct used to access grid information in tuvx + /// @brief A radiator struct used to access radiator information in tuvx struct Radiator { - /// @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 + /// @brief Creates a radiator instance + /// @param radiator_name The name of the radiator + /// @param height_grid The height grid + /// @param wavelength_grid The wavelength grid /// @param error The error struct to indicate success or failure - Radiator(const char *grid_name, const char *units, std::size_t num_sections, Error *error); + Radiator(const char *radiator_name, Grid* height_grid, Grid* wavelength_grid, Error *error); ~Radiator(); /// @brief Sets the optical_depths - /// @param edges The 2 dimensional optical_depths + /// @param optical_depths The 2 dimensional optical_depths /// @param num_vertical_layers The number of vertical layers - /// @param um_wavelength_bins The number of vertical layers + /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct 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 the optical_depths - /// @param edges The 2 dimensional optical_depths + /// @param optical_depths The 2 dimensional optical_depths /// @param num_vertical_layers The number of vertical layers - /// @param um_wavelength_bins The number of vertical layers + /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct 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 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 Sets the values of the single scattering albedos /// @param single_scattering_albedos The 2 dimensional single scattering albedos values /// @param num_vertical_layers The number of vertical layers @@ -65,7 +59,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void SetSingleScatteringAlbedos( + void GetSingleScatteringAlbedos( double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, @@ -84,23 +78,30 @@ namespace musica std::size_t num_streams, 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); + /// @brief Gets the values of the asymmetry factors + /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param num_vertical_layers The number of vertical layers + /// @param num_wavelength_bins The number of wavelength bins + /// @param num_streams The number of streams + /// @param error The error struct 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 *grid_; // A valid pointer to a grid instance indicates ownership by this wrapper + void *radiator_; // A valid pointer to a grid instance indicates ownership by this wrapper void *updater_; - friend class RadiatorMap; - friend class Profile; + // friend class RadiatorMap; + // friend class Profile; /// @brief Wraps an existing grid instance. Used by RadiatorMap /// @param updater The updater for the grid Radiator(void *updater) - : grid_(nullptr), + : radiator_(nullptr), updater_(updater) { } @@ -132,7 +133,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void SetOpticalDepths( + void SetRadiatorOpticalDepths( Radiator *radiator, double *optical_depths, std::size_t num_vertical_layers, @@ -145,7 +146,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void GetOpticalDepths( + void GetRadiatorOpticalDepths( Radiator *radiator, double *optical_depths, std::size_t num_vertical_layers, @@ -158,7 +159,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void SetSingleScatteringAlbedos( + void SetRadiatorSingleScatteringAlbedos( Radiator *radiator, double *single_scattering_albedos, std::size_t num_vertical_layers, @@ -171,7 +172,7 @@ namespace musica /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure - void GetSingleScatteringAlbedos( + void GetRadiatorSingleScatteringAlbedos( Radiator *radiator, double *single_scattering_albedos, std::size_t num_vertical_layers, @@ -184,7 +185,7 @@ namespace musica /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams /// @param error The error struct to indicate success or failure - void SetAsymmetryFactors( + void SetRadiatorAsymmetryFactors( Radiator *radiator, double *asymmetry_factor, std::size_t num_vertical_layers, @@ -198,7 +199,7 @@ namespace musica /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams /// @param error The error struct to indicate success or failure - void GetAsymmetryFactors( + void GetRadiatorAsymmetryFactors( double *asymmetry_factor, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, From 6cdef231a429dfd048abb75ae4792ac205140b3d Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 16:18:22 -0600 Subject: [PATCH 084/117] add radiator src --- include/musica/tuvx/radiator.hpp | 6 +- src/tuvx/radiator.cpp | 279 +++++++++++++++++++++++++++++++ src/tuvx/radiator_map.cpp | 186 +++++++++++++++++++++ 3 files changed, 468 insertions(+), 3 deletions(-) create mode 100644 src/tuvx/radiator.cpp create mode 100644 src/tuvx/radiator_map.cpp diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index a20dc8c0..a5595821 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -92,14 +92,14 @@ namespace musica Error *error); private: - void *radiator_; // A valid pointer to a grid instance indicates ownership by this wrapper + void *radiator_; // A valid pointer to a radiator instance indicates ownership by this wrapper void *updater_; // friend class RadiatorMap; // friend class Profile; - /// @brief Wraps an existing grid instance. Used by RadiatorMap - /// @param updater The updater for the grid + /// @brief Wraps an existing radiator instance. Used by RadiatorMap + /// @param updater The updater for the radiator Radiator(void *updater) : radiator_(nullptr), updater_(updater) diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp new file mode 100644 index 00000000..0d697318 --- /dev/null +++ b/src/tuvx/radiator.cpp @@ -0,0 +1,279 @@ +// Copyright (C) 2023-2024 National Center for Atmospheric Research +// SPDX-License-Identifier: Apache-2.0 +#include +#include + +#include +#include +#include + +namespace musica +{ + + // Radiator external C API functions + + Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *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); + } + + // + // in progress + // + // 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), units, &height_grid, &wavelength_grid, &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; + } + + InternalSetOpticalDepths( + void *radiator, + double *optical_depths, + std::size_t num_vertical_layers, + std::size_t num_wavelength_bins, + int *error_code); + + 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 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 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..bde22904 --- /dev/null +++ b/src/tuvx/radiator_map.cpp @@ -0,0 +1,186 @@ +// 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->AddGrid(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 + { + InternalAddGRadiator(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(); + } + + + /// @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 The name of the radiator + /// @param error The error struct to indicate success or failure + /// @return a radiator pointer + 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 From 2267552e2e9bab668dfd159570ee69d1377d3137 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 16:57:22 -0600 Subject: [PATCH 085/117] fix bugs --- include/musica/tuvx/radiator.hpp | 2 +- include/musica/tuvx/radiator_map.hpp | 11 +-- src/tuvx/CMakeLists.txt | 4 + src/tuvx/interface_radiator.F90 | 133 ++++++++++++++++++--------- src/tuvx/radiator.cpp | 31 +++---- src/tuvx/radiator_map.cpp | 19 ++-- 6 files changed, 118 insertions(+), 82 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index a5595821..32729ad0 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -23,7 +23,7 @@ namespace musica /// @param height_grid The height grid /// @param wavelength_grid The wavelength grid /// @param error The error struct to indicate success or failure - Radiator(const char *radiator_name, Grid* height_grid, Grid* wavelength_grid, Error *error); + Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); ~Radiator(); diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp index 980b65a7..ccaa9540 100644 --- a/include/musica/tuvx/radiator_map.hpp +++ b/include/musica/tuvx/radiator_map.hpp @@ -32,8 +32,8 @@ namespace musica /// @param error The error struct 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 + /// @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 The name of the radiator /// @param error The error struct to indicate success or failure /// @return a radiator pointer @@ -81,11 +81,8 @@ namespace musica void *InternalCreateRadiatorMap(int *error_code); void InternalDeleteRadiatordMap(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 * + 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 diff --git a/src/tuvx/CMakeLists.txt b/src/tuvx/CMakeLists.txt index 4d9acdb4..46fa14bc 100644 --- a/src/tuvx/CMakeLists.txt +++ b/src/tuvx/CMakeLists.txt @@ -5,10 +5,14 @@ target_sources(musica 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/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 index 6588a298..a0d6d1d0 100644 --- a/src/tuvx/interface_radiator.F90 +++ b/src/tuvx/interface_radiator.F90 @@ -12,9 +12,9 @@ module tuvx_interface_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_radiator(radiator_name, radiator_name_length, height_grid, & - wavelength_grid, error_code) result(radiator) & - bind(C, name="InternalCreateRadiator") + function internal_create_radiator(radiator_name, radiator_name_length, & + height_grid, wavelength_grid, 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 @@ -22,12 +22,12 @@ function internal_create_radiator(radiator_name, radiator_name_length, height_gr use tuvx_grid, only : grid_t ! arguments - type(c_ptr) :: radiator + type(c_ptr) :: radiator character(kind=c_char, len=1), dimension(*), intent(in) :: radiator_name - integer(kind=c_size_t), intent(in), value :: radiator_name_length - type(c_ptr), intent(in), value :: height_grid - type(c_ptr), intent(in), value :: wavelength_grid - integer(kind=c_int), intent(out) :: error_code + integer(kind=c_size_t), intent(in), value :: radiator_name_length + type(c_ptr), intent(in), value :: height_grid + type(c_ptr), intent(in), value :: wavelength_grid + integer(kind=c_int), intent(out) :: error_code ! variables type(radiator_from_host_t), pointer :: f_radiator @@ -50,7 +50,7 @@ end function internal_create_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine internal_delete_radiator(radiator, error_code) & - bind(C, name="InternalDeleteRadiator") + bind(C, name="InternalDeleteRadiator") use iso_c_binding, only: c_ptr, c_f_pointer, c_int ! arguments @@ -70,7 +70,7 @@ end subroutine internal_delete_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function internal_get_radiator_updater(radiator, error_code) & - bind(C, name="InternalGetRadiatorUpdater") result(updater) + 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 @@ -94,7 +94,7 @@ end function internal_get_radiator_updater !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine internal_delete_radiator_updater(updater, error_code) & - bind(C, name="InternalDeleteRadiatorUpdater") + 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 @@ -103,7 +103,7 @@ subroutine internal_delete_radiator_updater(updater, error_code) & integer(kind=c_int), intent(out) :: error_code ! variables - type(grid_radiator_t), pointer :: f_updater + type(radiator_t), pointer :: f_updater call c_f_pointer(updater, f_updater) if (associated(f_updater)) then @@ -114,8 +114,8 @@ end subroutine internal_delete_radiator_updater !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_optical_depths(radiator_updater, optical_depths, num_vertical_layers, & - num_wavelength_bins, error_code) & + 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 @@ -133,10 +133,12 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, num_ver 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]) + 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 + 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 @@ -146,8 +148,8 @@ end subroutine internal_set_optical_depths !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_get_optical_depths(radiator_updater, optical_depths, num_vertical_layers, & - num_wavelength_bins, error_code) & + 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 @@ -165,10 +167,12 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, num_ver 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]) + 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 + 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 @@ -178,9 +182,9 @@ 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") + 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 @@ -197,10 +201,12 @@ subroutine internal_set_single_scattering_albedos(radiator_updater, single_scatt 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]) + 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 + 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 @@ -210,9 +216,9 @@ 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") + 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 @@ -229,10 +235,12 @@ subroutine internal_get_single_scattering_albedos(radiator_updater, single_scatt 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]) + 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 + 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 @@ -242,16 +250,16 @@ end subroutine internal_get_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_set_asymmetry_factor(radiator_updater, asymmetry_factor, num_vertical_layers, & - num_wavelength_bins, num_streams, error_code) & - bind(C, name="InternalSetAsymmetryFactor") + 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_factor + type(c_ptr), value, intent(in) :: asymmetry_factors integer(kind=c_size_t), intent(in), value :: num_vertical_layers integer(kind=c_size_t), intent(in), value :: num_wavelength_bins integer(kind=c_size_t), intent(in), value :: num_streams @@ -259,21 +267,56 @@ subroutine internal_set_asymmetry_factor(radiator_updater, asymmetry_factor, num ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_asymmetry_factor(:,:,:) + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(asymmetry_factor, f_asymmetry_factor, [num_vertical_layers, num_wavelength_bins, num_streams]) + call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & + [num_vertical_layers, num_wavelength_bins, num_streams]) - if ((size(f_updater%radiator_%state_%layer_SSA_, 1) /= num_vertical_layers) .or. & - (size(f_updater%radiator_%state_%layer_SSA_, 2) /= num_wavelength_bins) .or. & - (size(f_updater%radiator_%state_%layer_G_, 3) /= num_streams)) then + 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_factor(:,:,:) + f_updater%radiator_%state_%layer_G_(:,:,:) = f_asymmetry_factors(:,:,:) - end subroutine internal_set_asymmetry_factor + 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), intent(in), value :: num_vertical_layers + integer(kind=c_size_t), intent(in), value :: num_wavelength_bins + integer(kind=c_size_t), intent(in), value :: 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_set_asymmetry_factors + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end module tuvx_interface_radiator \ No newline at end of file diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index 0d697318..e1ea9620 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -12,13 +12,13 @@ namespace musica // Radiator external C API functions - Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error); + Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error) { DeleteError(error); return new Radiator(radiator_name, height_grid, wavelength_grid, error); } - void DeleteRadiator(Radiator *radiator, Error *error); + void DeleteRadiator(Radiator *radiator, Error *error) { DeleteError(error); try @@ -38,7 +38,7 @@ namespace musica double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->SetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); @@ -60,7 +60,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->SetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); @@ -71,7 +71,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->GetSingleScatteringAlbedos(single_scattering_albedos, num_vertical_layers, num_wavelength_bins, error); @@ -83,7 +83,7 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { DeleteError(error); radiator->SetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); @@ -106,7 +106,7 @@ namespace musica // // Radiation class functions - Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); + Radiator::Radiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error) { int error_code = 0; radiator_ = @@ -137,18 +137,11 @@ namespace musica updater_ = nullptr; } - InternalSetOpticalDepths( - void *radiator, - double *optical_depths, - std::size_t num_vertical_layers, - std::size_t num_wavelength_bins, - int *error_code); - void Radiator::SetOpticalDepths( double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -169,7 +162,7 @@ namespace musica double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -190,7 +183,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -212,7 +205,7 @@ namespace musica double *single_scattering_albedos, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) @@ -235,7 +228,7 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { int error_code = 0; if (updater_ == nullptr) diff --git a/src/tuvx/radiator_map.cpp b/src/tuvx/radiator_map.cpp index bde22904..42a4958d 100644 --- a/src/tuvx/radiator_map.cpp +++ b/src/tuvx/radiator_map.cpp @@ -11,12 +11,12 @@ namespace musica // RadiatordMap external C API functions - RadiatorMap *CreateRadiatorMap(Error *error); + RadiatorMap *CreateRadiatorMap(Error *error) { DeleteError(error); return new RadiatorMap(error); } - + void DeleteRadiatorMap(RadiatorMap *radiator_map, Error *error) { DeleteError(error); @@ -31,13 +31,13 @@ namespace musica *error = NoError(); } - void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error); + void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error) { DeleteError(error); radiator_map->AddGrid(radiator, error); } - Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error); + Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error) { DeleteError(error); return radiator_map->GetRadiator(radiator_name, error); @@ -45,7 +45,7 @@ namespace musica // RadiatordMap class functions - RadiatorMap::RadiatorMap(Error *error); + RadiatorMap::RadiatorMap(Error *error) { int error_code = 0; radiator_map_ = InternalCreateRadiatorMap(&error_code); @@ -57,7 +57,7 @@ namespace musica *error = NoError(); } - RadiatorMap::~RadiatorMap(); + RadiatorMap::~RadiatorMap() { int error_code = 0; if (radiator_map_ != nullptr && owns_radiator_map_) @@ -68,7 +68,7 @@ namespace musica owns_radiator_map_ = false; } - void RadiatorMap::AddRadiator(Radiator *radiator, Error *error); + void RadiatorMap::AddRadiator(Radiator *radiator, Error *error) { if (radiator_map_ == nullptr) { @@ -129,9 +129,8 @@ namespace musica *error = NoError(); } - - /// @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 + /// @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 The name of the radiator /// @param error The error struct to indicate success or failure /// @return a radiator pointer From b85b1b0e9cbf99f2d74297dfd299a1adc5abbbf8 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 19 Jul 2024 17:38:26 -0600 Subject: [PATCH 086/117] fix bugs --- include/musica/tuvx/radiator.hpp | 2 +- src/tuvx/interface_radiator.F90 | 4 ++-- src/tuvx/radiator.cpp | 11 ++++------- 3 files changed, 7 insertions(+), 10 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 32729ad0..840a0887 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -236,7 +236,7 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, int *error_code); - void InternalGetsingleScatteringAlbedos( + void InternalGetSingleScatteringAlbedos( void *radiator, double *single_scattering_albedos, std::size_t num_vertical_layers, diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 index a0d6d1d0..3cb5bb89 100644 --- a/src/tuvx/interface_radiator.F90 +++ b/src/tuvx/interface_radiator.F90 @@ -133,7 +133,7 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, & real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(optical_depths, f_optical_depths, + 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) & @@ -167,7 +167,7 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, & real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) - call c_f_pointer(optical_depths, f_optical_depths, + 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) & diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index e1ea9620..10b363cc 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -12,7 +12,7 @@ namespace musica // Radiator external C API functions - Radiator *CreateRadiator(const char *radiator_name, Radiator *height_grid, Radiator *wavelength_grid, Error *error) + 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); @@ -49,7 +49,7 @@ namespace musica double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, - Error *error); + Error *error) { DeleteError(error); radiator->GetOpticalDepths(optical_depths, num_vertical_layers, num_wavelength_bins, error); @@ -95,22 +95,19 @@ namespace musica std::size_t num_vertical_layers, std::size_t num_wavelength_bins, std::size_t num_streams, - Error *error); + Error *error) { DeleteError(error); radiator->GetAsymmetryFactors(asymmetry_factors, num_vertical_layers, num_wavelength_bins, num_streams, error); } - // - // in progress - // // 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), units, &height_grid, &wavelength_grid, &error_code); + InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid, wavelength_grid, &error_code); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; From 65570e2ec1e95cf03951b410e8fb6bd85ce77f0c Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 22 Jul 2024 09:19:54 -0600 Subject: [PATCH 087/117] Moved tutorial subdir to fortran/test/tutorial. --- {tutorial => fortran/test/tutorial}/CMakeLists.txt | 0 {tutorial => fortran/test/tutorial}/demo.f90 | 0 fortran/test/unit/CMakeLists.txt | 2 +- tutorial/demo.c | 3 --- 4 files changed, 1 insertion(+), 4 deletions(-) rename {tutorial => fortran/test/tutorial}/CMakeLists.txt (100%) rename {tutorial => fortran/test/tutorial}/demo.f90 (100%) delete mode 100644 tutorial/demo.c diff --git a/tutorial/CMakeLists.txt b/fortran/test/tutorial/CMakeLists.txt similarity index 100% rename from tutorial/CMakeLists.txt rename to fortran/test/tutorial/CMakeLists.txt diff --git a/tutorial/demo.f90 b/fortran/test/tutorial/demo.f90 similarity index 100% rename from tutorial/demo.f90 rename to fortran/test/tutorial/demo.f90 diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 800492df..c2946b08 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -6,7 +6,7 @@ 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 ${PROJECT_SOURCE_DIR}/../tutorial/demo.f90) + create_standard_test_fortran(NAME demo_fortran SOURCES ../tutorial/demo.f90) endif() if (MUSICA_ENABLE_TUVX) diff --git a/tutorial/demo.c b/tutorial/demo.c deleted file mode 100644 index 553e50f6..00000000 --- a/tutorial/demo.c +++ /dev/null @@ -1,3 +0,0 @@ -void main(int argc, char* argv[]) { - -} From 263c4a1f6647c6f893b086338143c792940afcba Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 22 Jul 2024 09:25:22 -0600 Subject: [PATCH 088/117] Removed demo_c executable. --- fortran/test/tutorial/CMakeLists.txt | 4 ---- 1 file changed, 4 deletions(-) diff --git a/fortran/test/tutorial/CMakeLists.txt b/fortran/test/tutorial/CMakeLists.txt index a7961963..aae019eb 100644 --- a/fortran/test/tutorial/CMakeLists.txt +++ b/fortran/test/tutorial/CMakeLists.txt @@ -16,12 +16,8 @@ set(MUSICA_LIB_DIR "${MUSICA_INSTALL_DIR}/lib") message(STATUS "${MUSICA_INCLUDE_DIR}") message(STATUS "${MUSICA_LIB_DIR}") -add_executable(demo_c demo.c) add_executable(demo_f demo.f90) -target_include_directories(demo_c PUBLIC ${MUSICA_INCLUDE_DIR}) -target_link_directories(demo_c PUBLIC ${MUSICA_LIB_DIR}) - 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++) From 37f8495f5e34e5b34fb522af338f6066e0cf8c1a Mon Sep 17 00:00:00 2001 From: David Fillmore Date: Mon, 22 Jul 2024 09:31:59 -0600 Subject: [PATCH 089/117] Updated docs. --- .dockerignore | 1 - docs/source/tutorial/chapter0.rst | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.dockerignore b/.dockerignore index 85759380..293e77a1 100644 --- a/.dockerignore +++ b/.dockerignore @@ -13,7 +13,6 @@ !include/ !lib/ !src/ -!tutorial/ !python/ !pyproject.toml !LICENSE diff --git a/docs/source/tutorial/chapter0.rst b/docs/source/tutorial/chapter0.rst index 6fdf096d..60993b44 100644 --- a/docs/source/tutorial/chapter0.rst +++ b/docs/source/tutorial/chapter0.rst @@ -11,7 +11,7 @@ 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:: ../../../tutorial/CMakeLists.txt + .. literalinclude:: ../../../fortran/test/tutorial/CMakeLists.txt :language: cmake These `CMake` directives are essentially equivalent to compilation on the command line via From c248e1e8c0ff502027f9a5c7b611a1bb25187db4 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 22 Jul 2024 12:55:57 -0600 Subject: [PATCH 090/117] fix bugs in c sources --- include/musica/tuvx/radiator.hpp | 60 ++++++++++++++-------------- include/musica/tuvx/radiator_map.hpp | 45 +++++++++++---------- src/tuvx/radiator.cpp | 10 ++--- src/tuvx/radiator_map.cpp | 9 +---- 4 files changed, 58 insertions(+), 66 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 840a0887..9e490a1d 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -6,18 +6,15 @@ #include #include -#include -#include -#include namespace musica { class RadiatorMap; - class Profile; - /// @brief A radiator struct used to access radiator information in tuvx - struct Radiator + /// @brief A radiator class used to access radiator information in tuvx + class Radiator { + public: /// @brief Creates a radiator instance /// @param radiator_name The name of the radiator /// @param height_grid The height grid @@ -27,16 +24,16 @@ namespace musica ~Radiator(); - /// @brief Sets the optical_depths - /// @param optical_depths The 2 dimensional optical_depths + /// @brief Sets the optical depth values + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct 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 the optical_depths - /// @param optical_depths The 2 dimensional optical_depths + /// @brief Gets the optical depth values + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength layers /// @param error The error struct to indicate success or failure @@ -44,7 +41,7 @@ namespace musica GetOpticalDepths(double *optical_depths, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, Error *error); /// @brief Sets the values of the single scattering albedos - /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -54,8 +51,8 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the single scattering albedos - /// @param single_scattering_albedos The 2 dimensional single scattering albedos values + /// @brief Gets the values of the single scattering albedo + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -66,7 +63,7 @@ namespace musica Error *error); /// @brief Sets the values of the asymmetry factors - /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -79,7 +76,7 @@ namespace musica Error *error); /// @brief Gets the values of the asymmetry factors - /// @param asymmetry_factor The asymmetery factors values to set for the radiator + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -95,8 +92,7 @@ namespace musica void *radiator_; // A valid pointer to a radiator instance indicates ownership by this wrapper void *updater_; - // friend class RadiatorMap; - // friend class Profile; + friend class RadiatorMap; /// @brief Wraps an existing radiator instance. Used by RadiatorMap /// @param updater The updater for the radiator @@ -123,13 +119,13 @@ namespace musica Radiator *CreateRadiator(const char *radiator_name, Grid *height_grid, Grid *wavelength_grid, Error *error); /// @brief Deletes a TUV-x radiator instance - /// @param radiator The radiator to delete + /// @param radiator The pointer to radiator instance /// @param error The error struct to indicate success or failure void DeleteRadiator(Radiator *radiator, Error *error); - /// @brief Sets the values of the optical depths of the radiator - /// @param radiator The radiator to get the optical depths - /// @param optical_depths The optical depths values to get for the radiator + /// @brief Sets the optical depth values + /// @param radiator The pointer to radiator instance + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -140,9 +136,9 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the optical depths of the radiator - /// @param radiator The radiator to set the optical depths - /// @param optical_depths The optical depths values to set for the radiator + /// @brief Gets the optical depth values + /// @param radiator The pointer to radiator instance + /// @param optical_depths The 2 dimensional array of optical depth values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -154,8 +150,8 @@ namespace musica Error *error); /// @brief Sets the values of the single scattering albedos - /// @param radiator The radiator to set the single scattering albedos of - /// @param single_scattering_albedos The single scattering albedos values to set for the radiator + /// @param radiator The pointer to radiator instance + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -167,8 +163,8 @@ namespace musica Error *error); /// @brief Gets the values of the single scattering albedos - /// @param radiator The radiator to get the single scattering albedos of - /// @param single_scattering_albedos The single scattering albedos values to get for the radiator + /// @param radiator The pointer to radiator instance + /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param error The error struct to indicate success or failure @@ -180,7 +176,8 @@ namespace musica Error *error); /// @brief Sets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional asymmetery factors values to set for the radiator + /// @param radiator The pointer to radiator instance + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -194,7 +191,8 @@ namespace musica Error *error); /// @brief Gets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional asymmetery factors values to get for the radiator + /// @param radiator The pointer to radiator instance + /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values /// @param num_vertical_layers The number of vertical layers /// @param num_wavelength_bins The number of wavelength bins /// @param num_streams The number of streams @@ -261,4 +259,4 @@ namespace musica } #endif -} // namespace musica +} // namespace musica \ No newline at end of file diff --git a/include/musica/tuvx/radiator_map.hpp b/include/musica/tuvx/radiator_map.hpp index ccaa9540..c998c9ac 100644 --- a/include/musica/tuvx/radiator_map.hpp +++ b/include/musica/tuvx/radiator_map.hpp @@ -12,31 +12,32 @@ namespace musica { - /// @brief A radiator map struct used to access radiator information in tuvx - struct RadiatorMap + /// @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 @brief Creates a radiator map instance - /// @param error The error struct to indicate success or failure + /// @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 The radiator to add - /// @param error The error struct to indicate success or failure + /// @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 The name of the radiator - /// @param error The error struct to indicate success or failure - /// @return a radiator pointer + /// @param radiator_name Radiator name + /// @param error Error to indicate success or failure + /// @return Radiator Radiator *GetRadiator(const char *radiator_name, Error *error); private: @@ -52,26 +53,26 @@ namespace musica // The external C API for TUVX // callable by wrappers in other languages - /// @brief Creates a radiator map instance - /// @param error The error struct to indicate success or failure - /// @return a pointer to the radiator map + /// @brief Creates radiator map + /// @param error Error to indicate success or failure + /// @return Radiator map RadiatorMap *CreateRadiatorMap(Error *error); - /// @brief Deletes a radiator map instance - /// @param radiator_map The radiator map to delete - /// @param error The error struct to indicate success or failure + /// @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 The radiator map to add the radiator to - /// @param radiator The radiator to add - /// @param error The error struct to indicate success or failure + /// @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 The radiator map to get the radiator from - /// @param radiator_name The name of the radiator - /// @param error The error struct to indicate success or failure + /// @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); @@ -79,7 +80,7 @@ namespace musica // 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 InternalDeleteRadiatordMap(void *radiator_map, 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); diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index 10b363cc..e67962f6 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -1,6 +1,5 @@ // Copyright (C) 2023-2024 National Center for Atmospheric Research // SPDX-License-Identifier: Apache-2.0 -#include #include #include @@ -106,8 +105,7 @@ namespace musica 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, wavelength_grid, &error_code); + radiator_ = InternalCreateRadiator(radiator_name, strlen(radiator_name), height_grid, wavelength_grid, &error_code); if (error_code != 0) { *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator") }; @@ -220,7 +218,7 @@ namespace musica *error = NoError(); } - void SetAsymmetryFactors( + void Radiator::SetAsymmetryFactors( double *asymmetry_factors, std::size_t num_vertical_layers, std::size_t num_wavelength_bins, @@ -243,12 +241,12 @@ namespace musica *error = NoError(); } - void GetAsymmetryFactors( + 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); + Error *error) { int error_code = 0; if (updater_ == nullptr) diff --git a/src/tuvx/radiator_map.cpp b/src/tuvx/radiator_map.cpp index 42a4958d..92263dda 100644 --- a/src/tuvx/radiator_map.cpp +++ b/src/tuvx/radiator_map.cpp @@ -34,7 +34,7 @@ namespace musica void AddRadiator(RadiatorMap *radiator_map, Radiator *radiator, Error *error) { DeleteError(error); - radiator_map->AddGrid(radiator, error); + radiator_map->AddRadiator(radiator, error); } Radiator *GetRadiator(RadiatorMap *radiator_map, const char *radiator_name, Error *error) @@ -90,7 +90,7 @@ namespace musica try { - InternalAddGRadiator(radiator_map_, radiator->radiator_, &error_code); + 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") }; @@ -129,11 +129,6 @@ namespace musica *error = NoError(); } - /// @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 The name of the radiator - /// @param error The error struct to indicate success or failure - /// @return a radiator pointer Radiator *RadiatorMap::GetRadiator(const char *radiator_name, Error *error) { if (radiator_map_ == nullptr) From 90bd69aaba5701250e4d0186015412eb46ef6203 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 22 Jul 2024 15:45:12 -0600 Subject: [PATCH 091/117] fix bugs in f90 sources --- include/musica/tuvx/radiator.hpp | 168 ++++++++++++++-------------- src/tuvx/interface_radiator.F90 | 25 +++-- src/tuvx/interface_radiator_map.F90 | 12 +- 3 files changed, 103 insertions(+), 102 deletions(-) diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 9e490a1d..08970fb5 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -11,63 +11,63 @@ namespace musica { class RadiatorMap; - /// @brief A radiator class used to access radiator information in tuvx + /// @brief Radiator class used to access radiator information in tuvx class Radiator { public: - /// @brief Creates a radiator instance - /// @param radiator_name The name of the radiator - /// @param height_grid The height grid - /// @param wavelength_grid The wavelength grid - /// @param error The error struct to indicate success or failure + /// @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 the optical depth values - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength layers - /// @param error The error struct to indicate success or failure + /// @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 the optical depth values - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength layers - /// @param error The error struct to indicate success or failure + /// @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 the values of the single scattering albedos - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @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 the values of the single scattering albedo - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @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 the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @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, @@ -75,12 +75,12 @@ namespace musica std::size_t num_streams, Error *error); - /// @brief Gets the values of the asymmetry factors - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @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, @@ -111,24 +111,24 @@ namespace musica // The external C API for TUVX // callable by wrappers in other languages - /// @brief Creates a TUV-x radiator instance - /// @param radiator_name The name of the radiator - /// @param height_grid The height grid - /// @param wavelength_grid The wavelength grid - /// @param error The error struct to indicate success or failure + /// @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 a TUV-x radiator instance - /// @param radiator The pointer to radiator instance - /// @param error The error struct to indicate success or failure + /// @brief Deletes radiator + /// @param radiator Radiator + /// @param error Error to indicate success or failure void DeleteRadiator(Radiator *radiator, Error *error); - /// @brief Sets the optical depth values - /// @param radiator The pointer to radiator instance - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @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, @@ -136,12 +136,12 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the optical depth values - /// @param radiator The pointer to radiator instance - /// @param optical_depths The 2 dimensional array of optical depth values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @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, @@ -149,12 +149,12 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Sets the values of the single scattering albedos - /// @param radiator The pointer to radiator instance - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @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, @@ -162,12 +162,12 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Gets the values of the single scattering albedos - /// @param radiator The pointer to radiator instance - /// @param single_scattering_albedos The 2 dimensional array of single scattering albedos values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param error The error struct to indicate success or failure + /// @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, @@ -175,13 +175,13 @@ namespace musica std::size_t num_wavelength_bins, Error *error); - /// @brief Sets the values of the asymmetry factors - /// @param radiator The pointer to radiator instance - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @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, @@ -190,13 +190,13 @@ namespace musica std::size_t num_streams, Error *error); - /// @brief Gets the values of the asymmetry factors - /// @param radiator The pointer to radiator instance - /// @param asymmetry_factor The 3 dimensional array of asymmetery factor values - /// @param num_vertical_layers The number of vertical layers - /// @param num_wavelength_bins The number of wavelength bins - /// @param num_streams The number of streams - /// @param error The error struct to indicate success or failure + /// @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( double *asymmetry_factor, std::size_t num_vertical_layers, diff --git a/src/tuvx/interface_radiator.F90 b/src/tuvx/interface_radiator.F90 index 3cb5bb89..cbdc176b 100644 --- a/src/tuvx/interface_radiator.F90 +++ b/src/tuvx/interface_radiator.F90 @@ -17,9 +17,8 @@ function internal_create_radiator(radiator_name, radiator_name_length, & 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, only : grid_t + use tuvx_grid, only: grid_t ! arguments type(c_ptr) :: radiator @@ -32,8 +31,9 @@ function internal_create_radiator(radiator_name, radiator_name_length, & ! variables type(radiator_from_host_t), pointer :: f_radiator type(string_t) :: f_name - type(grid_t) :: f_height_grid - type(grid_t) :: f_wavelength_grid + type(grid_t), pointer :: f_height_grid + type(grid_t), pointer :: f_wavelength_grid + integer :: i allocate(character(len=radiator_name_length) :: f_name%val_) do i = 1, radiator_name_length @@ -103,7 +103,7 @@ subroutine internal_delete_radiator_updater(updater, error_code) & integer(kind=c_int), intent(out) :: error_code ! variables - type(radiator_t), pointer :: f_updater + type(radiator_updater_t), pointer :: f_updater call c_f_pointer(updater, f_updater) if (associated(f_updater)) then @@ -130,7 +130,7 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_optical_depths(:,:) + real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & @@ -164,7 +164,7 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_optical_depths(:,:) + real(kind=dk), pointer :: f_optical_depths(:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & @@ -198,7 +198,7 @@ subroutine internal_set_single_scattering_albedos(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + 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, & @@ -232,7 +232,7 @@ subroutine internal_get_single_scattering_albedos(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_single_scattering_albedos(:,:) + 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, & @@ -267,7 +267,7 @@ subroutine internal_set_asymmetry_factors(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & @@ -302,7 +302,7 @@ subroutine internal_get_asymmetry_factors(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater - real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) + real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(asymmetry_factors, f_asymmetry_factors, & @@ -316,7 +316,8 @@ subroutine internal_get_asymmetry_factors(radiator_updater, & end if f_asymmetry_factors(:,:,:) = f_updater%radiator_%state_%layer_G_(:,:,:) -end subroutine internal_set_asymmetry_factors +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 index 1d30e33c..7a0cfadd 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -3,11 +3,11 @@ ! module tuvx_interface_radiator_map - use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char + use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char use tuvx_radiator_warehouse, only : radiator_warehouse_t use tuvx_radiator, only : radiator_t - use musica_tuvx_util, only : to_f_string, string_t_c - use musica_string, only : string_t + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t implicit none @@ -107,7 +107,7 @@ function internal_get_radiator(radiator_map, c_radiator_name, & class(radiator_t), pointer :: f_radiator type(radiator_warehouse_t), pointer :: radiator_warehouse character(len=:), allocatable :: f_radiator_name - + integer :: i ! result type(c_ptr) :: radiator_ptr @@ -130,7 +130,7 @@ function internal_get_radiator(radiator_map, c_radiator_name, & radiator_ptr = c_null_ptr end select - end function interal_get_radiator + end function internal_get_radiator !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -138,7 +138,7 @@ function internal_get_radiator_updater_from_map(radiator_map, radiator, error_co 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, gradiator_updater_t + use tuvx_radiator_from_host, only: radiator_from_host_t, radiator_updater_t ! arguments type(c_ptr), intent(in), value :: radiator_map From 21ac00eb68eb5e939d6d1d9ee2c5933f18452356 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 24 Jul 2024 12:34:42 -0600 Subject: [PATCH 092/117] fix bugs --- fortran/tuvx/tuvx.F90 | 48 +++++++-- include/musica/tuvx/tuvx.hpp | 9 ++ src/packaging/CMakeLists.txt | 2 + src/tuvx/interface.F90 | 161 ++++++++++++++++------------ src/tuvx/interface_radiator_map.F90 | 2 +- src/tuvx/tuvx.cpp | 19 ++++ 6 files changed, 167 insertions(+), 74 deletions(-) diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index 94e4edd0..082712d8 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -2,11 +2,13 @@ ! 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 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 @@ -45,9 +47,17 @@ 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 + 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -59,6 +69,8 @@ end function get_profile_map_c 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 @@ -154,6 +166,28 @@ 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 diff --git a/include/musica/tuvx/tuvx.hpp b/include/musica/tuvx/tuvx.hpp index e89d7685..47516256 100644 --- a/include/musica/tuvx/tuvx.hpp +++ b/include/musica/tuvx/tuvx.hpp @@ -7,6 +7,7 @@ #include #include +#include #include #include @@ -38,6 +39,12 @@ namespace musica /// @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: @@ -55,6 +62,7 @@ namespace musica 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 @@ -63,6 +71,7 @@ namespace musica 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 } diff --git a/src/packaging/CMakeLists.txt b/src/packaging/CMakeLists.txt index 17c27bb3..9d04933f 100644 --- a/src/packaging/CMakeLists.txt +++ b/src/packaging/CMakeLists.txt @@ -76,6 +76,8 @@ if (MUSICA_ENABLE_TUVX) ${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/tuvx/interface.F90 b/src/tuvx/interface.F90 index 8c756bf5..624a6583 100644 --- a/src/tuvx/interface.F90 +++ b/src/tuvx/interface.F90 @@ -3,96 +3,101 @@ ! 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_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 +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 - 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) + 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 + end function internal_get_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) bind(C, name="InternalGetProfileMap") + 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 ! arguments @@ -115,4 +120,28 @@ end function internal_get_profile_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end module tuvx_interface + 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 + + ! arguments + type(c_ptr), intent(in), value :: tuvx + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: radiator_map_ptr + + ! 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() + + radiator_map_ptr = c_loc(radiator_warehouse) + + end function internal_get_radiator_map + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +end module tuvx_interface \ No newline at end of file diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index 7a0cfadd..81c26c52 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -107,7 +107,7 @@ function internal_get_radiator(radiator_map, c_radiator_name, & class(radiator_t), pointer :: f_radiator type(radiator_warehouse_t), pointer :: radiator_warehouse character(len=:), allocatable :: f_radiator_name - integer :: i + integer :: i ! result type(c_ptr) :: radiator_ptr diff --git a/src/tuvx/tuvx.cpp b/src/tuvx/tuvx.cpp index 7c17cf02..9abd977d 100644 --- a/src/tuvx/tuvx.cpp +++ b/src/tuvx/tuvx.cpp @@ -58,6 +58,12 @@ namespace musica return tuvx->CreateProfileMap(error); } + RadiatorMap *GetRadiatorMap(TUVX *tuvx, Error *error) + { + DeleteError(error); + return tuvx->CreateRadiatorMap(error); + } + // TUVX class functions TUVX::TUVX() @@ -131,4 +137,17 @@ namespace musica return profile_map; } + RadiatorMap *TUVX::CreateRadiatorMap(Error *error) + { + *error = NoError(); + int error_code = 0; + RadiatorMap *radiator_map = new RadiatorMap(InternalGetRadiatorMap(tuvx_, &error_code)); + if (error_code != 0) + { + *error = Error{ 1, CreateString(MUSICA_ERROR_CATEGORY), CreateString("Failed to create radiator map") }; + return nullptr; + } + return radiator_map; + } + } // namespace musica From f5256ad9c2880867364d810cb8fce5859d9e9706 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 24 Jul 2024 13:40:56 -0600 Subject: [PATCH 093/117] temp add radiator test --- cmake/dependencies.cmake | 3 +- src/test/unit/tuvx/CMakeLists.txt | 1 + src/test/unit/tuvx/radiatortest.cpp | 113 ++++++++++++++++++++++++++++ 3 files changed, 116 insertions(+), 1 deletion(-) create mode 100644 src/test/unit/tuvx/radiatortest.cpp diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index df84a956..d819d737 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,7 +75,8 @@ 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 80f896a0fb591987c2a79209377bd6f599b4fb6f) + # set_git_default(TUVX_GIT_TAG 80f896a0fb591987c2a79209377bd6f599b4fb6f) + set_git_default(TUVX_GIT_TAG make-radiator-updatable) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/src/test/unit/tuvx/CMakeLists.txt b/src/test/unit/tuvx/CMakeLists.txt index 28b926c0..05dcc0f8 100644 --- a/src/test/unit/tuvx/CMakeLists.txt +++ b/src/test/unit/tuvx/CMakeLists.txt @@ -1,6 +1,7 @@ include(test_util) create_standard_test_cxx(NAME tuvx_c_api SOURCES tuvx_c_api.cpp) +create_standard_test_cxx(NAME tuvx_radiator_test SOURCES radiatortest.cpp) ################################################################################ # Copy tuvx test data diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp new file mode 100644 index 00000000..e978e423 --- /dev/null +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -0,0 +1,113 @@ +#include +#include + +#include +#include + +using namespace musica; + +// Test fixture for the TUVX C API +class TuvxCApiTest : public ::testing::Test +{ + protected: + TUVX* tuvx; + + // the function that google test actually calls before each test + void SetUp() override + { + tuvx = nullptr; + } + + void SetUp(const char* config_path) + { + Error error; + tuvx = CreateTuvx(config_path, &error); + if (!IsSuccess(error)) + { + std::cerr << "Error creating TUVX instance: " << error.message_.value_ << std::endl; + } + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); + } + + void TearDown() override + { + if (tuvx == nullptr) + { + return; + } + Error error; + DeleteTuvx(tuvx, &error); + ASSERT_TRUE(IsSuccess(error)); + DeleteError(&error); + tuvx = nullptr; + } +}; + +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, "Aerosol radiator", &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); + + // TODO(jiwon) - Is 1d array of input okay? + // ! specify optical depths only + // od(:,1) = (/ 12.5_dk, 42.3_dk, 0.4_dk /) + // od(:,2) = (/ 49.2_dk, 12.5_dk, 92.1_dk /) + + std::vector optical_depths_flattened = {10.0, 20.0, 30.0, 40.0, 50.0, 60.0}; + std::size_t num_vertical_layers = 3; + std::size_t num_wavelength_bins = 2; + SetRadiatorOpticalDepths(radiator, optical_depths_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + + for(auto& depth : optical_depths_flattened) + { + depth =- 10.0; + } + GetRadiatorOpticalDepths(radiator, optical_depths_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + ASSERT_TRUE(IsSuccess(error)); + ASSERT_EQ(optical_depths_flattened[0], 0.0); + ASSERT_EQ(optical_depths_flattened[1], 10.0); + ASSERT_EQ(optical_depths_flattened[2], 20.0); + ASSERT_EQ(optical_depths_flattened[0], 30.0); + ASSERT_EQ(optical_depths_flattened[1], 40.0); + ASSERT_EQ(optical_depths_flattened[2], 50.0); + + num_vertical_layers = 2; + num_wavelength_bins = 2; + std::vector single_scattering_albedos_flattened = { 100.0, 100.0, 200, 200 }; + SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error) + ASSERT_TRUE(IsSuccess(error)); + for (auto& albedos : single_scattering_albedos_flattened) + { + albedos =+ 100.0; + } + // GetGridMidpoints(grid, midpoints.data(), midpoints.size(), &error); + // GetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &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); +} \ No newline at end of file From 5ac631d4facb9d32d918d97592bfbdc230a82fa7 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 24 Jul 2024 14:43:00 -0600 Subject: [PATCH 094/117] fix bugs --- src/test/unit/tuvx/radiatortest.cpp | 2 +- src/tuvx/interface.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index e978e423..43b52c3b 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -96,7 +96,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) num_vertical_layers = 2; num_wavelength_bins = 2; std::vector single_scattering_albedos_flattened = { 100.0, 100.0, 200, 200 }; - SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error) + SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); ASSERT_TRUE(IsSuccess(error)); for (auto& albedos : single_scattering_albedos_flattened) { diff --git a/src/tuvx/interface.F90 b/src/tuvx/interface.F90 index 624a6583..bc87c977 100644 --- a/src/tuvx/interface.F90 +++ b/src/tuvx/interface.F90 @@ -19,7 +19,7 @@ module tuvx_interface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_create_tuvx(c_config_path, config_path_length, error_code) + 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 @@ -53,7 +53,7 @@ end function internal_create_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine internal_delete_tuvx(tuvx, error_code) + subroutine internal_delete_tuvx(tuvx, error_code) & bind(C, name="InternalDeleteTuvx") use iso_c_binding, only: c_ptr, c_f_pointer @@ -72,7 +72,7 @@ end subroutine internal_delete_tuvx !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_grid_map(tuvx, error_code) result(grid_map_ptr) + 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 @@ -96,7 +96,7 @@ end function internal_get_grid_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_profile_map(tuvx, error_code) result(profile_map_ptr) + 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 @@ -120,7 +120,7 @@ end function internal_get_profile_map !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function internal_get_radiator_map(tuvx, error_code) result(radiator_map_ptr) + 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 From 0ae60e1c291a0812c5a2af15f08fe02896868481 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 26 Jul 2024 17:47:09 -0600 Subject: [PATCH 095/117] passed test --- include/musica/tuvx/grid.hpp | 2 + include/musica/tuvx/radiator.hpp | 5 +- src/test/unit/tuvx/radiatortest.cpp | 149 ++++++++++++++++++++++------ src/tuvx/interface_radiator.F90 | 57 +++++++---- src/tuvx/radiator.cpp | 2 +- 5 files changed, 162 insertions(+), 53 deletions(-) diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index c8bb4a60..86c7f46f 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -12,6 +12,7 @@ namespace musica { class GridMap; class Profile; + class Radiator; /// @brief A grid struct used to access grid information in tuvx struct Grid @@ -55,6 +56,7 @@ namespace musica 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 diff --git a/include/musica/tuvx/radiator.hpp b/include/musica/tuvx/radiator.hpp index 08970fb5..f08b9b33 100644 --- a/include/musica/tuvx/radiator.hpp +++ b/include/musica/tuvx/radiator.hpp @@ -198,6 +198,7 @@ namespace musica /// @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, @@ -210,8 +211,8 @@ namespace musica void *InternalCreateRadiator( const char *radiator_name, std::size_t radiator_name_length, - Grid *hegiht_grid, - Grid *wavelength_grid, + void *height_grid, + void *wavelength_grid, int *error_code); void InternalDeleteRadiator(void *radiator, int *error_code); void *InternalGetRadiatorUpdater(void *radiator, int *error_code); diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 43b52c3b..3419d0e5 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -3,6 +3,7 @@ #include #include +#include using namespace musica; @@ -68,46 +69,130 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) Radiator* radiator = CreateRadiator("foo", height, wavelength, &error); ASSERT_TRUE(IsSuccess(error)); ASSERT_NE(radiator, nullptr); - - // TODO(jiwon) - Is 1d array of input okay? - // ! specify optical depths only - // od(:,1) = (/ 12.5_dk, 42.3_dk, 0.4_dk /) - // od(:,2) = (/ 49.2_dk, 12.5_dk, 92.1_dk /) - - std::vector optical_depths_flattened = {10.0, 20.0, 30.0, 40.0, 50.0, 60.0}; + std::size_t num_vertical_layers = 3; std::size_t num_wavelength_bins = 2; - SetRadiatorOpticalDepths(radiator, optical_depths_flattened.data(), num_vertical_layers, num_wavelength_bins, &error); + + // 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 single_scattering_albedos_flattened = { 100.0, 100.0, 200, 200 }; - SetRadiatorSingleScatteringAlbedos(radiator, single_scattering_albedos_flattened.data(), num_vertical_layers, num_wavelength_bins, &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 radiator_from_host_t(f_name, f_height_grid, f_wavelength_grid) + 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 @@ -131,10 +132,17 @@ subroutine internal_set_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_optical_depths(:,:) - + integer(kind=c_int) :: i, iRow, iCol !TODO(test)jiwon + call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & - [num_vertical_layers, num_wavelength_bins]) + [num_vertical_layers, num_wavelength_bins]) + + do iRow = 1, num_wavelength_bins + do iCol = 1, num_vertical_layers + print *, "Value of f_i(" , iCol, ",", iRow, ") = ", f_optical_depths(iCol, iRow) + end do + end do if ((size(f_updater%radiator_%state_%layer_OD_, 1) /= num_vertical_layers) & .or. (size(f_updater%radiator_%state_%layer_OD_, 2) /= num_wavelength_bins)) & @@ -165,7 +173,8 @@ subroutine internal_get_optical_depths(radiator_updater, optical_depths, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_optical_depths(:,:) - + integer(kind=c_int) :: iRow, iCol + call c_f_pointer(radiator_updater, f_updater) call c_f_pointer(optical_depths, f_optical_depths, & [num_vertical_layers, num_wavelength_bins]) @@ -199,11 +208,17 @@ subroutine internal_set_single_scattering_albedos(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_single_scattering_albedos(:,:) - + integer(kind=c_int) :: i, iRow, iCol 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]) + do iRow = 1, num_wavelength_bins + do iCol = 1, num_vertical_layers + print *, "Value of f_i(" , iCol, ",", iRow, ") = ", f_single_scattering_albedos(iCol, iRow) + end do + end do + 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 @@ -268,11 +283,17 @@ subroutine internal_set_asymmetry_factors(radiator_updater, & ! variables type(radiator_updater_t), pointer :: f_updater real(kind=dk), pointer :: f_asymmetry_factors(:,:,:) - + integer(kind=c_int) :: i, iRow, iCol 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]) + do iRow = 1, num_wavelength_bins + do iCol = 1, num_vertical_layers + print *, "Value of f_i(" , iCol, ",", iRow, ") = ", f_asymmetry_factors(iCol, iRow, num_streams) + end do + end do + 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 diff --git a/src/tuvx/radiator.cpp b/src/tuvx/radiator.cpp index e67962f6..d0d76878 100644 --- a/src/tuvx/radiator.cpp +++ b/src/tuvx/radiator.cpp @@ -105,7 +105,7 @@ namespace musica 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, wavelength_grid, &error_code); + 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") }; From 80349d4615587f7e2f6b6e6119217d9a926f156f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 31 Jul 2024 09:46:41 -0600 Subject: [PATCH 096/117] incomplete test --- src/test/unit/tuvx/radiatortest.cpp | 236 ++++++++++++++++++++++++---- 1 file changed, 207 insertions(+), 29 deletions(-) diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 3419d0e5..4313a14e 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -45,21 +45,21 @@ class TuvxCApiTest : public ::testing::Test } }; -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, "Aerosol radiator", &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, 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) { @@ -70,6 +70,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) 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; @@ -82,7 +83,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) { optical_depths[row] = &optical_depths_1D[row * num_wavelength_bins]; } - + // int i = 1; for(int row = 0; row < num_vertical_layers; row++) { @@ -94,10 +95,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) } 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_vertical_layers; col++) + for(int col = 0; col < num_wavelength_bins; col++) { optical_depths[row][col] =- 999.0; } @@ -129,10 +129,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) } 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_vertical_layers; col++) + for(int col = 0; col < num_wavelength_bins; col++) { albedos[row][col] =- 999.0; } @@ -165,10 +164,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) 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_vertical_layers; col++) + for(int col = 0; col < num_wavelength_bins; col++) { factors[row][col] =- 999.0; } @@ -182,12 +180,10 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_EQ(factors[2][0], 5); ASSERT_EQ(factors[2][1], 6); - DeleteRadiator(radiator, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteGrid(height, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteGrid(wavelength, &error); - ASSERT_TRUE(IsSuccess(error)); + // 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; @@ -195,4 +191,186 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) delete[] albedos_1D; delete[] factors; delete[] factors_1D; -} \ No newline at end of file +} + +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); + // + // TODO(test) + // + AddRadiator(radiator_map, foo_radiator, &error); + ASSERT_TRUE(IsSuccess(error)); + + 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); + + std::size_t num_vertical_layers = 3; + std::size_t num_wavelength_bins = 2; + + // Test for optical depths + 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 Date: Wed, 31 Jul 2024 11:52:54 -0600 Subject: [PATCH 097/117] temp file for transfer --- src/tuvx/interface_radiator_map_v2.F90 | 178 +++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 src/tuvx/interface_radiator_map_v2.F90 diff --git a/src/tuvx/interface_radiator_map_v2.F90 b/src/tuvx/interface_radiator_map_v2.F90 new file mode 100644 index 00000000..7b14f6b5 --- /dev/null +++ b/src/tuvx/interface_radiator_map_v2.F90 @@ -0,0 +1,178 @@ +! 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_radiative_transfer, only : radiative_transfer_t + use tuvx_radiator_warehouse, only : radiator_warehouse_t + use tuvx_radiator, only : radiator_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 + use tuvx_radiative_transfer, only : radiative_transfer_t + + ! arguments + integer(kind=c_int), intent(out) :: error_code + + ! result + type(c_ptr) :: radiator_map + + ! variables + class(radiative_transfer_t), pointer :: f_radiative_transfer + class(radiator_warehouse_t), pointer :: f_radiator_warehouse + + f_radiative_transfer => radiative_transfer_t() + select type(f_radiative_transfer) + type is(radiative_transfer_t) + radiator_map = c_loc(f_radiative_transfer%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 + use tuvx_radiative_transfer, only : radiative_transfer_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + integer(kind=c_int), intent(out) :: error_code + + ! variables + ! type(radiator_warehouse_t), pointer :: f_radiator_warehouse + type(radiative_transfer_t), pointer :: f_radiative_transfer + call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) + deallocate(f_radiative_transfer%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_radiative_transfer, only : radiative_transfer_t + use tuvx_radiator_from_host, only: radiator_from_host_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiative_transfer_t), pointer :: f_radiative_transfer + type(radiator_from_host_t), pointer :: f_radiator + + call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + call f_radiative_transfer%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 + use tuvx_radiative_transfer, only : radiative_transfer_t + + ! arguments + type(c_ptr), intent(in), value :: radiator_map + character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name + integer(kind=c_size_t), value :: c_radiator_name_length + integer(kind=c_int), intent(out) :: error_code + + ! variables + type(radiative_transfer_t), pointer :: f_radiative_transfer + class(radiator_t), pointer :: f_radiator + 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, f_radiative_transfer%radiator_warehouse_) + write(*,*) " [jiwon] internal_get_radiator" + ! This doesn't work + f_radiator => f_radiative_transfer%radiator_warehouse_%get_radiator(f_radiator_name) + + 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 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), intent(in), value :: radiator_map + type(c_ptr), intent(in), value :: radiator + integer(kind=c_int), intent(out) :: error_code + + ! output + type(c_ptr) :: updater + + ! variables + type(radiative_transfer_t), pointer :: f_radiative_transfer + 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_radiative_transfer%radiator_warehouse) + call c_f_pointer(radiator, f_radiator) + + error_code = 0 + allocate(f_updater) + f_updater = f_radiative_transfer%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 From 7b8714b5cb143ed36e5ce7a9471eccb5999a6393 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 31 Jul 2024 18:29:07 -0600 Subject: [PATCH 098/117] working version --- src/test/unit/tuvx/radiatortest.cpp | 101 ++++++-------- src/tuvx/interface_radiator.F90 | 1 - src/tuvx/interface_radiator_map.F90 | 12 +- src/tuvx/interface_radiator_map_v2.F90 | 178 ------------------------- 4 files changed, 51 insertions(+), 241 deletions(-) delete mode 100644 src/tuvx/interface_radiator_map_v2.F90 diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 4313a14e..14bdb52d 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -73,7 +73,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) // 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 @@ -83,7 +82,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) { optical_depths[row] = &optical_depths_1D[row * num_wavelength_bins]; } - // int i = 1; for(int row = 0; row < num_vertical_layers; row++) { @@ -110,7 +108,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) 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]; @@ -144,7 +141,6 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) 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]; @@ -179,8 +175,7 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) ASSERT_EQ(factors[1][1], 4); ASSERT_EQ(factors[2][0], 5); ASSERT_EQ(factors[2][1], 6); - - // clean up + // Clean up DeleteRadiator(radiator, &error); ASSERT_TRUE(IsSuccess(error)); DeleteGrid(height, &error); ASSERT_TRUE(IsSuccess(error)); DeleteGrid(wavelength, &error); ASSERT_TRUE(IsSuccess(error)); @@ -198,18 +193,14 @@ 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); - // - // TODO(test) - // 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); @@ -218,11 +209,9 @@ TEST_F(TuvxCApiTest, CanCreateRadiatorMap) 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; - - // Test for optical depths 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 radiator_warehouse_t() select type(f_radiator_warehouse) type is(radiator_warehouse_t) - radiator_map = c_loc(f_radiator_warehouse) + 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -105,9 +105,11 @@ function internal_get_radiator(radiator_map, c_radiator_name, & ! 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 @@ -117,8 +119,10 @@ function internal_get_radiator(radiator_map, c_radiator_name, & end do call c_f_pointer(radiator_map, radiator_warehouse) - - f_radiator => radiator_warehouse%get_radiator(f_radiator_name) + + 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) diff --git a/src/tuvx/interface_radiator_map_v2.F90 b/src/tuvx/interface_radiator_map_v2.F90 deleted file mode 100644 index 7b14f6b5..00000000 --- a/src/tuvx/interface_radiator_map_v2.F90 +++ /dev/null @@ -1,178 +0,0 @@ -! 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_radiative_transfer, only : radiative_transfer_t - use tuvx_radiator_warehouse, only : radiator_warehouse_t - use tuvx_radiator, only : radiator_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 - use tuvx_radiative_transfer, only : radiative_transfer_t - - ! arguments - integer(kind=c_int), intent(out) :: error_code - - ! result - type(c_ptr) :: radiator_map - - ! variables - class(radiative_transfer_t), pointer :: f_radiative_transfer - class(radiator_warehouse_t), pointer :: f_radiator_warehouse - - f_radiative_transfer => radiative_transfer_t() - select type(f_radiative_transfer) - type is(radiative_transfer_t) - radiator_map = c_loc(f_radiative_transfer%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 - use tuvx_radiative_transfer, only : radiative_transfer_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - integer(kind=c_int), intent(out) :: error_code - - ! variables - ! type(radiator_warehouse_t), pointer :: f_radiator_warehouse - type(radiative_transfer_t), pointer :: f_radiative_transfer - call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) - deallocate(f_radiative_transfer%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_radiative_transfer, only : radiative_transfer_t - use tuvx_radiator_from_host, only: radiator_from_host_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - type(c_ptr), intent(in), value :: radiator - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(radiative_transfer_t), pointer :: f_radiative_transfer - type(radiator_from_host_t), pointer :: f_radiator - - call c_f_pointer(radiator_map, f_radiative_transfer%radiator_warehouse_) - call c_f_pointer(radiator, f_radiator) - - error_code = 0 - call f_radiative_transfer%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 - use tuvx_radiative_transfer, only : radiative_transfer_t - - ! arguments - type(c_ptr), intent(in), value :: radiator_map - character(len=1, kind=c_char), dimension(*), intent(in) :: c_radiator_name - integer(kind=c_size_t), value :: c_radiator_name_length - integer(kind=c_int), intent(out) :: error_code - - ! variables - type(radiative_transfer_t), pointer :: f_radiative_transfer - class(radiator_t), pointer :: f_radiator - 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, f_radiative_transfer%radiator_warehouse_) - write(*,*) " [jiwon] internal_get_radiator" - ! This doesn't work - f_radiator => f_radiative_transfer%radiator_warehouse_%get_radiator(f_radiator_name) - - 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 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), intent(in), value :: radiator_map - type(c_ptr), intent(in), value :: radiator - integer(kind=c_int), intent(out) :: error_code - - ! output - type(c_ptr) :: updater - - ! variables - type(radiative_transfer_t), pointer :: f_radiative_transfer - 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_radiative_transfer%radiator_warehouse) - call c_f_pointer(radiator, f_radiator) - - error_code = 0 - allocate(f_updater) - f_updater = f_radiative_transfer%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 From cab7fb0e1cdad4d7645661fa8623c2860a88f797 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 31 Jul 2024 18:54:40 -0600 Subject: [PATCH 099/117] fix test --- src/test/unit/tuvx/radiatortest.cpp | 30 ++++++++++++++--------------- src/tuvx/interface_radiator_map.F90 | 27 +++++++++++++++----------- 2 files changed, 31 insertions(+), 26 deletions(-) diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp index 14bdb52d..33e3e354 100644 --- a/src/test/unit/tuvx/radiatortest.cpp +++ b/src/test/unit/tuvx/radiatortest.cpp @@ -45,21 +45,21 @@ class TuvxCApiTest : public ::testing::Test } }; -// 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, 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) { diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index bb4cab88..3e5b1369 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -119,20 +119,25 @@ function internal_get_radiator(radiator_map, c_radiator_name, & end do call c_f_pointer(radiator_map, radiator_warehouse) - - 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 + if (.not. radiator_warehouse%exists(f_radiator_name)) then error_code = 1 - deallocate(f_radiator) radiator_ptr = c_null_ptr - end select + 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 From 29e42f631ce77e54506fabbabd69dfc45eaf20b2 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 13:37:52 -0600 Subject: [PATCH 100/117] fix bugs --- CMakeLists.txt | 2 +- .../fetch_content_integration/CMakeLists.txt | 3 ++- .../test_tuvx_api.F90 | 25 ++++++++++-------- fortran/tuvx/CMakeLists.txt | 2 ++ fortran/tuvx/radiator.F90 | 26 +++++++++---------- fortran/tuvx/tuvx.F90 | 8 +++--- 6 files changed, 36 insertions(+), 30 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 175f4b8b..27b92e20 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ option(MUSICA_ENABLE_MPI "Enable MPI parallel support" OFF) option(MUSICA_ENABLE_OPENMP "Enable OpemMP support" OFF) option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) option(MUSICA_BUILD_DOCS "Build the documentation" OFF) -option(MUSICA_ENABLE_MICM "Enable MICM" ON) +option(MUSICA_ENABLE_MICM "Enable MICM" OFF) option(MUSICA_ENABLE_TUVX "Enable TUV-x" ON) set(MUSICA_SET_MICM_VECTOR_MATRIX_SIZE "1" CACHE STRING "Set MICM vector-ordered matrix dimension") diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 3b978644..7dadb353 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -9,7 +9,8 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}) include(FetchContent) -set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") +# set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") +set(MUSICA_GIT_TAG "122-make-radiator-updatable" CACHE STRING "Git tag for the musica_fortran repository") message(STATUS "Using MUSICA_GIT_TAG: ${MUSICA_GIT_TAG}") diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 54b6e349..19f05faf 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, profile_map_t, profile_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,16 +56,18 @@ end subroutine test_tuvx_api_invalid_config subroutine test_tuvx_solve() - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t), pointer :: grids - character(len=256) :: config_path - type(grid_t), pointer :: grid - type(profile_map_t), pointer :: profiles - type(profile_t), pointer :: profile, profile_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 + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + type(grid_map_t), pointer :: grids + character(len=256) :: config_path + type(grid_t), pointer :: 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 edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) diff --git a/fortran/tuvx/CMakeLists.txt b/fortran/tuvx/CMakeLists.txt index cb3eeb6c..68e400c9 100644 --- a/fortran/tuvx/CMakeLists.txt +++ b/fortran/tuvx/CMakeLists.txt @@ -4,5 +4,7 @@ target_sources(musica-fortran 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/radiator.F90 b/fortran/tuvx/radiator.F90 index 1f7a4a9d..1b84c67b 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -78,7 +78,7 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, type(error_t_c), intent(inout) :: error end subroutine get_single_scattering_albedos_c - subroutine set_asymmetry_factors_c(radiator, asymmetry_factor, num_vertical_layers, & + subroutine set_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & num_wavelength_bins, num_streams, error) bind(C, name="SetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c @@ -90,7 +90,7 @@ subroutine set_asymmetry_factors_c(radiator, asymmetry_factor, num_vertical_laye type(error_t_c), intent(inout) :: error end subroutine set_asymmetry_factors_c - subroutine get_asymmetry_factors_c(radiator, symmetry_factor, num_vertical_layers, & + subroutine get_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_layers, & num_wavelength_bins, num_streams, error) bind(C, name="GetAsymmetryFactors") use iso_c_binding, only : c_ptr, c_size_t use musica_util, only: error_t_c @@ -154,7 +154,7 @@ end function radiator_t_ptr_constructor function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, error) & result(this) use iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, to_c_string + use musica_util, only: error_t, error_t_c, to_c_string, dk => musica_dk ! Arguments character(len=*), intent(in) :: radiator_name @@ -173,7 +173,7 @@ function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, err !! that does memory layout conversion !! this%ptr_ = create_radiator_c(to_c_string(radiator_name), c_loc(height_grid), & - c_loc(avelength_grid), error_c) + c_loc(wavelength_grid), error_c) error = error_t(error_c) end function radiator_t_constructor @@ -284,7 +284,7 @@ end subroutine get_single_scattering_albedos !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine set_asymmetry_factors(this, symmetry_factor, error) + 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 @@ -299,9 +299,9 @@ subroutine set_asymmetry_factors(this, symmetry_factor, error) integer(kind=c_size_t) :: num_wavelength_bins integer(kind=c_size_t) :: num_streams - num_vertical_layers = size(single_scattering_albedos, 1) - num_wavelength_bins = size(single_scattering_albedos, 2) - num_streams = size(num_streams, 3) + 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) @@ -311,7 +311,7 @@ end subroutine set_asymmetry_factors !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine get_asymmetry_factors(this, symmetry_factor, error) + 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 @@ -326,15 +326,15 @@ subroutine get_asymmetry_factors(this, symmetry_factor, error) integer(kind=c_size_t) :: num_wavelength_bins integer(kind=c_size_t) :: num_streams - num_vertical_layers = size(single_scattering_albedos, 1) - num_wavelength_bins = size(single_scattering_albedos, 2) - num_streams = size(num_streams, 3) + 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_single_scattering_albedos + end subroutine get_asymmetry_factors !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index 082712d8..daa228cf 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -171,14 +171,14 @@ 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 + class(tuvx_t), intent(inout) :: this + type(error_t), intent(inout) :: error ! Local variables - type(error_t_c) :: error_c + type(error_t_c) :: error_c ! Return value - type(radiator_map_t), pointer :: radiator_map + type(radiator_map_t), pointer :: radiator_map radiator_map => radiator_map_t(get_radiator_map_c(this%ptr_, error_c)) From a6f302d3c8f0dd102e57d957242a7bc7a6c4f1a8 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 17:46:36 -0600 Subject: [PATCH 101/117] fix fortran bugs --- docker/Dockerfile | 4 ++-- docker/Dockerfile.fortran-gcc | 2 +- docker/Dockerfile.fortran-gcc.integration | 2 +- docker/Dockerfile.memcheck | 2 +- docker/Dockerfile.mpi | 2 +- docker/Dockerfile.mpi_openmp | 2 +- docker/Dockerfile.openmp | 2 +- docker/Dockerfile.python | 2 +- fortran/tuvx/radiator.F90 | 12 ++++++------ fortran/tuvx/tuvx.F90 | 3 ++- 10 files changed, 17 insertions(+), 16 deletions(-) diff --git a/docker/Dockerfile b/docker/Dockerfile index 6fa6c930..377af261 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Release +ARG BUILD_TYPE=Debug RUN dnf -y update \ && dnf -y install \ @@ -9,7 +9,7 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index d21acb7e..93a9bcb1 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -13,7 +13,7 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - lapack-devel \ + # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.fortran-gcc.integration b/docker/Dockerfile.fortran-gcc.integration index 5e7204ca..8fdae414 100644 --- a/docker/Dockerfile.fortran-gcc.integration +++ b/docker/Dockerfile.fortran-gcc.integration @@ -14,7 +14,7 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - lapack-devel \ + # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index cd943615..d31397d6 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -9,7 +9,7 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi b/docker/Dockerfile.mpi index fa85b48f..3a16b622 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -16,7 +16,7 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi_openmp b/docker/Dockerfile.mpi_openmp index f48a4605..d6dfade1 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -16,7 +16,7 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index efc433b8..0ab97773 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -16,7 +16,7 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - lapack-devel \ + # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.python b/docker/Dockerfile.python index 02788a0f..5765515b 100644 --- a/docker/Dockerfile.python +++ b/docker/Dockerfile.python @@ -9,7 +9,7 @@ RUN dnf -y update \ gcc-fortran \ gdb \ git \ - lapack-devel \ + # lapack-devel \ make \ netcdf-fortran-devel \ pip \ diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 1b84c67b..d4abab92 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -33,7 +33,7 @@ subroutine delete_radiator_c(radiator, error) bind(C, name="DeleteRadiator") end subroutine delete_radiator_c subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & - num_wavelength_bins, error) bind(C, name="SetOpticalDepths") + 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 @@ -44,7 +44,7 @@ subroutine set_optical_depths_c(radiator, optical_depths, num_vertical_layers, & end subroutine set_optical_depths_c subroutine get_optical_depths_c(radiator, optical_depths, num_vertical_layers, & - num_wavelength_bins, error) bind(C, name="GetOpticalDepths") + 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 @@ -56,7 +56,7 @@ 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="SetSingleScatteringAlbedos") + 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 @@ -68,7 +68,7 @@ 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="GetSingleScatteringAlbedos") + 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 @@ -79,7 +79,7 @@ subroutine get_single_scattering_albedos_c(radiator, single_scattering_albedos, 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="SetAsymmetryFactors") + 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 @@ -91,7 +91,7 @@ subroutine set_asymmetry_factors_c(radiator, asymmetry_factors, num_vertical_lay 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="GetAsymmetryFactors") + 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 diff --git a/fortran/tuvx/tuvx.F90 b/fortran/tuvx/tuvx.F90 index daa228cf..36a58d79 100644 --- a/fortran/tuvx/tuvx.F90 +++ b/fortran/tuvx/tuvx.F90 @@ -15,7 +15,8 @@ module musica_tuvx #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) private - public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t + public :: tuvx_t, grid_map_t, grid_t, profile_map_t, profile_t, & + radiator_map_t, radiator_t !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 18d47cae768c71ea2d80c43f4079a8c18ea5c44f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 18:12:57 -0600 Subject: [PATCH 102/117] add radiator fortran test --- .../fetch_content_integration/CMakeLists.txt | 48 ++++++++++----- .../temp_radiator.F90 | 61 +++++++++++++++++++ 2 files changed, 95 insertions(+), 14 deletions(-) create mode 100644 fortran/test/fetch_content_integration/temp_radiator.F90 diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 7dadb353..8c10fb5d 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -90,23 +90,23 @@ endif() # API Test if (MUSICA_ENABLE_TUVX) - add_executable(test_tuvx_fortran_api test_tuvx_api.F90) + # add_executable(test_tuvx_fortran_api test_tuvx_api.F90) - target_link_libraries(test_tuvx_fortran_api - PRIVATE - musica::musica-fortran - ) + # target_link_libraries(test_tuvx_fortran_api + # PRIVATE + # musica::musica-fortran + # ) - set_target_properties(test_tuvx_fortran_api - PROPERTIES - LINKER_LANGUAGE Fortran - ) + # set_target_properties(test_tuvx_fortran_api + # PROPERTIES + # LINKER_LANGUAGE Fortran + # ) - add_test( - NAME test_tuvx_fortran_api - COMMAND $ - WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - ) + # add_test( + # NAME test_tuvx_fortran_api + # COMMAND $ + # WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + # ) add_custom_target( copy_tuvx_examples_dir ALL ${CMAKE_COMMAND} -E copy_directory @@ -118,3 +118,23 @@ if (MUSICA_ENABLE_TUVX) ${CMAKE_CURRENT_SOURCE_DIR}/../../../build/_deps/tuvx-src/data ${CMAKE_BINARY_DIR}/data ) endif() + + +# TODO(jiwon) - just a temp test +add_executable(test_jiwon temp_radiator.F90) + +target_link_libraries(test_jiwon + PRIVATE + musica::musica-fortran +) + +set_target_properties(test_jiwon + PROPERTIES + LINKER_LANGUAGE Fortran +) + +add_test( + NAME test_jiwon + COMMAND $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} +) \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/temp_radiator.F90 b/fortran/test/fetch_content_integration/temp_radiator.F90 new file mode 100644 index 00000000..04ed273f --- /dev/null +++ b/fortran/test/fetch_content_integration/temp_radiator.F90 @@ -0,0 +1,61 @@ +! Copyright (C) 2023-2024 National Center for Atmospheric Research +! SPDX-License-Identifier: Apache-2.0 +! +program combined_tuvx_tests + use iso_c_binding + 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 + + #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) + #define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) + + ! Call the valid test subroutine + call test_tuvx_api() + + ! Call the invalid test subroutine + ! disabling until tuv no longer calls stop internally + ! call test_tuvx_api_invalid_config() + + ! Call the solve test subroutine + call test_tuvx_solve() + + contains + subroutine test_jiwon_solve() + + type(tuvx_t), pointer :: tuvx + type(error_t) :: error + type(grid_map_t), pointer :: grids + character(len=256) :: config_path + type(grid_t), pointer :: 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 + + edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) + 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 /) + + config_path = "examples/ts1_tsmlt.json" + + tuvx => tuvx_t( config_path, error ) + ASSERT( error%is_success() ) + radiators => tuvx%get_radiators( error ) + ASSERT( error%is_success() ) + + ! grid => grids%get( "height", "km", error ) + ! ASSERT( .not. error%is_success() ) ! non-accessible grid + ! deallocate( grid ) + ! deallocate( grids ) + + end subroutine test_tuvx_solve + +end program combined_tuvx_tests \ No newline at end of file From 0101fe36237883e56efb579fece2175efada6f63 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Fri, 2 Aug 2024 18:36:08 -0600 Subject: [PATCH 103/117] test tag --- docker/Dockerfile.fortran-gcc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index 93a9bcb1..f4b1833b 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -33,10 +33,13 @@ ENV FFLAGS="-I/usr/include/" # Copy the musica code COPY . musica +ARG MUSICA_GIT_TAG=122-make-radiator-updatable + # Build and install MUSICA RUN cd musica \ && cmake -S . \ -B build \ + -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -D CMAKE_BUILD_TYPE=${BUILD_TYPE} \ -D MUSICA_BUILD_FORTRAN_INTERFACE=ON \ -D MUSICA_ENABLE_MEMCHECK=ON \ From f82d417cdf4c4ba6a41e8a7ca0ad1b863ad52618 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 07:37:55 -0600 Subject: [PATCH 104/117] add fortran test --- .../temp_radiator.F90 | 182 ++++++++++++++++-- .../test_tuvx_api.F90 | 2 +- fortran/test/unit/CMakeLists.txt | 29 +-- fortran/tuvx/profile.F90 | 2 +- fortran/tuvx/radiator.F90 | 45 ++--- 5 files changed, 199 insertions(+), 61 deletions(-) diff --git a/fortran/test/fetch_content_integration/temp_radiator.F90 b/fortran/test/fetch_content_integration/temp_radiator.F90 index 04ed273f..5673ddd8 100644 --- a/fortran/test/fetch_content_integration/temp_radiator.F90 +++ b/fortran/test/fetch_content_integration/temp_radiator.F90 @@ -1,26 +1,19 @@ ! Copyright (C) 2023-2024 National Center for Atmospheric Research ! SPDX-License-Identifier: Apache-2.0 ! -program combined_tuvx_tests +program combined_tuvx_tests2 use iso_c_binding 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 - + use musica_util, only: assert, error_t, dk => musica_dk + implicit none - #define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) - #define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) - - ! Call the valid test subroutine - call test_tuvx_api() +#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) +#define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) - ! Call the invalid test subroutine - ! disabling until tuv no longer calls stop internally - ! call test_tuvx_api_invalid_config() - - ! Call the solve test subroutine - call test_tuvx_solve() + ! Call the valid test subroutine + call test_jiwon_solve() contains subroutine test_jiwon_solve() @@ -29,7 +22,7 @@ subroutine test_jiwon_solve() type(error_t) :: error type(grid_map_t), pointer :: grids character(len=256) :: config_path - type(grid_t), pointer :: grid + 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 @@ -37,6 +30,10 @@ subroutine test_jiwon_solve() 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 = (/ 15.0, 25.0, 35.0, 45.0 /) @@ -44,18 +41,161 @@ subroutine test_jiwon_solve() 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() ) + +! ! +! ! TODO - Radiator starts here? +! ! radiators => tuvx%get_radiators( error ) ASSERT( error%is_success() ) - ! grid => grids%get( "height", "km", error ) - ! ASSERT( .not. error%is_success() ) ! non-accessible grid - ! deallocate( grid ) - ! deallocate( grids ) + radiator => radiators%get( "foo_radiator", error ) + ASSERT( .not. error%is_success() ) ! non-accessible grid + deallocate( radiator ) + deallocate( radiators ) - end subroutine test_tuvx_solve + 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 ) + + ! call radiator_copy + + 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( radiator_copy ) + deallocate( radiator ) + deallocate( radiators ) + deallocate( height_grid ) + deallocate( wavelength_grid ) + deallocate( tuvx ) + end subroutine test_jiwon_solve -end program combined_tuvx_tests \ No newline at end of file +end program combined_tuvx_tests2 \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 19f05faf..123e296c 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -59,7 +59,6 @@ subroutine test_tuvx_solve() type(tuvx_t), pointer :: tuvx type(error_t) :: error type(grid_map_t), pointer :: grids - character(len=256) :: config_path type(grid_t), pointer :: grid type(profile_map_t), pointer :: profiles type(profile_t), pointer :: profile, profile_copy @@ -68,6 +67,7 @@ subroutine test_tuvx_solve() 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 + character(len=256) :: config_path edges = (/ 1.0, 2.0, 3.0, 4.0, 5.0 /) midpoints = (/ 15.0, 25.0, 35.0, 45.0 /) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index 27b0de76..db21bb45 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -1,21 +1,22 @@ include(test_util) -create_standard_test_fortran(NAME fortran_util SOURCES util.F90) +# 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) -endif() +# 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) +# endif() if (MUSICA_ENABLE_TUVX) - create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) - create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) + # create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) + # create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) + create_standard_test_fortran(NAME temp_jiwon SOURCES ../fetch_content_integration/temp_radiator.F90) - if (MUSICA_ENABLE_OPENMP) - create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) - endif() - if (MUSICA_ENABLE_MPI) - create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) - endif() + # if (MUSICA_ENABLE_OPENMP) + # create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) + # endif() + # if (MUSICA_ENABLE_MPI) + # create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) + # endif() endif() diff --git a/fortran/tuvx/profile.F90 b/fortran/tuvx/profile.F90 index 68c8bd6a..757a08fc 100644 --- a/fortran/tuvx/profile.F90 +++ b/fortran/tuvx/profile.F90 @@ -16,7 +16,7 @@ module musica_tuvx_profile interface function create_profile_c(profile_name, profile_units, grid, error) & bind(C, name="CreateProfile") - use iso_c_binding, only: c_ptr, c_char, c_size_t + 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(*) diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index d4abab92..2b2f730a 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -19,8 +19,8 @@ function create_radiator_c(radiator_name, height_grid, wavelength_grid, error) & 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), intent(in) :: height_grid - type(c_ptr), intent(in) :: wavelength_grid + 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 @@ -151,29 +151,26 @@ 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 iso_c_binding, only: c_size_t, c_loc - use musica_util, only: error_t, error_t_c, to_c_string, dk => musica_dk + 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 - real(dk), target, dimension(:,:), intent(in) :: height_grid - real(dk), target, dimension(:,:), intent(in) :: wavelength_grid - type(error_t), intent(inout) :: error + 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 ) - !! - !! TODO(jiwon) - is it okay to c_loc() 2d array or should i create a new function - !! that does memory layout conversion - !! - this%ptr_ = create_radiator_c(to_c_string(radiator_name), c_loc(height_grid), & - c_loc(wavelength_grid), error_c) + 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 @@ -196,7 +193,7 @@ subroutine set_optical_depths(this, optical_depths, error) 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) @@ -210,9 +207,9 @@ subroutine get_optical_depths(this, optical_depths, error) use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this + class(radiator_t), intent(inout) :: this real(dk), target, dimension(:,:), intent(in) :: optical_depths - type(error_t), intent(inout) :: error + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -236,9 +233,9 @@ subroutine set_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this + class(radiator_t), intent(inout) :: this real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + type(error_t), intent(inout) :: error ! Local variables type(error_t_c) :: error_c @@ -263,12 +260,12 @@ subroutine get_single_scattering_albedos(this, single_scattering_albedos, & use musica_util, only: error_t, error_t_c, dk => musica_dk ! Arguments - class(radiator_t), intent(inout) :: this + class(radiator_t), intent(inout) :: this real(dk), target, dimension(:,:), intent(in) :: single_scattering_albedos - type(error_t), intent(inout) :: error + type(error_t), intent(inout) :: error ! Local variables - type(error_t_c) :: error_c + type(error_t_c) :: error_c integer(kind=c_size_t) :: num_vertical_layers integer(kind=c_size_t) :: num_wavelength_bins From 07cde7dbe4cb160143b05b5fc5bcb58a73151060 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 07:45:59 -0600 Subject: [PATCH 105/117] add tests back: --- fortran/test/unit/CMakeLists.txt | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index db21bb45..de18d125 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -1,22 +1,22 @@ include(test_util) -# create_standard_test_fortran(NAME fortran_util SOURCES util.F90) +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) -# endif() +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) +endif() if (MUSICA_ENABLE_TUVX) - # create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) - # create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) + create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) + create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) create_standard_test_fortran(NAME temp_jiwon SOURCES ../fetch_content_integration/temp_radiator.F90) - # if (MUSICA_ENABLE_OPENMP) - # create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) - # endif() - # if (MUSICA_ENABLE_MPI) - # create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) - # endif() + if (MUSICA_ENABLE_OPENMP) + create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) + endif() + if (MUSICA_ENABLE_MPI) + create_standard_test_fortran(NAME connect_to_tuvx_mpi SOURCES tuvx_mpi.F90) + endif() endif() From 72362cc7d5ec293321f05c4dedd66777568a1010 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 08:37:35 -0600 Subject: [PATCH 106/117] fix docker integration --- .../fetch_content_integration/CMakeLists.txt | 58 +++--- .../test_tuvx_api.F90 | 172 ++++++++++++++++-- fortran/tuvx/radiator.F90 | 22 +-- 3 files changed, 199 insertions(+), 53 deletions(-) diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 8c10fb5d..7ec611b1 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -90,23 +90,23 @@ endif() # API Test if (MUSICA_ENABLE_TUVX) - # add_executable(test_tuvx_fortran_api test_tuvx_api.F90) + add_executable(test_tuvx_fortran_api test_tuvx_api.F90) - # target_link_libraries(test_tuvx_fortran_api - # PRIVATE - # musica::musica-fortran - # ) + target_link_libraries(test_tuvx_fortran_api + PRIVATE + musica::musica-fortran + ) - # set_target_properties(test_tuvx_fortran_api - # PROPERTIES - # LINKER_LANGUAGE Fortran - # ) + set_target_properties(test_tuvx_fortran_api + PROPERTIES + LINKER_LANGUAGE Fortran + ) - # add_test( - # NAME test_tuvx_fortran_api - # COMMAND $ - # WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - # ) + add_test( + NAME test_tuvx_fortran_api + COMMAND $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + ) add_custom_target( copy_tuvx_examples_dir ALL ${CMAKE_COMMAND} -E copy_directory @@ -120,21 +120,21 @@ if (MUSICA_ENABLE_TUVX) endif() -# TODO(jiwon) - just a temp test -add_executable(test_jiwon temp_radiator.F90) +# # TODO(jiwon) - just a temp test +# add_executable(test_jiwon temp_radiator.F90) -target_link_libraries(test_jiwon - PRIVATE - musica::musica-fortran -) +# target_link_libraries(test_jiwon +# PRIVATE +# musica::musica-fortran +# ) -set_target_properties(test_jiwon - PROPERTIES - LINKER_LANGUAGE Fortran -) +# set_target_properties(test_jiwon +# PROPERTIES +# LINKER_LANGUAGE Fortran +# ) -add_test( - NAME test_jiwon - COMMAND $ - WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} -) \ No newline at end of file +# add_test( +# NAME test_jiwon +# COMMAND $ +# WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} +# ) \ No newline at end of file diff --git a/fortran/test/fetch_content_integration/test_tuvx_api.F90 b/fortran/test/fetch_content_integration/test_tuvx_api.F90 index 123e296c..7dfdddff 100644 --- a/fortran/test/fetch_content_integration/test_tuvx_api.F90 +++ b/fortran/test/fetch_content_integration/test_tuvx_api.F90 @@ -56,24 +56,36 @@ end subroutine test_tuvx_api_invalid_config subroutine test_tuvx_solve() - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t), pointer :: grids - type(grid_t), pointer :: 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 - character(len=256) :: config_path + 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 = (/ 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" @@ -315,12 +327,146 @@ subroutine test_tuvx_solve() 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/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 2b2f730a..121e3cb0 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -18,18 +18,18 @@ 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 + 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 + 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, & @@ -112,15 +112,15 @@ end subroutine get_asymmetry_factors_c procedure :: set_optical_depths ! Get radiator optical depths procedure :: get_optical_depths - ! Set the radiator single scattering albedos + ! Set radiator single scattering albedos procedure :: set_single_scattering_albedos - ! Get the radiator single scattering albedos + ! Get radiator single scattering albedos procedure :: get_single_scattering_albedos - ! Set the radiator asymmetry_factors + ! Set radiator asymmetry_factors procedure :: set_asymmetry_factors - ! Get the radiator asymmetry factors + ! Get radiator asymmetry factors procedure :: get_asymmetry_factors - ! Deallocate the radiator instance + ! Deallocate radiator instance final :: finalize_radiator_t end type radiator_t From ceb64d5eea817ae00e73a41fb6f9d1bf94ac98c2 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 10:25:23 -0600 Subject: [PATCH 107/117] revert cmake --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 27b92e20..175f4b8b 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -27,7 +27,7 @@ option(MUSICA_ENABLE_MPI "Enable MPI parallel support" OFF) option(MUSICA_ENABLE_OPENMP "Enable OpemMP support" OFF) option(MUSICA_ENABLE_MEMCHECK "Enable memory checking" OFF) option(MUSICA_BUILD_DOCS "Build the documentation" OFF) -option(MUSICA_ENABLE_MICM "Enable MICM" 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") From b75e012637678a5dcd19fb4bf57af3701eef460b Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 13:41:39 -0600 Subject: [PATCH 108/117] clean up --- src/tuvx/interface_profile_map.F90 | 8 ++++---- src/tuvx/interface_radiator_map.F90 | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/tuvx/interface_profile_map.F90 b/src/tuvx/interface_profile_map.F90 index a6057095..47e9cba7 100644 --- a/src/tuvx/interface_profile_map.F90 +++ b/src/tuvx/interface_profile_map.F90 @@ -3,11 +3,11 @@ ! 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 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 + use musica_tuvx_util, only : to_f_string, string_t_c + use musica_string, only : string_t implicit none diff --git a/src/tuvx/interface_radiator_map.F90 b/src/tuvx/interface_radiator_map.F90 index 3e5b1369..1ff04482 100644 --- a/src/tuvx/interface_radiator_map.F90 +++ b/src/tuvx/interface_radiator_map.F90 @@ -4,8 +4,8 @@ module tuvx_interface_radiator_map use iso_c_binding, only : c_ptr, c_loc, c_int, c_size_t, c_char - use tuvx_radiator_warehouse, only : radiator_warehouse_t 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 From 3611be0202cc308988c752ef886762d923c27cc7 Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Mon, 5 Aug 2024 15:49:06 -0600 Subject: [PATCH 109/117] code cleanup --- .../temp_radiator.F90 | 201 ---------- src/test/unit/tuvx/CMakeLists.txt | 1 - src/test/unit/tuvx/radiatortest.cpp | 361 ------------------ src/test/unit/tuvx/tuvx_c_api.cpp | 326 ++++++++++++++++ 4 files changed, 326 insertions(+), 563 deletions(-) delete mode 100644 fortran/test/fetch_content_integration/temp_radiator.F90 delete mode 100644 src/test/unit/tuvx/radiatortest.cpp diff --git a/fortran/test/fetch_content_integration/temp_radiator.F90 b/fortran/test/fetch_content_integration/temp_radiator.F90 deleted file mode 100644 index 5673ddd8..00000000 --- a/fortran/test/fetch_content_integration/temp_radiator.F90 +++ /dev/null @@ -1,201 +0,0 @@ -! Copyright (C) 2023-2024 National Center for Atmospheric Research -! SPDX-License-Identifier: Apache-2.0 -! -program combined_tuvx_tests2 - use iso_c_binding - 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, dk => musica_dk - - implicit none - -#define ASSERT( expr ) call assert( expr, __FILE__, __LINE__ ) -#define ASSERT_EQ( a, b ) call assert( a == b, __FILE__, __LINE__ ) - - ! Call the valid test subroutine - call test_jiwon_solve() - - contains - subroutine test_jiwon_solve() - - type(tuvx_t), pointer :: tuvx - type(error_t) :: error - type(grid_map_t), pointer :: grids - character(len=256) :: config_path - 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 = (/ 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() ) - -! ! -! ! TODO - Radiator starts here? -! ! - radiators => tuvx%get_radiators( error ) - ASSERT( error%is_success() ) - - radiator => radiators%get( "foo_radiator", error ) - ASSERT( .not. error%is_success() ) ! non-accessible grid - 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 ) - - ! call radiator_copy - - 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( radiator_copy ) - deallocate( radiator ) - deallocate( radiators ) - deallocate( height_grid ) - deallocate( wavelength_grid ) - deallocate( tuvx ) - end subroutine test_jiwon_solve - -end program combined_tuvx_tests2 \ No newline at end of file diff --git a/src/test/unit/tuvx/CMakeLists.txt b/src/test/unit/tuvx/CMakeLists.txt index 05dcc0f8..28b926c0 100644 --- a/src/test/unit/tuvx/CMakeLists.txt +++ b/src/test/unit/tuvx/CMakeLists.txt @@ -1,7 +1,6 @@ include(test_util) create_standard_test_cxx(NAME tuvx_c_api SOURCES tuvx_c_api.cpp) -create_standard_test_cxx(NAME tuvx_radiator_test SOURCES radiatortest.cpp) ################################################################################ # Copy tuvx test data diff --git a/src/test/unit/tuvx/radiatortest.cpp b/src/test/unit/tuvx/radiatortest.cpp deleted file mode 100644 index 33e3e354..00000000 --- a/src/test/unit/tuvx/radiatortest.cpp +++ /dev/null @@ -1,361 +0,0 @@ -#include -#include - -#include -#include -#include - -using namespace musica; - -// Test fixture for the TUVX C API -class TuvxCApiTest : public ::testing::Test -{ - protected: - TUVX* tuvx; - - // the function that google test actually calls before each test - void SetUp() override - { - tuvx = nullptr; - } - - void SetUp(const char* config_path) - { - Error error; - tuvx = CreateTuvx(config_path, &error); - if (!IsSuccess(error)) - { - std::cerr << "Error creating TUVX instance: " << error.message_.value_ << std::endl; - } - ASSERT_TRUE(IsSuccess(error)); - DeleteError(&error); - } - - void TearDown() override - { - if (tuvx == nullptr) - { - return; - } - Error error; - DeleteTuvx(tuvx, &error); - ASSERT_TRUE(IsSuccess(error)); - DeleteError(&error); - tuvx = nullptr; - } -}; - -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 Date: Mon, 5 Aug 2024 17:00:26 -0600 Subject: [PATCH 110/117] code clean up --- cmake/dependencies.cmake | 3 +- docker/Dockerfile | 2 +- docker/Dockerfile.fortran-gcc | 4 +- .../fetch_content_integration/CMakeLists.txt | 22 +-- fortran/test/unit/CMakeLists.txt | 1 - fortran/tuvx/radiator.F90 | 44 +++--- include/musica/tuvx/tuvx.hpp | 4 +- src/test/unit/tuvx/tuvx_c_api.cpp | 121 +++++++++------- src/tuvx/interface.F90 | 20 +-- src/tuvx/interface_radiator.F90 | 137 ++++++++---------- src/tuvx/interface_radiator_map.F90 | 24 +-- src/tuvx/radiator.cpp | 3 +- 12 files changed, 177 insertions(+), 208 deletions(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index d819d737..43de1d73 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,8 +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 80f896a0fb591987c2a79209377bd6f599b4fb6f) - set_git_default(TUVX_GIT_TAG make-radiator-updatable) + set_git_default(TUVX_GIT_TAG f8ae5a2) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/docker/Dockerfile b/docker/Dockerfile index 377af261..d93a7d06 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -1,6 +1,6 @@ FROM fedora:35 -ARG BUILD_TYPE=Debug +ARG BUILD_TYPE=Release RUN dnf -y update \ && dnf -y install \ diff --git a/docker/Dockerfile.fortran-gcc b/docker/Dockerfile.fortran-gcc index f4b1833b..77912573 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -33,14 +33,12 @@ ENV FFLAGS="-I/usr/include/" # Copy the musica code COPY . musica -ARG MUSICA_GIT_TAG=122-make-radiator-updatable - # Build and install MUSICA RUN cd musica \ && cmake -S . \ -B build \ - -D MUSICA_GIT_TAG=${MUSICA_GIT_TAG} \ -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/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 7ec611b1..1b4de550 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -117,24 +117,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() - - -# # TODO(jiwon) - just a temp test -# add_executable(test_jiwon temp_radiator.F90) - -# target_link_libraries(test_jiwon -# PRIVATE -# musica::musica-fortran -# ) - -# set_target_properties(test_jiwon -# PROPERTIES -# LINKER_LANGUAGE Fortran -# ) - -# add_test( -# NAME test_jiwon -# COMMAND $ -# WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} -# ) \ No newline at end of file +endif() \ No newline at end of file diff --git a/fortran/test/unit/CMakeLists.txt b/fortran/test/unit/CMakeLists.txt index e97843ba..c2946b08 100644 --- a/fortran/test/unit/CMakeLists.txt +++ b/fortran/test/unit/CMakeLists.txt @@ -12,7 +12,6 @@ endif() if (MUSICA_ENABLE_TUVX) create_standard_test_fortran(NAME connect_to_tuvx SOURCES tuvx.F90) create_standard_test_fortran(NAME tuvx_fortran_api SOURCES ../fetch_content_integration/test_tuvx_api.F90) - create_standard_test_fortran(NAME temp_jiwon SOURCES ../fetch_content_integration/temp_radiator.F90) if (MUSICA_ENABLE_OPENMP) create_standard_test_fortran(NAME connect_to_tuvx_openmp SOURCES tuvx_openmp.F90) diff --git a/fortran/tuvx/radiator.F90 b/fortran/tuvx/radiator.F90 index 121e3cb0..60a79ee6 100644 --- a/fortran/tuvx/radiator.F90 +++ b/fortran/tuvx/radiator.F90 @@ -157,10 +157,10 @@ function radiator_t_constructor(radiator_name, height_grid, wavelength_grid, & 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 + 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 @@ -182,9 +182,9 @@ subroutine set_optical_depths(this, optical_depths, error) 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 + 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 @@ -207,9 +207,9 @@ subroutine get_optical_depths(this, optical_depths, error) 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 + 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 @@ -233,9 +233,9 @@ subroutine set_single_scattering_albedos(this, single_scattering_albedos, & 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 + 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 @@ -260,9 +260,9 @@ subroutine get_single_scattering_albedos(this, single_scattering_albedos, & 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 + 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 @@ -286,9 +286,9 @@ subroutine set_asymmetry_factors(this, asymmetry_factors, error) 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 + 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 @@ -313,9 +313,9 @@ subroutine get_asymmetry_factors(this, asymmetry_factors, error) 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 + 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 diff --git a/include/musica/tuvx/tuvx.hpp b/include/musica/tuvx/tuvx.hpp index 47516256..bd862fde 100644 --- a/include/musica/tuvx/tuvx.hpp +++ b/include/musica/tuvx/tuvx.hpp @@ -39,8 +39,8 @@ namespace musica /// @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 + /// @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); diff --git a/src/test/unit/tuvx/tuvx_c_api.cpp b/src/test/unit/tuvx/tuvx_c_api.cpp index bfa47c3f..91dbbc93 100644 --- a/src/test/unit/tuvx/tuvx_c_api.cpp +++ b/src/test/unit/tuvx/tuvx_c_api.cpp @@ -417,16 +417,16 @@ TEST_F(TuvxCApiTest, CanCreateRadiator) // 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]; + double** optical_depths = new double*[num_vertical_layers]; // Fill in the pointers to the rows - for(int row =0; row Date: Mon, 5 Aug 2024 17:12:42 -0600 Subject: [PATCH 111/117] revert back to main branch --- fortran/test/fetch_content_integration/CMakeLists.txt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/fortran/test/fetch_content_integration/CMakeLists.txt b/fortran/test/fetch_content_integration/CMakeLists.txt index 1b4de550..d0707f7b 100644 --- a/fortran/test/fetch_content_integration/CMakeLists.txt +++ b/fortran/test/fetch_content_integration/CMakeLists.txt @@ -9,8 +9,7 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}) include(FetchContent) -# set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") -set(MUSICA_GIT_TAG "122-make-radiator-updatable" CACHE STRING "Git tag for the musica_fortran repository") +set(MUSICA_GIT_TAG "main" CACHE STRING "Git tag for the musica_fortran repository") message(STATUS "Using MUSICA_GIT_TAG: ${MUSICA_GIT_TAG}") From 879d5e992d7a6446373d45cf8bebd62f5d316213 Mon Sep 17 00:00:00 2001 From: Kyle Shores Date: Wed, 7 Aug 2024 08:16:15 -0500 Subject: [PATCH 112/117] 159 create an action to publish to pypi when we make a release (#184) * testing automated pypi release * trying to appropriately name the wheels * only need one version of python to build wheels for all other versions * trying to get macos to build successfully * excluding universal2 arch build for macos * seeing if arm64 works * trying to skip musllinux * trying to choose linux architecture support * trying to skip musllinux again * adding intel based mac build * trying to set the osx deployment target * trying a different way * that wasn't it * trying to force a minimum of 10.15 for macos? * setting action trigger * undoing version change * correcting project name --- .github/workflows/release.yml | 85 +++++++++++++++++++++++++++++++++++ pyproject.toml | 5 ++- 2 files changed, 89 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/release.yml 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/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" From d41d152b424f1655816750a8c3d0d2a96fb8935f Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 7 Aug 2024 11:16:57 -0600 Subject: [PATCH 113/117] Address review comments --- cmake/dependencies.cmake | 2 +- docker/Dockerfile | 1 - docker/Dockerfile.fortran-gcc | 1 - docker/Dockerfile.fortran-gcc.integration | 1 - docker/Dockerfile.memcheck | 1 - docker/Dockerfile.mpi | 1 - docker/Dockerfile.mpi_openmp | 1 - docker/Dockerfile.openmp | 1 - docker/Dockerfile.python | 1 - include/musica/tuvx/grid.hpp | 5 +++-- include/musica/tuvx/grid_map.hpp | 5 +++-- include/musica/tuvx/profile.hpp | 5 +++-- include/musica/tuvx/profile_map.hpp | 5 +++-- 13 files changed, 13 insertions(+), 17 deletions(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 43de1d73..f50decd0 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,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 f8ae5a2) + set_git_default(TUVX_GIT_TAG 0e27463) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} diff --git a/docker/Dockerfile b/docker/Dockerfile index d93a7d06..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 77912573..0a181191 100644 --- a/docker/Dockerfile.fortran-gcc +++ b/docker/Dockerfile.fortran-gcc @@ -13,7 +13,6 @@ RUN dnf -y update \ git \ hdf5-devel \ json-devel \ - # lapack-devel \ lcov \ libcurl-devel \ m4 \ diff --git a/docker/Dockerfile.fortran-gcc.integration b/docker/Dockerfile.fortran-gcc.integration index 8fdae414..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 \ diff --git a/docker/Dockerfile.memcheck b/docker/Dockerfile.memcheck index d31397d6..8b330b51 100644 --- a/docker/Dockerfile.memcheck +++ b/docker/Dockerfile.memcheck @@ -9,7 +9,6 @@ RUN dnf -y update \ gfortran \ gdb \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi b/docker/Dockerfile.mpi index 3a16b622..8935ca62 100644 --- a/docker/Dockerfile.mpi +++ b/docker/Dockerfile.mpi @@ -16,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.mpi_openmp b/docker/Dockerfile.mpi_openmp index d6dfade1..7a5eb9b8 100644 --- a/docker/Dockerfile.mpi_openmp +++ b/docker/Dockerfile.mpi_openmp @@ -16,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.openmp b/docker/Dockerfile.openmp index 0ab97773..cb612509 100644 --- a/docker/Dockerfile.openmp +++ b/docker/Dockerfile.openmp @@ -16,7 +16,6 @@ RUN sudo dnf -y install \ gcc-c++ \ gfortran \ git \ - # lapack-devel \ lcov \ make \ netcdf-fortran-devel \ diff --git a/docker/Dockerfile.python b/docker/Dockerfile.python index 5765515b..8484ddc7 100644 --- a/docker/Dockerfile.python +++ b/docker/Dockerfile.python @@ -9,7 +9,6 @@ RUN dnf -y update \ gcc-fortran \ gdb \ git \ - # lapack-devel \ make \ netcdf-fortran-devel \ pip \ diff --git a/include/musica/tuvx/grid.hpp b/include/musica/tuvx/grid.hpp index 86c7f46f..bd7a6d3b 100644 --- a/include/musica/tuvx/grid.hpp +++ b/include/musica/tuvx/grid.hpp @@ -14,9 +14,10 @@ namespace musica class Profile; class Radiator; - /// @brief A grid struct used to access grid information in tuvx - struct Grid + /// @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 diff --git a/include/musica/tuvx/grid_map.hpp b/include/musica/tuvx/grid_map.hpp index b1d95ae0..50686593 100644 --- a/include/musica/tuvx/grid_map.hpp +++ b/include/musica/tuvx/grid_map.hpp @@ -12,9 +12,10 @@ namespace musica { - /// @brief A grid map struct used to access grid information in tuvx - struct GridMap + /// @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) diff --git a/include/musica/tuvx/profile.hpp b/include/musica/tuvx/profile.hpp index 147d970a..309f9bbc 100644 --- a/include/musica/tuvx/profile.hpp +++ b/include/musica/tuvx/profile.hpp @@ -14,9 +14,10 @@ namespace musica { class ProfileMap; - /// @brief A struct used to interact with TUV-x profiles (properties with values on a grid) - struct Profile + /// @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 diff --git a/include/musica/tuvx/profile_map.hpp b/include/musica/tuvx/profile_map.hpp index 35fc8857..0b5ee6fe 100644 --- a/include/musica/tuvx/profile_map.hpp +++ b/include/musica/tuvx/profile_map.hpp @@ -13,9 +13,10 @@ namespace musica { - /// @brief A struct used to store a collection of profiles - struct ProfileMap + /// @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) From 2a419e9dc0d1e24f143fb1dfa5f3cf2c921cf98c Mon Sep 17 00:00:00 2001 From: Jiwon Gim Date: Wed, 7 Aug 2024 11:28:16 -0600 Subject: [PATCH 114/117] fix tuvx git tag --- cmake/dependencies.cmake | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index f50decd0..81d930e2 100644 --- a/cmake/dependencies.cmake +++ b/cmake/dependencies.cmake @@ -75,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 0e27463) + set_git_default(TUVX_GIT_TAG 674ee1e72853bb44d23c36602fa73c955b2f021d) FetchContent_Declare(tuvx GIT_REPOSITORY ${TUVX_GIT_REPOSITORY} From 1194034be71d8914612ab04c09ded95c8418691e Mon Sep 17 00:00:00 2001 From: Kyle Shores Date: Wed, 7 Aug 2024 15:53:39 -0500 Subject: [PATCH 115/117] Python error checking (#189) * adding error checking, some debug statements for the python wrapper * adding error checking to python, updating micm tag * getting tests to pass * correcting a fortran test * newest tuvx commit * I don't know what's wrong with nvidia --- CMakeLists.txt | 2 +- cmake/dependencies.cmake | 2 +- configs/chapman/species.json | 2 +- .../test_micm_api.F90 | 21 ++++------ include/musica/micm.hpp | 2 + python/test/test_chapman.py | 13 +++---- python/wrapper.cpp | 6 +++ src/micm/micm.cpp | 3 +- src/test/unit/micm/micm_c_api.cpp | 39 +++++++------------ 9 files changed, 40 insertions(+), 50 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 175f4b8b..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) diff --git a/cmake/dependencies.cmake b/cmake/dependencies.cmake index 81d930e2..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} 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/fortran/test/fetch_content_integration/test_micm_api.F90 b/fortran/test/fetch_content_integration/test_micm_api.F90 index 24d9d31c..6450850f 100644 --- a/fortran/test/fetch_content_integration/test_micm_api.F90 +++ b/fortran/test/fetch_content_integration/test_micm_api.F90 @@ -30,7 +30,7 @@ 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 @@ -52,8 +52,8 @@ subroutine test_api() 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 /) + 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 /) @@ -109,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", solver_type, num_grid_cells, error ) - ASSERT( error%is_error( MICM_ERROR_CATEGORY_CONFIGURATION, \ - MICM_CONFIGURATION_ERROR_CODE_INVALID_FILE_PATH ) ) + 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/include/musica/micm.hpp b/include/musica/micm.hpp index a7356f6e..e475fb7f 100644 --- a/include/musica/micm.hpp +++ b/include/musica/micm.hpp @@ -216,6 +216,7 @@ namespace musica using RosenbrockVectorType = typename micm::RosenbrockSolverParameters:: template SolverType>; using Rosenbrock = micm::Solver>; + using VectorState = micm::State; std::unique_ptr rosenbrock_; /// @brief Standard-ordered Rosenbrock solver type @@ -224,6 +225,7 @@ namespace musica using RosenbrockStandardType = typename micm::RosenbrockSolverParameters:: template SolverType>; using RosenbrockStandard = micm::Solver>; + using StandardState = micm::State; std::unique_ptr rosenbrock_standard_; private: diff --git a/python/test/test_chapman.py b/python/test/test_chapman.py index f61d79ec..ed1de5e4 100644 --- a/python/test/test_chapman.py +++ b/python/test/test_chapman.py @@ -10,7 +10,7 @@ def test_micm_solve(self): 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", @@ -41,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 8f828f19..390d8cbc 100644 --- a/python/wrapper.cpp +++ b/python/wrapper.cpp @@ -78,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) diff --git a/src/micm/micm.cpp b/src/micm/micm.cpp index dd5b804a..6ab7f00f 100644 --- a/src/micm/micm.cpp +++ b/src/micm/micm.cpp @@ -248,7 +248,8 @@ namespace musica micm::ProcessSet, micm::LinearSolver< micm::SparseMatrix>, - micm::LuDecomposition>>(micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) + micm::LuDecomposition>, + VectorState>(micm::RosenbrockSolverParameters::ThreeStageRosenbrockParameters()) .SetSystem(solver_parameters_->system_) .SetReactions(solver_parameters_->processes_) .SetNumberOfGridCells(num_grid_cells_) diff --git a/src/test/unit/micm/micm_c_api.cpp b/src/test/unit/micm/micm_c_api.cpp index 638b7742..90a17387 100644 --- a/src/test/unit/micm/micm_c_api.cpp +++ b/src/test/unit/micm/micm_c_api.cpp @@ -97,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++) { @@ -130,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) { @@ -201,8 +191,8 @@ TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) 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; @@ -234,11 +224,10 @@ TEST_F(MicmCApiTest, SolveUsingVectorOrderedRosenbrock) 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; @@ -269,8 +258,8 @@ TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) 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; @@ -300,12 +289,10 @@ TEST(RosenbrockStandardOrder, SolveUsingStandardOrderedRosenbrock) &error); 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; From e688fea7ffe4c0680d488dad7da500cb427e2825 Mon Sep 17 00:00:00 2001 From: Kyle Shores Date: Wed, 7 Aug 2024 15:56:20 -0500 Subject: [PATCH 116/117] Updating citation version number --- CITATION.cff | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 514c7d9c8fcc30a4a5d5c1976ee1c76a876af1fe Mon Sep 17 00:00:00 2001 From: Kyle Shores Date: Wed, 7 Aug 2024 16:46:41 -0500 Subject: [PATCH 117/117] updating version number so we can upload to pypi --- CITATION.cff | 2 +- CMakeLists.txt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/CITATION.cff b/CITATION.cff index 590cfe13..96141455 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.1 \ No newline at end of file +version: 0.7.3 \ No newline at end of file diff --git a/CMakeLists.txt b/CMakeLists.txt index 4f3831d0..d416647e 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.1) +project(musica-distribution VERSION 0.7.3) set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH};${PROJECT_SOURCE_DIR}/cmake) set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_MODULE_PATH}/SetDefaults.cmake)