diff --git a/schemes/musica/tuvx/musica_ccpp_tuvx_temperature.F90 b/schemes/musica/tuvx/musica_ccpp_tuvx_temperature.F90 new file mode 100644 index 0000000..af24d0e --- /dev/null +++ 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 \ No newline at end of file diff --git a/test/musica/tuvx/CMakeLists.txt b/test/musica/tuvx/CMakeLists.txt index 7b7daac..b863be5 100644 --- 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 $ "" ${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 $ + WORKING_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} +) + +add_memory_check_test(test_tuvx_temperature $ "" ${CMAKE_RUNTIME_OUTPUT_DIRECTORY}) \ No newline at end of file diff --git a/test/musica/tuvx/test_tuvx_temperature.F90 b/test/musica/tuvx/test_tuvx_temperature.F90 new file mode 100644 index 0000000..44173bd --- /dev/null +++ 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 \ No newline at end of file