merge issue 94 and add temperature update modules

ESCOMP · Oct 17, 2024 · afd9a99 · afd9a99
1 parent 452f068
commit afd9a99
Show file tree

Hide file tree

Showing 3 changed files with 169 additions and 0 deletions.
diff --git a/schemes/musica/tuvx/musica_ccpp_tuvx_temperature.F90 b/schemes/musica/tuvx/musica_ccpp_tuvx_temperature.F90
@@ -0,0 +1,75 @@
+module musica_ccpp_tuvx_temperature
+  implicit none
+
+  private
+  public :: create_temperature_profile, set_temperature_values
+
+  !> Label for temperature in TUV-x
+  character(len=*), parameter :: temperature_label = "temperature"
+  !> Units for temperature in TUV-x
+  character(len=*), parameter :: temperature_units = "K"
+
+contains
+
+  !> Creates a TUV-x temperature profile
+  function create_temperature_profile( height_grid, errmsg, errcode ) &
+      result( profile )
+
+    use musica_ccpp_util,    only: has_error_occurred
+    use musica_tuvx_grid,    only: grid_t
+    use musica_tuvx_profile, only: profile_t
+    use musica_util,         only: error_t
+
+    ! Arguments
+    type(grid_t),     intent(in)  :: height_grid
+    character(len=*), intent(out) :: errmsg
+    integer,          intent(out) :: errcode
+
+    ! Return value
+    type(profile_t),  pointer :: profile
+
+    ! Local variables
+    type(error_t) :: error
+
+    profile => profile_t( temperature_label, temperature_units, &
+                          height_grid, error )
+    if ( has_error_occurred( error, errmsg, errcode ) ) return
+
+  end function create_temperature_profile
+
+  !> Sets TUV-x temperatures from host-model temperatures
+  !!
+  !! See description of `musica_ccpp_tuvx_hegihts_grid.F90` for
+  !! CAM-SIMA <-> TUV-x height grid mapping
+  subroutine set_temperature_values( profile, host_midpoint_temperatures, &
+      host_surface_temperature, errmsg, errcode )
+
+    use musica_ccpp_util,    only: has_error_occurred
+    use musica_tuvx_profile, only: profile_t
+    use musica_util,         only: error_t
+    use ccpp_kinds,          only: kind_phys
+
+    ! Arguments
+    type(profile_t),  intent(inout) :: profile
+    real(kind_phys),  intent(in)    :: host_midpoint_temperatures(:)  ! K
+    real(kind_phys),  intent(in)    :: host_surface_temperature       ! K
+    character(len=*), intent(out)   :: errmsg
+    integer,          intent(out)   :: errcode
+
+    ! Local variables
+    type(error_t)   :: error
+    real(kind_phys) :: interfaces(size(host_midpoint_temperatures)+2)
+    integer         :: n_host_midpoint_temperatures
+
+    n_host_midpoint_temperatures = size(host_midpoint_temperatures)
+
+    interfaces(1) = host_surface_temperature
+    interfaces(2:n_host_midpoint_temperatures+1) = host_midpoint_temperatures(n_host_midpoint_temperatures:1:-1)
+    interfaces(n_host_midpoint_temperatures+2) = host_midpoint_temperatures(1)
+
+    call profile%set_edge_values( interfaces, error )
+    if ( has_error_occurred( error, errmsg, errcode ) ) return
+
+  end subroutine set_temperature_values
+
+end module musica_ccpp_tuvx_temperature
diff --git a/test/musica/tuvx/CMakeLists.txt b/test/musica/tuvx/CMakeLists.txt
@@ -1,3 +1,4 @@
+# Height grid
 add_executable(test_tuvx_height_grid test_tuvx_height_grid.F90)
 
 target_sources(test_tuvx_height_grid
@@ -24,3 +25,32 @@ add_test(
 )
 
 add_memory_check_test(test_tuvx_height_grid $<TARGET_FILE:test_tuvx_height_grid> "" ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
+
+# Temperature
+add_executable(test_tuvx_temperature test_tuvx_temperature.F90)
+
+target_sources(test_tuvx_temperature
+  PUBLIC
+    ${MUSICA_SRC_PATH}/tuvx/musica_ccpp_tuvx_height_grid.F90
+    ${MUSICA_SRC_PATH}/tuvx/musica_ccpp_tuvx_temperature.F90
+    ${MUSICA_SRC_PATH}/musica_ccpp_util.F90
+    ${CCPP_TEST_SRC_PATH}/ccpp_kinds.F90
+)
+
+target_link_libraries(test_tuvx_temperature
+  PRIVATE
+    musica::musica-fortran
+)
+
+set_target_properties(test_tuvx_temperature
+  PROPERTIES
+  LINKER_LANGUAGE Fortran
+)
+
+add_test(
+  NAME test_tuvx_temperature
+  COMMAND $<TARGET_FILE:test_tuvx_temperature>
+  WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}
+)
+
+add_memory_check_test(test_tuvx_temperature $<TARGET_FILE:test_tuvx_temperature> "" ${CMAKE_RUNTIME_OUTPUT_DIRECTORY})
diff --git a/test/musica/tuvx/test_tuvx_temperature.F90 b/test/musica/tuvx/test_tuvx_temperature.F90
@@ -0,0 +1,64 @@
+program test_tuvx_temperature
+
+  use musica_ccpp_tuvx_temperature
+
+  implicit none
+
+#define ASSERT(x) if (.not.(x)) then; write(*,*) "Assertion failed[", __FILE__, ":", __LINE__, "]: x"; stop 1; endif
+#define ASSERT_NEAR( a, b, abs_error ) if( (abs(a - b) >= abs_error) .and. (abs(a - b) /= 0.0) ) then; write(*,*) "Assertion failed[", __FILE__, ":", __LINE__, "]: a, b"; stop 1; endif
+
+  call test_update_temperature()
+
+contains
+
+  subroutine test_update_temperature()
+    use musica_ccpp_tuvx_height_grid, only: create_height_grid
+    use musica_util,                  only: error_t
+    use musica_tuvx_grid,             only: grid_t
+    use musica_tuvx_profile,          only: profile_t
+    use ccpp_kinds,                   only: kind_phys
+
+    integer, parameter       :: NUM_HOST_MIDPOINTS = 5
+    integer, parameter       :: NUM_HOST_INTERFACES = 6
+    real(kind_phys), target  :: host_midpoint_temperature(NUM_HOST_MIDPOINTS)
+    real(kind_phys), target  :: host_surface_temperature = 300.3_kind_phys
+    type(grid_t),    pointer :: height_grid
+    type(profile_t), pointer :: profile
+    character(len=512)       :: errmsg
+    integer                  :: errcode
+    real(kind_phys)          :: abs_error = 1e-4
+    integer                  :: i
+
+    ! local variables
+    real(kind_phys), dimension(NUM_HOST_MIDPOINTS+2) :: interface_temperatures
+    type(error_t) :: error
+
+    host_midpoint_temperature = (/ 800.8_kind_phys, 700.7_kind_phys, 600.6_kind_phys, 500.5_kind_phys, 400.4_kind_phys /)
+
+    height_grid => create_height_grid(NUM_HOST_MIDPOINTS, NUM_HOST_INTERFACES, &
+                                      errmsg, errcode)
+    profile => create_temperature_profile( height_grid, errmsg, errcode )
+    ASSERT(errcode == 0)
+    ASSERT(associated(profile))
+
+    call set_temperature_values( profile, host_midpoint_temperature, &
+                                 host_surface_temperature, errmsg, errcode )
+    ASSERT(errcode == 0)
+
+    call profile%get_edge_values( interface_temperatures, error)
+    ASSERT(error%is_success())
+
+    ASSERT_NEAR(interface_temperatures(1), 300.3, abs_error)
+    ASSERT_NEAR(interface_temperatures(2), 400.4, abs_error)
+    ASSERT_NEAR(interface_temperatures(3), 500.5, abs_error)
+    ASSERT_NEAR(interface_temperatures(4), 600.6, abs_error)
+    ASSERT_NEAR(interface_temperatures(5), 700.7, abs_error)
+    ASSERT_NEAR(interface_temperatures(6), 800.8, abs_error)
+    ASSERT_NEAR(interface_temperatures(7), 800.8, abs_error)
+
+    deallocate( profile )
+    deallocate( height_grid )
+
+  end subroutine test_update_temperature
+
+end program test_tuvx_temperature