Update surface albedo in TUV-x prior to calculating rate constants

schemes/musica/musica_ccpp.F90

@@ -26,14 +26,17 @@ end subroutine musica_ccpp_register
   !> \section arg_table_musica_ccpp_init Argument Table
   !! \htmlinclude musica_ccpp_init.html
   subroutine musica_ccpp_init(vertical_layer_dimension, vertical_interface_dimension, &
-                              errmsg, errcode)
-    integer,            intent(in)  :: vertical_layer_dimension     ! (count)
-    integer,            intent(in)  :: vertical_interface_dimension ! (count)
+                              photolysis_wavelength_grid_interfaces, errmsg, errcode)
+    use ccpp_kinds, only : kind_phys
+
+    integer,            intent(in)  :: vertical_layer_dimension                 ! (count)
+    integer,            intent(in)  :: vertical_interface_dimension             ! (count)
+    real(kind_phys),    intent(in)  :: photolysis_wavelength_grid_interfaces(:) ! m
     character(len=512), intent(out) :: errmsg
     integer,            intent(out) :: errcode
 
     call tuvx_init(vertical_layer_dimension, vertical_interface_dimension, &
-                   errmsg, errcode)
+                   photolysis_wavelength_grid_interfaces, errmsg, errcode)
     if (errcode /= 0) return
     call micm_init(errmsg, errcode)
     if (errcode /= 0) return
@@ -44,12 +47,13 @@ end subroutine musica_ccpp_init
   !! \htmlinclude musica_ccpp_run.html
   !!
   !! The standard name for the variable 'surface_tempearture' is
-  !! `blackbody_temperature_at_surface` because this is what we have as
-  !! the standard name for `cam_in%ts`, whcih represents the same quantity.
+  !! 'blackbody_temperature_at_surface' because this is what we have as
+  !! the standard name for 'cam_in%ts', whcih represents the same quantity.
   subroutine musica_ccpp_run(time_step, temperature, pressure, dry_air_density, constituent_props, &
                              constituents, geopotential_height_wrt_surface_at_midpoint,            &
                              geopotential_height_wrt_surface_at_interface, surface_temperature,    &
-                             surface_geopotential, standard_gravitational_acceleration, errmsg, errcode)
+                             surface_geopotential, surface_albedo,                                 &
+                             standard_gravitational_acceleration, errmsg, errcode)
     use musica_ccpp_micm_util,     only: reshape_into_micm_arr, reshape_into_ccpp_arr
     use musica_ccpp_micm_util,     only: convert_to_mol_per_cubic_meter, convert_to_mass_mixing_ratio
     use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t
@@ -67,6 +71,7 @@ subroutine musica_ccpp_run(time_step, temperature, pressure, dry_air_density, co
     real(kind_phys),    intent(in)    :: geopotential_height_wrt_surface_at_interface(:,:) ! m (column, interface)
     real(kind_phys),    intent(in)    :: surface_temperature(:)                            ! K
     real(kind_phys),    intent(in)    :: surface_geopotential(:)                           ! m2 s-2
+    real(kind_phys),    intent(in)    :: surface_albedo                                    ! unitless
     real(kind_phys),    intent(in)    :: standard_gravitational_acceleration               ! m s-2
     character(len=512), intent(out)   :: errmsg
     integer,            intent(out)   :: errcode
@@ -92,8 +97,8 @@ subroutine musica_ccpp_run(time_step, temperature, pressure, dry_air_density, co
     call tuvx_run(temperature, dry_air_density,                 &
                   geopotential_height_wrt_surface_at_midpoint,  &
                   geopotential_height_wrt_surface_at_interface, &
-                  surface_temperature,                          &
-                  surface_geopotential,                         &
+                  surface_temperature, surface_geopotential,    &
+                  surface_albedo,                               &
                   standard_gravitational_acceleration,          &
                   photolysis_rate_constants,                    &
                   errmsg, errcode)

schemes/musica/musica_ccpp.meta

@@ -19,6 +19,12 @@
   type = integer
   dimensions = ()
   intent = in
+[ photolysis_wavelength_grid_interfaces ]
+  standard_name = photolysis_wavelength_grid_interfaces
+  units = m
+  type = real | kind = kind_phys
+  dimensions = (photolysis_wavelength_grid_interface_dimension)
+  intent = in
 [ errmsg ]
   standard_name = ccpp_error_message
   units = none
@@ -95,6 +101,12 @@
   units = m2 s-2
   dimensions = (horizontal_loop_extent)
   intent = in
+[ surface_albedo ]
+  standard_name = surface_albedo_due_to_UV_and_VIS_direct
+  type = real | kind = kind_phys
+  units = None
+  dimensions = ()
+  intent = in
 [ standard_gravitational_acceleration ]
   standard_name = standard_gravitational_acceleration
   units = m s-2

schemes/musica/tuvx/musica_ccpp_tuvx.F90

@@ -12,23 +12,32 @@ module musica_ccpp_tuvx
 
   public :: tuvx_init, tuvx_run, tuvx_final
 
-  type(tuvx_t),    pointer :: tuvx => null( )
-  type(grid_t),    pointer :: height_grid => null( )
-  type(profile_t), pointer :: temperature_profile => null( )
+  type(tuvx_t),    pointer :: tuvx => null()
+  type(grid_t),    pointer :: height_grid => null()
+  type(grid_t),    pointer :: wavelength_grid => null()
+  type(profile_t), pointer :: temperature_profile => null()
+  type(profile_t), pointer :: surface_albedo_profile => null()
 
 contains
 
   !> Intitialize TUV-x
   subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, &
-                       errmsg, errcode)
+                       wavelength_grid_interfaces, errmsg, errcode)
     use musica_tuvx, only: grid_map_t, profile_map_t, radiator_map_t
     use musica_util, only: error_t
-    use musica_ccpp_tuvx_height_grid, only: create_height_grid, &
-                                            height_grid_label, height_grid_unit
-    use musica_ccpp_tuvx_temperature, only: create_temperature_profile, &
-                                            temperature_label, temperature_unit
-    integer,            intent(in)  :: vertical_layer_dimension     ! (count)
-    integer,            intent(in)  :: vertical_interface_dimension ! (count)
+    use musica_ccpp_tuvx_util, only: tuvx_deallocate
+    use musica_ccpp_tuvx_height_grid, &
+      only: create_height_grid, height_grid_label, height_grid_unit
+    use musica_ccpp_tuvx_wavelength_grid, &
+      only: create_wavelength_grid, wavelength_grid_label, wavelength_grid_unit
+    use musica_ccpp_tuvx_temperature, &
+      only: create_temperature_profile, temperature_label, temperature_unit
+    use musica_ccpp_tuvx_surface_albedo, &
+      only: create_surface_albedo_profile, surface_albedo_label, surface_albedo_unit
+
+    integer,            intent(in)  :: vertical_layer_dimension      ! (count)
+    integer,            intent(in)  :: vertical_interface_dimension  ! (count)
+    real(kind_phys),    intent(in)  :: wavelength_grid_interfaces(:) ! m
     character(len=512), intent(out) :: errmsg
     integer,            intent(out) :: errcode
 
@@ -50,71 +59,79 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, &
 
     call grids%add( height_grid, error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( grids )
-      deallocate( height_grid )
-      height_grid => null()
+      call tuvx_deallocate( grids, null(), null(), null(), height_grid, null(), &
+                            null(), null() )
+      return
+    end if
+
+    wavelength_grid => create_wavelength_grid( wavelength_grid_interfaces, &
+                                               errmsg, errcode )
+    if (errcode /= 0) then
+      call tuvx_deallocate( grids, null(), null(), null(), height_grid, null(), &
+                            null(), null() )
+      return
+    endif
+
+    call grids%add( wavelength_grid, error )
+    if (has_error_occurred( error, errmsg, errcode )) then
+      call tuvx_deallocate( grids, null(), null(), null(), height_grid, &
+                            wavelength_grid, null(), null() )
       return
     end if
 
     profiles => profile_map_t( error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( grids )
-      deallocate( height_grid )
-      height_grid => null()
+      call tuvx_deallocate( grids, null(), null(), null(), height_grid, &
+                            wavelength_grid, null(), null() )
       return
     end if
 
     temperature_profile => create_temperature_profile( height_grid, errmsg, errcode )
     if (errcode /= 0) then
-      deallocate( grids )
-      deallocate( height_grid )
-      height_grid => null()
-      deallocate( profiles )
+      call tuvx_deallocate( grids, profiles, null(), null(), height_grid, &
+                            wavelength_grid, null(), null() )
       return
     endif
 
     call profiles%add( temperature_profile, error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( grids )
-      deallocate( height_grid )
-      height_grid => null()
-      deallocate( profiles )
-      deallocate( temperature_profile )
-      temperature_profile => null()
+      call tuvx_deallocate( grids, profiles, null(), null(), height_grid, &
+                            wavelength_grid, temperature_profile, null() )
+      return
+    end if
+
+    surface_albedo_profile => create_surface_albedo_profile( wavelength_grid, &
+                                                             errmsg, errcode )
+    if (errcode /= 0) then
+      call tuvx_deallocate( grids, profiles, null(), null(), height_grid, &
+                            wavelength_grid, temperature_profile, null() )
+      return
+    endif
+
+    call profiles%add( surface_albedo_profile, error )
+    if (has_error_occurred( error, errmsg, errcode )) then
+      call tuvx_deallocate( grids, profiles, null(), null(), height_grid, &
+            wavelength_grid, temperature_profile, surface_albedo_profile )
       return
     end if
 
     radiators => radiator_map_t( error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( grids )
-      deallocate( height_grid )
-      height_grid => null()
-      deallocate( profiles )
-      deallocate( temperature_profile )
-      temperature_profile => null()
+      call tuvx_deallocate( grids, profiles, null(), null(), height_grid, &
+            wavelength_grid, temperature_profile, surface_albedo_profile )
       return
     end if
 
     tuvx => tuvx_t( filename_of_tuvx_configuration, grids, profiles, &
                     radiators, error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( grids )
-      deallocate( height_grid )
-      height_grid => null()
-      deallocate( profiles )
-      deallocate( temperature_profile )
-      temperature_profile => null()
-      deallocate( radiators )
+      call tuvx_deallocate( grids, profiles, radiators, null(), height_grid, &
+            wavelength_grid, temperature_profile, surface_albedo_profile )
       return
     end if
 
-    deallocate( grids )
-    deallocate( height_grid )
-    height_grid => null()
-    deallocate( profiles )
-    deallocate( temperature_profile )
-    temperature_profile => null()
-    deallocate( radiators )
+    call tuvx_deallocate( grids, profiles, radiators, null(), height_grid, &
+          wavelength_grid, temperature_profile, surface_albedo_profile )
 
     grids => tuvx%get_grids( error )
     if (has_error_occurred( error, errmsg, errcode )) then
@@ -125,30 +142,42 @@ subroutine tuvx_init(vertical_layer_dimension, vertical_interface_dimension, &
 
     height_grid => grids%get( height_grid_label, height_grid_unit, error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( tuvx )
-      tuvx => null()
-      deallocate( grids )
+      call tuvx_deallocate( grids, null(), null(), tuvx, null(), null(), &
+                            null(), null() )
       return
     end if
 
-    deallocate( grids )
+    wavelength_grid => grids%get( wavelength_grid_label, wavelength_grid_unit, &
+                                  error )
+    if (has_error_occurred( error, errmsg, errcode )) then
+      call tuvx_deallocate( grids, null(), null(), tuvx, height_grid, null(), &
+                            null(), null() )
+      return
+    end if
 
     profiles => tuvx%get_profiles( error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( tuvx )
-      tuvx => null()
+      call tuvx_deallocate( grids, null(), null(), tuvx, height_grid, &
+            wavelength_grid, null(), null() )
       return
     end if
 
     temperature_profile => profiles%get( temperature_label, temperature_unit, error )
     if (has_error_occurred( error, errmsg, errcode )) then
-      deallocate( tuvx )
-      tuvx => null()
-      deallocate( profiles )
+      call tuvx_deallocate( grids, profiles, null(), tuvx, height_grid, &
+            wavelength_grid, null(), null() )
+      return
+    end if
+
+    surface_albedo_profile => profiles%get( surface_albedo_label, surface_albedo_unit, error )
+    if (has_error_occurred( error, errmsg, errcode )) then
+      call tuvx_deallocate( grids, profiles, null(), tuvx, height_grid, &
+            wavelength_grid, temperature_profile, null() )
       return
     end if
 
-    deallocate( profiles )
+    call tuvx_deallocate( grids, profiles, null(), null(), null(), null(), &
+                          null(), null() )
 
   end subroutine tuvx_init
 
@@ -157,18 +186,21 @@ subroutine tuvx_run(temperature, dry_air_density,                 &
                       geopotential_height_wrt_surface_at_midpoint,  &
                       geopotential_height_wrt_surface_at_interface, &
                       surface_temperature, surface_geopotential,    &
+                      surface_albedo,                               &
                       standard_gravitational_acceleration,          &
                       photolysis_rate_constants, errmsg, errcode)
-    use musica_util,                  only: error_t
-    use musica_ccpp_tuvx_height_grid, only: set_height_grid_values, calculate_heights
-    use musica_ccpp_tuvx_temperature, only: set_temperature_values
+    use musica_util,                     only: error_t
+    use musica_ccpp_tuvx_height_grid,    only: set_height_grid_values, calculate_heights
+    use musica_ccpp_tuvx_temperature,    only: set_temperature_values
+    use musica_ccpp_tuvx_surface_albedo, only: set_surface_albedo_values
 
     real(kind_phys),    intent(in)  :: temperature(:,:)                                  ! K (column, layer)
     real(kind_phys),    intent(in)  :: dry_air_density(:,:)                              ! kg m-3 (column, layer)
     real(kind_phys),    intent(in)  :: geopotential_height_wrt_surface_at_midpoint(:,:)  ! m (column, layer)
     real(kind_phys),    intent(in)  :: geopotential_height_wrt_surface_at_interface(:,:) ! m (column, interface)
     real(kind_phys),    intent(in)  :: surface_temperature(:)                            ! K
     real(kind_phys),    intent(in)  :: surface_geopotential(:)                           ! m2 s-2
+    real(kind_phys),    intent(in)  :: surface_albedo                                    ! unitless
     real(kind_phys),    intent(in)  :: standard_gravitational_acceleration               ! m s-2
     ! temporarily set to Chapman mechanism and 1 dimension
     ! until mapping between MICM and TUV-x is implemented
@@ -199,6 +231,9 @@ subroutine tuvx_run(temperature, dry_air_density,                 &
       if (errcode /= 0) return
     end do
 
+    call set_surface_albedo_values( surface_albedo_profile, surface_albedo, errmsg, errcode )
+    if (errcode /= 0) return
+
     ! stand-in until actual photolysis rate constants are calculated
     photolysis_rate_constants(:) = 1.0e-6_kind_phys
 
@@ -217,11 +252,21 @@ subroutine tuvx_final(errmsg, errcode)
       height_grid => null()
     end if
 
+    if (associated( wavelength_grid )) then
+      deallocate( wavelength_grid )
+      wavelength_grid => null()
+    end if
+
     if (associated( temperature_profile )) then
       deallocate( temperature_profile )
       temperature_profile => null()
     end if
 
+    if (associated( surface_albedo_profile )) then
+      deallocate( surface_albedo_profile )
+      surface_albedo_profile => null()
+    end if
+
     if (associated( tuvx )) then
       deallocate( tuvx )
       tuvx => null()