From e0642e9acbce8cf6a8b4516453216246e6a91503 Mon Sep 17 00:00:00 2001 From: "Srbinovsky, Jhan (O&A, Aspendale)" Date: Wed, 14 Aug 2024 10:21:59 +1000 Subject: [PATCH 1/3] coupled - this appliation directory SHOULD have nothing to do with the rest of the model --- .../AM3/control/cable/CM3/air_type_cbl.F90 | 142 + .../control/cable/CM3/balances_type_cbl.F90 | 304 ++ .../AM3/control/cable/CM3/bgc_pool_type.F90 | 115 + .../AM3/control/cable/CM3/cable_common.F90 | 143 + .../control/cable/CM3/cable_define_types.F90 | 72 + .../AM3/control/cable/CM3/cbl_canopy_type.F90 | 587 ++++ .../AM3/control/cable/CM3/cbl_cbm_mod.F90 | 403 +++ .../AM3/control/cable/CM3/climate_type.F90 | 306 ++ .../AM3/control/cable/CM3/met_type_cbl.F90 | 227 ++ .../AM3/control/cable/CM3/radiation_type.F90 | 311 ++ .../cable/CM3/read_cable_namelists_mod.F90 | 116 + .../AM3/control/cable/CM3/roughness_type.F90 | 247 ++ .../AM3/control/cable/CM3/soil_type_cbl.F90 | 517 +++ .../AM3/control/cable/CM3/ssnow_type.F90 | 960 ++++++ .../AM3/control/cable/CM3/sum_flux_type.F90 | 173 + .../AM3/control/cable/CM3/veg_type.F90 | 429 +++ .../explicit/cable_land_sf_explicit_cbl.F90 | 2931 +++++++++++++++++ .../cable_land/explicit/sf_flux_mod_cbl.F90 | 270 ++ .../cable/cable_land/extra/hydrol_mod_cbl.F90 | 1075 ++++++ .../implicit/cable_land_sf_implicit_cbl.F90 | 931 ++++++ .../cable/cable_land/implicit/poop_diff | 29 + .../radiation/alloc_rad_albedo_vars_cbl.F90 | 267 ++ .../radiation/cable_land_albedo_mod_cbl.F90 | 386 +++ .../explicit/cable_explicit_driver.F90 | 280 ++ .../explicit/cable_explicit_main.F90 | 385 +++ .../explicit/cable_explicit_main.F90.cnp | 401 +++ .../explicit/cable_explicit_unpack.F90 | 195 ++ .../interface/hydrology/cable_hyd_driver.F90 | 38 + .../interface/hydrology/cable_hyd_main.F90 | 150 + .../interface/hydrology/cable_wblake_fix.F90 | 19 + .../implicit/cable_implicit_driver.F90 | 249 ++ .../implicit/cable_implicit_main.F90 | 242 ++ .../implicit/cable_implicit_unpack.F90 | 400 +++ .../implicit/cbl_prognostic_bank.F90 | 167 + .../interface/radiation/rad_driver_cbl.F90 | 192 ++ .../interface/radiation/rad_unpack_cbl.F90 | 137 + .../cable/shared/LAI_canopy_height_cbl.F90 | 100 + .../control/cable/shared/cable_fields_mod.F90 | 61 + .../control/cable/shared/cable_model_env.F90 | 105 + .../cable/shared/cable_surface_types_mod.F90 | 377 +++ .../cable/shared/land_tile_ids_mod_cbl.F90 | 121 + .../control/cable/shared/params_io_cbl.F90 | 355 ++ .../cable/shared/progs_cbl_vars_mod.F90 | 386 +++ .../cable/shared/work_vars_mod_cbl.F90 | 361 ++ .../cable/util/activeTile_mask_cbl.F90 | 100 + .../cable/util/cable_jules_links_mod.F90 | 196 ++ .../cable/util/cable_model_env_opts.F90 | 12 + .../cable/util/init/cable_um_init_bgc.F90 | 35 + .../util/init/cable_um_init_respiration.F90 | 44 + .../cable/util/init/cable_um_init_sumflux.F90 | 35 + .../control/cable/util/init/cbl_um_init.F90 | 134 + .../cable/util/init/cbl_um_init_soil.F90 | 236 ++ .../cable/util/init/cbl_um_init_soilsnow.F90 | 157 + .../cable/util/init/cbl_um_init_veg.F90 | 71 + .../util/init/cbl_um_init_veg.F90.manual | 77 + .../control/cable/util/map_paramaters_cbl.F90 | 230 ++ .../AM3/control/cable/util/pack_mod_cbl.F90 | 164 + .../cable/util/update/cbl_um_update.F90 | 117 + .../util/update/cbl_um_update_canopy.F90 | 36 + .../cable/util/update/cbl_um_update_met.F90 | 111 + .../util/update/cbl_um_update_radiation.F90 | 88 + .../util/update/cbl_um_update_roughness.F90 | 73 + .../util/update/cbl_um_update_soilsnow.F90 | 48 + .../control/casa/shared/cnp_fields_mod.F90 | 19 + .../casa/shared/progs_cnp_vars_mod.F90 | 182 + .../control/casa/shared/work_vars_mod_cnp.F90 | 52 + .../AM3/initialisation/cable_pft_params.F90 | 1033 ++++++ .../AM3/initialisation/cable_soil_params.F90 | 150 + .../init_cable_working_vars.F90 | 63 + .../AM3/initialisation/init_soilin_cbl.inc | 187 ++ .../AM3/initialisation/init_vegin_cbl.inc | 479 +++ .../prognostics/init_cable_progs.F90 | 65 + .../prognostics/init_cnp_progs.F90 | 33 + .../prognostics/read_cable_progs.F90 | 276 ++ 74 files changed, 20165 insertions(+) create mode 100644 src/coupled/AM3/control/cable/CM3/air_type_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/balances_type_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/bgc_pool_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/cable_common.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/cable_define_types.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/cbl_canopy_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/cbl_cbm_mod.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/climate_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/met_type_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/radiation_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/read_cable_namelists_mod.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/roughness_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/soil_type_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/ssnow_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/sum_flux_type.F90 create mode 100644 src/coupled/AM3/control/cable/CM3/veg_type.F90 create mode 100644 src/coupled/AM3/control/cable/cable_land/explicit/cable_land_sf_explicit_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/cable_land/explicit/sf_flux_mod_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/cable_land/extra/hydrol_mod_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/cable_land/implicit/cable_land_sf_implicit_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/cable_land/implicit/poop_diff create mode 100644 src/coupled/AM3/control/cable/cable_land/radiation/alloc_rad_albedo_vars_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/cable_land/radiation/cable_land_albedo_mod_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/interface/explicit/cable_explicit_driver.F90 create mode 100644 src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90 create mode 100644 src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90.cnp create mode 100644 src/coupled/AM3/control/cable/interface/explicit/cable_explicit_unpack.F90 create mode 100644 src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_driver.F90 create mode 100644 src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_main.F90 create mode 100644 src/coupled/AM3/control/cable/interface/hydrology/cable_wblake_fix.F90 create mode 100644 src/coupled/AM3/control/cable/interface/implicit/cable_implicit_driver.F90 create mode 100644 src/coupled/AM3/control/cable/interface/implicit/cable_implicit_main.F90 create mode 100644 src/coupled/AM3/control/cable/interface/implicit/cable_implicit_unpack.F90 create mode 100644 src/coupled/AM3/control/cable/interface/implicit/cbl_prognostic_bank.F90 create mode 100644 src/coupled/AM3/control/cable/interface/radiation/rad_driver_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/interface/radiation/rad_unpack_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/shared/LAI_canopy_height_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/shared/cable_fields_mod.F90 create mode 100644 src/coupled/AM3/control/cable/shared/cable_model_env.F90 create mode 100644 src/coupled/AM3/control/cable/shared/cable_surface_types_mod.F90 create mode 100644 src/coupled/AM3/control/cable/shared/land_tile_ids_mod_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/shared/params_io_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/shared/progs_cbl_vars_mod.F90 create mode 100644 src/coupled/AM3/control/cable/shared/work_vars_mod_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/util/activeTile_mask_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/util/cable_jules_links_mod.F90 create mode 100644 src/coupled/AM3/control/cable/util/cable_model_env_opts.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cable_um_init_bgc.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cable_um_init_respiration.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cable_um_init_sumflux.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cbl_um_init.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cbl_um_init_soil.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cbl_um_init_soilsnow.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90 create mode 100644 src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90.manual create mode 100644 src/coupled/AM3/control/cable/util/map_paramaters_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/util/pack_mod_cbl.F90 create mode 100644 src/coupled/AM3/control/cable/util/update/cbl_um_update.F90 create mode 100644 src/coupled/AM3/control/cable/util/update/cbl_um_update_canopy.F90 create mode 100644 src/coupled/AM3/control/cable/util/update/cbl_um_update_met.F90 create mode 100644 src/coupled/AM3/control/cable/util/update/cbl_um_update_radiation.F90 create mode 100644 src/coupled/AM3/control/cable/util/update/cbl_um_update_roughness.F90 create mode 100644 src/coupled/AM3/control/cable/util/update/cbl_um_update_soilsnow.F90 create mode 100644 src/coupled/AM3/control/casa/shared/cnp_fields_mod.F90 create mode 100644 src/coupled/AM3/control/casa/shared/progs_cnp_vars_mod.F90 create mode 100644 src/coupled/AM3/control/casa/shared/work_vars_mod_cnp.F90 create mode 100644 src/coupled/AM3/initialisation/cable_pft_params.F90 create mode 100644 src/coupled/AM3/initialisation/cable_soil_params.F90 create mode 100644 src/coupled/AM3/initialisation/init_cable_working_vars.F90 create mode 100644 src/coupled/AM3/initialisation/init_soilin_cbl.inc create mode 100644 src/coupled/AM3/initialisation/init_vegin_cbl.inc create mode 100644 src/coupled/AM3/initialisation/prognostics/init_cable_progs.F90 create mode 100644 src/coupled/AM3/initialisation/prognostics/init_cnp_progs.F90 create mode 100644 src/coupled/AM3/initialisation/prognostics/read_cable_progs.F90 diff --git a/src/coupled/AM3/control/cable/CM3/air_type_cbl.F90 b/src/coupled/AM3/control/cable/CM3/air_type_cbl.F90 new file mode 100644 index 000000000..efca2e623 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/air_type_cbl.F90 @@ -0,0 +1,142 @@ +MODULE cable_air_type_mod + +IMPLICIT NONE + +PUBLIC :: air_type +PUBLIC :: air_data_type +PUBLIC :: alloc_air_type +PUBLIC :: dealloc_air_type +PUBLIC :: assoc_air_type +PUBLIC :: nullify_air_cbl + +TYPE air_data_type + + REAL, ALLOCATABLE :: rho (:) ! dry air density (kg m-3) + REAL, ALLOCATABLE :: volm(:) ! molar volume (m3 mol-1) + REAL, ALLOCATABLE :: rlam(:) ! latent heat for water (j/kg) + REAL, ALLOCATABLE :: qsat(:) ! saturation specific humidity + REAL, ALLOCATABLE :: epsi(:) ! d(qsat)/dt ((kg/kg)/k) + REAL, ALLOCATABLE :: visc(:) ! air kinematic viscosity (m2/s) + REAL, ALLOCATABLE :: psyc(:) ! psychrometric constant + REAL, ALLOCATABLE :: dsatdk(:) ! d(es)/dt (mb/k) + REAL, ALLOCATABLE :: cmolar(:) ! conv. from m/s to mol/m2/s + +END TYPE air_data_type + +TYPE air_type + + REAL, POINTER :: rho (:) ! dry air density (kg m-3) + REAL, POINTER :: volm(:) ! molar volume (m3 mol-1) + REAL, POINTER :: rlam(:) ! latent heat for water (j/kg) + REAL, POINTER :: qsat(:) ! saturation specific humidity + REAL, POINTER :: epsi(:) ! d(qsat)/dt ((kg/kg)/k) + REAL, POINTER :: visc(:) ! air kinematic viscosity (m2/s) + REAL, POINTER :: psyc(:) ! psychrometric constant + REAL, POINTER :: dsatdk(:) ! d(es)/dt (mb/k) + REAL, POINTER :: cmolar(:) ! conv. from m/s to mol/m2/s + +END TYPE air_type + +CONTAINS + +SUBROUTINE alloc_air_type(air, mp) +IMPLICIT NONE + +TYPE(air_data_type), INTENT(INOUT) :: air +INTEGER, INTENT(IN) :: mp + +ALLOCATE( air% rho (mp) ) +ALLOCATE( air% volm (mp) ) +ALLOCATE( air% rlam (mp) ) +ALLOCATE( air% qsat (mp) ) +ALLOCATE( air% epsi (mp) ) +ALLOCATE( air% visc (mp) ) +ALLOCATE( air% psyc (mp) ) +ALLOCATE( air% dsatdk(mp) ) +ALLOCATE( air% cmolar(mp) ) + +air% rho (:) = 0.0 +air% volm(:) = 0.0 +air% rlam(:) = 0.0 +air% qsat(:) = 0.0 +air% epsi(:) = 0.0 +air% visc(:) = 0.0 +air% psyc(:) = 0.0 +air% dsatdk(:) = 0.0 +air% cmolar(:) = 0.0 + +RETURN +END SUBROUTINE alloc_air_type + +SUBROUTINE dealloc_air_type(air) +IMPLICIT NONE + +TYPE(air_type), INTENT(inout) :: air + +DEALLOCATE( air% rho ) +DEALLOCATE( air% volm ) +DEALLOCATE( air% rlam ) +DEALLOCATE( air% qsat ) +DEALLOCATE( air% epsi ) +DEALLOCATE( air% visc ) +DEALLOCATE( air% psyc ) +DEALLOCATE( air% dsatdk ) +DEALLOCATE( air% cmolar ) + +RETURN +END SUBROUTINE dealloc_air_type + +SUBROUTINE assoc_air_type(air, air_data ) +! Description: +! Associate the CABLE work pointers in the derived type structure +IMPLICIT NONE + +!Arguments +TYPE(air_type), INTENT(IN OUT) :: air +TYPE(air_data_type), INTENT(IN OUT), TARGET :: air_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' + +!End of header + +CALL nullify_air_cbl(air) + +air% rho => air_data% rho +air% volm => air_data% volm +air% rlam => air_data% rlam +air% qsat => air_data% qsat +air% epsi => air_data% epsi +air% visc => air_data% visc +air% psyc => air_data% psyc +air% dsatdk => air_data% dsatdk +air% cmolar => air_data% cmolar + +RETURN +END SUBROUTINE assoc_air_type + +SUBROUTINE nullify_air_cbl( air ) +! Description: +! Nullify the CABLE work pointers in the derived type structure +IMPLICIT NONE + +!Arguments +TYPE(air_type), INTENT(IN OUT) :: air + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_AIR_VARS_CBL' +!End of header + +NULLIFY( air % rho ) +NULLIFY( air % volm ) +NULLIFY( air % rlam ) +NULLIFY( air % qsat ) +NULLIFY( air % epsi ) +NULLIFY( air % visc ) +NULLIFY( air % psyc ) +NULLIFY( air % dsatdk ) +NULLIFY( air % cmolar ) + +RETURN + +END SUBROUTINE nullify_air_cbl + +END MODULE cable_air_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/balances_type_cbl.F90 b/src/coupled/AM3/control/cable/CM3/balances_type_cbl.F90 new file mode 100644 index 000000000..7c5b4036e --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/balances_type_cbl.F90 @@ -0,0 +1,304 @@ +MODULE cable_balances_type_mod + +IMPLICIT NONE + +PUBLIC :: balances_type +PUBLIC :: balances_data_type +PUBLIC :: alloc_balances_type +PUBLIC :: dealloc_balances_type +PUBLIC :: assoc_balances_type +PUBLIC :: nullify_balances_cbl + +! Energy and water balance variables: +TYPE balances_data_type + + REAL, ALLOCATABLE :: drybal(:) ! energy balance for dry canopy + REAL, ALLOCATABLE :: ebal(:) ! energy balance per time step (W/m^2) (:) + REAL, ALLOCATABLE :: ebal_tot(:) ! cumulative energy balance (W/m^2) (:) + REAL, ALLOCATABLE :: ebal_cncheck(:) ! energy balance consistency check (W/m^2) (:) + REAL, ALLOCATABLE :: ebal_tot_cncheck(:) ! cumulative energy balance (W/m^2) (:) + REAL, ALLOCATABLE :: ebaltr(:) ! energy balance per time step (W/m^2) (:) + REAL, ALLOCATABLE :: ebal_tottr(:) ! cumulative energy balance (W/m^2) (:) + REAL, ALLOCATABLE :: evap_tot(:) ! cumulative evapotranspiration (mm/dels) (:) + REAL, ALLOCATABLE :: osnowd0(:) ! snow depth, first time step (:) + REAL, ALLOCATABLE :: precip_tot(:) ! cumulative precipitation (mm/dels) (:) + REAL, ALLOCATABLE :: rnoff_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, ALLOCATABLE :: wbal(:) ! water balance per time step (mm/dels) (:) + REAL, ALLOCATABLE :: wbal_tot(:) ! cumulative water balance (mm/dels) (:) + REAL, ALLOCATABLE :: wbtot0(:) ! total soil water (mm), first time step (:) + REAL, ALLOCATABLE :: wetbal(:) ! energy balance for wet canopy (:) + REAL, ALLOCATABLE :: cansto0(:) ! canopy water storage (mm) (:) + REAL, ALLOCATABLE :: owbtot(:) ! total soil water (mm), first time step (:) + REAL, ALLOCATABLE :: evapc_tot(:) ! cumulative evapotranspiration (mm/dels) (:) + REAL, ALLOCATABLE :: evaps_tot(:) ! cumulative evapotranspiration (mm/dels) (:) + REAL, ALLOCATABLE :: rnof1_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, ALLOCATABLE :: rnof2_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, ALLOCATABLE :: snowdc_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, ALLOCATABLE :: wbal_tot1(:) ! cumulative water balance (mm/dels) (:) + REAL, ALLOCATABLE :: delwc_tot(:) ! energy balance for wet canopy (:) + REAL, ALLOCATABLE :: qasrf_tot(:) ! heat advected to the snow by precip. (:) + REAL, ALLOCATABLE :: qfsrf_tot(:) ! energy of snowpack phase changes (:) + REAL, ALLOCATABLE :: qssrf_tot(:) ! energy of snowpack phase changes (:) + REAL, ALLOCATABLE :: Radbal (:) + REAL, ALLOCATABLE :: EbalSoil (:) + REAL, ALLOCATABLE :: Ebalveg (:) + REAL, ALLOCATABLE :: Radbalsum (:) + +END TYPE balances_data_type + +TYPE balances_type + + REAL, POINTER :: drybal(:) ! energy balance for dry canopy + REAL, POINTER :: ebal(:) ! energy balance per time step (W/m^2) (:) + REAL, POINTER :: ebal_tot(:) ! cumulative energy balance (W/m^2) (:) + REAL, POINTER :: ebal_cncheck(:) ! energy balance consistency check (W/m^2) (:) + REAL, POINTER :: ebal_tot_cncheck(:) ! cumulative energy balance (W/m^2) (:) + REAL, POINTER :: ebaltr(:) ! energy balance per time step (W/m^2) (:) + REAL, POINTER :: ebal_tottr(:) ! cumulative energy balance (W/m^2) (:) + REAL, POINTER :: evap_tot(:) ! cumulative evapotranspiration (mm/dels) (:) + REAL, POINTER :: osnowd0(:) ! snow depth, first time step (:) + REAL, POINTER :: precip_tot(:) ! cumulative precipitation (mm/dels) (:) + REAL, POINTER :: rnoff_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, POINTER :: wbal(:) ! water balance per time step (mm/dels) (:) + REAL, POINTER :: wbal_tot(:) ! cumulative water balance (mm/dels) (:) + REAL, POINTER :: wbtot0(:) ! total soil water (mm), first time step (:) + REAL, POINTER :: wetbal(:) ! energy balance for wet canopy (:) + REAL, POINTER :: cansto0(:) ! canopy water storage (mm) (:) + REAL, POINTER :: owbtot(:) ! total soil water (mm), first time step (:) + REAL, POINTER :: evapc_tot(:) ! cumulative evapotranspiration (mm/dels) (:) + REAL, POINTER :: evaps_tot(:) ! cumulative evapotranspiration (mm/dels) (:) + REAL, POINTER :: rnof1_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, POINTER :: rnof2_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, POINTER :: snowdc_tot(:) ! cumulative runoff (mm/dels) (:) + REAL, POINTER :: wbal_tot1(:) ! cumulative water balance (mm/dels) (:) + REAL, POINTER :: delwc_tot(:) ! energy balance for wet canopy (:) + REAL, POINTER :: qasrf_tot(:) ! heat advected to the snow by precip. (:) + REAL, POINTER :: qfsrf_tot(:) ! energy of snowpack phase changes (:) + REAL, POINTER :: qssrf_tot(:) ! energy of snowpack phase changes (:) + REAL, POINTER :: Radbal (:) + REAL, POINTER :: EbalSoil (:) + REAL, POINTER :: Ebalveg (:) + REAL, POINTER :: Radbalsum (:) + +END TYPE balances_type + +CONTAINS + +SUBROUTINE alloc_balances_type(balances, mp) +IMPLICIT NONE + +TYPE(balances_data_type), INTENT(INOUT) :: balances +INTEGER, INTENT(IN) :: mp + +ALLOCATE( balances% drybal (mp) ) +ALLOCATE( balances% ebal (mp) ) +ALLOCATE( balances% ebal_tot (mp) ) +ALLOCATE( balances% ebal_cncheck (mp) ) +ALLOCATE( balances% ebal_tot_cncheck (mp) ) +ALLOCATE( balances% ebaltr (mp) ) +ALLOCATE( balances% ebal_tottr (mp) ) +ALLOCATE( balances% evap_tot (mp) ) +ALLOCATE( balances% osnowd0 (mp) ) +ALLOCATE( balances% precip_tot (mp) ) +ALLOCATE( balances% rnoff_tot (mp) ) +ALLOCATE( balances% wbal (mp) ) +ALLOCATE( balances% wbal_tot (mp) ) +ALLOCATE( balances% wbtot0 (mp) ) +ALLOCATE( balances% wetbal (mp) ) +ALLOCATE( balances% cansto0 (mp) ) +ALLOCATE( balances% owbtot (mp) ) +ALLOCATE( balances% evapc_tot (mp) ) +ALLOCATE( balances% evaps_tot (mp) ) +ALLOCATE( balances% rnof1_tot (mp) ) +ALLOCATE( balances% rnof2_tot (mp) ) +ALLOCATE( balances% snowdc_tot (mp) ) +ALLOCATE( balances% wbal_tot1 (mp) ) +ALLOCATE( balances% delwc_tot (mp) ) +ALLOCATE( balances% qasrf_tot (mp) ) +ALLOCATE( balances% qfsrf_tot (mp) ) +ALLOCATE( balances% qssrf_tot (mp) ) +ALLOCATE( balances% Radbal (mp) ) +ALLOCATE( balances% EbalSoil (mp) ) +ALLOCATE( balances% Ebalveg (mp) ) +ALLOCATE( balances% Radbalsum (mp) ) + +balances % drybal (:) = 0.0 +balances % ebal (:) = 0.0 +balances % ebal_tot (:) = 0.0 +balances % ebal_cncheck (:) = 0.0 +balances % ebal_tot_cncheck (:) = 0.0 +balances % ebaltr (:) = 0.0 +balances % ebal_tottr (:) = 0.0 +balances % evap_tot (:) = 0.0 +balances % osnowd0 (:) = 0.0 +balances % precip_tot (:) = 0.0 +balances % rnoff_tot (:) = 0.0 +balances % wbal (:) = 0.0 +balances % wbal_tot (:) = 0.0 +balances % wbtot0 (:) = 0.0 +balances % wetbal (:) = 0.0 +balances % cansto0 (:) = 0.0 +balances % owbtot (:) = 0.0 +balances % evapc_tot (:) = 0.0 +balances % evaps_tot (:) = 0.0 +balances % rnof1_tot (:) = 0.0 +balances % rnof2_tot (:) = 0.0 +balances % snowdc_tot (:) = 0.0 +balances % wbal_tot1 (:) = 0.0 +balances % delwc_tot (:) = 0.0 +balances % qasrf_tot (:) = 0.0 +balances % qfsrf_tot (:) = 0.0 +balances % qssrf_tot (:) = 0.0 +balances % Radbal (:) = 0.0 +balances % EbalSoil (:) = 0.0 +balances % Ebalveg (:) = 0.0 +balances % Radbalsum (:) = 0.0 + +RETURN +END SUBROUTINE alloc_balances_type + +SUBROUTINE dealloc_balances_type(balances) +IMPLICIT NONE + +TYPE(balances_type), INTENT(inout) :: balances + +DEALLOCATE( balances% drybal ) +DEALLOCATE( balances% ebal ) +DEALLOCATE( balances% ebal_tot ) +DEALLOCATE( balances% ebal_cncheck ) +DEALLOCATE( balances% ebal_tot_cncheck ) +DEALLOCATE( balances% ebaltr ) +DEALLOCATE( balances% ebal_tottr ) +DEALLOCATE( balances% evap_tot ) +DEALLOCATE( balances% osnowd0 ) +DEALLOCATE( balances% precip_tot ) +DEALLOCATE( balances% rnoff_tot ) +DEALLOCATE( balances% wbal ) +DEALLOCATE( balances% wbal_tot ) +DEALLOCATE( balances% wbtot0 ) +DEALLOCATE( balances% wetbal ) +DEALLOCATE( balances% cansto0 ) +DEALLOCATE( balances% owbtot ) +DEALLOCATE( balances% evapc_tot ) +DEALLOCATE( balances% evaps_tot ) +DEALLOCATE( balances% rnof1_tot ) +DEALLOCATE( balances% rnof2_tot ) +DEALLOCATE( balances% snowdc_tot ) +DEALLOCATE( balances% wbal_tot1 ) +DEALLOCATE( balances% delwc_tot ) +DEALLOCATE( balances% qasrf_tot ) +DEALLOCATE( balances% qfsrf_tot ) +DEALLOCATE( balances% qssrf_tot ) +DEALLOCATE( balances% Radbal ) +DEALLOCATE( balances% EbalSoil ) +DEALLOCATE( balances% Ebalveg ) +DEALLOCATE( balances% Radbalsum ) + +RETURN +END SUBROUTINE dealloc_balances_type + +SUBROUTINE assoc_balances_type(balances, balances_data ) +! Description: +! Associate the CABLE work pointers in the derived type structure +IMPLICIT NONE + +!Arguments +TYPE(balances_type), INTENT(IN OUT) :: balances +TYPE(balances_data_type), INTENT(IN OUT), TARGET :: balances_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_balances_cbl(balances) + +balances% drybal => balances_data% drybal +balances% ebal => balances_data% ebal +balances% ebal_tot => balances_data% ebal_tot +balances% ebal_cncheck => balances_data% ebal_cncheck +balances% ebal_tot_cncheck => balances_data% ebal_tot_cncheck +balances% ebaltr => balances_data% ebaltr +balances% ebal_tottr => balances_data% ebal_tottr +balances% evap_tot => balances_data% evap_tot +balances% osnowd0 => balances_data% osnowd0 +balances% precip_tot => balances_data% precip_tot +balances% rnoff_tot => balances_data% rnoff_tot +balances% wbal => balances_data% wbal +balances% wbal_tot => balances_data% wbal_tot +balances% wbtot0 => balances_data% wbtot0 +balances% wetbal => balances_data% wetbal +balances% cansto0 => balances_data% cansto0 +balances% owbtot => balances_data% owbtot +balances% evapc_tot => balances_data% evapc_tot +balances% evaps_tot => balances_data% evaps_tot +balances% rnof1_tot => balances_data% rnof1_tot +balances% rnof2_tot => balances_data% rnof2_tot +balances% snowdc_tot => balances_data% snowdc_tot +balances% wbal_tot1 => balances_data% wbal_tot1 +balances% delwc_tot => balances_data% delwc_tot +balances% qasrf_tot => balances_data% qasrf_tot +balances% qfsrf_tot => balances_data% qfsrf_tot +balances% qssrf_tot => balances_data% qssrf_tot +balances% Radbal => balances_data% Radbal +balances% EbalSoil => balances_data% EbalSoil +balances% Ebalveg => balances_data% Ebalveg +balances% Radbalsum => balances_data% Radbalsum + +RETURN +END SUBROUTINE assoc_balances_type + +SUBROUTINE nullify_balances_cbl( balances ) +! Description: +! Nullify the CABLE work pointers in the derived type structure +IMPLICIT NONE + +!Arguments +TYPE(balances_type), INTENT(IN OUT) :: balances + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( balances % drybal ) +NULLIFY( balances % ebal ) +NULLIFY( balances % ebal_tot ) +NULLIFY( balances % ebal_cncheck ) +NULLIFY( balances % ebal_tot_cncheck) +NULLIFY( balances % ebaltr ) +NULLIFY( balances % ebal_tottr ) +NULLIFY( balances % evap_tot ) +NULLIFY( balances % osnowd0 ) +NULLIFY( balances % precip_tot ) +NULLIFY( balances % rnoff_tot ) +NULLIFY( balances % wbal ) +NULLIFY( balances % wbal_tot ) +NULLIFY( balances % wbtot0 ) +NULLIFY( balances % wetbal ) +NULLIFY( balances % cansto0 ) +NULLIFY( balances % owbtot ) +NULLIFY( balances % evapc_tot ) +NULLIFY( balances % evaps_tot ) +NULLIFY( balances % rnof1_tot ) +NULLIFY( balances % rnof2_tot ) +NULLIFY( balances % snowdc_tot ) +NULLIFY( balances % wbal_tot1 ) +NULLIFY( balances % delwc_tot ) +NULLIFY( balances % qasrf_tot ) +NULLIFY( balances % qfsrf_tot ) +NULLIFY( balances % qssrf_tot ) +NULLIFY( balances % Radbal ) +NULLIFY( balances % EbalSoil ) +NULLIFY( balances % Ebalveg ) +NULLIFY( balances % Radbalsum ) + +RETURN + +END SUBROUTINE nullify_balances_cbl + +END MODULE cable_balances_type_mod + + + + + + + + diff --git a/src/coupled/AM3/control/cable/CM3/bgc_pool_type.F90 b/src/coupled/AM3/control/cable/CM3/bgc_pool_type.F90 new file mode 100644 index 000000000..9697c7d5a --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/bgc_pool_type.F90 @@ -0,0 +1,115 @@ +MODULE cable_bgc_pool_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: bgc_pool_type +PUBLIC :: bgc_pool_data_type +PUBLIC :: alloc_bgc_pool_type +PUBLIC :: dealloc_bgc_pool_type +PUBLIC :: assoc_bgc_pool_type +PUBLIC :: nullify_bgc_pool_cbl + +TYPE bgc_pool_data_type + + REAL, ALLOCATABLE :: ratecp (:) ! plant carbon rate constant (1/year) + REAL, ALLOCATABLE :: ratecs (:) ! soil carbon rate constant (1/year) + REAL, ALLOCATABLE :: cplant (:,:) ! plant carbon (g C/m2)) + REAL, ALLOCATABLE :: csoil (:,:) ! soil carbon (g C/m2) + +END TYPE bgc_pool_data_type + +TYPE bgc_pool_type + + REAL, POINTER :: ratecp (:) ! plant carbon rate constant (1/year) + REAL, POINTER :: ratecs (:) ! soil carbon rate constant (1/year) + REAL, POINTER :: cplant (:,:) ! plant carbon (g C/m2)) + REAL, POINTER :: csoil (:,:) ! soil carbon (g C/m2) + +END TYPE bgc_pool_type + +CONTAINS + +SUBROUTINE alloc_bgc_pool_type(bgc_pool, mp) + +USE grid_constants_mod_cbl, ONLY: nsCs ! # soil carbon stores +USE grid_constants_mod_cbl, ONLY: nvCs ! # vegetation carbon stores + +IMPLICIT NONE + +TYPE(bgc_pool_data_type), INTENT(INOUT) :: bgc_pool +INTEGER, INTENT(IN) :: mp + +ALLOCATE( bgc_pool% ratecp (nvCs) ) +ALLOCATE( bgc_pool% ratecs (nsCs) ) +ALLOCATE( bgc_pool% cplant (mp,nvCs) ) +ALLOCATE( bgc_pool% csoil (mp,nsCs) ) + +bgc_pool % ratecp(:) = 0.0 +bgc_pool % ratecs(:) = 0.0 +bgc_pool % cplant(:,:) = 0.0 +bgc_pool % csoil (:,:) = 0.0 + +RETURN +END SUBROUTINE alloc_bgc_pool_type + +SUBROUTINE dealloc_bgc_pool_type(bgc_pool) + +TYPE(bgc_pool_type), INTENT(inout) :: bgc_pool + +DEALLOCATE ( bgc_pool % ratecp) +DEALLOCATE ( bgc_pool % ratecs) +DEALLOCATE ( bgc_pool % cplant) +DEALLOCATE ( bgc_pool % csoil ) + +RETURN +END SUBROUTINE dealloc_bgc_pool_type + +SUBROUTINE assoc_bgc_pool_type(bgc_pool, bgc_pool_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(bgc_pool_type), INTENT(IN OUT) :: bgc_pool +TYPE(bgc_pool_data_type), INTENT(IN OUT), TARGET :: bgc_pool_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_bgc_pool_cbl(bgc_pool) + +bgc_pool% ratecp => bgc_pool_data% ratecp +bgc_pool% ratecs => bgc_pool_data% ratecs +bgc_pool% cplant => bgc_pool_data% cplant +bgc_pool% csoil => bgc_pool_data% csoil + +RETURN +END SUBROUTINE assoc_bgc_pool_type + +SUBROUTINE nullify_bgc_pool_cbl( bgc_pool ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(bgc_pool_type), INTENT(IN OUT) :: bgc_pool + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( bgc_pool % ratecp ) +NULLIFY( bgc_pool % ratecs ) +NULLIFY( bgc_pool % cplant ) +NULLIFY( bgc_pool % csoil ) + +RETURN + +END SUBROUTINE nullify_bgc_pool_cbl + +END MODULE cable_bgc_pool_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/cable_common.F90 b/src/coupled/AM3/control/cable/CM3/cable_common.F90 new file mode 100644 index 000000000..5c4c15a17 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/cable_common.F90 @@ -0,0 +1,143 @@ +!============================================================================== +! This source code is part of the +! Australian Community Atmosphere Biosphere Land Exchange (CABLE) model. +! This work is licensed under the CSIRO Open Source Software License +! Agreement (variation of the BSD / MIT License). +! +! You may not use this file except in compliance with this License. +! A copy of the License (CSIRO_BSD_MIT_License_v2.0_CABLE.txt) is located +! in each directory containing CABLE code. +! +! ============================================================================== +! Purpose: Reads vegetation and soil parameter files, fills vegin, soilin +! NB. Most soil parameters overwritten by spatially explicit datasets +! input as ancillary file (for ACCESS) or surface data file (for offline) +! Module enables accessibility of variables throughout CABLE +! +! Contact: Jhan.Srbinovsky@csiro.au +! +! History: v2.0 vegin%dleaf now calculated from leaf length and width +! Parameter files were read elsewhere in v1.8 (init_subrs) +! +! ============================================================================== + +MODULE cable_common_module + +USE cable_runtime_opts_mod ,ONLY : cable_user +USE cable_runtime_opts_mod ,ONLY : satuparam +USE cable_runtime_opts_mod ,ONLY : wiltparam + + IMPLICIT NONE + + INTEGER, PARAMETER :: pe=120 + !---allows reference to "gl"obal timestep in run (from atm_step) + !---total number of timesteps, and processing node + INTEGER, SAVE :: ktau_gl, kend_gl, knode_gl, kwidth_gl + + LOGICAL :: L_fudge = .FALSE. + + INTEGER, SAVE :: CurYear ! current year of multiannual run + + ! set from environment variable $HOME + CHARACTER(LEN=200) :: & + myhome + + ! switch to calc sil albedo using soil colour - Ticket #27 + LOGICAL :: calcsoilalbedo = .FALSE. + !---Lestevens Sept2012 + !---CASACNP switches and cycle index + LOGICAL, SAVE :: l_casacnp,l_laiFeedbk,l_vcmaxFeedbk + LOGICAL :: l_luc = .FALSE. + LOGICAL :: l_thinforest = .FALSE. + LOGICAL :: l_landuse = .FALSE. + + !---CABLE runtime switches def in this type + TYPE kbl_internal_switches + LOGICAL :: um = .FALSE., um_explicit = .FALSE., um_implicit = .FALSE., & + um_radiation = .FALSE., um_hydrology = .FALSE., esm15 = .FALSE. + LOGICAL :: offline = .FALSE., mk3l = .FALSE. + END TYPE kbl_internal_switches + + ! instantiate internal switches + TYPE(kbl_internal_switches), SAVE :: cable_runtime + + ! hydraulic_redistribution switch _soilsnow module + LOGICAL :: redistrb = .FALSE. + + TYPE organic_soil_params + !Below are the soil properties for fully organic soil + + REAL :: & + hyds_vec_organic = 1.0e-4,& + sucs_vec_organic = 10.3, & + clappb_organic = 2.91, & + ssat_vec_organic = 0.9, & + watr_organic = 0.1, & + sfc_vec_hk = 1.157407e-06, & + swilt_vec_hk = 2.31481481e-8 + + END TYPE organic_soil_params + + TYPE gw_parameters_type + + REAL :: & + MaxHorzDrainRate=2e-4, & !anisintropy * q_max [qsub] + EfoldHorzDrainRate=2.0, & !e fold rate of q_horz + MaxSatFraction=2500.0, & !parameter controll max sat fraction + hkrz=0.5, & !hyds_vec variation with z + zdepth=1.5, & !level where hyds_vec(z) = hyds_vec(no z) + frozen_frac=0.05, & !ice fraction to determine first non-frozen layer for qsub + SoilEvapAlpha = 1.0, & !modify field capacity dependence of soil evap limit + IceAlpha=3.0, & + IceBeta=1.0 + + REAL :: ice_impedence=5.0 + + TYPE(organic_soil_params) :: org + + INTEGER :: level_for_satfrac = 6 + LOGICAL :: ssgw_ice_switch = .FALSE. + + LOGICAL :: subsurface_sat_drainage = .TRUE. + + END TYPE gw_parameters_type + + TYPE(gw_parameters_type), SAVE :: gw_params + + REAL, SAVE :: &!should be able to change parameters! + max_glacier_snowd=1100.0,& + snow_ccnsw = 2.0, & + !jh!an:clobber - effectively force single layer snow + !snmin = 100.0, & ! for 1-layer; + snmin = 1., & ! for 3-layer; + max_ssdn = 750.0, & ! + max_sconds = 2.51, & ! + frozen_limit = 0.85 ! EAK Feb2011 (could be 0.95) + +contains + + ELEMENTAL FUNCTION IS_LEAPYEAR( YYYY ) + IMPLICIT NONE + INTEGER,INTENT(IN) :: YYYY + LOGICAL :: IS_LEAPYEAR + + IS_LEAPYEAR = .FALSE. + IF ( ( ( MOD( YYYY, 4 ) .EQ. 0 .AND. MOD( YYYY, 100 ) .NE. 0 ) .OR. & + MOD( YYYY,400 ) .EQ. 0 ) ) IS_LEAPYEAR = .TRUE. + + END FUNCTION IS_LEAPYEAR + + FUNCTION LEAP_DAY( YYYY ) + IMPLICIT NONE + INTEGER :: YYYY, LEAP_DAY + + IF ( IS_LEAPYEAR ( YYYY ) ) THEN + LEAP_DAY = 1 + ELSE + LEAP_DAY = 0 + END IF + END FUNCTION LEAP_DAY + + + +END MODULE cable_common_module diff --git a/src/coupled/AM3/control/cable/CM3/cable_define_types.F90 b/src/coupled/AM3/control/cable/CM3/cable_define_types.F90 new file mode 100644 index 000000000..6337bb888 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/cable_define_types.F90 @@ -0,0 +1,72 @@ +!============================================================================== +! This source code is part of the +! Australian Community Atmosphere Biosphere Land Exchange (CABLE) model. +! This work is licensed under the CSIRO Open Source Software License +! Agreement (variation of the BSD / MIT License). +! +! You may not use this file except in compliance with this License. +! A copy of the License (CSIRO_BSD_MIT_License_v2.0_CABLE.txt) is located +! in each directory containing CABLE code. +! +! ============================================================================== +! Purpose: defines parameters, variables and derived types, allocation and +! deallocation of these derived types +! +! Contact: Bernard.Pak@csiro.au +! +! History: Brings together define_dimensions and define_types from v1.4b +! rs20 now in veg% instead of soil% +! fes split into fess and fesp (though fes still defined) +! +! Jan 2016: Now includes climate% for use in climate variables required for +! prognostic phenology and potential veg type +! ============================================================================== + +MODULE cable_def_types_mod + +! Scattered throughout CABLE (science code) there are USEs of these vars which +! are/were declared/defined in multiple places. We are migrating to only having +! them defined in one place. Bringing them into the header here satisfies legacy +USE grid_constants_mod_cbl, ONLY: nrb, nrs, mp, swb +USE grid_constants_mod_cbl, ONLY: mstype => nsoil_max ! # of soil types [9] +USE grid_constants_mod_cbl, ONLY: mvtype => ntype_max ! # of PFT types [17] +USE grid_constants_mod_cbl, ONLY: ms => nsl ! # soil layers !sm_levels in JULES IO +USE grid_constants_mod_cbl, ONLY: msn => nsnl ! # snow layers +USE grid_constants_mod_cbl, ONLY: ncp => nvCs ! # vegetation carbon s +USE grid_constants_mod_cbl, ONLY: ncs => nsCs ! # soil carbon stores +USE grid_constants_mod_cbl, ONLY: ntype_max ! Max # tiles ! compile time constant +USE grid_constants_mod_cbl, ONLY: mf ! # leaves (sunlit, shaded) +USE grid_constants_mod_cbl, ONLY: niter ! # iterations for za/L +USE cable_other_constants_mod, ONLY: r_2 ! currently DOUBLE precision was + ! SELECTED_REAL_KIND(12, 50) + +! Scattered throughout CABLE (science code) there are USEs of these vars. We are +! ascertaining (per "module") how we can better describe this data structure. As +! a first step they are now declared/defined in independent, per module, files. +! Bringing them into the header here satisfies legacy +USE cable_canopy_type_mod, ONLY: canopy_type +USE cable_met_type_mod, ONLY: met_type +USE cable_air_type_mod, ONLY: air_type +USE cable_balances_type_mod, ONLY: balances_type +USE cable_soil_type_mod, ONLY: soil_parameter_type => soil_type +USE cable_veg_type_mod, ONLY: veg_parameter_type => veg_type +USE cable_soil_snow_type_mod, ONLY: soil_snow_type +USE cable_radiation_type_mod, ONLY: radiation_type +USE cable_roughness_type_mod, ONLY: roughness_type +USE cable_bgc_pool_type_mod, ONLY: bgc_pool_type +USE cable_climate_type_mod, ONLY: climate_type +USE cable_sum_flux_type_mod, ONLY: sum_flux_type + +IMPLICIT NONE + +PUBLIC + +! CABLE special KINDs for representing INTEGER/REAL values with at least +! 10-digit precision. NA in UM/JULES anyway as -i8 -r8 compile flags overrride + +INTEGER, PARAMETER :: i_d = KIND(9) ! this is useless but needs to be def + +INTEGER :: mland ! # land grid cells where is this used? +INTEGER, PARAMETER :: n_ktherm = 3 ! where is this used? remove? local? + +END MODULE cable_def_types_mod diff --git a/src/coupled/AM3/control/cable/CM3/cbl_canopy_type.F90 b/src/coupled/AM3/control/cable/CM3/cbl_canopy_type.F90 new file mode 100644 index 000000000..615642fa7 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/cbl_canopy_type.F90 @@ -0,0 +1,587 @@ +MODULE cable_canopy_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: canopy_type +PUBLIC :: canopy_data_type +PUBLIC :: alloc_canopy_type +PUBLIC :: dealloc_canopy_type +PUBLIC :: assoc_canopy_type +PUBLIC :: nullify_canopy_cbl + +! Canopy/vegetation variables: +TYPE canopy_data_type + + REAL, ALLOCATABLE, PUBLIC :: cansto(:) ! canopy water storage (mm) + REAL, ALLOCATABLE, PUBLIC :: cduv(:) ! drag coefficient for momentum + REAL, ALLOCATABLE, PUBLIC :: delwc(:) ! change in canopy water store (mm/dels) + REAL, ALLOCATABLE, PUBLIC :: dewmm(:) ! dewfall (mm) + REAL, ALLOCATABLE, PUBLIC :: fe(:) ! total latent heat (W/m2) + REAL, ALLOCATABLE, PUBLIC :: fh(:) ! total sensible heat (W/m2) + REAL, ALLOCATABLE, PUBLIC :: fpn(:) ! plant photosynthesis (g C m-2 s-1) + REAL, ALLOCATABLE, PUBLIC :: frp(:) ! plant respiration (g C m-2 s-1) + REAL, ALLOCATABLE, PUBLIC :: frpw(:) ! plant respiration (woody component) (g C m-2 s-1) + REAL, ALLOCATABLE, PUBLIC :: frpr(:) ! plant respiration (root component) (g C m-2 s-1) + REAL, ALLOCATABLE, PUBLIC :: frs(:) ! soil respiration (g C m-2 s-1) + REAL, ALLOCATABLE, PUBLIC :: fnee(:) ! net carbon flux (g C m-2 s-1) + REAL, ALLOCATABLE, PUBLIC :: frday(:) ! daytime leaf resp + REAL, ALLOCATABLE, PUBLIC :: fnv(:) ! net rad. avail. to canopy (W/m2) + REAL, ALLOCATABLE, PUBLIC :: fev(:) ! latent hf from canopy (W/m2) + REAL, ALLOCATABLE, PUBLIC :: epot(:) ! total potential evaporation + REAL, ALLOCATABLE, PUBLIC :: fnpp(:) ! npp flux + REAL, ALLOCATABLE, PUBLIC :: fevw_pot(:) ! potential lat heat from canopy + REAL, ALLOCATABLE, PUBLIC :: gswx_T(:) ! ! stom cond for water + REAL, ALLOCATABLE, PUBLIC :: cdtq(:) ! drag coefficient for momentum + REAL, ALLOCATABLE, PUBLIC :: wetfac_cs(:) ! + REAL, ALLOCATABLE, PUBLIC :: fevw(:) ! lat heat fl wet canopy (W/m2) + REAL, ALLOCATABLE, PUBLIC :: fhvw(:) ! sens heatfl from wet canopy (W/m2) + REAL, ALLOCATABLE, PUBLIC :: oldcansto(:) ! canopy water storage (mm) + REAL, ALLOCATABLE, PUBLIC :: fhv(:) ! sens heatfl from canopy (W/m2) + REAL, ALLOCATABLE, PUBLIC :: fns(:) ! net rad avail to soil (W/m2) + REAL, ALLOCATABLE, PUBLIC :: fhs(:) ! sensible heat flux from soil + REAL, ALLOCATABLE, PUBLIC :: fhs_cor(:) ! + REAL, ALLOCATABLE, PUBLIC :: ga(:) ! ground heat flux (W/m2) ??? + REAL, ALLOCATABLE, PUBLIC :: ghflux(:) ! ground heat flux (W/m2) ??? + REAL, ALLOCATABLE, PUBLIC :: precis(:) ! throughfall to soil, after snow (mm) + REAL, ALLOCATABLE, PUBLIC :: qscrn(:) ! specific humudity at screen height (g/g) + REAL, ALLOCATABLE, PUBLIC :: rnet(:) ! net radiation absorbed by surface (W/m2) + REAL, ALLOCATABLE, PUBLIC :: rniso(:) !isothermal net radiation absorbed by surface (W/m2) + REAL, ALLOCATABLE, PUBLIC :: segg(:) ! latent heatfl from soil mm + REAL, ALLOCATABLE, PUBLIC :: sghflux(:) ! ground heat flux (W/m2) ??? + REAL, ALLOCATABLE, PUBLIC :: through(:) ! canopy throughfall (mm) + REAL, ALLOCATABLE, PUBLIC :: through_sn(:) ! canopy snow throughfall (equal to precip_sn) (mm) + REAL, ALLOCATABLE, PUBLIC :: spill(:) ! can.storage excess after dewfall (mm) + REAL, ALLOCATABLE, PUBLIC :: tscrn(:) ! air temperature at screen height (oC) + REAL, ALLOCATABLE, PUBLIC :: wcint(:) ! canopy rainfall interception (mm) + REAL, ALLOCATABLE, PUBLIC :: tv(:) ! vegetation temp (K) + REAL, ALLOCATABLE, PUBLIC :: us(:) ! friction velocity + REAL, ALLOCATABLE, PUBLIC :: uscrn(:) ! wind speed at screen height (m/s) + REAL, ALLOCATABLE, PUBLIC :: vlaiw(:) ! lai adj for snow depth for calc of resistances + REAL, ALLOCATABLE, PUBLIC :: rghlai(:) ! lai adj for snow depth for calc of resistances + REAL, ALLOCATABLE, PUBLIC :: fwet(:) ! fraction of canopy wet + REAL, ALLOCATABLE, PUBLIC :: fns_cor(:) ! correction to net rad avail to soil (W/m2) + REAL, ALLOCATABLE, PUBLIC :: ga_cor(:) ! correction to ground heat flux (W/m2) + REAL, ALLOCATABLE, PUBLIC :: evapfbl(:,:) ! + REAL, ALLOCATABLE, PUBLIC :: gswx(:,:) ! stom cond for water + REAL, ALLOCATABLE, PUBLIC :: zetar(:,:) ! stability parameter (ref height) + REAL, ALLOCATABLE, PUBLIC :: zetash(:,:) ! stability parameter (shear height) + REAL(r_2), ALLOCATABLE, PUBLIC :: fess(:) ! latent heatfl from soil (w/m2) + REAL(r_2), ALLOCATABLE, PUBLIC :: fesp(:) ! latent heatfl from soil (w/m2) + REAL(r_2), ALLOCATABLE, PUBLIC :: dgdtg(:) ! derivative of gflux wrt soil temp + REAL(r_2), ALLOCATABLE, PUBLIC :: fes(:) ! latent heatfl from soil (w/m2) + REAL(r_2), ALLOCATABLE, PUBLIC :: fes_cor(:) ! latent heatfl from soil (w/m2) + REAL(r_2), ALLOCATABLE, PUBLIC :: fevc(:) ! dry canopy transpiration (w/m2) + REAL(r_2), ALLOCATABLE, PUBLIC :: ofes(:) ! latent heatfl from soil (w/m2) + REAL(r_2), ALLOCATABLE, PUBLIC :: sublayer_dz(:) ! + REAL(r_2), ALLOCATABLE, PUBLIC :: gw(:,:) ! dry canopy conductance (ms-1) edit vh 6/7/09 + REAL(r_2), ALLOCATABLE, PUBLIC :: ancj(:,:,:) ! limiting photosynthetic rates (Rubisco,RuBP,sink) vh 6/7/09 + REAL(r_2), ALLOCATABLE, PUBLIC :: tlfy(:,:) ! sunlit and shaded leaf temperatures + REAL(r_2), ALLOCATABLE, PUBLIC :: ecy(:,:) ! sunlit and shaded leaf transpiration (dry canopy) + REAL(r_2), ALLOCATABLE, PUBLIC :: ecx(:,:) ! sunlit and shaded leaf latent heat flux + REAL(r_2), ALLOCATABLE, PUBLIC :: ci(:,:,:) ! intra-cellular CO2 vh 6/7/09 + REAL(r_2), ALLOCATABLE, PUBLIC :: fwsoil(:) ! + ! vh_js ! !litter thermal conductivity (Wm-2K-1) and vapour diffusivity (m2s-1) + REAL(r_2), ALLOCATABLE, PUBLIC :: kthLitt(:) ! + REAL(r_2), ALLOCATABLE, PUBLIC :: DvLitt(:) ! + !SSEB - new variables limits on correction terms - for future use + !REAL(r_2), DIMENSION(:), POINTER :: & + ! fescor_upp,& ! upper limit on the correction term fes_cor (W/m2) + ! fescor_low ! lower limit on the correction term fes_cor (W/m2) + +END TYPE canopy_data_type + +! Canopy/vegetation variables: +TYPE canopy_type + + REAL, POINTER, PUBLIC :: cansto(:) ! canopy water storage (mm) + REAL, POINTER, PUBLIC :: cduv(:) ! drag coefficient for momentum + REAL, POINTER, PUBLIC :: delwc(:) ! change in canopy water store (mm/dels) + REAL, POINTER, PUBLIC :: dewmm(:) ! dewfall (mm) + REAL, POINTER, PUBLIC :: fe(:) ! total latent heat (W/m2) + REAL, POINTER, PUBLIC :: fh(:) ! total sensible heat (W/m2) + REAL, POINTER, PUBLIC :: fpn(:) ! plant photosynthesis (g C m-2 s-1) + REAL, POINTER, PUBLIC :: frp(:) ! plant respiration (g C m-2 s-1) + REAL, POINTER, PUBLIC :: frpw(:) ! plant respiration (woody component) (g C m-2 s-1) + REAL, POINTER, PUBLIC :: frpr(:) ! plant respiration (root component) (g C m-2 s-1) + REAL, POINTER, PUBLIC :: frs(:) ! soil respiration (g C m-2 s-1) + REAL, POINTER, PUBLIC :: fnee(:) ! net carbon flux (g C m-2 s-1) + REAL, POINTER, PUBLIC :: frday(:) ! daytime leaf resp + REAL, POINTER, PUBLIC :: fnv(:) ! net rad. avail. to canopy (W/m2) + REAL, POINTER, PUBLIC :: fev(:) ! latent hf from canopy (W/m2) + REAL, POINTER, PUBLIC :: epot(:) ! total potential evaporation + REAL, POINTER, PUBLIC :: fnpp(:) ! npp flux + REAL, POINTER, PUBLIC :: fevw_pot(:) ! potential lat heat from canopy + REAL, POINTER, PUBLIC :: gswx_T(:) ! ! stom cond for water + REAL, POINTER, PUBLIC :: cdtq(:) ! drag coefficient for momentum + REAL, POINTER, PUBLIC :: wetfac_cs(:) ! + REAL, POINTER, PUBLIC :: fevw(:) ! lat heat fl wet canopy (W/m2) + REAL, POINTER, PUBLIC :: fhvw(:) ! sens heatfl from wet canopy (W/m2) + REAL, POINTER, PUBLIC :: oldcansto(:) ! canopy water storage (mm) + REAL, POINTER, PUBLIC :: fhv(:) ! sens heatfl from canopy (W/m2) + REAL, POINTER, PUBLIC :: fns(:) ! net rad avail to soil (W/m2) + REAL, POINTER, PUBLIC :: fhs(:) ! sensible heat flux from soil + REAL, POINTER, PUBLIC :: fhs_cor(:) ! + REAL, POINTER, PUBLIC :: ga(:) ! ground heat flux (W/m2) ??? + REAL, POINTER, PUBLIC :: ghflux(:) ! ground heat flux (W/m2) ??? + REAL, POINTER, PUBLIC :: precis(:) ! throughfall to soil, after snow (mm) + REAL, POINTER, PUBLIC :: qscrn(:) ! specific humudity at screen height (g/g) + REAL, POINTER, PUBLIC :: rnet(:) ! net radiation absorbed by surface (W/m2) + REAL, POINTER, PUBLIC :: rniso(:) !isothermal net radiation absorbed by surface (W/m2) + REAL, POINTER, PUBLIC :: segg(:) ! latent heatfl from soil mm + REAL, POINTER, PUBLIC :: sghflux(:) ! ground heat flux (W/m2) ??? + REAL, POINTER, PUBLIC :: through(:) ! canopy throughfall (mm) + REAL, POINTER, PUBLIC :: through_sn(:) ! canopy snow throughfall (equal to precip_sn) (mm) + REAL, POINTER, PUBLIC :: spill(:) ! can.storage excess after dewfall (mm) + REAL, POINTER, PUBLIC :: tscrn(:) ! air temperature at screen height (oC) + REAL, POINTER, PUBLIC :: wcint(:) ! canopy rainfall interception (mm) + REAL, POINTER, PUBLIC :: tv(:) ! vegetation temp (K) + REAL, POINTER, PUBLIC :: us(:) ! friction velocity + REAL, POINTER, PUBLIC :: uscrn(:) ! wind speed at screen height (m/s) + REAL, POINTER, PUBLIC :: vlaiw(:) ! lai adj for snow depth for calc of resistances + REAL, POINTER, PUBLIC :: rghlai(:) ! lai adj for snow depth for calc of resistances + REAL, POINTER, PUBLIC :: fwet(:) ! fraction of canopy wet + REAL, POINTER, PUBLIC :: fns_cor(:) ! correction to net rad avail to soil (W/m2) + REAL, POINTER, PUBLIC :: ga_cor(:) ! correction to ground heat flux (W/m2) + REAL, POINTER, PUBLIC :: evapfbl(:,:) ! + REAL, POINTER, PUBLIC :: gswx(:,:) ! stom cond for water + REAL, POINTER, PUBLIC :: zetar(:,:) ! stability parameter (ref height) + REAL, POINTER, PUBLIC :: zetash(:,:) ! stability parameter (shear height) + REAL(r_2), POINTER, PUBLIC :: fess(:) ! latent heatfl from soil (w/m2) + REAL(r_2), POINTER, PUBLIC :: fesp(:) ! latent heatfl from soil (w/m2) + REAL(r_2), POINTER, PUBLIC :: dgdtg(:) ! derivative of gflux wrt soil temp + REAL(r_2), POINTER, PUBLIC :: fes(:) ! latent heatfl from soil (w/m2) + REAL(r_2), POINTER, PUBLIC :: fes_cor(:) ! latent heatfl from soil (w/m2) + REAL(r_2), POINTER, PUBLIC :: fevc(:) ! dry canopy transpiration (w/m2) + REAL(r_2), POINTER, PUBLIC :: ofes(:) ! latent heatfl from soil (w/m2) + REAL(r_2), POINTER, PUBLIC :: sublayer_dz(:) ! + REAL(r_2), POINTER, PUBLIC :: gw(:,:) ! dry canopy conductance (ms-1) edit vh 6/7/09 + REAL(r_2), POINTER, PUBLIC :: ancj(:,:,:) ! limiting photosynthetic rates (Rubisco,RuBP,sink) vh 6/7/09 + REAL(r_2), POINTER, PUBLIC :: tlfy(:,:) ! sunlit and shaded leaf temperatures + REAL(r_2), POINTER, PUBLIC :: ecy(:,:) ! sunlit and shaded leaf transpiration (dry canopy) + REAL(r_2), POINTER, PUBLIC :: ecx(:,:) ! sunlit and shaded leaf latent heat flux + REAL(r_2), POINTER, PUBLIC :: ci(:,:,:) ! intra-cellular CO2 vh 6/7/09 + REAL(r_2), POINTER, PUBLIC :: fwsoil(:) ! + REAL(r_2), POINTER, PUBLIC :: kthLitt(:) !!litter thermal conductivity (Wm-2K-1) and vapour diffusivity (m2s-1) + REAL(r_2), POINTER, PUBLIC :: DvLitt(:) ! + !SSEB - new variables limits on correction terms - for future use + !REAL(r_2), DIMENSION(:), POINTER :: & + ! fescor_upp,& ! upper limit on the correction term fes_cor (W/m2) + ! fescor_low ! lower limit on the correction term fes_cor (W/m2) + +END TYPE canopy_type + + +CONTAINS + +SUBROUTINE alloc_canopy_type(var, mp) + +USE grid_constants_mod_cbl, ONLY: mf ! # leaves (sunlit/shaded) +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: niter ! number of iterations for za/L + +IMPLICIT NONE + +TYPE(canopy_data_type), INTENT(INOUT) :: var +INTEGER, INTENT(IN) :: mp + +ALLOCATE( var% fess(mp) ) +ALLOCATE( var% fesp(mp) ) +ALLOCATE( var% cansto(mp) ) +ALLOCATE( var% cduv(mp) ) +ALLOCATE( var% delwc(mp) ) +ALLOCATE( var% dewmm(mp) ) +ALLOCATE( var% dgdtg(mp) ) +ALLOCATE( var% fe(mp) ) +ALLOCATE( var% fh(mp) ) +ALLOCATE( var% fpn(mp) ) +ALLOCATE( var% frp(mp) ) +ALLOCATE( var% frpw(mp) ) +ALLOCATE( var% frpr(mp) ) +ALLOCATE( var% frs(mp) ) +ALLOCATE( var% fnee(mp) ) +ALLOCATE( var% frday(mp) ) +ALLOCATE( var% fnv(mp) ) +ALLOCATE( var% fev(mp) ) +ALLOCATE( var% fevc(mp) ) +ALLOCATE( var% fhv(mp) ) +ALLOCATE( var% fns(mp) ) +ALLOCATE( var% fhs(mp) ) +ALLOCATE( var% fhs_cor(mp) ) +ALLOCATE( var% ga(mp) ) +ALLOCATE( var% ghflux(mp) ) +ALLOCATE( var% precis(mp) ) +ALLOCATE( var% qscrn(mp) ) +ALLOCATE( var% rnet(mp) ) +ALLOCATE( var% rniso(mp) ) +ALLOCATE( var% segg(mp) ) +ALLOCATE( var% sghflux(mp) ) +ALLOCATE( var% through(mp) ) +ALLOCATE( var% through_sn(mp) ) +ALLOCATE( var% spill(mp) ) +ALLOCATE( var% tscrn(mp) ) +ALLOCATE( var% wcint(mp) ) +ALLOCATE( var% tv(mp) ) +ALLOCATE( var% us(mp) ) +ALLOCATE( var% uscrn(mp) ) +ALLOCATE( var% rghlai(mp) ) +ALLOCATE( var% vlaiw(mp) ) +ALLOCATE( var% fwet(mp) ) +ALLOCATE( var% fns_cor(mp) ) !REV_CORR variable +ALLOCATE( var% ga_cor(mp) ) !REV_CORR variable +ALLOCATE( var % evapfbl(mp,nsl) ) +ALLOCATE( var% epot(mp) ) +ALLOCATE( var% fnpp(mp) ) +ALLOCATE( var% fevw_pot(mp) ) +ALLOCATE( var% gswx_T(mp) ) +ALLOCATE( var% cdtq(mp) ) +ALLOCATE( var% wetfac_cs(mp) ) +ALLOCATE( var% fevw(mp) ) +ALLOCATE( var% fhvw(mp) ) +ALLOCATE( var% fes(mp) ) +ALLOCATE( var% fes_cor(mp) ) +ALLOCATE( var% gswx(mp,mf) ) +ALLOCATE( var% oldcansto(mp) ) +ALLOCATE( var% zetar(mp,niter) ) +ALLOCATE( var% zetash(mp,niter) ) +ALLOCATE( var % fwsoil(mp) ) +ALLOCATE( var % ofes(mp) ) +ALLOCATE( var%sublayer_dz(mp) ) +ALLOCATE( var % gw(mp,mf) ) ! dry canopy conductance (ms-1) edit vh 6/7/09 +ALLOCATE( var % ancj(mp,mf,3) ) ! limiting photosynthetic rates (Rubisco,RuBP,sink) vh 6/7/09 +ALLOCATE( var % tlfy(mp,mf) ) ! sunlit and shaded leaf temperatures +ALLOCATE( var % ecy(mp,mf) ) ! sunlit and shaded leaf transpiration (dry canopy) +ALLOCATE( var % ecx(mp,mf) ) ! sunlit and shaded leaf latent heat flux +ALLOCATE( var % ci(mp,mf,3) ) ! intra-cellular CO2 vh 6/7/09 +ALLOCATE(var % kthLitt(mp)) +ALLOCATE(var % DvLitt(mp)) +!ALLOCATE( var% fescor_upp(mp) ) !SSEB variable +!ALLOCATE( var% fescor_low(mp) ) !SSEB variable + +var % cansto(:) = 0.0 +var % cduv(:) = 0.0 +var % delwc(:) = 0.0 +var % dewmm(:) = 0.0 +var % fe(:) = 0.0 +var % fh(:) = 0.0 +var % fpn(:) = 0.0 +var % frp(:) = 0.0 +var % frpw(:) = 0.0 +var % frpr(:) = 0.0 +var % frs(:) = 0.0 +var % fnee(:) = 0.0 +var % frday(:) = 0.0 +var % fnv(:) = 0.0 +var % fev(:) = 0.0 +var % epot(:) = 0.0 +var % fnpp(:) = 0.0 +var % fevw_pot(:) = 0.0 +var % gswx_T(:) = 0.0 +var % cdtq(:) = 0.0 +var % wetfac_cs(:) = 0.0 +var % fevw(:) = 0.0 +var % fhvw(:) = 0.0 +var % oldcansto(:) = 0.0 +var % fhv(:) = 0.0 +var % fns(:) = 0.0 +var % fhs(:) = 0.0 +var % fhs_cor(:) = 0.0 +var % ga(:) = 0.0 +var % ghflux(:) = 0.0 +var % precis(:) = 0.0 +var % qscrn(:) = 0.0 +var % rnet(:) = 0.0 +var % rniso(:) = 0.0 +var % segg(:) = 0.0 +var % sghflux(:) = 0.0 +var % through(:) = 0.0 +var % through_sn(:) = 0.0 +var % spill(:) = 0.0 +var % tscrn(:) = 0.0 +var % wcint(:) = 0.0 +var % tv(:) = 0.0 +var % us(:) = 0.0 +var % uscrn(:) = 0.0 +var % vlaiw(:) = 0.0 +var % rghlai(:) = 0.0 +var % fwet(:) = 0.0 +var % fns_cor(:) = 0.0 +var % ga_cor(:) = 0.0 +var % evapfbl(:,:) = 0.0 +var % gswx(:,:) = 0.0 +var % zetar(:,:) = 0.0 +var % zetash(:,:) = 0.0 +var % fess(:) = 0.0_r_2 +var % fesp(:) = 0.0_r_2 +var % dgdtg(:) = 0.0_r_2 +var % fes(:) = 0.0_r_2 +var % fes_cor(:) = 0.0_r_2 +var % fevc(:) = 0.0_r_2 +var % ofes(:) = 0.0_r_2 +var % sublayer_dz(:) = 0.0_r_2 +var % gw(:,:) = 0.0_r_2 +var % ancj(:,:,:) = 0.0_r_2 +var % tlfy(:,:) = 0.0_r_2 +var % ecy(:,:) = 0.0_r_2 +var % ecx(:,:) = 0.0_r_2 +var % ci(:,:,:) = 0.0_r_2 +var % fwsoil(:) = 0.0_r_2 +var % kthLitt(:) = 0.0_r_2 +var % DvLitt(:) = 0.0_r_2 + + +RETURN +END SUBROUTINE alloc_canopy_type + +SUBROUTINE dealloc_canopy_type(var) + + TYPE(canopy_type), INTENT(inout) :: var + + DEALLOCATE ( var % fess ) + DEALLOCATE ( var % fesp ) + DEALLOCATE( var% cansto ) + DEALLOCATE( var% cduv ) + DEALLOCATE( var% delwc ) + DEALLOCATE( var% dewmm ) + DEALLOCATE( var% dgdtg ) + DEALLOCATE( var% fe ) + DEALLOCATE( var% fh ) + DEALLOCATE( var% fpn ) + DEALLOCATE( var% frp ) + DEALLOCATE( var% frpw ) + DEALLOCATE( var% frpr ) + DEALLOCATE( var% frs ) + DEALLOCATE( var% fnee ) + DEALLOCATE( var% frday ) + DEALLOCATE( var% fnv ) + DEALLOCATE( var% fev ) + DEALLOCATE( var% fevc ) + DEALLOCATE( var% fhv ) + DEALLOCATE( var% fns ) + DEALLOCATE( var% fhs ) + DEALLOCATE( var% fhs_cor ) + DEALLOCATE( var% ga ) + DEALLOCATE( var% ghflux ) + DEALLOCATE( var% precis ) + DEALLOCATE( var% qscrn ) + DEALLOCATE( var% rnet ) + DEALLOCATE( var% rniso ) + DEALLOCATE( var% segg ) + DEALLOCATE( var% sghflux ) + DEALLOCATE( var% through ) + DEALLOCATE( var% through_sn ) + DEALLOCATE( var% spill ) + DEALLOCATE( var% tscrn ) + DEALLOCATE( var% wcint ) + DEALLOCATE( var% tv ) + DEALLOCATE( var% us ) + DEALLOCATE( var% uscrn ) + DEALLOCATE( var% rghlai ) + DEALLOCATE( var% vlaiw ) + DEALLOCATE( var% fwet ) + DEALLOCATE( var% fns_cor ) !REV_CORR variable + DEALLOCATE( var% ga_cor ) !REV_CORR variable + DEALLOCATE ( var % evapfbl ) + DEALLOCATE( var% epot ) + DEALLOCATE( var% fnpp ) + DEALLOCATE( var% fevw_pot ) + DEALLOCATE( var% gswx_T ) + DEALLOCATE( var% cdtq ) + DEALLOCATE( var% wetfac_cs ) + DEALLOCATE( var% fevw ) + DEALLOCATE( var% fhvw ) + DEALLOCATE( var% fes ) + DEALLOCATE( var% fes_cor ) + DEALLOCATE( var% gswx ) + DEALLOCATE( var% oldcansto ) + DEALLOCATE( var% zetar ) + DEALLOCATE( var% zetash ) + DEALLOCATE ( var % fwsoil ) + DEALLOCATE ( var % ofes ) + DEALLOCATE( var% sublayer_dz ) + DEALLOCATE (var % kthLitt) + DEALLOCATE (var % DvLitt) + !DEALLOCATE( var% fescor_upp ) !SSEB variable + !DEALLOCATE( var% fescor_low ) !SSEB variable + +END SUBROUTINE dealloc_canopy_type + +SUBROUTINE assoc_canopy_type(canopy, canopy_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(canopy_type), INTENT(IN OUT) :: canopy +TYPE(canopy_data_type), INTENT(IN OUT), TARGET :: canopy_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' + +!End of header + +CALL nullify_canopy_cbl(canopy) + +canopy% cansto => canopy_data% cansto +canopy% cduv => canopy_data% cduv +canopy% delwc => canopy_data% delwc +canopy% dewmm => canopy_data% dewmm +canopy% fe => canopy_data% fe +canopy% fh => canopy_data% fh +canopy% fpn => canopy_data% fpn +canopy% frp => canopy_data% frp +canopy% frpw => canopy_data% frpw +canopy% frpr => canopy_data% frpr +canopy% frs => canopy_data% frs +canopy% fnee => canopy_data% fnee +canopy% frday => canopy_data% frday +canopy% fnv => canopy_data% fnv +canopy% fev => canopy_data% fev +canopy% epot => canopy_data% epot +canopy% fnpp => canopy_data% fnpp +canopy% fevw_pot => canopy_data% fevw_pot +canopy% gswx_T => canopy_data% gswx_T +canopy% cdtq => canopy_data% cdtq +canopy% wetfac_cs => canopy_data% wetfac_cs +canopy% fevw => canopy_data% fevw +canopy% fhvw => canopy_data% fhvw +canopy% oldcansto => canopy_data% oldcansto +canopy% fhv => canopy_data% fhv +canopy% fns => canopy_data% fns +canopy% fhs => canopy_data% fhs +canopy% fhs_cor => canopy_data% fhs_cor +canopy% ga => canopy_data% ga +canopy% ghflux => canopy_data% ghflux +canopy% precis => canopy_data% precis +canopy% qscrn => canopy_data% qscrn +canopy% rnet => canopy_data% rnet +canopy% rniso => canopy_data% rniso +canopy% segg => canopy_data% segg +canopy% sghflux => canopy_data% sghflux +canopy% through => canopy_data% through +canopy% through_sn => canopy_data% through_sn +canopy% spill => canopy_data% spill +canopy% tscrn => canopy_data% tscrn +canopy% wcint => canopy_data% wcint +canopy% tv => canopy_data% tv +canopy% us => canopy_data% us +canopy% uscrn => canopy_data% uscrn +canopy% vlaiw => canopy_data% vlaiw +canopy% rghlai => canopy_data% rghlai +canopy% fwet => canopy_data% fwet +canopy% fns_cor => canopy_data% fns_cor +canopy% ga_cor => canopy_data% ga_cor +canopy% evapfbl => canopy_data% evapfbl +canopy% gswx => canopy_data% gswx +canopy% zetar => canopy_data% zetar +canopy% zetash => canopy_data% zetash +canopy% fess => canopy_data% fess +canopy% fesp => canopy_data% fesp +canopy% dgdtg => canopy_data% dgdtg +canopy% fes => canopy_data% fes +canopy% fes_cor => canopy_data% fes_cor +canopy% fevc => canopy_data% fevc +canopy% ofes => canopy_data% ofes +canopy% sublayer_dz => canopy_data% sublayer_dz +canopy% gw => canopy_data% gw +canopy% ancj => canopy_data% ancj +canopy% tlfy => canopy_data% tlfy +canopy% ecy => canopy_data% ecy +canopy% ecx => canopy_data% ecx +canopy% ci => canopy_data% ci +canopy% fwsoil => canopy_data% fwsoil +canopy% kthLitt => canopy_data% kthLitt +canopy% DvLitt => canopy_data% DvLitt + +RETURN +END SUBROUTINE assoc_canopy_type + +!=============================================================================== +SUBROUTINE nullify_canopy_cbl( var ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(canopy_type), INTENT(IN OUT) :: var + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_WORK_VARS_CBL' + +!End of header + + NULLIFY( var % fess ) + NULLIFY( var % fesp ) + NULLIFY( var% cansto ) + NULLIFY( var% cduv ) + NULLIFY( var% delwc ) + NULLIFY( var% dewmm ) + NULLIFY( var% dgdtg ) + NULLIFY( var% fe ) + NULLIFY( var% fh ) + NULLIFY( var% fpn ) + NULLIFY( var% frp ) + NULLIFY( var% frpw ) + NULLIFY( var% frpr ) + NULLIFY( var% frs ) + NULLIFY( var% fnee ) + NULLIFY( var% frday ) + NULLIFY( var% fnv ) + NULLIFY( var% fev ) + NULLIFY( var% fevc ) + NULLIFY( var% fhv ) + NULLIFY( var% fns ) + NULLIFY( var% fhs ) + NULLIFY( var% fhs_cor ) + NULLIFY( var% ga ) + NULLIFY( var% ghflux ) + NULLIFY( var% precis ) + NULLIFY( var% qscrn ) + NULLIFY( var% rnet ) + NULLIFY( var% rniso ) + NULLIFY( var% segg ) + NULLIFY( var% sghflux ) + NULLIFY( var% through ) + NULLIFY( var% through_sn ) + NULLIFY( var% spill ) + NULLIFY( var% tscrn ) + NULLIFY( var% wcint ) + NULLIFY( var% tv ) + NULLIFY( var% us ) + NULLIFY( var% uscrn ) + NULLIFY( var% rghlai ) + NULLIFY( var% vlaiw ) + NULLIFY( var% fwet ) + NULLIFY( var% fns_cor ) !REV_CORR variable + NULLIFY( var% ga_cor ) !REV_CORR variable + NULLIFY( var % evapfbl ) + NULLIFY( var% epot ) + NULLIFY( var% fnpp ) + NULLIFY( var% fevw_pot ) + NULLIFY( var% gswx_T ) + NULLIFY( var% cdtq ) + NULLIFY( var% wetfac_cs ) + NULLIFY( var% fevw ) + NULLIFY( var% fhvw ) + NULLIFY( var% fes ) + NULLIFY( var% fes_cor ) + NULLIFY( var% gswx ) + NULLIFY( var% oldcansto ) + NULLIFY( var% zetar ) + NULLIFY( var% zetash ) + NULLIFY( var % fwsoil ) + NULLIFY( var % ofes ) + NULLIFY( var% sublayer_dz ) + NULLIFY( var % kthLitt)! liiter resistances to heat and vapour transfer + NULLIFY( var % DvLitt) + !DEALLOCATE( var% fescor_upp ) !SSEB variable + !DEALLOCATE( var% fescor_low ) !SSEB variable + +RETURN + +END SUBROUTINE nullify_canopy_cbl + +END MODULE cable_canopy_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/cbl_cbm_mod.F90 b/src/coupled/AM3/control/cable/CM3/cbl_cbm_mod.F90 new file mode 100644 index 000000000..26de76a76 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/cbl_cbm_mod.F90 @@ -0,0 +1,403 @@ +MODULE cable_cbm_module + + IMPLICIT NONE + + PRIVATE + PUBLIC cbm_expl, cbm_impl + +CONTAINS + +SUBROUTINE cbm_expl( mp, nrb, ktau,dels, air, bgc, canopy, met, & + bal, rad, rough, soil, ssnow, sum_flux, veg, climate ) +!subrs: +USE cbl_albedo_mod, ONLY: albedo +USE cbl_init_radiation_module, ONLY: init_radiation +USE cbl_masks_mod, ONLY: fveg_mask, fsunlit_mask, fsunlit_veg_mask +USE snow_aging_mod, ONLY: snow_aging +USE cable_roughness_module, ONLY: ruff_resist +USE cable_air_module, ONLY: define_air +USE cable_canopy_module, ONLY: define_canopy + +USE cable_common_module +USE cable_carbon_module + +USE cable_def_types_mod, ONLY: met_type, radiation_type, veg_parameter_type, & + soil_parameter_type, roughness_type, & + canopy_type, soil_snow_type, balances_type, & + air_type, bgc_pool_type, sum_flux_type, & + climate_type + +! data: scalars +USE cable_other_constants_mod, ONLY: Ccoszen_tols => coszen_tols +USE cable_other_constants_mod, ONLY: Crad_thresh => rad_thresh +USE cable_other_constants_mod, ONLY: clai_thresh => lai_thresh +USE cable_other_constants_mod, ONLY: cgauss_w => gauss_w +USE cable_math_constants_mod, ONLY: cpi => pi +USE cable_math_constants_mod, ONLY: cpi180 => pi180 +USE cable_phys_constants_mod, ONLY: tfrz +USE cable_phys_constants_mod, ONLY: cEMLEAF=> EMLEAF +USE cable_phys_constants_mod, ONLY: cEMSOIL=> EMSOIL +USE cable_phys_constants_mod, ONLY: cSBOLTZ=> SBOLTZ +USE grid_constants_mod_cbl, ONLY: ICE_SoilType, nsl, nsnl +USE cable_surface_types_mod, ONLY: ICE_SurfaceType => ICE_cable, lakes_cable + +IMPLICIT NONE + +! CABLE model variables +TYPE (air_type), INTENT(INOUT) :: air +TYPE (bgc_pool_type), INTENT(INOUT) :: bgc +TYPE (canopy_type), INTENT(INOUT) :: canopy +TYPE (met_type), INTENT(INOUT) :: met +TYPE (balances_type), INTENT(INOUT) :: bal +TYPE (radiation_type), INTENT(INOUT) :: rad +TYPE (roughness_type), INTENT(INOUT) :: rough +TYPE (soil_snow_type), INTENT(INOUT) :: ssnow +TYPE (sum_flux_type), INTENT(INOUT) :: sum_flux +TYPE (soil_parameter_type), INTENT(INOUT) :: soil +TYPE (veg_parameter_type), INTENT(INOUT) :: veg +TYPE (climate_type) :: climate + +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nrb +REAL, INTENT(IN) :: dels ! time setp size (s) +INTEGER, INTENT(IN) :: ktau +INTEGER :: k,kk,j + +! local vars +LOGICAL :: veg_mask(mp), sunlit_mask(mp), sunlit_veg_mask(mp) +LOGICAL :: cbl_standalone = .FALSE. +LOGICAL :: jls_standalone = .FALSE. +LOGICAL :: jls_radiation = .FALSE. + +!co-efficients usoughout init_radiation ` called from _albedo as well +REAL :: c1(mp,nrb) +REAL :: rhoch(mp,nrb) +REAL :: xk(mp,nrb) +REAL :: veg_wt(mp) +REAL :: veg_trad(mp) +REAL :: soil_wt(mp) +REAL :: soil_trad(mp) +REAL :: trad_corr(mp) + +CHARACTER(LEN=8), PARAMETER :: subr_name = "ExpCbmT_" + +!explicit ONLY +CALL ruff_resist( veg, rough, ssnow, canopy, veg%vlai, veg%hc, canopy%vlaiw ) + +! Height adjustment not used in ACCESS CM2. See CABLE ticket 197 +! met%tk = met%tk + C%grav/C%capp*(rough%zref_tq + 0.9*rough%z0m) +CALL define_air (met, air) + +call fveg_mask( veg_mask, mp, Clai_thresh, canopy%vlaiw ) +call fsunlit_mask( sunlit_mask, mp, CRAD_THRESH,( met%fsd(:,1)+met%fsd(:,2) ) ) +call fsunlit_veg_mask( sunlit_veg_mask, veg_mask, sunlit_mask, mp ) + +CALL init_radiation( rad%extkb, rad%extkd, & + !ExtCoeff_beam, ExtCoeff_dif, + rad%extkbm, rad%extkdm, Rad%Fbeam, & + !EffExtCoeff_beam, EffExtCoeff_dif, RadFbeam, + c1, rhoch, xk, & + mp,nrb, & + Clai_thresh, Ccoszen_tols, CGauss_w, Cpi, Cpi180, & + cbl_standalone, jls_standalone, jls_radiation, & + subr_name, & + veg_mask, & + veg%Xfang, veg%taul, veg%refl, & + !VegXfang, VegTaul, VegRefl + met%coszen, int(met%DoY), met%fsd, & + !coszen, metDoY, SW_down, + canopy%vlaiw & + ) !reducedLAIdue2snow + +!Ticket 331 refactored albedo code for JAC +CALL snow_aging(ssnow%snage,mp,dels,ssnow%snowd,ssnow%osnowd,ssnow%tggsn(:,1), & + ssnow%tgg(:,1),ssnow%isflag,veg%iveg,soil%isoilm) + +!explicit ONLY +CALL Albedo( ssnow%AlbSoilsn, soil%AlbSoil, & + !AlbSnow, AlbSoil, + mp, nrb, & + ICE_SoilType, lakes_cable, & + jls_radiation, & + veg_mask, & + Ccoszen_tols, CGAUSS_W, & + veg%iveg, soil%isoilm, veg%refl, veg%taul, & + !surface_type, VegRefl, VegTaul, + met%coszen, canopy%vlaiw, & + !coszen, reducedLAIdue2snow, + ssnow%snowd, ssnow%ssdnn, ssnow%tgg(:,1), ssnow%snage, & + !SnowDepth, SnowDensity, SoilTemp, SnowAge, + xk, c1, rhoch, & + rad%fbeam, rad%albedo, & + !RadFbeam, RadAlbedo, + rad%extkb, rad%extkd, & + !ExtCoeff_beam, ExtCoeff_dif, + rad%extkbm, rad%extkdm, & + !EffExtCoeff_beam, EffExtCoeff_dif, + rad%rhocbm, rad%rhocdf, & + !CanopyRefl_beam,CanopyRefl_dif, + rad%cexpkbm, rad%cexpkdm, & + !CanopyTransmit_beam, CanopyTransmit_dif, + rad%reffbm, rad%reffdf & + ) !EffSurfRefl_beam, EffSurfRefldif_ + +! on 1st call tss, wetfac initialized in _um_init_soilsnow +! on subsequent calls it has the value as updated in soilsnow +ssnow%otss = ssnow%tss + +! on subsequent calls it has the value as updated in CALL from surfwetness +ssnow%owetfac = ssnow%wetfac + +CALL define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,climate, sunlit_veg_mask, canopy%vlaiw) + +! reset tss, wetfac, cansto to value corresponding to beginning of timestep +ssnow%tss = ssnow%otss +ssnow%wetfac = ssnow%owetfac +canopy%cansto = canopy%oldcansto + +! need to adjust fe after soilsnow +canopy%fev = canopy%fevc + canopy%fevw + +! Calculate total latent heat flux: +canopy%fe = canopy%fev + canopy%fes + +! Calculate net radiation absorbed by soil + veg +canopy%rnet = canopy%fns + canopy%fnv + +! Calculate radiative/skin temperature: +!Jan 2018: UM assumes a single emissivity for the surface in the radiation scheme +!To accommodate this a single value of is 1. is assumed in ACCESS +! any leaf/soil emissivity /=1 must be incorporated into rad%trad. +! check that emissivities (pft and nvg) set = 1 within the UM i/o configuration +! CM2 - further adapted to pass the correction term onto %trad correctly +!rad%trad = ( ( 1.-rad%transd ) * Cemleaf * canopy%tv**4 + & +! rad%transd * Cemsoil * ssnow%otss**4 + canopy%fns_cor/CSBOLTZ )**0.25 + +veg_wt = 1.0 - rad%transd +veg_trad = Cemleaf * canopy%tv**4 +soil_wt = rad%transd +soil_trad = Cemsoil * ssnow%otss**4 +trad_corr = canopy%fns_cor/CSBOLTZ + +rad%trad = ( veg_wt * veg_trad ) + ( soil_wt * soil_trad ) + trad_corr +rad%trad = rad%trad**0.25 + +RETURN +END SUBROUTINE cbm_expl + +SUBROUTINE cbm_impl( cycleno, numcycles, mp, nrb, ktau, dels, & + air, bgc, canopy, met, bal, rad, rough, & + soil, ssnow, sum_flux, veg, climate ) + +USE cable_common_module +USE cable_carbon_module + +USE cable_def_types_mod, ONLY : met_type, radiation_type, veg_parameter_type, & + soil_parameter_type, roughness_type, & + canopy_type, soil_snow_type, balances_type, & + air_type, bgc_pool_type, sum_flux_type + +USE cable_def_types_mod, only : climate_type + +USE casadimension, only : icycle ! used in casa_cnp +USE cable_roughness_module, only : ruff_resist +USE cable_air_module, only : define_air +USE cable_canopy_module, only : define_canopy + +!subrs: +USE cbl_albedo_mod, ONLY: albedo +USE cbl_init_radiation_module, ONLY: init_radiation +USE cbl_soil_snow_main_module, ONLY : soil_snow +USE cbl_masks_mod, ONLY: fveg_mask, fsunlit_mask, fsunlit_veg_mask +USE snow_aging_mod, ONLY : snow_aging + +!jhan:pass these !data +USE cable_other_constants_mod, ONLY: Ccoszen_tols => coszen_tols +USE cable_other_constants_mod, ONLY: Crad_thresh => rad_thresh +USE cable_other_constants_mod, ONLY: clai_thresh => lai_thresh +USE cable_other_constants_mod, ONLY: cgauss_w => gauss_w +USE cable_math_constants_mod, ONLY: cpi => pi +USE cable_math_constants_mod, ONLY: cpi180 => pi180 +USE cable_phys_constants_mod, ONLY: cEMLEAF=> EMLEAF +USE cable_phys_constants_mod, ONLY: cEMSOIL=> EMSOIL +USE cable_phys_constants_mod, ONLY: cSBOLTZ=> SBOLTZ +USE grid_constants_mod_cbl, ONLY: ICE_SoilType +USE cable_surface_types_mod, ONLY: ICE_SurfaceType => ICE_cable, lakes_cable + +IMPLICIT NONE + +!ptrs to local constants +! CABLE model variables +TYPE (air_type), INTENT(INOUT) :: air +TYPE (bgc_pool_type), INTENT(INOUT) :: bgc +TYPE (canopy_type), INTENT(INOUT) :: canopy +TYPE (met_type), INTENT(INOUT) :: met +TYPE (balances_type), INTENT(INOUT) :: bal +TYPE (radiation_type), INTENT(INOUT) :: rad +TYPE (roughness_type), INTENT(INOUT) :: rough +TYPE (soil_snow_type), INTENT(INOUT) :: ssnow +TYPE (sum_flux_type), INTENT(INOUT) :: sum_flux +TYPE (soil_parameter_type), INTENT(INOUT) :: soil +TYPE (veg_parameter_type), INTENT(INOUT) :: veg +TYPE (climate_type) :: climate + +INTEGER, INTENT(IN) :: cycleno ! # cycle in UM implicit dynamics +INTEGER, INTENT(IN) :: numcycles ! total # cycles in implicit dynamics +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nrb +REAL, INTENT(IN) :: dels ! time setp size (s) +INTEGER, INTENT(IN) :: ktau +INTEGER :: k,kk,j + +LOGICAL :: veg_mask(mp), sunlit_mask(mp), sunlit_veg_mask(mp) + +LOGICAL :: cbl_standalone = .FALSE. +LOGICAL :: jls_standalone = .FALSE. +LOGICAL :: jls_radiation = .FALSE. + +!co-efficients used in init_radiation and albedo +REAL :: c1(mp,nrb) +REAL :: rhoch(mp,nrb) +REAL :: xk(mp,nrb) + +REAL :: veg_wt(mp) +REAL :: veg_trad(mp) +REAL :: soil_wt(mp) +REAL :: soil_trad(mp) +REAL :: trad_corr(mp) + +CHARACTER(LEN=8), PARAMETER :: subr_name = "cbm_impl" + +CALL define_air (met, air) + +call fveg_mask( veg_mask, mp, Clai_thresh, canopy%vlaiw ) +call fsunlit_mask( sunlit_mask, mp, CRAD_THRESH,( met%fsd(:,1)+met%fsd(:,2) ) ) +call fsunlit_veg_mask( sunlit_veg_mask, veg_mask, sunlit_mask, mp ) + +CALL init_radiation( rad%extkb, rad%extkd, & + !ExtCoeff_beam, ExtCoeff_dif, + rad%extkbm, rad%extkdm, Rad%Fbeam, & + !EffExtCoeff_beam, EffExtCoeff_dif, RadFbeam, + c1, rhoch, xk, & + mp,nrb, & + Clai_thresh, Ccoszen_tols, CGauss_w, Cpi, Cpi180, & + cbl_standalone, jls_standalone, jls_radiation, & + subr_name, & + veg_mask, & + veg%Xfang, veg%taul, veg%refl, & + !VegXfang, VegTaul, VegRefl + met%coszen, int(met%DoY), met%fsd, & + !coszen, metDoY, SW_down, + canopy%vlaiw & + ) !reducedLAIdue2snow + +! on 1st call tss, wetfac initialized in _um_init_soilsnow +! on subsequent calls it has the value as updated in soilsnow +ssnow%otss = ssnow%tss + +! on subsequent calls it has the value as updated in CALL from surfwetness +ssnow%owetfac = ssnow%wetfac + +CALL define_canopy(bal,rad,rough,air,met,dels,ssnow,soil,veg, canopy,climate, sunlit_veg_mask, canopy%vlaiw) + +CALL soil_snow(dels, soil, ssnow, canopy, met, bal,veg) +ssnow%deltss = ssnow%tss-ssnow%otss + +! reset tss & wetfac to value corresponding to beginning of timestep +IF( cycleno .NE. numcycles ) THEN + ssnow%tss = ssnow%otss + ssnow%wetfac = ssnow%owetfac + canopy%cansto = canopy%oldcansto +ENDIF + +! correction required for energy balance in online simulations +! REV_CORR - multiple changes to address %cls bugs and revised correction +! terms. Also - do not apply correction terms if using SLI +! SSEB package will move these calculations to within soilsnow +IF( cable_user%SOIL_STRUC=='default') THEN + + canopy%fhs = canopy%fhs + ( ssnow%tss-ssnow%otss ) * ssnow%dfh_dtg + canopy%fhs_cor = canopy%fhs_cor + ( ssnow%tss-ssnow%otss ) * ssnow%dfh_dtg + canopy%fh = canopy%fhv + canopy%fhs + + !canopy%fes = canopy%fes + ( ssnow%tss-ssnow%otss ) * & + ! ( ssnow%dfe_ddq * ssnow%ddq_dtg ) + ! !( ssnow%cls * ssnow%dfe_ddq * ssnow%ddq_dtg ) + ! + !Ticket 137 - remove double couting of %cls + !canopy%fes_cor = canopy%fes_cor + ( ssnow%tss-ssnow%otss ) * & + ! ( ssnow%dfe_ddq * ssnow%ddq_dtg ) + ! ( ssnow%cls * ssnow%dfe_ddq * ssnow%ddq_dtg ) + + !INH rewritten in terms of %dfe_dtg - NB factor %cls above was a bug + canopy%fes = canopy%fes + ( ssnow%tss-ssnow%otss ) * ssnow%dfe_dtg + + !INH NB factor %cls in %fes_cor above was a bug - see Ticket #135 #137 + canopy%fes_cor = canopy%fes_cor + (ssnow%tss-ssnow%otss) * ssnow%dfe_dtg + !canopy%fes_cor = canopy%fes_cor + ssnow%cls*(ssnow%tss-ssnow%otss) & + ! * ssnow%dfe_dtg + + IF (cable_user%L_REV_CORR) THEN + !INH need to add on corrections to all terms in the soil energy balance + canopy%fns_cor = canopy%fns_cor + (ssnow%tss-ssnow%otss)*ssnow%dfn_dtg + + !NB %fns_cor also added onto out%Rnet and out%LWnet in cable_output and + !cable_checks as the correction term needs to pass through the + !canopy in entirity not be partially absorbed and %fns not used there + !(as would be the case if rad%flws were changed) + canopy%fns = canopy%fns + ( ssnow%tss-ssnow%otss )*ssnow%dfn_dtg + + canopy%ga_cor = canopy%ga_cor + ( ssnow%tss-ssnow%otss )*canopy%dgdtg + canopy%ga = canopy%ga + ( ssnow%tss-ssnow%otss )*canopy%dgdtg + + !assign all the correction to %fes to %fess - none to %fesp + canopy%fess = canopy%fess + ( ssnow%tss-ssnow%otss ) * ssnow%dfe_dtg + + ENDIF +ENDIF +! need to adjust fe after soilsnow +canopy%fev = canopy%fevc + canopy%fevw + +! Calculate total latent heat flux: +canopy%fe = canopy%fev + canopy%fes + +! Calculate net radiation absorbed by soil + veg +canopy%rnet = canopy%fns + canopy%fnv + +! Calculate radiative/skin temperature: +!Jan 2018: UM assumes a single emissivity for the surface in the radiation scheme +!To accommodate this a single value of is 1. is assumed in ACCESS +! any leaf/soil emissivity /=1 must be incorporated into rad%trad. +! check that emissivities (pft and nvg) set = 1 within the UM i/o configuration +! CM2 - further adapted to pass the correction term onto %trad correctly + +veg_wt = 1.0 - rad%transd +veg_trad = Cemleaf * canopy%tv**4 +soil_wt = rad%transd +soil_trad = Cemsoil * ssnow%otss**4 +trad_corr = canopy%fns_cor/CSBOLTZ + +rad%trad = ( veg_wt * veg_trad ) + ( soil_wt * soil_trad ) + trad_corr +rad%trad = rad%trad**0.25 + +! In physical model only (i.e. without CASA-CNP) +! calculate canopy%frp +CALL plantcarb(veg,bgc,met,canopy) + +!calculate canopy%frs +CALL soilcarb(soil, ssnow, veg, bgc, met, canopy) + +CALL carbon_pl(dels, soil, ssnow, veg, canopy, bgc) + +canopy%fnpp = -1.0* canopy%fpn - canopy%frp +canopy%fnee = canopy%fpn + canopy%frs + canopy%frp + +RETURN +END SUBROUTINE cbm_impl + + + + +END MODULE cable_cbm_module + + diff --git a/src/coupled/AM3/control/cable/CM3/climate_type.F90 b/src/coupled/AM3/control/cable/CM3/climate_type.F90 new file mode 100644 index 000000000..5431b2170 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/climate_type.F90 @@ -0,0 +1,306 @@ +MODULE cable_climate_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: climate_type +PUBLIC :: climate_data_type +PUBLIC :: alloc_climate_type +PUBLIC :: dealloc_climate_type +PUBLIC :: assoc_climate_type +PUBLIC :: nullify_climate_cbl + +! Climate data: +TYPE climate_data_type + + INTEGER :: nyear_average = 20 + INTEGER :: nday_average = 31 + INTEGER :: nyears ! number of years in climate record + INTEGER :: doy ! day of year + + INTEGER, ALLOCATABLE :: chilldays (:) ! length of chilling period (period with T<5deg) + INTEGER, ALLOCATABLE :: iveg (:) ! potential vegetation type based on climatic constraints + INTEGER, ALLOCATABLE :: biome (:) + + REAL, ALLOCATABLE :: dtemp (:) ! daily temperature + REAL, ALLOCATABLE :: dmoist (:) ! daily moisture availability + REAL, ALLOCATABLE :: mtemp (:) ! mean temperature over the last 31 days + REAL, ALLOCATABLE :: qtemp (:) ! mean temperature over the last 91 days + REAL, ALLOCATABLE :: mmoist (:) ! monthly moisture availability + REAL, ALLOCATABLE :: mtemp_min (:) ! minimum monthly temperature + REAL, ALLOCATABLE :: mtemp_max (:) ! maximum monhtly temperature + REAL, ALLOCATABLE :: qtemp_max (:) ! mean temperature of the warmest quarter (so far this year) + REAL, ALLOCATABLE :: mtemp_min20 (:) ! minimum monthly temperature, averaged over 20 y + REAL, ALLOCATABLE :: mtemp_max20 (:) ! maximum monhtly temperature, averaged over 20 y + REAL, ALLOCATABLE :: atemp_mean (:) ! annual average temperature + REAL, ALLOCATABLE :: AGDD5 (:) + REAL, ALLOCATABLE :: GDD5 (:) ! growing degree day sum relative to 5deg base temperature + REAL, ALLOCATABLE :: AGDD0 (:) + REAL, ALLOCATABLE :: GDD0 (:) ! growing degree day sum relative to 0deg base temperature + REAL, ALLOCATABLE :: alpha_PT (:) ! ratio of annual evap to annual PT evap + REAL, ALLOCATABLE :: evap_PT (:) ! annual PT evap [mm] + REAL, ALLOCATABLE :: aevap (:) ! annual evap [mm] + REAL, ALLOCATABLE :: alpha_PT20 (:) + REAL, ALLOCATABLE :: qtemp_max_last_year (:) ! mean temperature of the warmest quarter (last calendar year) + + REAL, ALLOCATABLE :: mtemp_min_20 (:,:) ! mimimum monthly temperatures for the last 20 y + REAL, ALLOCATABLE :: mtemp_max_20 (:,:) ! maximum monthly temperatures for the last 20 y + REAL, ALLOCATABLE :: dtemp_31 (:,:) ! daily temperature for the last 31 days + REAL, ALLOCATABLE :: dmoist_31 (:,:) ! daily moisture availability for the last 31 days + REAL, ALLOCATABLE :: alpha_PT_20 (:,:) ! priestley Taylor Coefft for last 20 y + REAL, ALLOCATABLE :: dtemp_91 (:,:) ! daily temperature for the last 91 days + +END TYPE climate_data_type + +TYPE climate_type + + INTEGER, POINTER :: nyear_average + INTEGER, POINTER :: nday_average + INTEGER, POINTER :: nyears ! number of years in climate record + INTEGER, POINTER :: doy ! day of year + + INTEGER, POINTER :: chilldays (:) ! length of chilling period (period with T<5deg) + INTEGER, POINTER :: iveg (:) ! potential vegetation type based on climatic constraints + INTEGER, POINTER :: biome (:) + + REAL, POINTER :: dtemp (:) ! daily temperature + REAL, POINTER :: dmoist (:) ! daily moisture availability + REAL, POINTER :: mtemp (:) ! mean temperature over the last 31 days + REAL, POINTER :: qtemp (:) ! mean temperature over the last 91 days + REAL, POINTER :: mmoist (:) ! monthly moisture availability + REAL, POINTER :: mtemp_min (:) ! minimum monthly temperature + REAL, POINTER :: mtemp_max (:) ! maximum monhtly temperature + REAL, POINTER :: qtemp_max (:) ! mean temperature of the warmest quarter (so far this year) + REAL, POINTER :: mtemp_min20 (:) ! minimum monthly temperature, averaged over 20 y + REAL, POINTER :: mtemp_max20 (:) ! maximum monhtly temperature, averaged over 20 y + REAL, POINTER :: atemp_mean (:) ! annual average temperature + REAL, POINTER :: AGDD5 (:) + REAL, POINTER :: GDD5 (:) ! growing degree day sum relative to 5deg base temperature + REAL, POINTER :: AGDD0 (:) + REAL, POINTER :: GDD0 (:) ! growing degree day sum relative to 0deg base temperature + REAL, POINTER :: alpha_PT (:) ! ratio of annual evap to annual PT evap + REAL, POINTER :: evap_PT (:) ! annual PT evap [mm] + REAL, POINTER :: aevap (:) ! annual evap [mm] + REAL, POINTER :: alpha_PT20 (:) + REAL, POINTER :: qtemp_max_last_year (:) ! mean temperature of the warmest quarter (last calendar year) + + REAL, POINTER :: mtemp_min_20 (:,:) ! mimimum monthly temperatures for the last 20 y + REAL, POINTER :: mtemp_max_20 (:,:) ! maximum monthly temperatures for the last 20 y + REAL, POINTER :: dtemp_31 (:,:) ! daily temperature for the last 31 days + REAL, POINTER :: dmoist_31 (:,:) ! daily moisture availability for the last 31 days + REAL, POINTER :: alpha_PT_20 (:,:) ! priestley Taylor Coefft for last 20 y + REAL, POINTER :: dtemp_91 (:,:) ! daily temperature for the last 91 days + +END TYPE climate_type + +CONTAINS + +SUBROUTINE alloc_climate_type(climate, mp) + +USE grid_constants_mod_cbl, ONLY: mf ! # leaves (sunlit/shaded) +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: niter ! number of iterations for za/L + +IMPLICIT NONE + +TYPE(climate_data_type), INTENT(INOUT) :: climate +INTEGER, INTENT(IN) :: mp + +ALLOCATE( climate% chilldays (1) ) +ALLOCATE( climate% iveg (1) ) +ALLOCATE( climate% biome (1) ) +ALLOCATE( climate% dtemp (1) ) +ALLOCATE( climate% dmoist (1) ) +ALLOCATE( climate% mtemp (1) ) +ALLOCATE( climate% qtemp (1) ) +ALLOCATE( climate% mmoist (1) ) +ALLOCATE( climate% mtemp_min (1) ) +ALLOCATE( climate% mtemp_max (1) ) +ALLOCATE( climate% qtemp_max (1) ) +ALLOCATE( climate% mtemp_min20 (1) ) +ALLOCATE( climate% mtemp_max20 (1) ) +ALLOCATE( climate% atemp_mean (1) ) +ALLOCATE( climate% AGDD5 (1) ) +ALLOCATE( climate% GDD5 (1) ) +ALLOCATE( climate% AGDD0 (1) ) +ALLOCATE( climate% GDD0 (1) ) +ALLOCATE( climate% alpha_PT (1) ) +ALLOCATE( climate% evap_PT (1) ) +ALLOCATE( climate% aevap (1) ) +ALLOCATE( climate% alpha_PT20 (1) ) +ALLOCATE( climate% qtemp_max_last_year (1) ) +ALLOCATE( climate% mtemp_min_20 (1,1) ) +ALLOCATE( climate% mtemp_max_20 (1,1) ) +ALLOCATE( climate% dtemp_31 (1,1) ) +ALLOCATE( climate% dmoist_31 (1,1) ) +ALLOCATE( climate% alpha_PT_20 (1,1) ) +ALLOCATE( climate% dtemp_91 (1,1) ) + +climate% chilldays (:) = 0.0 +climate% iveg (:) = 0.0 +climate% biome (:) = 0.0 +climate% dtemp (:) = 0.0 +climate% dmoist (:) = 0.0 +climate% mtemp (:) = 0.0 +climate% qtemp (:) = 0.0 +climate% mmoist (:) = 0.0 +climate% mtemp_min (:) = 0.0 +climate% mtemp_max (:) = 0.0 +climate% qtemp_max (:) = 0.0 +climate% mtemp_min20 (:) = 0.0 +climate% mtemp_max20 (:) = 0.0 +climate% atemp_mean (:) = 0.0 +climate% AGDD5 (:) = 0.0 +climate% GDD5 (:) = 0.0 +climate% AGDD0 (:) = 0.0 +climate% GDD0 (:) = 0.0 +climate% alpha_PT (:) = 0.0 +climate% evap_PT (:) = 0.0 +climate% aevap (:) = 0.0 +climate% alpha_PT20 (:) = 0.0 +climate% qtemp_max_last_year (:) = 0.0 +climate% mtemp_min_20 (:,:) = 0.0 +climate% mtemp_max_20 (:,:) = 0.0 +climate% dtemp_31 (:,:) = 0.0 +climate% dmoist_31 (:,:) = 0.0 +climate% alpha_PT_20 (:,:) = 0.0 +climate% dtemp_91 (:,:) = 0.0 + +RETURN +END SUBROUTINE alloc_climate_type + +SUBROUTINE dealloc_climate_type(climate) + +TYPE(climate_type), INTENT(inout) :: climate + +DEALLOCATE ( climate% chilldays ) +DEALLOCATE ( climate% iveg ) +DEALLOCATE ( climate% biome ) +DEALLOCATE ( climate% dtemp ) +DEALLOCATE ( climate% dmoist ) +DEALLOCATE ( climate% mtemp ) +DEALLOCATE ( climate% qtemp ) +DEALLOCATE ( climate% mmoist ) +DEALLOCATE ( climate% mtemp_min ) +DEALLOCATE ( climate% mtemp_max ) +DEALLOCATE ( climate% qtemp_max ) +DEALLOCATE ( climate% mtemp_min20 ) +DEALLOCATE ( climate% mtemp_max20 ) +DEALLOCATE ( climate% atemp_mean ) +DEALLOCATE ( climate% AGDD5 ) +DEALLOCATE ( climate% GDD5 ) +DEALLOCATE ( climate% AGDD0 ) +DEALLOCATE ( climate% GDD0 ) +DEALLOCATE ( climate% alpha_PT ) +DEALLOCATE ( climate% evap_PT ) +DEALLOCATE ( climate% aevap ) +DEALLOCATE ( climate% alpha_PT20 ) +DEALLOCATE ( climate % qtemp_max_last_year ) +DEALLOCATE ( climate % mtemp_min_20 ) +DEALLOCATE ( climate % mtemp_max_20 ) +DEALLOCATE ( climate % dtemp_31 ) +DEALLOCATE ( climate % dmoist_31 ) +DEALLOCATE ( climate % alpha_PT_20 ) +DEALLOCATE ( climate % dtemp_91 ) + +RETURN +END SUBROUTINE dealloc_climate_type + +SUBROUTINE assoc_climate_type(climate, climate_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(climate_type), INTENT(IN OUT) :: climate +TYPE(climate_data_type), INTENT(IN OUT), TARGET :: climate_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_climate_cbl(climate) + +climate% chilldays => climate_data% chilldays +climate% iveg => climate_data% iveg +climate% biome => climate_data% biome +climate% dtemp => climate_data% dtemp +climate% dmoist => climate_data% dmoist +climate% mtemp => climate_data% mtemp +climate% qtemp => climate_data% qtemp +climate% mmoist => climate_data% mmoist +climate% mtemp_min => climate_data% mtemp_min +climate% mtemp_max => climate_data% mtemp_max +climate% qtemp_max => climate_data% qtemp_max +climate% mtemp_min20 => climate_data% mtemp_min20 +climate% mtemp_max20 => climate_data% mtemp_max20 +climate% atemp_mean => climate_data% atemp_mean +climate% AGDD5 => climate_data% AGDD5 +climate% GDD5 => climate_data% GDD5 +climate% AGDD0 => climate_data% AGDD0 +climate% GDD0 => climate_data% GDD0 +climate% alpha_PT => climate_data% alpha_PT +climate% evap_PT => climate_data% evap_PT +climate% aevap => climate_data% aevap +climate% alpha_PT20 => climate_data% alpha_PT20 +climate% qtemp_max_last_year => climate_data% qtemp_max_last_year +climate% mtemp_min_20 => climate_data% mtemp_min_20 +climate% mtemp_max_20 => climate_data% mtemp_max_20 +climate% dtemp_31 => climate_data% dtemp_31 +climate% dmoist_31 => climate_data% dmoist_31 +climate% alpha_PT_20 => climate_data% alpha_PT_20 +climate% dtemp_91 => climate_data% dtemp_91 + +RETURN +END SUBROUTINE assoc_climate_type + +SUBROUTINE nullify_climate_cbl( climate ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(climate_type), INTENT(IN OUT) :: climate + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( climate% chilldays ) +NULLIFY( climate% iveg ) +NULLIFY( climate% biome ) +NULLIFY( climate% dtemp ) +NULLIFY( climate% dmoist ) +NULLIFY( climate% mtemp ) +NULLIFY( climate% qtemp ) +NULLIFY( climate% mmoist ) +NULLIFY( climate% mtemp_min ) +NULLIFY( climate% mtemp_max ) +NULLIFY( climate% qtemp_max ) +NULLIFY( climate% mtemp_min20 ) +NULLIFY( climate% mtemp_max20 ) +NULLIFY( climate% atemp_mean ) +NULLIFY( climate% AGDD5 ) +NULLIFY( climate% GDD5 ) +NULLIFY( climate% AGDD0 ) +NULLIFY( climate% GDD0 ) +NULLIFY( climate% alpha_PT ) +NULLIFY( climate% evap_PT ) +NULLIFY( climate% aevap ) +NULLIFY( climate% alpha_PT20 ) +NULLIFY( climate % qtemp_max_last_year ) +NULLIFY( climate % mtemp_min_20 ) +NULLIFY( climate % mtemp_max_20 ) +NULLIFY( climate % dtemp_31 ) +NULLIFY( climate % dmoist_31 ) +NULLIFY( climate % alpha_PT_20 ) +NULLIFY( climate % dtemp_91 ) + +RETURN + +END SUBROUTINE nullify_climate_cbl + +END MODULE cable_climate_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/met_type_cbl.F90 b/src/coupled/AM3/control/cable/CM3/met_type_cbl.F90 new file mode 100644 index 000000000..9e8414515 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/met_type_cbl.F90 @@ -0,0 +1,227 @@ +MODULE cable_met_type_mod + +IMPLICIT NONE + +PUBLIC :: met_type +PUBLIC :: met_data_type +PUBLIC :: alloc_met_type +PUBLIC :: dealloc_met_type +PUBLIC :: assoc_met_type +PUBLIC :: nullify_met_cbl + +! Meterological data: +TYPE met_data_type + + INTEGER, ALLOCATABLE :: year (:) ! local time year AD + INTEGER, ALLOCATABLE :: moy (:) ! local time month of year + REAL, ALLOCATABLE :: ca (:) ! CO2 concentration (mol/mol) + REAL, ALLOCATABLE :: doy (:) ! local time day of year = days since + REAL, ALLOCATABLE :: hod (:) ! local hour of day + REAL, ALLOCATABLE :: ofsd (:) ! downward SW radiation (W/m2) + REAL, ALLOCATABLE :: fld (:) ! downward LW radiation (W/m2) + REAL, ALLOCATABLE :: precip (:) ! rainfall (liquid+solid)(mm/dels) + REAL, ALLOCATABLE :: precip_sn (:) ! solid preipitation only (mm/dels) + REAL, ALLOCATABLE :: tk (:) ! surface air temperature (oK) + REAL, ALLOCATABLE :: tvair (:) ! within canopy air temperature (oK) + REAL, ALLOCATABLE :: tvrad (:) ! radiative veg. temperature (K) + REAL, ALLOCATABLE :: pmb (:) ! surface air pressure (mbar) + REAL, ALLOCATABLE :: ua (:) ! surface wind speed (m/s) + REAL, ALLOCATABLE :: qv (:) ! surface specific humidity (g/g) + REAL, ALLOCATABLE :: coszen (:) ! cos(zenith angle of sun) + REAL, ALLOCATABLE :: Ndep (:) ! nitrogen deposition (gN m-2 d-1) + REAL, ALLOCATABLE :: qvair (:) ! in canopy specific humidity (g/g) + REAL, ALLOCATABLE :: da (:) ! H2O vap pres deficit at ref height (Pa) + REAL, ALLOCATABLE :: dva (:) ! H2O vap pres deficit in canopy + REAL, ALLOCATABLE :: fsd (:,:) ! downward SW radiation (W/m2) + +END TYPE met_data_type + +TYPE met_type + + INTEGER, POINTER :: year (:) ! local time year AD + INTEGER, POINTER :: moy (:) ! local time month of year + REAL, POINTER :: ca (:) ! CO2 concentration (mol/mol) + REAL, POINTER :: doy (:) ! local time day of year = days since + REAL, POINTER :: hod (:) ! local hour of day + REAL, POINTER :: ofsd (:) ! downward SW radiation (W/m2) + REAL, POINTER :: fld (:) ! downward LW radiation (W/m2) + REAL, POINTER :: precip (:) ! rainfall (liquid+solid)(mm/dels) + REAL, POINTER :: precip_sn (:) ! solid preipitation only (mm/dels) + REAL, POINTER :: tk (:) ! surface air temperature (oK) + REAL, POINTER :: tvair (:) ! within canopy air temperature (oK) + REAL, POINTER :: tvrad (:) ! radiative veg. temperature (K) + REAL, POINTER :: pmb (:) ! surface air pressure (mbar) + REAL, POINTER :: ua (:) ! surface wind speed (m/s) + REAL, POINTER :: qv (:) ! surface specific humidity (g/g) + REAL, POINTER :: coszen (:) ! cos(zenith angle of sun) + REAL, POINTER :: Ndep (:) ! nitrogen deposition (gN m-2 d-1) + REAL, POINTER :: qvair (:) ! in canopy specific humidity (g/g) + REAL, POINTER :: da (:) ! H2O vap pres deficit at ref height (Pa) + REAL, POINTER :: dva (:) ! H2O vap pres deficit in canopy + REAL, POINTER :: fsd (:,:) ! downward SW radiation (W/m2) + +END TYPE met_type + +CONTAINS + +SUBROUTINE alloc_met_type(met, mp) +USE grid_constants_mod_cbl, ONLY: swb ! # SW bands +IMPLICIT NONE + +TYPE(met_data_type), INTENT(INOUT) :: met +INTEGER, INTENT(IN) :: mp + +ALLOCATE( met% year (mp) ) +ALLOCATE( met% moy (mp) ) +ALLOCATE( met% ca (mp) ) +ALLOCATE( met% doy (mp) ) +ALLOCATE( met% hod (mp) ) +ALLOCATE( met% ofsd (mp) ) +ALLOCATE( met% fld (mp) ) +ALLOCATE( met% precip (mp) ) +ALLOCATE( met% precip_sn (mp) ) +ALLOCATE( met% tk (mp) ) +ALLOCATE( met% tvair (mp) ) +ALLOCATE( met% tvrad (mp) ) +ALLOCATE( met% pmb (mp) ) +ALLOCATE( met% ua (mp) ) +ALLOCATE( met% qv (mp) ) +ALLOCATE( met% coszen (mp) ) +ALLOCATE( met% Ndep (mp) ) +ALLOCATE( met% qvair (mp) ) +ALLOCATE( met% da (mp) ) +ALLOCATE( met% dva (mp) ) +ALLOCATE( met% fsd (mp,swb) ) + +met % year (:) = 0.0 +met % moy (:) = 0.0 +met % ca (:) = 0.0 +met % doy (:) = 0.0 +met % hod (:) = 0.0 +met % ofsd (:) = 0.0 +met % fld (:) = 0.0 +met % precip (:) = 0.0 +met % precip_sn (:) = 0.0 +met % tk (:) = 0.0 +met % tvair (:) = 0.0 +met % tvrad (:) = 0.0 +met % pmb (:) = 0.0 +met % ua (:) = 0.0 +met % qv (:) = 0.0 +met % coszen (:) = 0.0 +met % Ndep (:) = 0.0 +met % qvair (:) = 0.0 +met % da (:) = 0.0 +met % dva (:) = 0.0 +met % fsd (:,:) = 0.0 + +RETURN +END SUBROUTINE alloc_met_type + +SUBROUTINE dealloc_met_type(met) +IMPLICIT NONE + +TYPE(met_type), INTENT(inout) :: met + +DEALLOCATE ( met % year ) +DEALLOCATE ( met % moy ) +DEALLOCATE ( met % ca ) +DEALLOCATE ( met % doy ) +DEALLOCATE ( met % hod ) +DEALLOCATE ( met % ofsd ) +DEALLOCATE ( met % fld ) +DEALLOCATE ( met % precip ) +DEALLOCATE ( met % precip_sn ) +DEALLOCATE ( met % tk ) +DEALLOCATE ( met % tvair ) +DEALLOCATE ( met % tvrad ) +DEALLOCATE ( met % pmb ) +DEALLOCATE ( met % ua ) +DEALLOCATE ( met % qv ) +DEALLOCATE ( met % coszen ) +DEALLOCATE ( met % Ndep ) +DEALLOCATE ( met % qvair ) +DEALLOCATE ( met % da ) +DEALLOCATE ( met % dva ) +DEALLOCATE ( met % fsd ) + +RETURN +END SUBROUTINE dealloc_met_type + +SUBROUTINE assoc_met_type(met, met_data ) +! Description: +! Associate the CABLE work pointers in the derived type structure +IMPLICIT NONE + +!Arguments +TYPE(met_type), INTENT(IN OUT) :: met +TYPE(met_data_type), INTENT(IN OUT), TARGET :: met_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_met_cbl(met) + +met% year => met_data% year +met% moy => met_data% moy +met% ca => met_data% ca +met% doy => met_data% doy +met% hod => met_data% hod +met% ofsd => met_data% ofsd +met% fld => met_data% fld +met% precip => met_data% precip +met% precip_sn => met_data% precip_sn +met% tk => met_data% tk +met% tvair => met_data% tvair +met% tvrad => met_data% tvrad +met% pmb => met_data% pmb +met% ua => met_data% ua +met% qv => met_data% qv +met% coszen => met_data% coszen +met% Ndep => met_data% Ndep +met% qvair => met_data% qvair +met% da => met_data% da +met% dva => met_data% dva +met% fsd => met_data% fsd + +RETURN +END SUBROUTINE assoc_met_type + +SUBROUTINE nullify_met_cbl( met ) +! Description: +! Nullify the CABLE work pointers in the derived type structure +IMPLICIT NONE + +!Arguments +TYPE(met_type), INTENT(IN OUT) :: met + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( met % year ) +NULLIFY( met % moy ) +NULLIFY( met % ca ) +NULLIFY( met % doy ) +NULLIFY( met % hod ) +NULLIFY( met % ofsd ) +NULLIFY( met % fld ) +NULLIFY( met % precip ) +NULLIFY( met % precip_sn ) +NULLIFY( met % tk ) +NULLIFY( met % tvair ) +NULLIFY( met % tvrad ) +NULLIFY( met % pmb ) +NULLIFY( met % ua ) +NULLIFY( met % qv ) +NULLIFY( met % coszen ) +NULLIFY( met % Ndep ) +NULLIFY( met % qvair ) +NULLIFY( met % da ) +NULLIFY( met % dva ) +NULLIFY( met % fsd ) + +RETURN + +END SUBROUTINE nullify_met_cbl + +END MODULE cable_met_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/radiation_type.F90 b/src/coupled/AM3/control/cable/CM3/radiation_type.F90 new file mode 100644 index 000000000..6fd845a91 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/radiation_type.F90 @@ -0,0 +1,311 @@ +MODULE cable_radiation_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: radiation_type +PUBLIC :: radiation_data_type +PUBLIC :: alloc_radiation_type +PUBLIC :: dealloc_radiation_type +PUBLIC :: assoc_radiation_type +PUBLIC :: nullify_radiation_cbl + +! Radiation variables: +TYPE radiation_data_type + + REAL, ALLOCATABLE :: transb (:) ! fraction SW beam tranmitted through canopy + REAL, ALLOCATABLE :: albedo_T (:) ! canopy+soil albedo for VIS+NIR + REAL, ALLOCATABLE :: longitude (:) ! longitude + REAL, ALLOCATABLE :: workp1 (:) ! absorbed short-wave radiation for soil + REAL, ALLOCATABLE :: workp2 (:) ! absorbed short-wave radiation for soil + REAL, ALLOCATABLE :: workp3 (:) ! absorbed short-wave radiation for soil + REAL, ALLOCATABLE :: extkb (:) ! beam radiation extinction coeff + REAL, ALLOCATABLE :: extkd2 (:) ! diffuse 2D radiation extinction coeff + REAL, ALLOCATABLE :: extkd (:) ! diffuse radiation extinction coeff (-) + REAL, ALLOCATABLE :: flws (:) ! soil long-wave radiation + REAL, ALLOCATABLE :: latitude (:) ! latitude + REAL, ALLOCATABLE :: lwabv (:) ! long wave absorbed by vegetation + REAL, ALLOCATABLE :: qssabs (:) ! absorbed short-wave radiation for soil + REAL, ALLOCATABLE :: transd (:) ! frac SW diffuse transmitted through canopy + REAL, ALLOCATABLE :: trad (:) ! radiative temperature (soil and veg) + REAL, ALLOCATABLE :: otrad (:) ! radiative temperature on previous timestep (ACCESS) + + REAL, ALLOCATABLE :: fvlai (:,:) ! leaf area index of big leaf + REAL, ALLOCATABLE :: rhocdf (:,:) ! canopy diffuse reflectance (-) + REAL, ALLOCATABLE :: rniso (:,:) ! sum(rad%qcan, 3) total abs by canopy (W/m2) + REAL, ALLOCATABLE :: scalex (:,:) ! scaling PARAMETER for big leaf + REAL, ALLOCATABLE :: albedo (:,:) ! canopy+soil albedo + REAL, ALLOCATABLE :: reffdf (:,:) ! effective conopy diffuse reflectance + REAL, ALLOCATABLE :: reffbm (:,:) ! effective conopy beam reflectance + REAL, ALLOCATABLE :: extkbm (:,:) ! modified k beam(6.20)(for leaf scattering) + REAL, ALLOCATABLE :: extkdm (:,:) ! modified k diffuse(6.20)(for leaf scattering) + REAL, ALLOCATABLE :: fbeam (:,:) ! beam fraction + REAL, ALLOCATABLE :: cexpkbm (:,:) ! canopy beam transmittance + REAL, ALLOCATABLE :: cexpkdm (:,:) ! canopy diffuse transmittance + REAL, ALLOCATABLE :: rhocbm (:,:) ! modified canopy beam reflectance(6.21) + REAL, ALLOCATABLE :: gradis (:,:) ! radiative conductance + + REAL, ALLOCATABLE :: qcan (:,:,:) ! absorbed radiation for canopy (W/m^2) + +END TYPE radiation_data_type + +TYPE radiation_type + + REAL, POINTER :: transb (:) ! fraction SW beam tranmitted through canopy + REAL, POINTER :: albedo_T (:) ! canopy+soil albedo for VIS+NIR + REAL, POINTER :: longitude (:) ! longitude + REAL, POINTER :: workp1 (:) ! absorbed short-wave radiation for soil + REAL, POINTER :: workp2 (:) ! absorbed short-wave radiation for soil + REAL, POINTER :: workp3 (:) ! absorbed short-wave radiation for soil + REAL, POINTER :: extkb (:) ! beam radiation extinction coeff + REAL, POINTER :: extkd2 (:) ! diffuse 2D radiation extinction coeff + REAL, POINTER :: extkd (:) ! diffuse radiation extinction coeff (-) + REAL, POINTER :: flws (:) ! soil long-wave radiation + REAL, POINTER :: latitude (:) ! latitude + REAL, POINTER :: lwabv (:) ! long wave absorbed by vegetation + REAL, POINTER :: qssabs (:) ! absorbed short-wave radiation for soil + REAL, POINTER :: transd (:) ! frac SW diffuse transmitted through canopy + REAL, POINTER :: trad (:) ! radiative temperature (soil and veg) + REAL, POINTER :: otrad (:) ! radiative temperature on previous timestep (ACCESS) + + REAL, POINTER :: fvlai (:,:) ! leaf area index of big leaf + REAL, POINTER :: rhocdf (:,:) ! canopy diffuse reflectance (-) + REAL, POINTER :: rniso (:,:) ! sum(rad%qcan, 3) total abs by canopy (W/m2) + REAL, POINTER :: scalex (:,:) ! scaling PARAMETER for big leaf + REAL, POINTER :: albedo (:,:) ! canopy+soil albedo + REAL, POINTER :: reffdf (:,:) ! effective conopy diffuse reflectance + REAL, POINTER :: reffbm (:,:) ! effective conopy beam reflectance + REAL, POINTER :: extkbm (:,:) ! modified k beam(6.20)(for leaf scattering) + REAL, POINTER :: extkdm (:,:) ! modified k diffuse(6.20)(for leaf scattering) + REAL, POINTER :: fbeam (:,:) ! beam fraction + REAL, POINTER :: cexpkbm (:,:) ! canopy beam transmittance + REAL, POINTER :: cexpkdm (:,:) ! canopy diffuse transmittance + REAL, POINTER :: rhocbm (:,:) ! modified canopy beam reflectance(6.21) + REAL, POINTER :: gradis (:,:) ! radiative conductance + + REAL, POINTER :: qcan (:,:,:) ! absorbed radiation for canopy (W/m^2) + +END TYPE radiation_type + +CONTAINS + +SUBROUTINE alloc_radiation_type(radiation, mp) + +USE grid_constants_mod_cbl, ONLY: mf ! # leaves (sunlit/shaded) +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: nrb, swb ! # Radiation/SW bands + +IMPLICIT NONE + +TYPE(radiation_data_type), INTENT(INOUT) :: radiation +INTEGER, INTENT(IN) :: mp + +ALLOCATE( radiation% transb (mp) ) +ALLOCATE( radiation% albedo_T (mp) ) +ALLOCATE( radiation% longitude (mp) ) +ALLOCATE( radiation% workp1 (mp) ) +ALLOCATE( radiation% workp2 (mp) ) +ALLOCATE( radiation% workp3 (mp) ) +ALLOCATE( radiation% extkb (mp) ) +ALLOCATE( radiation% extkd2 (mp) ) +ALLOCATE( radiation% extkd (mp) ) +ALLOCATE( radiation% flws (mp) ) +ALLOCATE( radiation% latitude (mp) ) +ALLOCATE( radiation% lwabv (mp) ) +ALLOCATE( radiation% qssabs (mp) ) +ALLOCATE( radiation% transd (mp) ) +ALLOCATE( radiation% trad (mp) ) +ALLOCATE( radiation% otrad (mp) ) + +ALLOCATE( radiation% fvlai (mp,mf ) ) +ALLOCATE( radiation% rhocdf (mp,nrb) ) +ALLOCATE( radiation% rniso (mp,mf ) ) +ALLOCATE( radiation% scalex (mp,mf ) ) +ALLOCATE( radiation% albedo (mp,nrb) ) +ALLOCATE( radiation% reffdf (mp,nrb) ) +ALLOCATE( radiation% reffbm (mp,nrb) ) +ALLOCATE( radiation% extkbm (mp,nrb) ) +ALLOCATE( radiation% extkdm (mp,nrb) ) +ALLOCATE( radiation% fbeam (mp,nrb) ) +ALLOCATE( radiation% cexpkbm (mp,swb) ) +ALLOCATE( radiation% cexpkdm (mp,swb) ) +ALLOCATE( radiation% rhocbm (mp,nrb) ) +ALLOCATE( radiation% gradis (mp,mf ) ) + +ALLOCATE( radiation% qcan (mp,mf,nrb) ) + +radiation % transb (:) = 0.0 +radiation % albedo_T (:) = 0.0 +radiation % longitude (:) = 0.0 +radiation % workp1 (:) = 0.0 +radiation % workp2 (:) = 0.0 +radiation % workp3 (:) = 0.0 +radiation % extkb (:) = 0.0 +radiation % extkd2 (:) = 0.0 +radiation % extkd (:) = 0.0 +radiation % flws (:) = 0.0 +radiation % latitude (:) = 0.0 +radiation % lwabv (:) = 0.0 +radiation % qssabs (:) = 0.0 +radiation % transd (:) = 0.0 +radiation % trad (:) = 0.0 +radiation % otrad (:) = 0.0 +radiation % fvlai (:,:) = 0.0 +radiation % rhocdf (:,:) = 0.0 +radiation % rniso (:,:) = 0.0 +radiation % scalex (:,:) = 0.0 +radiation % albedo (:,:) = 0.0 +radiation % reffdf (:,:) = 0.0 +radiation % reffbm (:,:) = 0.0 +radiation % extkbm (:,:) = 0.0 +radiation % extkdm (:,:) = 0.0 +radiation % fbeam (:,:) = 0.0 +radiation % cexpkbm (:,:) = 0.0 +radiation % cexpkdm (:,:) = 0.0 +radiation % rhocbm (:,:) = 0.0 +radiation % gradis (:,:) = 0.0 +radiation % qcan (:,:,:) = 0.0 + +RETURN +END SUBROUTINE alloc_radiation_type + +SUBROUTINE dealloc_radiation_type(radiation) + +TYPE(radiation_type), INTENT(inout) :: radiation + +DEALLOCATE ( radiation % transb ) +DEALLOCATE ( radiation % albedo_T ) +DEALLOCATE ( radiation % longitude ) +DEALLOCATE ( radiation % workp1 ) +DEALLOCATE ( radiation % workp2 ) +DEALLOCATE ( radiation % workp3 ) +DEALLOCATE ( radiation % extkb ) +DEALLOCATE ( radiation % extkd2 ) +DEALLOCATE ( radiation % extkd ) +DEALLOCATE ( radiation % flws ) +DEALLOCATE ( radiation % latitude ) +DEALLOCATE ( radiation % lwabv ) +DEALLOCATE ( radiation % qssabs ) +DEALLOCATE ( radiation % transd ) +DEALLOCATE ( radiation % trad ) +DEALLOCATE ( radiation % otrad ) +DEALLOCATE ( radiation % fvlai ) +DEALLOCATE ( radiation % rhocdf ) +DEALLOCATE ( radiation % rniso ) +DEALLOCATE ( radiation % scalex ) +DEALLOCATE ( radiation % albedo ) +DEALLOCATE ( radiation % reffdf ) +DEALLOCATE ( radiation % reffbm ) +DEALLOCATE ( radiation % extkbm ) +DEALLOCATE ( radiation % extkdm ) +DEALLOCATE ( radiation % fbeam ) +DEALLOCATE ( radiation % cexpkbm ) +DEALLOCATE ( radiation % cexpkdm ) +DEALLOCATE ( radiation % rhocbm ) +DEALLOCATE ( radiation % gradis ) +DEALLOCATE ( radiation % qcan ) + +RETURN +END SUBROUTINE dealloc_radiation_type + +SUBROUTINE assoc_radiation_type(radiation, radiation_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(radiation_type), INTENT(IN OUT) :: radiation +TYPE(radiation_data_type), INTENT(IN OUT), TARGET :: radiation_data +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_radiation_cbl(radiation) + +radiation% transb => radiation_data% transb +radiation% albedo_T => radiation_data% albedo_T +radiation% longitude => radiation_data% longitude +radiation% workp1 => radiation_data% workp1 +radiation% workp2 => radiation_data% workp2 +radiation% workp3 => radiation_data% workp3 +radiation% extkb => radiation_data% extkb +radiation% extkd2 => radiation_data% extkd2 +radiation% extkd => radiation_data% extkd +radiation% flws => radiation_data% flws +radiation% latitude => radiation_data% latitude +radiation% lwabv => radiation_data% lwabv +radiation% qssabs => radiation_data% qssabs +radiation% transd => radiation_data% transd +radiation% trad => radiation_data% trad +radiation% otrad => radiation_data% otrad +radiation% fvlai => radiation_data% fvlai +radiation% rhocdf => radiation_data% rhocdf +radiation% rniso => radiation_data% rniso +radiation% scalex => radiation_data% scalex +radiation% albedo => radiation_data% albedo +radiation% reffdf => radiation_data% reffdf +radiation% reffbm => radiation_data% reffbm +radiation% extkbm => radiation_data% extkbm +radiation% extkdm => radiation_data% extkdm +radiation% fbeam => radiation_data% fbeam +radiation% cexpkbm => radiation_data% cexpkbm +radiation% cexpkdm => radiation_data% cexpkdm +radiation% rhocbm => radiation_data% rhocbm +radiation% gradis => radiation_data% gradis +radiation% qcan => radiation_data% qcan + +RETURN +END SUBROUTINE assoc_radiation_type + +SUBROUTINE nullify_radiation_cbl( radiation ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(radiation_type), INTENT(IN OUT) :: radiation + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( radiation % transb ) +NULLIFY( radiation % albedo_T ) +NULLIFY( radiation % longitude ) +NULLIFY( radiation % workp1 ) +NULLIFY( radiation % workp2 ) +NULLIFY( radiation % workp3 ) +NULLIFY( radiation % extkb ) +NULLIFY( radiation % extkd2 ) +NULLIFY( radiation % extkd ) +NULLIFY( radiation % flws ) +NULLIFY( radiation % latitude ) +NULLIFY( radiation % lwabv ) +NULLIFY( radiation % qssabs ) +NULLIFY( radiation % transd ) +NULLIFY( radiation % trad ) +NULLIFY( radiation % otrad ) +NULLIFY( radiation % fvlai ) +NULLIFY( radiation % rhocdf ) +NULLIFY( radiation % rniso ) +NULLIFY( radiation % scalex ) +NULLIFY( radiation % albedo ) +NULLIFY( radiation % reffdf ) +NULLIFY( radiation % reffbm ) +NULLIFY( radiation % extkbm ) +NULLIFY( radiation % extkdm ) +NULLIFY( radiation % fbeam ) +NULLIFY( radiation % cexpkbm ) +NULLIFY( radiation % cexpkdm ) +NULLIFY( radiation % rhocbm ) +NULLIFY( radiation % gradis ) +NULLIFY( radiation % qcan ) + +RETURN + +END SUBROUTINE nullify_radiation_cbl + +END MODULE cable_radiation_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/read_cable_namelists_mod.F90 b/src/coupled/AM3/control/cable/CM3/read_cable_namelists_mod.F90 new file mode 100644 index 000000000..6684a35a1 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/read_cable_namelists_mod.F90 @@ -0,0 +1,116 @@ +#if defined(UM_JULES) +! *****************************COPYRIGHT******************************* +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT******************************* +! +! Wrapper module containing subroutines for reading cable namelists +! +MODULE read_cable_namelists_mod + +! Description: +! Contains read_cable_ and read_ subroutines +! for reading namelists into cable during a UM-JULES job. +! +! Method: +! The unit number holding the namelist is passed as the sole argument +! to each file. +! +! Code Owner: Please refer to ModuleLeaders.txt and UM file CodeOwners.txt +! This file belongs in section: top_level +! +! Code Description: +! Language: FORTRAN 95. +! This code is written to UMDP3 v8.5 programming standards. + + +USE umPrintMgr , ONLY: & + PrintStatus, PrStatus_Oper + +USE UM_ParCore, ONLY: & + mype + +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +INTEGER(KIND=jpim), PARAMETER, PRIVATE :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER, PRIVATE :: zhook_out = 1 + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='READ_CABLE_NAMELISTS_MOD' + +CONTAINS + +! ********************************************************************* + +SUBROUTINE read_cable_surface_types (unitnumber) + +! Description: +! Read the cable_SURFACE_TYPES namelist + +USE cable_surface_types_mod, ONLY: & + print_nlist_cable_surface_types, & + check_cable_surface_types, read_nml_cable_surface_types, & + set_derived_variables_cable_surface_types + + +USE land_tile_ids_mod, ONLY: surface_type_ids_jls => surface_type_ids +USE land_tile_ids_mod_cbl, ONLY: set_surface_type_ids_cbl +USE land_tile_ids_mod_cbl, ONLY: surface_type_ids_cbl => surface_type_ids + +IMPLICIT NONE + +! Subroutine arguments +INTEGER, INTENT(IN) :: unitnumber + +REAL(KIND=jprb) :: zhook_handle +CHARACTER(LEN=*), PARAMETER :: RoutineName='READ_cable_SURFACE_TYPES' + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL read_nml_cable_surface_types(unitnumber) +CALL set_derived_variables_cable_surface_types() +IF (PrintStatus >= PrStatus_Oper .AND. mype == 0) THEN + CALL print_nlist_cable_surface_types() +END IF +! Set the surface_type_ids array and carry out additional checks +CALL set_surface_type_ids_cbl() +surface_type_ids_jls = surface_type_ids_cbl +CALL check_cable_surface_types() + + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE read_cable_surface_types + +SUBROUTINE read_cable_model_environment(unitnumber) + +! Description: +! Read the cable namelist + +USE cable_model_env_mod, ONLY: read_nml_cable_model_env +USE cable_model_env_mod, ONLY: set_derived_variables_cable_model_env + +IMPLICIT NONE + +! Subroutine arguments +INTEGER, INTENT(IN) :: unitnumber + +REAL(KIND=jprb) :: zhook_handle +CHARACTER(LEN=*), PARAMETER :: RoutineName='READ_CABLE_MODEL_ENVIRONMENT' + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL read_nml_cable_model_env(unitnumber) + +CALL set_derived_variables_cable_model_env() + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE read_cable_model_environment + + +END MODULE read_cable_namelists_mod +#endif diff --git a/src/coupled/AM3/control/cable/CM3/roughness_type.F90 b/src/coupled/AM3/control/cable/CM3/roughness_type.F90 new file mode 100644 index 000000000..7f89277b5 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/roughness_type.F90 @@ -0,0 +1,247 @@ +MODULE cable_roughness_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: roughness_type +PUBLIC :: roughness_data_type +PUBLIC :: alloc_roughness_type +PUBLIC :: dealloc_roughness_type +PUBLIC :: assoc_roughness_type +PUBLIC :: nullify_roughness_cbl + +! Roughness variables: +TYPE roughness_data_type + + REAL, ALLOCATABLE :: disp (:) ! zero-plane displacement + REAL, ALLOCATABLE :: hruff (:) ! canopy height above snow level + REAL, ALLOCATABLE :: hruff_grmx (:) ! max ht of canopy from tiles on same grid + REAL, ALLOCATABLE :: rt0us (:) ! eq. 3.54, SCAM manual (CSIRO tech report 132) + REAL, ALLOCATABLE :: rt1usa (:) ! resistance from disp to hruf + REAL, ALLOCATABLE :: rt1usb (:) ! resist fr hruf to zruffs (zref if zref roughness_data% disp +roughness% hruff => roughness_data% hruff +roughness% hruff_grmx => roughness_data% hruff_grmx +roughness% rt0us => roughness_data% rt0us +roughness% rt1usa => roughness_data% rt1usa +roughness% rt1usb => roughness_data% rt1usb +roughness% rt1 => roughness_data% rt1 +roughness% za_uv => roughness_data% za_uv +roughness% za_tq => roughness_data% za_tq +roughness% z0m => roughness_data% z0m +roughness% zref_uv => roughness_data% zref_uv +roughness% zref_tq => roughness_data% zref_tq +roughness% zruffs => roughness_data% zruffs +roughness% z0soilsn => roughness_data% z0soilsn +roughness% z0soil => roughness_data% z0soil +roughness% coexp => roughness_data% coexp +roughness% usuh => roughness_data% usuh +roughness% term2 => roughness_data% term2 +roughness% term3 => roughness_data% term3 +roughness% term5 => roughness_data% term5 +roughness% term6 => roughness_data% term6 +roughness% term6a => roughness_data% term6a + +RETURN +END SUBROUTINE assoc_roughness_type + +SUBROUTINE nullify_roughness_cbl( roughness ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(roughness_type), INTENT(IN OUT) :: roughness + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( roughness % disp ) +NULLIFY( roughness % hruff ) +NULLIFY( roughness % hruff_grmx ) +NULLIFY( roughness % rt0us ) +NULLIFY( roughness % rt1usa ) +NULLIFY( roughness % rt1usb ) +NULLIFY( roughness % rt1 ) +NULLIFY( roughness % za_uv ) +NULLIFY( roughness % za_tq ) +NULLIFY( roughness % z0m ) +NULLIFY( roughness % zref_uv ) +NULLIFY( roughness % zref_tq ) +NULLIFY( roughness % zruffs ) +NULLIFY( roughness % z0soilsn ) +NULLIFY( roughness % z0soil ) +NULLIFY( roughness % coexp ) +NULLIFY( roughness % usuh ) +NULLIFY( roughness % term2 ) +NULLIFY( roughness % term3 ) +NULLIFY( roughness % term5 ) +NULLIFY( roughness % term6 ) +NULLIFY( roughness % term6a ) + +RETURN + +END SUBROUTINE nullify_roughness_cbl + +END MODULE cable_roughness_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/soil_type_cbl.F90 b/src/coupled/AM3/control/cable/CM3/soil_type_cbl.F90 new file mode 100644 index 000000000..4c0002e11 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/soil_type_cbl.F90 @@ -0,0 +1,517 @@ +MODULE cable_soil_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: soil_type +PUBLIC :: soil_data_type +PUBLIC :: alloc_soil_type +PUBLIC :: dealloc_soil_type +PUBLIC :: assoc_soil_type +PUBLIC :: nullify_soil_cbl + +! Soil parameters: +TYPE soil_data_type + + INTEGER, ALLOCATABLE :: isoilm (:) ! integer soil type + REAL, ALLOCATABLE :: bch (:) ! parameter b in Campbell equation + REAL, ALLOCATABLE :: c3 (:) ! c3 drainage coeff (fraction) + REAL, ALLOCATABLE :: clay (:) ! fraction of soil which is clay + REAL, ALLOCATABLE :: css (:) ! soil specific heat capacity [kJ/kg/K] + REAL, ALLOCATABLE :: hsbh (:) ! difsat * etasat (=hyds*abs(sucs)*bch) + REAL, ALLOCATABLE :: hyds (:) ! hydraulic cond@ saturation [m/s], Ksat + REAL, ALLOCATABLE :: i2bp3 (:) ! par. one in K vis suction (=nint(bch)+2) + REAL, ALLOCATABLE :: ibp2 (:) ! par. two in K vis suction (fn of pbch) + REAL, ALLOCATABLE :: rhosoil (:) ! soil density [kg/m3] + REAL, ALLOCATABLE :: sand (:) ! fraction of soil which is sand + REAL, ALLOCATABLE :: sfc (:) ! vol H2O @ field capacity + REAL, ALLOCATABLE :: silt (:) ! fraction of soil which is silt + REAL, ALLOCATABLE :: ssat (:) ! vol H2O @ saturation + REAL, ALLOCATABLE :: sucs (:) ! suction at saturation (m) + REAL, ALLOCATABLE :: swilt (:) ! vol H2O @ wilting + REAL, ALLOCATABLE :: zse (:) ! soil layer thickness (1=top) [m] + REAL, ALLOCATABLE :: zshh (:) ! dist b/n consecutive layer midpoints (m) + REAL, ALLOCATABLE :: soilcol (:) ! color per patches/tiles Ticket #27 + REAL, ALLOCATABLE :: albsoilf (:) ! soil reflectance Ticket #27 + REAL, ALLOCATABLE :: albsoil (:,:)! soil reflectance + + REAL(r_2), ALLOCATABLE :: heat_cap_lower_limit (:,:) + REAL(r_2), ALLOCATABLE :: zse_vec (:,:) + REAL(r_2), ALLOCATABLE :: css_vec (:,:) + REAL(r_2), ALLOCATABLE :: cnsd_vec (:,:) + REAL(r_2), ALLOCATABLE :: cnsd (:) ! thermal cond dry soil [W/m/K] + REAL(r_2), ALLOCATABLE :: pwb_min (:) ! working var (swilt/ssat)**ibp2 + + REAL(r_2), ALLOCATABLE :: drain_dens (:) ! mean dist to rivers/streams + REAL(r_2), ALLOCATABLE :: elev (:) ! elevation above sea level + REAL(r_2), ALLOCATABLE :: elev_std (:) ! elevation above sea level + REAL(r_2), ALLOCATABLE :: slope (:) ! mean slope of grid cell + REAL(r_2), ALLOCATABLE :: slope_std (:) ! stddev of grid cell slope + + ! Parameters for GW module that vary with soil layer + REAL(r_2), ALLOCATABLE :: sucs_vec (:,:) ! psi at saturation in [mm] + REAL(r_2), ALLOCATABLE :: hyds_vec (:,:) ! sat hydraulic cond [mm/s] + REAL(r_2), ALLOCATABLE :: bch_vec (:,:) ! C and H B [none] + REAL(r_2), ALLOCATABLE :: clay_vec (:,:) ! fraction of soil that is clay + REAL(r_2), ALLOCATABLE :: sand_vec (:,:) ! fraction of soil that is sand + REAL(r_2), ALLOCATABLE :: silt_vec (:,:) ! fraction of soil that is silt + REAL(r_2), ALLOCATABLE :: org_vec (:,:) ! frac soil made of organic soils + REAL(r_2), ALLOCATABLE :: rhosoil_vec (:,:) ! soil density [kg/m3] + REAL(r_2), ALLOCATABLE :: ssat_vec (:,:) ! vol H2O content at sat [mm3/mm3] + REAL(r_2), ALLOCATABLE :: watr (:,:) ! resid soil H2O content [mm3/mm3] + REAL(r_2), ALLOCATABLE :: sfc_vec (:,:) ! field capcacity (hk = 1 mm/day) + REAL(r_2), ALLOCATABLE :: swilt_vec (:,:) ! wilting point (hk = 0.02 mm/day) + + ! Parameters for GW module for the aquifer + REAL(r_2), ALLOCATABLE :: GWsucs_vec (:) ! head in the aquifer [mm] + REAL(r_2), ALLOCATABLE :: GWhyds_vec (:) ! satur hydraulic cond [mm/s] + REAL(r_2), ALLOCATABLE :: GWbch_vec (:) ! clapp and horn b [none] + REAL(r_2), ALLOCATABLE :: GWssat_vec (:) ! saturated water content [mm3/mm3] + REAL(r_2), ALLOCATABLE :: GWwatr (:) ! residual water content [mm3/mm3] + REAL(r_2), ALLOCATABLE :: GWz (:) ! node depth of the aquifer [m] + REAL(r_2), ALLOCATABLE :: GWdz (:) ! thickness of the aquifer [m] + REAL(r_2), ALLOCATABLE :: GWrhosoil_vec(:) ! density of substrate [kg/m3] + + ! Additional SLI parameters + INTEGER(r_2), ALLOCATABLE :: nhorizons (:) ! number of soil horizons + INTEGER(r_2), ALLOCATABLE :: ishorizon (:,:) ! horizon number 1:nhorizons + REAL(r_2), ALLOCATABLE :: clitt (:) ! litter (tC/ha) + REAL(r_2), ALLOCATABLE :: zeta (:) ! macropore parameter + REAL(r_2), ALLOCATABLE :: fsatmax (:) ! variably saturated area parameter + !REAL(r_2), DIMENSION(:,:), POINTER :: swilt_vec ! vol H2O @ wilting + !REAL(r_2), DIMENSION(:,:), POINTER :: ssat_vec ! vol H2O @ sat + !REAL(r_2), DIMENSION(:,:), POINTER :: sfc_vec ! vol H2O @ fc + +END TYPE soil_data_type + +TYPE soil_type + + INTEGER, POINTER :: isoilm (:) ! integer soil type + REAL, POINTER :: bch (:) ! parameter b in Campbell equation + REAL, POINTER :: c3 (:) ! c3 drainage coeff (fraction) + REAL, POINTER :: clay (:) ! fraction of soil which is clay + REAL, POINTER :: css (:) ! soil specific heat capacity [kJ/kg/K] + REAL, POINTER :: hsbh (:) ! difsat * etasat (=hyds*abs(sucs)*bch) + REAL, POINTER :: hyds (:) ! hydraulic cond@ saturation [m/s], Ksat + REAL, POINTER :: i2bp3 (:) ! par. one in K vis suction (=nint(bch)+2) + REAL, POINTER :: ibp2 (:) ! par. two in K vis suction (fn of pbch) + REAL, POINTER :: rhosoil (:) ! soil density [kg/m3] + REAL, POINTER :: sand (:) ! fraction of soil which is sand + REAL, POINTER :: sfc (:) ! vol H2O @ field capacity + REAL, POINTER :: silt (:) ! fraction of soil which is silt + REAL, POINTER :: ssat (:) ! vol H2O @ saturation + REAL, POINTER :: sucs (:) ! suction at saturation (m) + REAL, POINTER :: swilt (:) ! vol H2O @ wilting + REAL, POINTER :: zse (:) ! thickness of each soil layer (1=top) [m] + REAL, POINTER :: zshh (:) ! dist b/n consecutive layer midpoints (m) + REAL, POINTER :: soilcol (:) ! color per patches/tiles Ticket #27 + REAL, POINTER :: albsoilf (:) ! soil reflectance Ticket #27 + REAL, POINTER :: albsoil (:,:) ! soil reflectance + + REAL(r_2), POINTER :: heat_cap_lower_limit (:,:) + REAL(r_2), POINTER :: zse_vec (:,:) + REAL(r_2), POINTER :: css_vec (:,:) + REAL(r_2), POINTER :: cnsd_vec (:,:) + REAL(r_2), POINTER :: cnsd (:) ! thermal cond dry soil [W/m/K] + REAL(r_2), POINTER :: pwb_min (:) ! working var (swilt/ssat)**ibp2 + + REAL(r_2), POINTER :: drain_dens (:) ! mean dist to rivers/streams) + REAL(r_2), POINTER :: elev (:) ! elevation above sea level + REAL(r_2), POINTER :: elev_std (:) ! elevation above sea level + REAL(r_2), POINTER :: slope (:) ! mean slope of grid cell + REAL(r_2), POINTER :: slope_std (:) ! stddev of grid cell slope + + ! Parameters for GW module that vary with soil layer + REAL(r_2), POINTER :: sucs_vec (:,:) ! psi at saturation in [mm] + REAL(r_2), POINTER :: hyds_vec (:,:) ! sat hydraulic cond [mm/s] + REAL(r_2), POINTER :: bch_vec (:,:) ! C and H B [none] + REAL(r_2), POINTER :: clay_vec (:,:) ! fraction of soil that is clay + REAL(r_2), POINTER :: sand_vec (:,:) ! fraction of soil that is sand + REAL(r_2), POINTER :: silt_vec (:,:) ! fraction of soil that is silt + REAL(r_2), POINTER :: org_vec (:,:) ! frac soil made of organic soils + REAL(r_2), POINTER :: rhosoil_vec (:,:) ! soil density [kg/m3] + REAL(r_2), POINTER :: ssat_vec (:,:) ! vol H2O content at sat [mm3/mm3] + REAL(r_2), POINTER :: watr (:,:) ! resid soil H2O content [mm3/mm3] + REAL(r_2), POINTER :: sfc_vec (:,:) ! field capcacity (hk = 1 mm/day) + REAL(r_2), POINTER :: swilt_vec (:,:) ! wilting point (hk = 0.02 mm/day) + + ! Parameters for GW module for the aquifer + REAL(r_2), POINTER :: GWsucs_vec (:) ! head in the aquifer [mm] + REAL(r_2), POINTER :: GWhyds_vec (:) ! satur hydraulic cond [mm/s] + REAL(r_2), POINTER :: GWbch_vec (:) ! clapp and horn b [none] + REAL(r_2), POINTER :: GWssat_vec (:) ! saturated water content [mm3/mm3] + REAL(r_2), POINTER :: GWwatr (:) ! residual water content [mm3/mm3] + REAL(r_2), POINTER :: GWz (:) ! node depth of the aquifer [m] + REAL(r_2), POINTER :: GWdz (:) ! thickness of the aquifer [m] + REAL(r_2), POINTER :: GWrhosoil_vec(:) ! density of substrate [kg/m3] + + ! Additional SLI parameters + INTEGER(r_2), POINTER :: nhorizons (:) ! number of soil horizons + INTEGER(r_2), POINTER :: ishorizon (:,:) ! horizon number 1:nhorizons + REAL(r_2), POINTER :: clitt (:) ! litter (tC/ha) + REAL(r_2), POINTER :: zeta (:) ! macropore parameter + REAL(r_2), POINTER :: fsatmax (:) ! variably saturated area parameter + !REAL(r_2), DIMENSION(:,:), POINTER :: swilt_vec ! vol H2O @ wilting + !REAL(r_2), DIMENSION(:,:), POINTER :: ssat_vec ! vol H2O @ sat + !REAL(r_2), DIMENSION(:,:), POINTER :: sfc_vec ! vol H2O @ fc + +END TYPE soil_type + +CONTAINS + +SUBROUTINE alloc_soil_type(soil, mp) + +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: swb ! # SW bands + +IMPLICIT NONE + +TYPE(soil_data_type), INTENT(INOUT) :: soil +INTEGER, INTENT(IN) :: mp + +ALLOCATE( soil% isoilm (mp) ) +ALLOCATE( soil% bch (mp) ) +ALLOCATE( soil% c3 (mp) ) +ALLOCATE( soil% clay (mp) ) +ALLOCATE( soil% css (mp) ) +ALLOCATE( soil% hsbh (mp) ) +ALLOCATE( soil% hyds (mp) ) +ALLOCATE( soil% i2bp3 (mp) ) +ALLOCATE( soil% ibp2 (mp) ) +ALLOCATE( soil% rhosoil (mp) ) +ALLOCATE( soil% sand (mp) ) +ALLOCATE( soil% sfc (mp) ) +ALLOCATE( soil% silt (mp) ) +ALLOCATE( soil% ssat (mp) ) +ALLOCATE( soil% sucs (mp) ) +ALLOCATE( soil% swilt (mp) ) +ALLOCATE( soil% zse (nsl) ) +ALLOCATE( soil% zshh (nsl+1) ) +ALLOCATE( soil% soilcol (mp) ) +ALLOCATE( soil% albsoilf (mp) ) +ALLOCATE( soil% albsoil (mp,swb) ) + +ALLOCATE( soil% heat_cap_lower_limit (mp,nsl) ) +ALLOCATE( soil% zse_vec (mp,nsl) ) +ALLOCATE( soil% css_vec (mp,nsl) ) +ALLOCATE( soil% cnsd_vec (mp,nsl) ) +ALLOCATE( soil% cnsd (mp) ) +ALLOCATE( soil% pwb_min (mp) ) + +ALLOCATE( soil% drain_dens (mp) ) ! mean dist to rivers/streams +ALLOCATE( soil% elev (mp) ) ! elevation above sea level +ALLOCATE( soil% elev_std (mp) ) ! elevation above sea level +ALLOCATE( soil% slope (mp) ) ! mean slope of grid cell +ALLOCATE( soil% slope_std (mp) ) ! stddev of grid cell slope + +! Parameters for GW module that vary with soil layer +ALLOCATE( soil% sucs_vec (mp,nsl) ) +ALLOCATE( soil% hyds_vec (mp,nsl) ) +ALLOCATE( soil% bch_vec (mp,nsl) ) +ALLOCATE( soil% clay_vec (mp,nsl) ) +ALLOCATE( soil% sand_vec (mp,nsl) ) +ALLOCATE( soil% silt_vec (mp,nsl) ) +ALLOCATE( soil% org_vec (mp,nsl) ) +ALLOCATE( soil% rhosoil_vec (mp,nsl) ) +ALLOCATE( soil% ssat_vec (mp,nsl) ) +ALLOCATE( soil% watr (mp,nsl) ) +ALLOCATE( soil% sfc_vec (mp,nsl) ) +ALLOCATE( soil% swilt_vec (mp,nsl) ) + +! Parameters for GW module for the aquifer +ALLOCATE( soil% GWhyds_vec (mp) ) +ALLOCATE( soil% GWsucs_vec (mp) ) +ALLOCATE( soil% GWbch_vec (mp) ) +ALLOCATE( soil% GWssat_vec (mp) ) +ALLOCATE( soil% GWwatr (mp) ) +ALLOCATE( soil% GWz (mp) ) +ALLOCATE( soil% GWdz (mp) ) +ALLOCATE( soil% GWrhosoil_vec(mp) ) + +! Additional SLI parameters +ALLOCATE( soil% nhorizons(mp) ) +ALLOCATE( soil% ishorizon(mp,nsl) ) +ALLOCATE( soil% clitt (mp) ) +ALLOCATE( soil% zeta (mp) ) +ALLOCATE( soil% fsatmax (mp) ) + +soil % isoilm (:) = 0.0 +soil % bch (:) = 0.0 +soil % c3 (:) = 0.0 +soil % clay (:) = 0.0 +soil % css (:) = 0.0 +soil % hsbh (:) = 0.0 +soil % hyds (:) = 0.0 +soil % i2bp3 (:) = 0.0 +soil % ibp2 (:) = 0.0 +soil % rhosoil (:) = 0.0 +soil % sand (:) = 0.0 +soil % sfc (:) = 0.0 +soil % silt (:) = 0.0 +soil % ssat (:) = 0.0 +soil % sucs (:) = 0.0 +soil % swilt (:) = 0.0 +soil % zse (:) = 0.0 +soil % zshh (:) = 0.0 +soil % soilcol (:) = 0.0 +soil % albsoilf (:) = 0.0 +soil % albsoil (:,:) = 0.0 +soil % zse_vec (:,:) = 0.0 +soil % css_vec (:,:) = 0.0 +soil % cnsd_vec (:,:) = 0.0 +soil % cnsd (:) = 0.0 +soil % pwb_min (:) = 0.0 +soil % drain_dens (:) = 0.0 +soil % elev (:) = 0.0 +soil % elev_std (:) = 0.0 +soil % slope (:) = 0.0 +soil % slope_std (:) = 0.0 +soil % sucs_vec (:,:) = 0.0 +soil % hyds_vec (:,:) = 0.0 +soil % bch_vec (:,:) = 0.0 +soil % clay_vec (:,:) = 0.0 +soil % sand_vec (:,:) = 0.0 +soil % silt_vec (:,:) = 0.0 +soil % org_vec (:,:) = 0.0 +soil % rhosoil_vec (:,:) = 0.0 +soil % ssat_vec (:,:) = 0.0 +soil % watr (:,:) = 0.0 +soil % sfc_vec (:,:) = 0.0 +soil % swilt_vec (:,:) = 0.0 +soil % GWhyds_vec (:) = 0.0 +soil % GWsucs_vec (:) = 0.0 +soil % GWbch_vec (:) = 0.0 +soil % GWssat_vec (:) = 0.0 +soil % GWwatr (:) = 0.0 +soil % GWz (:) = 0.0 +soil % GWdz (:) = 0.0 +soil % GWrhosoil_vec (:) = 0.0 +soil % nhorizons (:) = 0.0 +soil % ishorizon (:,:) = 0.0 +soil % clitt (:) = 0.0 +soil % zeta (:) = 0.0 +soil % fsatmax (:) = 0.0 +soil % heat_cap_lower_limit(:,:) = 0.0 + +RETURN +END SUBROUTINE alloc_soil_type + +SUBROUTINE dealloc_soil_type(soil) + +TYPE(soil_type), INTENT(inout) :: soil + +DEALLOCATE ( soil % isoilm ) +DEALLOCATE ( soil % bch ) +DEALLOCATE ( soil % c3 ) +DEALLOCATE ( soil % clay ) +DEALLOCATE ( soil % css ) +DEALLOCATE ( soil % hsbh ) +DEALLOCATE ( soil % hyds ) +DEALLOCATE ( soil % i2bp3 ) +DEALLOCATE ( soil % ibp2 ) +DEALLOCATE ( soil % rhosoil ) +DEALLOCATE ( soil % sand ) +DEALLOCATE ( soil % sfc ) +DEALLOCATE ( soil % silt ) +DEALLOCATE ( soil % ssat ) +DEALLOCATE ( soil % sucs ) +DEALLOCATE ( soil % swilt ) +DEALLOCATE ( soil % zse ) +DEALLOCATE ( soil % zshh ) +DEALLOCATE ( soil % soilcol ) +DEALLOCATE ( soil % albsoilf ) +DEALLOCATE ( soil % albsoil ) +DEALLOCATE ( soil % heat_cap_lower_limit ) +DEALLOCATE ( soil % zse_vec ) +DEALLOCATE ( soil % css_vec ) +DEALLOCATE ( soil % cnsd_vec ) +DEALLOCATE ( soil % cnsd ) +DEALLOCATE ( soil % pwb_min ) +DEALLOCATE ( soil % drain_dens ) +DEALLOCATE ( soil % elev ) +DEALLOCATE ( soil % elev_std ) +DEALLOCATE ( soil % slope ) +DEALLOCATE ( soil % slope_std ) +DEALLOCATE ( soil % sucs_vec ) +DEALLOCATE ( soil % hyds_vec ) +DEALLOCATE ( soil % bch_vec ) +DEALLOCATE ( soil % clay_vec ) +DEALLOCATE ( soil % sand_vec ) +DEALLOCATE ( soil % silt_vec ) +DEALLOCATE ( soil % org_vec ) +DEALLOCATE ( soil % rhosoil_vec ) +DEALLOCATE ( soil % ssat_vec ) +DEALLOCATE ( soil % watr ) +DEALLOCATE ( soil % sfc_vec ) +DEALLOCATE ( soil % swilt_vec ) +DEALLOCATE ( soil % GWhyds_vec ) +DEALLOCATE ( soil % GWsucs_vec ) +DEALLOCATE ( soil % GWbch_vec ) +DEALLOCATE ( soil % GWssat_vec ) +DEALLOCATE ( soil % GWwatr ) +DEALLOCATE ( soil % GWz ) +DEALLOCATE ( soil % GWdz ) +DEALLOCATE ( soil % GWrhosoil_vec ) +DEALLOCATE ( soil % nhorizons ) +DEALLOCATE ( soil % ishorizon ) +DEALLOCATE ( soil % clitt ) +DEALLOCATE ( soil % zeta ) +DEALLOCATE ( soil % fsatmax ) + +RETURN +END SUBROUTINE dealloc_soil_type + +SUBROUTINE assoc_soil_type(soil, soil_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(soil_type), INTENT(IN OUT) :: soil +TYPE(soil_data_type), INTENT(IN OUT), TARGET :: soil_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_soil_cbl(soil) + +soil% isoilm => soil_data% isoilm +soil% bch => soil_data% bch +soil% c3 => soil_data% c3 +soil% clay => soil_data% clay +soil% css => soil_data% css +soil% hsbh => soil_data% hsbh +soil% hyds => soil_data% hyds +soil% i2bp3 => soil_data% i2bp3 +soil% ibp2 => soil_data% ibp2 +soil% rhosoil => soil_data% rhosoil +soil% sand => soil_data% sand +soil% sfc => soil_data% sfc +soil% silt => soil_data% silt +soil% ssat => soil_data% ssat +soil% sucs => soil_data% sucs +soil% swilt => soil_data% swilt +soil% zse => soil_data% zse +soil% zshh => soil_data% zshh +soil% soilcol => soil_data% soilcol +soil% albsoilf => soil_data% albsoilf +soil% albsoil => soil_data% albsoil +soil% heat_cap_lower_limit => soil_data% heat_cap_lower_limit +soil% zse_vec => soil_data% zse_vec +soil% css_vec => soil_data% css_vec +soil% cnsd_vec => soil_data% cnsd_vec +soil% cnsd => soil_data% cnsd +soil% pwb_min => soil_data% pwb_min +soil% drain_dens => soil_data% drain_dens +soil% elev => soil_data% elev +soil% elev_std => soil_data% elev_std +soil% slope => soil_data% slope +soil% slope_std => soil_data% slope_std +soil% sucs_vec => soil_data% sucs_vec +soil% hyds_vec => soil_data% hyds_vec +soil% bch_vec => soil_data% bch_vec +soil% clay_vec => soil_data% clay_vec +soil% sand_vec => soil_data% sand_vec +soil% silt_vec => soil_data% silt_vec +soil% org_vec => soil_data% org_vec +soil% rhosoil_vec => soil_data% rhosoil_vec +soil% ssat_vec => soil_data% ssat_vec +soil% watr => soil_data% watr +soil% sfc_vec => soil_data% sfc_vec +soil% swilt_vec => soil_data% swilt_vec +soil% GWhyds_vec => soil_data% GWhyds_vec +soil% GWsucs_vec => soil_data% GWsucs_vec +soil% GWbch_vec => soil_data% GWbch_vec +soil% GWssat_vec => soil_data% GWssat_vec +soil% GWwatr => soil_data% GWwatr +soil% GWz => soil_data% GWz +soil% GWdz => soil_data% GWdz +soil% GWrhosoil_vec => soil_data% GWrhosoil_vec +soil% nhorizons => soil_data% nhorizons +soil% ishorizon => soil_data% ishorizon +soil% clitt => soil_data% clitt +soil% zeta => soil_data% zeta +soil% fsatmax => soil_data% fsatmax + +RETURN +END SUBROUTINE assoc_soil_type + +SUBROUTINE nullify_soil_cbl( soil ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(soil_type), INTENT(IN OUT) :: soil + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( soil % isoilm ) +NULLIFY( soil % bch ) +NULLIFY( soil % c3 ) +NULLIFY( soil % clay ) +NULLIFY( soil % css ) +NULLIFY( soil % hsbh ) +NULLIFY( soil % hyds ) +NULLIFY( soil % i2bp3 ) +NULLIFY( soil % ibp2 ) +NULLIFY( soil % rhosoil ) +NULLIFY( soil % sand ) +NULLIFY( soil % sfc ) +NULLIFY( soil % silt ) +NULLIFY( soil % ssat ) +NULLIFY( soil % sucs ) +NULLIFY( soil % swilt ) +NULLIFY( soil % zse ) +NULLIFY( soil % zshh ) +NULLIFY( soil % soilcol ) +NULLIFY( soil % albsoilf ) +NULLIFY( soil % albsoil ) +NULLIFY( soil % heat_cap_lower_limit ) +NULLIFY( soil % zse_vec ) +NULLIFY( soil % css_vec ) +NULLIFY( soil % cnsd_vec ) +NULLIFY( soil % cnsd ) +NULLIFY( soil % pwb_min ) +NULLIFY( soil % drain_dens ) +NULLIFY( soil % elev ) +NULLIFY( soil % elev_std ) +NULLIFY( soil % slope ) +NULLIFY( soil % slope_std ) +NULLIFY( soil % sucs_vec ) +NULLIFY( soil % hyds_vec ) +NULLIFY( soil % bch_vec ) +NULLIFY( soil % clay_vec ) +NULLIFY( soil % sand_vec ) +NULLIFY( soil % silt_vec ) +NULLIFY( soil % org_vec ) +NULLIFY( soil % rhosoil_vec ) +NULLIFY( soil % ssat_vec ) +NULLIFY( soil % watr ) +NULLIFY( soil % sfc_vec ) +NULLIFY( soil % swilt_vec ) +NULLIFY( soil % GWhyds_vec ) +NULLIFY( soil % GWsucs_vec ) +NULLIFY( soil % GWbch_vec ) +NULLIFY( soil % GWssat_vec ) +NULLIFY( soil % GWwatr ) +NULLIFY( soil % GWz ) +NULLIFY( soil % GWdz ) +NULLIFY( soil % GWrhosoil_vec ) +NULLIFY( soil % nhorizons ) +NULLIFY( soil % ishorizon ) +NULLIFY( soil % clitt ) +NULLIFY( soil % zeta ) +NULLIFY( soil % fsatmax ) + +RETURN + +END SUBROUTINE nullify_soil_cbl + +END MODULE cable_soil_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/ssnow_type.F90 b/src/coupled/AM3/control/cable/CM3/ssnow_type.F90 new file mode 100644 index 000000000..c107987a6 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/ssnow_type.F90 @@ -0,0 +1,960 @@ +MODULE cable_soil_snow_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: soil_snow_type +PUBLIC :: soil_snow_data_type +PUBLIC :: alloc_soil_snow_type +PUBLIC :: dealloc_soil_snow_type +PUBLIC :: assoc_soil_snow_type +PUBLIC :: nullify_soil_snow_cbl + +! Soil and snow variables: +TYPE soil_snow_data_type + + INTEGER, ALLOCATABLE :: isflag(:) ! 0 => no snow 1 => snow + REAL, ALLOCATABLE :: iantrct (:) ! pointer to Antarctic land points + REAL, ALLOCATABLE :: pudsto (:) ! puddle storage + REAL, ALLOCATABLE :: pudsmx (:) ! puddle storage + REAL, ALLOCATABLE :: cls (:) ! factor for latent heat + REAL, ALLOCATABLE :: dfn_dtg (:) ! d(canopy%fns)/d(ssnow%tgg) + REAL, ALLOCATABLE :: dfh_dtg (:) ! d(canopy%fhs)/d(ssnow%tgg) + REAL, ALLOCATABLE :: dfe_ddq (:) ! d(canopy%fes)/d(dq) - REV_CORR: no longer necessary + REAL, ALLOCATABLE :: ddq_dtg (:) ! d(dq)/d(ssnow%tgg) - REV_CORR: no longer necessary + REAL, ALLOCATABLE :: dfe_dtg (:) ! d(canopy%fes)/d(ssnow%tgg) - REV_CORR: covers above vars + REAL, ALLOCATABLE :: evapsn (:) ! snow evaporation + REAL, ALLOCATABLE :: fwtop (:) ! water flux to the soil + REAL, ALLOCATABLE :: fwtop1 (:) ! water flux to the soil + REAL, ALLOCATABLE :: fwtop2 (:) ! water flux to the soil + REAL, ALLOCATABLE :: fwtop3 (:) ! water flux to the soil + REAL, ALLOCATABLE :: osnowd (:) ! snow depth from previous time step + REAL, ALLOCATABLE :: potev (:) ! potential evapotranspiration + REAL, ALLOCATABLE :: runoff (:) ! total runoff (mm/dels) + REAL, ALLOCATABLE :: rnof1 (:) ! surface runoff (mm/dels) + REAL, ALLOCATABLE :: rnof2 (:) ! deep drainage (mm/dels) + REAL, ALLOCATABLE :: rtsoil (:) ! turbulent resistance for soil + REAL, ALLOCATABLE :: wbtot1 (:) ! total soil water (mm) + REAL, ALLOCATABLE :: wbtot2 (:) ! total soil water (mm) + REAL, ALLOCATABLE :: wb_lake (:) + REAL, ALLOCATABLE :: totwblake (:) !daily integrated wb_lake: used in ACCESS + REAL, ALLOCATABLE :: sinfil (:) + REAL, ALLOCATABLE :: qstss (:) + REAL, ALLOCATABLE :: wetfac (:) ! surface wetness fact. at current time step + REAL, ALLOCATABLE :: owetfac (:) ! surface wetness fact. at previous time step + REAL, ALLOCATABLE :: t_snwlr (:) ! top snow layer depth in 3 layer snowpack + REAL, ALLOCATABLE :: tggav (:) ! mean soil temperature in K + REAL, ALLOCATABLE :: otgg (:) ! soil temperature in K + REAL, ALLOCATABLE :: otss (:) ! surface temperature (weighted soil, snow) + REAL, ALLOCATABLE :: tprecip (:) + REAL, ALLOCATABLE :: tevap (:) + REAL, ALLOCATABLE :: trnoff (:) + REAL, ALLOCATABLE :: totenbal (:) + REAL, ALLOCATABLE :: totenbal2 (:) + REAL, ALLOCATABLE :: fland (:) ! factor for latent heat + REAL, ALLOCATABLE :: ifland (:) ! integer soil type + REAL, ALLOCATABLE :: qasrf (:) ! heat advected to the snow by precip. + REAL, ALLOCATABLE :: qfsrf (:) ! energy of snowpack phase changes + REAL, ALLOCATABLE :: qssrf (:) ! sublimation + REAL, ALLOCATABLE :: snage (:) ! snow age + REAL, ALLOCATABLE :: snowd (:) ! snow depth (liquid water) + REAL, ALLOCATABLE :: smelt (:) ! snow melt + REAL, ALLOCATABLE :: ssdnn (:) ! average snow density + REAL, ALLOCATABLE :: tss (:) ! surface temperature (weighted soil, snow) + REAL, ALLOCATABLE :: tss_p (:) ! surface temperature (weighted soil, snow) + REAL, ALLOCATABLE :: deltss (:) ! surface temperature (weighted soil, snow) + REAL, ALLOCATABLE :: owb1 (:) ! surface temperature (weighted soil, snow) + + REAL, ALLOCATABLE :: sconds (:,:) ! + REAL, ALLOCATABLE :: sdepth (:,:) ! snow depth + REAL, ALLOCATABLE :: smass (:,:) ! snow mass + REAL, ALLOCATABLE :: ssdn (:,:) ! snow densities + REAL, ALLOCATABLE :: tgg (:,:) ! soil temperature in K + REAL, ALLOCATABLE :: tggsn (:,:) ! snow temperature in K + REAL, ALLOCATABLE :: dtmlt (:,:) ! water flux to the soil + REAL, ALLOCATABLE :: albsoilsn (:,:) ! soil + snow reflectance + REAL, ALLOCATABLE :: evapfbl (:,:) ! + REAL, ALLOCATABLE :: tilefrac (:,:) ! factor for latent heat + + REAL(r_2), ALLOCATABLE :: wbtot (:) ! total soil water (mm) + + REAL(r_2), ALLOCATABLE :: gammzz (:,:) ! heat capacity for each soil layer + REAL(r_2), ALLOCATABLE :: wb (:,:) ! volumetric soil moisture (solid+liq) + REAL(r_2), ALLOCATABLE :: wbice (:,:) ! soil ice + REAL(r_2), ALLOCATABLE :: wblf (:,:) + REAL(r_2), ALLOCATABLE :: wbfice (:,:) + + ! variables for the revised soil moisture + GW scheme + REAL(r_2), ALLOCATABLE :: GWwb (:) ! water content in aquifer [mm3/mm3] + REAL(r_2), ALLOCATABLE :: GWhk (:) ! aquifer hydraulic conductivity [mm/s] + REAL(r_2), ALLOCATABLE :: GWdhkdw (:) ! aquifer d(hk) over d(water content) [(mm/s)/(mm3/mm3)] + REAL(r_2), ALLOCATABLE :: GWdsmpdw (:) ! aquifer d(smp) / dw [(mm)/(mm3/mm3)] + REAL(r_2), ALLOCATABLE :: wtd (:) ! water table depth [mm] + REAL(r_2), ALLOCATABLE :: GWsmp (:) ! aquifer soil matric potential [mm] + REAL(r_2), ALLOCATABLE :: GWwbeq (:) ! equilibrium aquifer water content [mm3/mm3] + REAL(r_2), ALLOCATABLE :: GWzq (:) ! equilibrium aquifer smp [mm] + REAL(r_2), ALLOCATABLE :: qhz (:) ! horizontal hydraulic conductivity in 1D gw model for soil layers [mm/s] + REAL(r_2), ALLOCATABLE :: satfrac (:) + REAL(r_2), ALLOCATABLE :: Qrecharge (:) + REAL(r_2), ALLOCATABLE :: rh_srf (:) + REAL(r_2), ALLOCATABLE :: rtevap_sat (:) + REAL(r_2), ALLOCATABLE :: rtevap_unsat (:) + REAL(r_2), ALLOCATABLE :: rt_qh_sublayer(:) + + REAL(r_2), ALLOCATABLE :: wbeq (:,:) ! equilibrium water content [mm3/mm3] + REAL(r_2), ALLOCATABLE :: zq (:,:) ! equilibrium smp [mm] + REAL(r_2), ALLOCATABLE :: icefrac (:,:) ! ice fraction [none] -> ice mass / total mass + REAL(r_2), ALLOCATABLE :: fracice (:,:) ! alternate ice fraction [none] - parameterized + REAL(r_2), ALLOCATABLE :: hk (:,:) ! hydraulic conductivity for soil layers [mm/s] + REAL(r_2), ALLOCATABLE :: smp (:,:) ! soil matric potential for soil layers [mm] + REAL(r_2), ALLOCATABLE :: dhkdw (:,:) ! d(hydraulic conductivity ) d(water) for soil layers [(mm/s)/(mm3/mm3)] + REAL(r_2), ALLOCATABLE :: dsmpdw (:,:) ! d(smp)/ d(water) for soil layers [(mm)/(mm3/mm3)] + REAL(r_2), ALLOCATABLE :: wbliq (:,:) ! volumetric liquid water content [mm3/mm3] + REAL(r_2), ALLOCATABLE :: wmliq (:,:) ! water mass [mm] liq + REAL(r_2), ALLOCATABLE :: wmice (:,:) ! water mass [mm] ice + REAL(r_2), ALLOCATABLE :: wmtot (:,:) ! water mass [mm] liq+ice ->total + REAL(r_2), ALLOCATABLE :: qhlev (:,:) + + ! Additional SLI variables: + REAL(r_2), ALLOCATABLE :: S (:,:) ! moisture content relative to sat value (edit vh 23/01/08) + REAL(r_2), ALLOCATABLE :: Tsoil (:,:) ! Tsoil (deg C) + REAL(r_2), ALLOCATABLE :: SL (:) ! litter moisture content relative to sat value (edit vh 23/01/08) + REAL(r_2), ALLOCATABLE :: TL (:) ! litter temperature in K (edit vh 23/01/08) + REAL(r_2), ALLOCATABLE :: h0 (:) ! pond height in m (edit vh 23/01/08) + REAL(r_2), ALLOCATABLE :: rex (:,:) ! root extraction from each layer (mm/dels) + REAL(r_2), ALLOCATABLE :: wflux (:,:) ! water flux at layer boundaries (mm s-1) + REAL(r_2), ALLOCATABLE :: delwcol (:) ! change in water column (mm / dels) + REAL(r_2), ALLOCATABLE :: zdelta (:) ! water table depth (edit vh 23/06/08) + REAL(r_2), ALLOCATABLE :: kth (:,:) ! thermal conductivity (edit vh 29/07/08) + REAL(r_2), ALLOCATABLE :: Tsurface (:) ! tepmerature at surface (soil, pond or litter) (edit vh 22/10/08) + REAL(r_2), ALLOCATABLE :: lE (:) ! soil latent heat flux + REAL(r_2), ALLOCATABLE :: evap (:) ! soil evaporation (mm / dels) + REAL(r_2), ALLOCATABLE :: ciso (:,:) ! concentration of minor isotopologue in soil water (kg m-3 water) + REAL(r_2), ALLOCATABLE :: cisoL (:) ! concentration of minor isotopologue in litter water (kg m-3 water) + REAL(r_2), ALLOCATABLE :: rlitt (:) ! resistance to heat/moisture transfer through litter (m-1 s) + REAL(r_2), ALLOCATABLE :: thetai (:,:) ! volumetric ice content (MC) + REAL(r_2), ALLOCATABLE :: snowliq (:,:) ! liquid snow content (mm H2O) + REAL(r_2), ALLOCATABLE :: nsteps (:) ! number of iterations at each timestep + REAL(r_2), ALLOCATABLE :: TsurfaceFR (:) ! tepmerature at surface (soil, pond or litter) (edit vh 22/10/08) + REAL(r_2), ALLOCATABLE :: Ta_daily (:,:) ! air temp averaged over last 24h + INTEGER, ALLOCATABLE :: nsnow (:) ! number of layers in snow-pack (0-nsnow_max) + REAL(r_2), ALLOCATABLE :: Qadv_daily (:) ! advective heat flux into surface , daily average (W m-2) + REAL(r_2), ALLOCATABLE :: G0_daily (:) ! conductive heat flux into surface , daily average (W m-2) + REAL(r_2), ALLOCATABLE :: Qevap_daily (:) ! evaporative flux at surface, daily average (m s-1) + REAL(r_2), ALLOCATABLE :: Qprec_daily (:) ! liquid precip, daily average (m s-1) + REAL(r_2), ALLOCATABLE :: Qprec_snow_daily (:) ! solid precip, daily average (m s-1) + +END TYPE soil_snow_data_type + +TYPE soil_snow_type + + INTEGER, POINTER :: isflag(:) ! 0 => no snow 1 => snow + REAL, POINTER :: iantrct (:) ! pointer to Antarctic land points + REAL, POINTER :: pudsto (:) ! puddle storage + REAL, POINTER :: pudsmx (:) ! puddle storage + REAL, POINTER :: cls (:) ! factor for latent heat + REAL, POINTER :: dfn_dtg (:) ! d(canopy%fns)/d(ssnow%tgg) + REAL, POINTER :: dfh_dtg (:) ! d(canopy%fhs)/d(ssnow%tgg) + REAL, POINTER :: dfe_ddq (:) ! d(canopy%fes)/d(dq) - REV_CORR: no longer necessary + REAL, POINTER :: ddq_dtg (:) ! d(dq)/d(ssnow%tgg) - REV_CORR: no longer necessary + REAL, POINTER :: dfe_dtg (:) ! d(canopy%fes)/d(ssnow%tgg) - REV_CORR: covers above vars + REAL, POINTER :: evapsn (:) ! snow evaporation + REAL, POINTER :: fwtop (:) ! water flux to the soil + REAL, POINTER :: fwtop1 (:) ! water flux to the soil + REAL, POINTER :: fwtop2 (:) ! water flux to the soil + REAL, POINTER :: fwtop3 (:) ! water flux to the soil + REAL, POINTER :: osnowd (:) ! snow depth from previous time step + REAL, POINTER :: potev (:) ! potential evapotranspiration + REAL, POINTER :: runoff (:) ! total runoff (mm/dels) + REAL, POINTER :: rnof1 (:) ! surface runoff (mm/dels) + REAL, POINTER :: rnof2 (:) ! deep drainage (mm/dels) + REAL, POINTER :: rtsoil (:) ! turbulent resistance for soil + REAL, POINTER :: wbtot1 (:) ! total soil water (mm) + REAL, POINTER :: wbtot2 (:) ! total soil water (mm) + REAL, POINTER :: wb_lake (:) + REAL, POINTER :: totwblake (:) !daily integrated wb_lake: used in ACCESS + REAL, POINTER :: sinfil (:) + REAL, POINTER :: qstss (:) + REAL, POINTER :: wetfac (:) ! surface wetness fact. at current time step + REAL, POINTER :: owetfac (:) ! surface wetness fact. at previous time step + REAL, POINTER :: t_snwlr (:) ! top snow layer depth in 3 layer snowpack + REAL, POINTER :: tggav (:) ! mean soil temperature in K + REAL, POINTER :: otgg (:) ! soil temperature in K + REAL, POINTER :: otss (:) ! surface temperature (weighted soil, snow) + REAL, POINTER :: tprecip (:) + REAL, POINTER :: tevap (:) + REAL, POINTER :: trnoff (:) + REAL, POINTER :: totenbal (:) + REAL, POINTER :: totenbal2 (:) + REAL, POINTER :: fland (:) ! factor for latent heat + REAL, POINTER :: ifland (:) ! integer soil type + REAL, POINTER :: qasrf (:) ! heat advected to the snow by precip. + REAL, POINTER :: qfsrf (:) ! energy of snowpack phase changes + REAL, POINTER :: qssrf (:) ! sublimation + REAL, POINTER :: snage (:) ! snow age + REAL, POINTER :: snowd (:) ! snow depth (liquid water) + REAL, POINTER :: smelt (:) ! snow melt + REAL, POINTER :: ssdnn (:) ! average snow density + REAL, POINTER :: tss (:) ! surface temperature (weighted soil, snow) + REAL, POINTER :: tss_p (:) ! surface temperature (weighted soil, snow) + REAL, POINTER :: deltss (:) ! surface temperature (weighted soil, snow) + REAL, POINTER :: owb1 (:) ! surface temperature (weighted soil, snow) + + REAL, POINTER :: sconds (:,:) ! + REAL, POINTER :: sdepth (:,:) ! snow depth + REAL, POINTER :: smass (:,:) ! snow mass + REAL, POINTER :: ssdn (:,:) ! snow densities + REAL, POINTER :: tgg (:,:) ! soil temperature in K + REAL, POINTER :: tggsn (:,:) ! snow temperature in K + REAL, POINTER :: dtmlt (:,:) ! water flux to the soil + REAL, POINTER :: albsoilsn (:,:) ! soil + snow reflectance + REAL, POINTER :: evapfbl (:,:) ! + REAL, POINTER :: tilefrac (:,:) ! factor for latent heat + + REAL(r_2), POINTER :: wbtot (:) ! total soil water (mm) + + REAL(r_2), POINTER :: gammzz (:,:) ! heat capacity for each soil layer + REAL(r_2), POINTER :: wb (:,:) ! volumetric soil moisture (solid+liq) + REAL(r_2), POINTER :: wbice (:,:) ! soil ice + REAL(r_2), POINTER :: wblf (:,:) + REAL(r_2), POINTER :: wbfice (:,:) + + ! variables for the revised soil moisture + GW scheme + REAL(r_2), POINTER :: GWwb (:) ! water content in aquifer [mm3/mm3] + REAL(r_2), POINTER :: GWhk (:) ! aquifer hydraulic conductivity [mm/s] + REAL(r_2), POINTER :: GWdhkdw (:) ! aquifer d(hk) over d(water content) [(mm/s)/(mm3/mm3)] + REAL(r_2), POINTER :: GWdsmpdw (:) ! aquifer d(smp) / dw [(mm)/(mm3/mm3)] + REAL(r_2), POINTER :: wtd (:) ! water table depth [mm] + REAL(r_2), POINTER :: GWsmp (:) ! aquifer soil matric potential [mm] + REAL(r_2), POINTER :: GWwbeq (:) ! equilibrium aquifer water content [mm3/mm3] + REAL(r_2), POINTER :: GWzq (:) ! equilibrium aquifer smp [mm] + REAL(r_2), POINTER :: qhz (:) ! horizontal hydraulic conductivity in 1D gw model for soil layers [mm/s] + REAL(r_2), POINTER :: satfrac (:) + REAL(r_2), POINTER :: Qrecharge (:) + REAL(r_2), POINTER :: rh_srf (:) + REAL(r_2), POINTER :: rtevap_sat (:) + REAL(r_2), POINTER :: rtevap_unsat (:) + REAL(r_2), POINTER :: rt_qh_sublayer(:) + + REAL(r_2), POINTER :: wbeq (:,:) ! equilibrium water content [mm3/mm3] + REAL(r_2), POINTER :: zq (:,:) ! equilibrium smp [mm] + REAL(r_2), POINTER :: icefrac (:,:) ! ice fraction [none] -> ice mass / total mass + REAL(r_2), POINTER :: fracice (:,:) ! alternate ice fraction [none] - parameterized + REAL(r_2), POINTER :: hk (:,:) ! hydraulic conductivity for soil layers [mm/s] + REAL(r_2), POINTER :: smp (:,:) ! soil matric potential for soil layers [mm] + REAL(r_2), POINTER :: dhkdw (:,:) ! d(hydraulic conductivity ) d(water) for soil layers [(mm/s)/(mm3/mm3)] + REAL(r_2), POINTER :: dsmpdw (:,:) ! d(smp)/ d(water) for soil layers [(mm)/(mm3/mm3)] + REAL(r_2), POINTER :: wbliq (:,:) ! volumetric liquid water content [mm3/mm3] + REAL(r_2), POINTER :: wmliq (:,:) ! water mass [mm] liq + REAL(r_2), POINTER :: wmice (:,:) ! water mass [mm] ice + REAL(r_2), POINTER :: wmtot (:,:) ! water mass [mm] liq+ice ->total + REAL(r_2), POINTER :: qhlev (:,:) + + ! Additional SLI variables: + REAL(r_2), POINTER :: S (:,:) ! moisture content relative to sat value (edit vh 23/01/08) + REAL(r_2), POINTER :: Tsoil (:,:) ! Tsoil (deg C) + REAL(r_2), POINTER :: SL (:) ! litter moisture content relative to sat value (edit vh 23/01/08) + REAL(r_2), POINTER :: TL (:) ! litter temperature in K (edit vh 23/01/08) + REAL(r_2), POINTER :: h0 (:) ! pond height in m (edit vh 23/01/08) + REAL(r_2), POINTER :: rex (:,:) ! root extraction from each layer (mm/dels) + REAL(r_2), POINTER :: wflux (:,:) ! water flux at layer boundaries (mm s-1) + REAL(r_2), POINTER :: delwcol (:) ! change in water column (mm / dels) + REAL(r_2), POINTER :: zdelta (:) ! water table depth (edit vh 23/06/08) + REAL(r_2), POINTER :: kth (:,:) ! thermal conductivity (edit vh 29/07/08) + REAL(r_2), POINTER :: Tsurface (:) ! tepmerature at surface (soil, pond or litter) (edit vh 22/10/08) + REAL(r_2), POINTER :: lE (:) ! soil latent heat flux + REAL(r_2), POINTER :: evap (:) ! soil evaporation (mm / dels) + REAL(r_2), POINTER :: ciso (:,:) ! concentration of minor isotopologue in soil water (kg m-3 water) + REAL(r_2), POINTER :: cisoL (:) ! concentration of minor isotopologue in litter water (kg m-3 water) + REAL(r_2), POINTER :: rlitt (:) ! resistance to heat/moisture transfer through litter (m-1 s) + REAL(r_2), POINTER :: thetai (:,:) ! volumetric ice content (MC) + REAL(r_2), POINTER :: snowliq (:,:) ! liquid snow content (mm H2O) + REAL(r_2), POINTER :: nsteps (:) ! number of iterations at each timestep + REAL(r_2), POINTER :: TsurfaceFR (:) ! tepmerature at surface (soil, pond or litter) (edit vh 22/10/08) + REAL(r_2), POINTER :: Ta_daily (:,:) ! air temp averaged over last 24h + INTEGER, POINTER :: nsnow (:) ! number of layers in snow-pack (0-nsnow_max) + REAL(r_2), POINTER :: Qadv_daily (:) ! advective heat flux into surface , daily average (W m-2) + REAL(r_2), POINTER :: G0_daily (:) ! conductive heat flux into surface , daily average (W m-2) + REAL(r_2), POINTER :: Qevap_daily (:) ! evaporative flux at surface, daily average (m s-1) + REAL(r_2), POINTER :: Qprec_daily (:) ! liquid precip, daily average (m s-1) + REAL(r_2), POINTER :: Qprec_snow_daily (:) ! solid precip, daily average (m s-1) + +END TYPE soil_snow_type + +CONTAINS + +SUBROUTINE alloc_soil_snow_type(soil_snow, mp) + +USE grid_constants_mod_cbl, ONLY: nsnl ! # snow layers +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: nrb ! # radiation bands *2SW, *1LW(legacy) +USE grid_constants_mod_cbl, ONLY: ntype_max ! # PFTs + +IMPLICIT NONE + +TYPE(soil_snow_data_type), INTENT(INOUT) :: soil_snow +INTEGER, INTENT(IN) :: mp + +ALLOCATE( soil_snow% isflag (mp) ) +ALLOCATE( soil_snow% iantrct (mp) ) +ALLOCATE( soil_snow% pudsto (mp) ) +ALLOCATE( soil_snow% pudsmx (mp) ) +ALLOCATE( soil_snow% cls (mp) ) +ALLOCATE( soil_snow% dfn_dtg (mp) ) +ALLOCATE( soil_snow% dfh_dtg (mp) ) +ALLOCATE( soil_snow% dfe_ddq (mp) ) +ALLOCATE( soil_snow% ddq_dtg (mp) ) +ALLOCATE( soil_snow% dfe_dtg (mp) ) +ALLOCATE( soil_snow% evapsn (mp) ) +ALLOCATE( soil_snow% fwtop (mp) ) +ALLOCATE( soil_snow% fwtop1 (mp) ) +ALLOCATE( soil_snow% fwtop2 (mp) ) +ALLOCATE( soil_snow% fwtop3 (mp) ) +ALLOCATE( soil_snow% osnowd (mp) ) +ALLOCATE( soil_snow% potev (mp) ) +ALLOCATE( soil_snow% runoff (mp) ) +ALLOCATE( soil_snow% rnof1 (mp) ) +ALLOCATE( soil_snow% rnof2 (mp) ) +ALLOCATE( soil_snow% rtsoil (mp) ) +ALLOCATE( soil_snow% wbtot1 (mp) ) +ALLOCATE( soil_snow% wbtot2 (mp) ) +ALLOCATE( soil_snow% wb_lake (mp) ) +ALLOCATE( soil_snow% totwblake (mp) ) +ALLOCATE( soil_snow% sinfil (mp) ) +ALLOCATE( soil_snow% qstss (mp) ) +ALLOCATE( soil_snow% wetfac (mp) ) +ALLOCATE( soil_snow% owetfac (mp) ) +ALLOCATE( soil_snow% t_snwlr (mp) ) +ALLOCATE( soil_snow% tggav (mp) ) +ALLOCATE( soil_snow% otgg (mp) ) +ALLOCATE( soil_snow% otss (mp) ) +ALLOCATE( soil_snow% tprecip (mp) ) +ALLOCATE( soil_snow% tevap (mp) ) +ALLOCATE( soil_snow% trnoff (mp) ) +ALLOCATE( soil_snow% totenbal (mp) ) +ALLOCATE( soil_snow% totenbal2 (mp) ) +ALLOCATE( soil_snow% fland (mp) ) +ALLOCATE( soil_snow% ifland (mp) ) +ALLOCATE( soil_snow% qasrf (mp) ) +ALLOCATE( soil_snow% qfsrf (mp) ) +ALLOCATE( soil_snow% qssrf (mp) ) +ALLOCATE( soil_snow% snage (mp) ) +ALLOCATE( soil_snow% snowd (mp) ) +ALLOCATE( soil_snow% smelt (mp) ) +ALLOCATE( soil_snow% ssdnn (mp) ) +ALLOCATE( soil_snow% tss (mp) ) +ALLOCATE( soil_snow% tss_p (mp) ) +ALLOCATE( soil_snow% deltss (mp) ) +ALLOCATE( soil_snow% owb1 (mp) ) +ALLOCATE( soil_snow% sconds (mp,nsnl) ) +ALLOCATE( soil_snow% sdepth (mp,nsnl) ) +ALLOCATE( soil_snow% smass (mp,nsnl) ) +ALLOCATE( soil_snow% ssdn (mp,nsnl) ) +ALLOCATE( soil_snow% tgg (mp,nsl) ) +ALLOCATE( soil_snow% tggsn (mp,nsnl) ) +ALLOCATE( soil_snow% dtmlt (mp,nsnl) ) +ALLOCATE( soil_snow% albsoilsn (mp,nrb) ) +ALLOCATE( soil_snow% evapfbl (mp,nsl) ) +ALLOCATE( soil_snow% tilefrac (mp,ntype_max) ) +ALLOCATE( soil_snow% wbtot (mp) ) +ALLOCATE( soil_snow% gammzz (mp,nsl) ) +ALLOCATE( soil_snow% wb (mp,nsl) ) +ALLOCATE( soil_snow% wbice (mp,nsl) ) +ALLOCATE( soil_snow% wblf (mp,nsl) ) +ALLOCATE( soil_snow% wbfice (mp,nsl) ) +ALLOCATE( soil_snow% GWwb (mp) ) +ALLOCATE( soil_snow% GWhk (mp) ) +ALLOCATE( soil_snow% GWdhkdw (mp) ) +ALLOCATE( soil_snow% GWdsmpdw (mp) ) +ALLOCATE( soil_snow% wtd (mp) ) +ALLOCATE( soil_snow% GWsmp (mp) ) +ALLOCATE( soil_snow% GWwbeq (mp) ) +ALLOCATE( soil_snow% GWzq (mp) ) +ALLOCATE( soil_snow% qhz (mp) ) +ALLOCATE( soil_snow% satfrac (mp) ) +ALLOCATE( soil_snow% Qrecharge (mp) ) +ALLOCATE( soil_snow% rh_srf (mp) ) +ALLOCATE( soil_snow% rtevap_sat (mp) ) +ALLOCATE( soil_snow% rtevap_unsat (mp) ) +ALLOCATE( soil_snow% rt_qh_sublayer(mp) ) +ALLOCATE( soil_snow% wbeq (mp,nsl) ) +ALLOCATE( soil_snow% zq (mp,nsl) ) +ALLOCATE( soil_snow% icefrac (mp,nsl) ) +ALLOCATE( soil_snow% fracice (mp,nsl) ) +ALLOCATE( soil_snow% hk (mp,nsl) ) +ALLOCATE( soil_snow% smp (mp,nsl) ) +ALLOCATE( soil_snow% dhkdw (mp,nsl) ) +ALLOCATE( soil_snow% dsmpdw (mp,nsl) ) +ALLOCATE( soil_snow% wbliq (mp,nsl) ) +ALLOCATE( soil_snow% wmliq (mp,nsl) ) +ALLOCATE( soil_snow% wmice (mp,nsl) ) +ALLOCATE( soil_snow% wmtot (mp,nsl) ) +ALLOCATE( soil_snow% qhlev (mp,nsl+1) ) +ALLOCATE( soil_snow% S (mp,nsl) ) +ALLOCATE( soil_snow% Tsoil (mp,nsl) ) +ALLOCATE( soil_snow% SL (mp) ) +ALLOCATE( soil_snow% TL (mp) ) +ALLOCATE( soil_snow% h0 (mp) ) +ALLOCATE( soil_snow% rex (mp,nsl) ) +ALLOCATE( soil_snow% wflux (mp,0:nsl) ) +ALLOCATE( soil_snow% delwcol (mp) ) +ALLOCATE( soil_snow% zdelta (mp) ) +ALLOCATE( soil_snow% kth (mp,nsl) ) +ALLOCATE( soil_snow% Tsurface (mp) ) +ALLOCATE( soil_snow% lE (mp) ) +ALLOCATE( soil_snow% evap (mp) ) +ALLOCATE( soil_snow% ciso (mp,nsl+1) ) +ALLOCATE( soil_snow% cisoL (mp) ) +ALLOCATE( soil_snow% rlitt (mp) ) +ALLOCATE( soil_snow% thetai (mp,nsl) ) +ALLOCATE( soil_snow% snowliq (mp,nsnl) ) +ALLOCATE( soil_snow% nsteps (mp) ) +ALLOCATE( soil_snow% TsurfaceFR (mp) ) +ALLOCATE( soil_snow% Ta_daily (mp,100) ) +ALLOCATE( soil_snow% nsnow (mp) ) +ALLOCATE( soil_snow% Qadv_daily (mp) ) +ALLOCATE( soil_snow% G0_daily (mp) ) +ALLOCATE( soil_snow% Qevap_daily (mp) ) +ALLOCATE( soil_snow% Qprec_daily (mp) ) +ALLOCATE( soil_snow% Qprec_snow_daily (mp) ) + +soil_snow % isflag (:) = 0.0 +soil_snow % iantrct (:) = 0.0 +soil_snow % pudsto (:) = 0.0 +soil_snow % pudsmx (:) = 0.0 +soil_snow % cls (:) = 0.0 +soil_snow % dfn_dtg (:) = 0.0 +soil_snow % dfh_dtg (:) = 0.0 +soil_snow % dfe_ddq (:) = 0.0 +soil_snow % ddq_dtg (:) = 0.0 +soil_snow % dfe_dtg (:) = 0.0 +soil_snow % evapsn (:) = 0.0 +soil_snow % fwtop (:) = 0.0 +soil_snow % fwtop1 (:) = 0.0 +soil_snow % fwtop2 (:) = 0.0 +soil_snow % fwtop3 (:) = 0.0 +soil_snow % osnowd (:) = 0.0 +soil_snow % potev (:) = 0.0 +soil_snow % runoff (:) = 0.0 +soil_snow % rnof1 (:) = 0.0 +soil_snow % rnof2 (:) = 0.0 +soil_snow % rtsoil (:) = 0.0 +soil_snow % wbtot1 (:) = 0.0 +soil_snow % wbtot2 (:) = 0.0 +soil_snow % wb_lake (:) = 0.0 +soil_snow % totwblake (:) = 0.0 +soil_snow % sinfil (:) = 0.0 +soil_snow % qstss (:) = 0.0 +soil_snow % wetfac (:) = 0.0 +soil_snow % owetfac (:) = 0.0 +soil_snow % t_snwlr (:) = 0.0 +soil_snow % tggav (:) = 0.0 +soil_snow % otgg (:) = 0.0 +soil_snow % otss (:) = 0.0 +soil_snow % tprecip (:) = 0.0 +soil_snow % tevap (:) = 0.0 +soil_snow % trnoff (:) = 0.0 +soil_snow % totenbal (:) = 0.0 +soil_snow % totenbal2 (:) = 0.0 +soil_snow % fland (:) = 0.0 +soil_snow % ifland (:) = 0.0 +soil_snow % qasrf (:) = 0.0 +soil_snow % qfsrf (:) = 0.0 +soil_snow % qssrf (:) = 0.0 +soil_snow % snage (:) = 0.0 +soil_snow % snowd (:) = 0.0 +soil_snow % smelt (:) = 0.0 +soil_snow % ssdnn (:) = 0.0 +soil_snow % tss (:) = 0.0 +soil_snow % tss_p (:) = 0.0 +soil_snow % deltss (:) = 0.0 +soil_snow % owb1 (:) = 0.0 +soil_snow % sconds (:,:) = 0.0 +soil_snow % sdepth (:,:) = 0.0 +soil_snow % smass (:,:) = 0.0 +soil_snow % ssdn (:,:) = 0.0 +soil_snow % tgg (:,:) = 0.0 +soil_snow % tggsn (:,:) = 0.0 +soil_snow % dtmlt (:,:) = 0.0 +soil_snow % albsoilsn (:,:) = 0.0 +soil_snow % evapfbl (:,:) = 0.0 +soil_snow % tilefrac (:,:) = 0.0 +soil_snow % wbtot (:) = 0.0 +soil_snow % gammzz (:,:) = 0.0 +soil_snow % wb (:,:) = 0.0 +soil_snow % wbice (:,:) = 0.0 +soil_snow % wblf (:,:) = 0.0 +soil_snow % wbfice (:,:) = 0.0 +soil_snow % GWwb (:) = 0.0 +soil_snow % GWhk (:) = 0.0 +soil_snow % GWdhkdw (:) = 0.0 +soil_snow % GWdsmpdw (:) = 0.0 +soil_snow % wtd (:) = 0.0 +soil_snow % GWsmp (:) = 0.0 +soil_snow % GWwbeq (:) = 0.0 +soil_snow % GWzq (:) = 0.0 +soil_snow % qhz (:) = 0.0 +soil_snow % satfrac (:) = 0.0 +soil_snow % Qrecharge (:) = 0.0 +soil_snow % rh_srf (:) = 0.0 +soil_snow % rtevap_sat (:) = 0.0 +soil_snow % rtevap_unsat (:) = 0.0 +soil_snow % rt_qh_sublayer (:) = 0.0 +soil_snow % wbeq (:,:) = 0.0 +soil_snow % zq (:,:) = 0.0 +soil_snow % icefrac (:,:) = 0.0 +soil_snow % fracice (:,:) = 0.0 +soil_snow % hk (:,:) = 0.0 +soil_snow % smp (:,:) = 0.0 +soil_snow % dhkdw (:,:) = 0.0 +soil_snow % dsmpdw (:,:) = 0.0 +soil_snow % wbliq (:,:) = 0.0 +soil_snow % wmliq (:,:) = 0.0 +soil_snow % wmice (:,:) = 0.0 +soil_snow % wmtot (:,:) = 0.0 +soil_snow % qhlev (:,:) = 0.0 +soil_snow % S (:,:) = 0.0 +soil_snow % Tsoil (:,:) = 0.0 +soil_snow % SL (:) = 0.0 +soil_snow % TL (:) = 0.0 +soil_snow % h0 (:) = 0.0 +soil_snow % rex (:,:) = 0.0 +soil_snow % wflux (:,:) = 0.0 +soil_snow % delwcol (:) = 0.0 +soil_snow % zdelta (:) = 0.0 +soil_snow % kth (:,:) = 0.0 +soil_snow % Tsurface (:) = 0.0 +soil_snow % lE (:) = 0.0 +soil_snow % evap (:) = 0.0 +soil_snow % ciso (:,:) = 0.0 +soil_snow % cisoL (:) = 0.0 +soil_snow % rlitt (:) = 0.0 +soil_snow % thetai (:,:) = 0.0 +soil_snow % snowliq (:,:) = 0.0 +soil_snow % nsteps (:) = 0.0 +soil_snow % TsurfaceFR (:) = 0.0 +soil_snow % Ta_daily (:,:) = 0.0 +soil_snow % nsnow (:) = 0.0 +soil_snow % Qadv_daily (:) = 0.0 +soil_snow % G0_daily (:) = 0.0 +soil_snow % Qevap_daily (:) = 0.0 +soil_snow % Qprec_daily (:) = 0.0 +soil_snow % Qprec_snow_daily(:) = 0.0 + +RETURN +END SUBROUTINE alloc_soil_snow_type + +SUBROUTINE dealloc_soil_snow_type(soil_snow) + +TYPE(soil_snow_type), INTENT(inout) :: soil_snow + +DEALLOCATE ( soil_snow % isflag ) +DEALLOCATE ( soil_snow % iantrct ) +DEALLOCATE ( soil_snow % pudsto ) +DEALLOCATE ( soil_snow % pudsmx ) +DEALLOCATE ( soil_snow % cls ) +DEALLOCATE ( soil_snow % dfn_dtg ) +DEALLOCATE ( soil_snow % dfh_dtg ) +DEALLOCATE ( soil_snow % dfe_ddq ) +DEALLOCATE ( soil_snow % ddq_dtg ) +DEALLOCATE ( soil_snow % dfe_dtg ) +DEALLOCATE ( soil_snow % evapsn ) +DEALLOCATE ( soil_snow % fwtop ) +DEALLOCATE ( soil_snow % fwtop1 ) +DEALLOCATE ( soil_snow % fwtop2 ) +DEALLOCATE ( soil_snow % fwtop3 ) +DEALLOCATE ( soil_snow % osnowd ) +DEALLOCATE ( soil_snow % potev ) +DEALLOCATE ( soil_snow % runoff ) +DEALLOCATE ( soil_snow % rnof1 ) +DEALLOCATE ( soil_snow % rnof2 ) +DEALLOCATE ( soil_snow % rtsoil ) +DEALLOCATE ( soil_snow % wbtot1 ) +DEALLOCATE ( soil_snow % wbtot2 ) +DEALLOCATE ( soil_snow % wb_lake ) +DEALLOCATE ( soil_snow % totwblake ) +DEALLOCATE ( soil_snow % sinfil ) +DEALLOCATE ( soil_snow % qstss ) +DEALLOCATE ( soil_snow % wetfac ) +DEALLOCATE ( soil_snow % owetfac ) +DEALLOCATE ( soil_snow % t_snwlr ) +DEALLOCATE ( soil_snow % tggav ) +DEALLOCATE ( soil_snow % otgg ) +DEALLOCATE ( soil_snow % otss ) +DEALLOCATE ( soil_snow % tprecip ) +DEALLOCATE ( soil_snow % tevap ) +DEALLOCATE ( soil_snow % trnoff ) +DEALLOCATE ( soil_snow % totenbal ) +DEALLOCATE ( soil_snow % totenbal2 ) +DEALLOCATE ( soil_snow % fland ) +DEALLOCATE ( soil_snow % ifland ) +DEALLOCATE ( soil_snow % qasrf ) +DEALLOCATE ( soil_snow % qfsrf ) +DEALLOCATE ( soil_snow % qssrf ) +DEALLOCATE ( soil_snow % snage ) +DEALLOCATE ( soil_snow % snowd ) +DEALLOCATE ( soil_snow % smelt ) +DEALLOCATE ( soil_snow % ssdnn ) +DEALLOCATE ( soil_snow % tss ) +DEALLOCATE ( soil_snow % tss_p ) +DEALLOCATE ( soil_snow % deltss ) +DEALLOCATE ( soil_snow % owb1 ) +DEALLOCATE ( soil_snow % sconds ) +DEALLOCATE ( soil_snow % sdepth ) +DEALLOCATE ( soil_snow % smass ) +DEALLOCATE ( soil_snow % ssdn ) +DEALLOCATE ( soil_snow % tgg ) +DEALLOCATE ( soil_snow % tggsn ) +DEALLOCATE ( soil_snow % dtmlt ) +DEALLOCATE ( soil_snow % albsoilsn ) +DEALLOCATE ( soil_snow % evapfbl ) +DEALLOCATE ( soil_snow % tilefrac ) +DEALLOCATE ( soil_snow % wbtot ) +DEALLOCATE ( soil_snow % gammzz ) +DEALLOCATE ( soil_snow % wb ) +DEALLOCATE ( soil_snow % wbice ) +DEALLOCATE ( soil_snow % wblf ) +DEALLOCATE ( soil_snow % wbfice ) +DEALLOCATE ( soil_snow % GWwb ) +DEALLOCATE ( soil_snow % GWhk ) +DEALLOCATE ( soil_snow % GWdhkdw ) +DEALLOCATE ( soil_snow % GWdsmpdw ) +DEALLOCATE ( soil_snow % wtd ) +DEALLOCATE ( soil_snow % GWsmp ) +DEALLOCATE ( soil_snow % GWwbeq ) +DEALLOCATE ( soil_snow % GWzq ) +DEALLOCATE ( soil_snow % qhz ) +DEALLOCATE ( soil_snow % satfrac ) +DEALLOCATE ( soil_snow % Qrecharge ) +DEALLOCATE ( soil_snow % rh_srf ) +DEALLOCATE ( soil_snow % rtevap_sat ) +DEALLOCATE ( soil_snow % rtevap_unsat ) +DEALLOCATE ( soil_snow % rt_qh_sublayer ) +DEALLOCATE ( soil_snow % wbeq ) +DEALLOCATE ( soil_snow % zq ) +DEALLOCATE ( soil_snow % icefrac ) +DEALLOCATE ( soil_snow % fracice ) +DEALLOCATE ( soil_snow % hk ) +DEALLOCATE ( soil_snow % smp ) +DEALLOCATE ( soil_snow % dhkdw ) +DEALLOCATE ( soil_snow % dsmpdw ) +DEALLOCATE ( soil_snow % wbliq ) +DEALLOCATE ( soil_snow % wmliq ) +DEALLOCATE ( soil_snow % wmice ) +DEALLOCATE ( soil_snow % wmtot ) +DEALLOCATE ( soil_snow % qhlev ) +DEALLOCATE ( soil_snow % S ) +DEALLOCATE ( soil_snow % Tsoil ) +DEALLOCATE ( soil_snow % SL ) +DEALLOCATE ( soil_snow % TL ) +DEALLOCATE ( soil_snow % h0 ) +DEALLOCATE ( soil_snow % rex ) +DEALLOCATE ( soil_snow % wflux ) +DEALLOCATE ( soil_snow % delwcol ) +DEALLOCATE ( soil_snow % zdelta ) +DEALLOCATE ( soil_snow % kth ) +DEALLOCATE ( soil_snow % Tsurface ) +DEALLOCATE ( soil_snow % lE ) +DEALLOCATE ( soil_snow % evap ) +DEALLOCATE ( soil_snow % ciso ) +DEALLOCATE ( soil_snow % cisoL ) +DEALLOCATE ( soil_snow % rlitt ) +DEALLOCATE ( soil_snow % thetai ) +DEALLOCATE ( soil_snow % snowliq ) +DEALLOCATE ( soil_snow % nsteps ) +DEALLOCATE ( soil_snow % TsurfaceFR ) +DEALLOCATE ( soil_snow % Ta_daily ) +DEALLOCATE ( soil_snow % nsnow ) +DEALLOCATE ( soil_snow % Qadv_daily ) +DEALLOCATE ( soil_snow % G0_daily ) +DEALLOCATE ( soil_snow % Qevap_daily ) +DEALLOCATE ( soil_snow % Qprec_daily ) +DEALLOCATE ( soil_snow % Qprec_snow_daily) + +RETURN +END SUBROUTINE dealloc_soil_snow_type + +SUBROUTINE assoc_soil_snow_type(soil_snow, soil_snow_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(soil_snow_type), INTENT(IN OUT) :: soil_snow +TYPE(soil_snow_data_type), INTENT(IN OUT), TARGET :: soil_snow_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_soil_snow_cbl(soil_snow) + +soil_snow% isflag => soil_snow_data% isflag +soil_snow% iantrct => soil_snow_data% iantrct +soil_snow% pudsto => soil_snow_data% pudsto +soil_snow% pudsmx => soil_snow_data% pudsmx +soil_snow% cls => soil_snow_data% cls +soil_snow% dfn_dtg => soil_snow_data% dfn_dtg +soil_snow% dfh_dtg => soil_snow_data% dfh_dtg +soil_snow% dfe_ddq => soil_snow_data% dfe_ddq +soil_snow% ddq_dtg => soil_snow_data% ddq_dtg +soil_snow% dfe_dtg => soil_snow_data% dfe_dtg +soil_snow% evapsn => soil_snow_data% evapsn +soil_snow% fwtop => soil_snow_data% fwtop +soil_snow% fwtop1 => soil_snow_data% fwtop1 +soil_snow% fwtop2 => soil_snow_data% fwtop2 +soil_snow% fwtop3 => soil_snow_data% fwtop3 +soil_snow% osnowd => soil_snow_data% osnowd +soil_snow% potev => soil_snow_data% potev +soil_snow% runoff => soil_snow_data% runoff +soil_snow% rnof1 => soil_snow_data% rnof1 +soil_snow% rnof2 => soil_snow_data% rnof2 +soil_snow% rtsoil => soil_snow_data% rtsoil +soil_snow% wbtot1 => soil_snow_data% wbtot1 +soil_snow% wbtot2 => soil_snow_data% wbtot2 +soil_snow% wb_lake => soil_snow_data% wb_lake +soil_snow% totwblake => soil_snow_data% totwblake +soil_snow% sinfil => soil_snow_data% sinfil +soil_snow% qstss => soil_snow_data% qstss +soil_snow% wetfac => soil_snow_data% wetfac +soil_snow% owetfac => soil_snow_data% owetfac +soil_snow% t_snwlr => soil_snow_data% t_snwlr +soil_snow% tggav => soil_snow_data% tggav +soil_snow% otgg => soil_snow_data% otgg +soil_snow% otss => soil_snow_data% otss +soil_snow% tprecip => soil_snow_data% tprecip +soil_snow% tevap => soil_snow_data% tevap +soil_snow% trnoff => soil_snow_data% trnoff +soil_snow% totenbal => soil_snow_data% totenbal +soil_snow% totenbal2 => soil_snow_data% totenbal2 +soil_snow% fland => soil_snow_data% fland +soil_snow% ifland => soil_snow_data% ifland +soil_snow% qasrf => soil_snow_data% qasrf +soil_snow% qfsrf => soil_snow_data% qfsrf +soil_snow% qssrf => soil_snow_data% qssrf +soil_snow% snage => soil_snow_data% snage +soil_snow% snowd => soil_snow_data% snowd +soil_snow% smelt => soil_snow_data% smelt +soil_snow% ssdnn => soil_snow_data% ssdnn +soil_snow% tss => soil_snow_data% tss +soil_snow% tss_p => soil_snow_data% tss_p +soil_snow% deltss => soil_snow_data% deltss +soil_snow% owb1 => soil_snow_data% owb1 +soil_snow% sconds => soil_snow_data% sconds +soil_snow% sdepth => soil_snow_data% sdepth +soil_snow% smass => soil_snow_data% smass +soil_snow% ssdn => soil_snow_data% ssdn +soil_snow% tgg => soil_snow_data% tgg +soil_snow% tggsn => soil_snow_data% tggsn +soil_snow% dtmlt => soil_snow_data% dtmlt +soil_snow% albsoilsn => soil_snow_data% albsoilsn +soil_snow% evapfbl => soil_snow_data% evapfbl +soil_snow% tilefrac => soil_snow_data% tilefrac +soil_snow% wbtot => soil_snow_data% wbtot +soil_snow% gammzz => soil_snow_data% gammzz +soil_snow% wb => soil_snow_data% wb +soil_snow% wbice => soil_snow_data% wbice +soil_snow% wblf => soil_snow_data% wblf +soil_snow% wbfice => soil_snow_data% wbfice +soil_snow% GWwb => soil_snow_data% GWwb +soil_snow% GWhk => soil_snow_data% GWhk +soil_snow% GWdhkdw => soil_snow_data% GWdhkdw +soil_snow% GWdsmpdw => soil_snow_data% GWdsmpdw +soil_snow% wtd => soil_snow_data% wtd +soil_snow% GWsmp => soil_snow_data% GWsmp +soil_snow% GWwbeq => soil_snow_data% GWwbeq +soil_snow% GWzq => soil_snow_data% GWzq +soil_snow% qhz => soil_snow_data% qhz +soil_snow% satfrac => soil_snow_data% satfrac +soil_snow% Qrecharge => soil_snow_data% Qrecharge +soil_snow% rh_srf => soil_snow_data% rh_srf +soil_snow% rtevap_sat => soil_snow_data% rtevap_sat +soil_snow% rtevap_unsat => soil_snow_data% rtevap_unsat +soil_snow% rt_qh_sublayer => soil_snow_data% rt_qh_sublayer +soil_snow% wbeq => soil_snow_data% wbeq +soil_snow% zq => soil_snow_data% zq +soil_snow% icefrac => soil_snow_data% icefrac +soil_snow% fracice => soil_snow_data% fracice +soil_snow% hk => soil_snow_data% hk +soil_snow% smp => soil_snow_data% smp +soil_snow% dhkdw => soil_snow_data% dhkdw +soil_snow% dsmpdw => soil_snow_data% dsmpdw +soil_snow% wbliq => soil_snow_data% wbliq +soil_snow% wmliq => soil_snow_data% wmliq +soil_snow% wmice => soil_snow_data% wmice +soil_snow% wmtot => soil_snow_data% wmtot +soil_snow% qhlev => soil_snow_data% qhlev +soil_snow% S => soil_snow_data% S +soil_snow% Tsoil => soil_snow_data% Tsoil +soil_snow% SL => soil_snow_data% SL +soil_snow% TL => soil_snow_data% TL +soil_snow% h0 => soil_snow_data% h0 +soil_snow% rex => soil_snow_data% rex +soil_snow% wflux => soil_snow_data% wflux +soil_snow% delwcol => soil_snow_data% delwcol +soil_snow% zdelta => soil_snow_data% zdelta +soil_snow% kth => soil_snow_data% kth +soil_snow% Tsurface => soil_snow_data% Tsurface +soil_snow% lE => soil_snow_data% lE +soil_snow% evap => soil_snow_data% evap +soil_snow% ciso => soil_snow_data% ciso +soil_snow% cisoL => soil_snow_data% cisoL +soil_snow% rlitt => soil_snow_data% rlitt +soil_snow% thetai => soil_snow_data% thetai +soil_snow% snowliq => soil_snow_data% snowliq +soil_snow% nsteps => soil_snow_data% nsteps +soil_snow% TsurfaceFR => soil_snow_data% TsurfaceFR +soil_snow% Ta_daily => soil_snow_data% Ta_daily +soil_snow% nsnow => soil_snow_data% nsnow +soil_snow% Qadv_daily => soil_snow_data% Qadv_daily +soil_snow% G0_daily => soil_snow_data% G0_daily +soil_snow% Qevap_daily => soil_snow_data% Qevap_daily +soil_snow% Qprec_daily => soil_snow_data% Qprec_daily +soil_snow% Qprec_snow_daily => soil_snow_data% Qprec_snow_daily + +RETURN +END SUBROUTINE assoc_soil_snow_type + +SUBROUTINE nullify_soil_snow_cbl( soil_snow ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(soil_snow_type), INTENT(IN OUT) :: soil_snow + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( soil_snow % isflag ) +NULLIFY( soil_snow % iantrct ) +NULLIFY( soil_snow % pudsto ) +NULLIFY( soil_snow % pudsmx ) +NULLIFY( soil_snow % cls ) +NULLIFY( soil_snow % dfn_dtg ) +NULLIFY( soil_snow % dfh_dtg ) +NULLIFY( soil_snow % dfe_ddq ) +NULLIFY( soil_snow % ddq_dtg ) +NULLIFY( soil_snow % dfe_dtg ) +NULLIFY( soil_snow % evapsn ) +NULLIFY( soil_snow % fwtop ) +NULLIFY( soil_snow % fwtop1 ) +NULLIFY( soil_snow % fwtop2 ) +NULLIFY( soil_snow % fwtop3 ) +NULLIFY( soil_snow % osnowd ) +NULLIFY( soil_snow % potev ) +NULLIFY( soil_snow % runoff ) +NULLIFY( soil_snow % rnof1 ) +NULLIFY( soil_snow % rnof2 ) +NULLIFY( soil_snow % rtsoil ) +NULLIFY( soil_snow % wbtot1 ) +NULLIFY( soil_snow % wbtot2 ) +NULLIFY( soil_snow % wb_lake ) +NULLIFY( soil_snow % totwblake ) +NULLIFY( soil_snow % sinfil ) +NULLIFY( soil_snow % qstss ) +NULLIFY( soil_snow % wetfac ) +NULLIFY( soil_snow % owetfac ) +NULLIFY( soil_snow % t_snwlr ) +NULLIFY( soil_snow % tggav ) +NULLIFY( soil_snow % otgg ) +NULLIFY( soil_snow % otss ) +NULLIFY( soil_snow % tprecip ) +NULLIFY( soil_snow % tevap ) +NULLIFY( soil_snow % trnoff ) +NULLIFY( soil_snow % totenbal ) +NULLIFY( soil_snow % totenbal2 ) +NULLIFY( soil_snow % fland ) +NULLIFY( soil_snow % ifland ) +NULLIFY( soil_snow % qasrf ) +NULLIFY( soil_snow % qfsrf ) +NULLIFY( soil_snow % qssrf ) +NULLIFY( soil_snow % snage ) +NULLIFY( soil_snow % snowd ) +NULLIFY( soil_snow % smelt ) +NULLIFY( soil_snow % ssdnn ) +NULLIFY( soil_snow % tss ) +NULLIFY( soil_snow % tss_p ) +NULLIFY( soil_snow % deltss ) +NULLIFY( soil_snow % owb1 ) +NULLIFY( soil_snow % sconds ) +NULLIFY( soil_snow % sdepth ) +NULLIFY( soil_snow % smass ) +NULLIFY( soil_snow % ssdn ) +NULLIFY( soil_snow % tgg ) +NULLIFY( soil_snow % tggsn ) +NULLIFY( soil_snow % dtmlt ) +NULLIFY( soil_snow % albsoilsn ) +NULLIFY( soil_snow % evapfbl ) +NULLIFY( soil_snow % tilefrac ) +NULLIFY( soil_snow % wbtot ) +NULLIFY( soil_snow % gammzz ) +NULLIFY( soil_snow % wb ) +NULLIFY( soil_snow % wbice ) +NULLIFY( soil_snow % wblf ) +NULLIFY( soil_snow % wbfice ) +NULLIFY( soil_snow % GWwb ) +NULLIFY( soil_snow % GWhk ) +NULLIFY( soil_snow % GWdhkdw ) +NULLIFY( soil_snow % GWdsmpdw ) +NULLIFY( soil_snow % wtd ) +NULLIFY( soil_snow % GWsmp ) +NULLIFY( soil_snow % GWwbeq ) +NULLIFY( soil_snow % GWzq ) +NULLIFY( soil_snow % qhz ) +NULLIFY( soil_snow % satfrac ) +NULLIFY( soil_snow % Qrecharge ) +NULLIFY( soil_snow % rh_srf ) +NULLIFY( soil_snow % rtevap_sat ) +NULLIFY( soil_snow % rtevap_unsat ) +NULLIFY( soil_snow % rt_qh_sublayer ) +NULLIFY( soil_snow % wbeq ) +NULLIFY( soil_snow % zq ) +NULLIFY( soil_snow % icefrac ) +NULLIFY( soil_snow % fracice ) +NULLIFY( soil_snow % hk ) +NULLIFY( soil_snow % smp ) +NULLIFY( soil_snow % dhkdw ) +NULLIFY( soil_snow % dsmpdw ) +NULLIFY( soil_snow % wbliq ) +NULLIFY( soil_snow % wmliq ) +NULLIFY( soil_snow % wmice ) +NULLIFY( soil_snow % wmtot ) +NULLIFY( soil_snow % qhlev ) +NULLIFY( soil_snow % S ) +NULLIFY( soil_snow % Tsoil ) +NULLIFY( soil_snow % SL ) +NULLIFY( soil_snow % TL ) +NULLIFY( soil_snow % h0 ) +NULLIFY( soil_snow % rex ) +NULLIFY( soil_snow % wflux ) +NULLIFY( soil_snow % delwcol ) +NULLIFY( soil_snow % zdelta ) +NULLIFY( soil_snow % kth ) +NULLIFY( soil_snow % Tsurface ) +NULLIFY( soil_snow % lE ) +NULLIFY( soil_snow % evap ) +NULLIFY( soil_snow % ciso ) +NULLIFY( soil_snow % cisoL ) +NULLIFY( soil_snow % rlitt ) +NULLIFY( soil_snow % thetai ) +NULLIFY( soil_snow % snowliq ) +NULLIFY( soil_snow % nsteps ) +NULLIFY( soil_snow % TsurfaceFR ) +NULLIFY( soil_snow % Ta_daily ) +NULLIFY( soil_snow % nsnow ) +NULLIFY( soil_snow % Qadv_daily ) +NULLIFY( soil_snow % G0_daily ) +NULLIFY( soil_snow % Qevap_daily ) +NULLIFY( soil_snow % Qprec_daily ) +NULLIFY( soil_snow % Qprec_snow_daily ) + +RETURN + +END SUBROUTINE nullify_soil_snow_cbl + +END MODULE cable_soil_snow_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/sum_flux_type.F90 b/src/coupled/AM3/control/cable/CM3/sum_flux_type.F90 new file mode 100644 index 000000000..d3cc53e86 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/sum_flux_type.F90 @@ -0,0 +1,173 @@ +MODULE cable_sum_flux_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: sum_flux_type +PUBLIC :: sum_flux_data_type +PUBLIC :: alloc_sum_flux_type +PUBLIC :: dealloc_sum_flux_type +PUBLIC :: assoc_sum_flux_type +PUBLIC :: nullify_sum_flux_cbl + +! Cumulative flux variables: +TYPE sum_flux_data_type + + REAL, ALLOCATABLE :: sumpn (:) ! sum of canopy photosynthesis (g C m-2) + REAL, ALLOCATABLE :: sumrp (:) ! sum of plant respiration (g C m-2) + REAL, ALLOCATABLE :: sumrpw (:) ! sum of plant respiration (g C m-2) + REAL, ALLOCATABLE :: sumrpr (:) ! sum of plant respiration (g C m-2) + REAL, ALLOCATABLE :: sumrs (:) ! sum of soil respiration (g C m-2) + REAL, ALLOCATABLE :: sumrd (:) ! sum of daytime respiration (g C m-2) + REAL, ALLOCATABLE :: dsumpn (:) ! daily sumpn + REAL, ALLOCATABLE :: dsumrp (:) ! daily sumrp + REAL, ALLOCATABLE :: dsumrs (:) ! daily sumrs + REAL, ALLOCATABLE :: dsumrd (:) ! daily sumrd + REAL, ALLOCATABLE :: sumxrp (:) ! sum plant resp. modifier + REAL, ALLOCATABLE :: sumxrs (:) ! sum soil resp. modifier + +END TYPE sum_flux_data_type + +TYPE sum_flux_type + + REAL, POINTER :: sumpn (:) ! sum of canopy photosynthesis (g C m-2) + REAL, POINTER :: sumrp (:) ! sum of plant respiration (g C m-2) + REAL, POINTER :: sumrpw (:) ! sum of plant respiration (g C m-2) + REAL, POINTER :: sumrpr (:) ! sum of plant respiration (g C m-2) + REAL, POINTER :: sumrs (:) ! sum of soil respiration (g C m-2) + REAL, POINTER :: sumrd (:) ! sum of daytime respiration (g C m-2) + REAL, POINTER :: dsumpn (:) ! daily sumpn + REAL, POINTER :: dsumrp (:) ! daily sumrp + REAL, POINTER :: dsumrs (:) ! daily sumrs + REAL, POINTER :: dsumrd (:) ! daily sumrd + REAL, POINTER :: sumxrp (:) ! sum plant resp. modifier + REAL, POINTER :: sumxrs (:) ! sum soil resp. modifier + +END TYPE sum_flux_type + +CONTAINS + +SUBROUTINE alloc_sum_flux_type(sum_flux, mp) + +USE grid_constants_mod_cbl, ONLY: mf ! # leaves (sunlit/shaded) +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: niter ! number of iterations for za/L + +IMPLICIT NONE + +TYPE(sum_flux_data_type), INTENT(INOUT) :: sum_flux +INTEGER, INTENT(IN) :: mp + +ALLOCATE( sum_flux% sumpn (mp) ) +ALLOCATE( sum_flux% sumrp (mp) ) +ALLOCATE( sum_flux% sumrpw (mp) ) +ALLOCATE( sum_flux% sumrpr (mp) ) +ALLOCATE( sum_flux% sumrs (mp) ) +ALLOCATE( sum_flux% sumrd (mp) ) +ALLOCATE( sum_flux% dsumpn (mp) ) +ALLOCATE( sum_flux% dsumrp (mp) ) +ALLOCATE( sum_flux% dsumrs (mp) ) +ALLOCATE( sum_flux% dsumrd (mp) ) +ALLOCATE( sum_flux% sumxrp (mp) ) +ALLOCATE( sum_flux% sumxrs (mp) ) + +sum_flux % sumpn (:) = 0.0 +sum_flux % sumrp (:) = 0.0 +sum_flux % sumrpw (:) = 0.0 +sum_flux % sumrpr (:) = 0.0 +sum_flux % sumrs (:) = 0.0 +sum_flux % sumrd (:) = 0.0 +sum_flux % dsumpn (:) = 0.0 +sum_flux % dsumrp (:) = 0.0 +sum_flux % dsumrs (:) = 0.0 +sum_flux % dsumrd (:) = 0.0 +sum_flux % sumxrp (:) = 0.0 +sum_flux % sumxrs (:) = 0.0 + +RETURN +END SUBROUTINE alloc_sum_flux_type + +SUBROUTINE dealloc_sum_flux_type(sum_flux) + +TYPE(sum_flux_type), INTENT(inout) :: sum_flux + +DEALLOCATE ( sum_flux % sumpn ) +DEALLOCATE ( sum_flux % sumrp ) +DEALLOCATE ( sum_flux % sumrpw ) +DEALLOCATE ( sum_flux % sumrpr ) +DEALLOCATE ( sum_flux % sumrs ) +DEALLOCATE ( sum_flux % sumrd ) +DEALLOCATE ( sum_flux % dsumpn ) +DEALLOCATE ( sum_flux % dsumrp ) +DEALLOCATE ( sum_flux % dsumrs ) +DEALLOCATE ( sum_flux % dsumrd ) +DEALLOCATE ( sum_flux % sumxrp ) +DEALLOCATE ( sum_flux % sumxrs ) + +RETURN +END SUBROUTINE dealloc_sum_flux_type + +SUBROUTINE assoc_sum_flux_type(sum_flux, sum_flux_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(sum_flux_type), INTENT(IN OUT) :: sum_flux +TYPE(sum_flux_data_type), INTENT(IN OUT), TARGET :: sum_flux_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_sum_flux_cbl(sum_flux) + +sum_flux% sumpn => sum_flux_data% sumpn +sum_flux% sumrp => sum_flux_data% sumrp +sum_flux% sumrpw => sum_flux_data% sumrpw +sum_flux% sumrpr => sum_flux_data% sumrpr +sum_flux% sumrs => sum_flux_data% sumrs +sum_flux% sumrd => sum_flux_data% sumrd +sum_flux% dsumpn => sum_flux_data% dsumpn +sum_flux% dsumrp => sum_flux_data% dsumrp +sum_flux% dsumrs => sum_flux_data% dsumrs +sum_flux% dsumrd => sum_flux_data% dsumrd +sum_flux% sumxrp => sum_flux_data% sumxrp +sum_flux% sumxrs => sum_flux_data% sumxrs + +RETURN +END SUBROUTINE assoc_sum_flux_type + +SUBROUTINE nullify_sum_flux_cbl( sum_flux ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(sum_flux_type), INTENT(IN OUT) :: sum_flux + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( sum_flux % sumpn ) +NULLIFY( sum_flux % sumrp ) +NULLIFY( sum_flux % sumrpw ) +NULLIFY( sum_flux % sumrpr ) +NULLIFY( sum_flux % sumrs ) +NULLIFY( sum_flux % sumrd ) +NULLIFY( sum_flux % dsumpn ) +NULLIFY( sum_flux % dsumrp ) +NULLIFY( sum_flux % dsumrs ) +NULLIFY( sum_flux % dsumrd ) +NULLIFY( sum_flux % sumxrp ) +NULLIFY( sum_flux % sumxrs ) + +RETURN + +END SUBROUTINE nullify_sum_flux_cbl + +END MODULE cable_sum_flux_type_mod diff --git a/src/coupled/AM3/control/cable/CM3/veg_type.F90 b/src/coupled/AM3/control/cable/CM3/veg_type.F90 new file mode 100644 index 000000000..f886d6466 --- /dev/null +++ b/src/coupled/AM3/control/cable/CM3/veg_type.F90 @@ -0,0 +1,429 @@ +MODULE cable_veg_type_mod + +USE cable_other_constants_mod, ONLY: r_2 + +IMPLICIT NONE + +PUBLIC :: veg_type +PUBLIC :: veg_data_type +PUBLIC :: alloc_veg_type +PUBLIC :: dealloc_veg_type +PUBLIC :: assoc_veg_type +PUBLIC :: nullify_veg_cbl + +! Vegetation parameters: +TYPE veg_data_type + + INTEGER, ALLOCATABLE :: iveg (:) ! vegetation(+nveg) type + INTEGER, ALLOCATABLE :: iLU (:) ! land use type + LOGICAL, ALLOCATABLE :: deciduous (:) ! flag used for phenology fix + + REAL, ALLOCATABLE :: canst1 (:) ! max intercepted water by canopy (mm/LAI) + REAL, ALLOCATABLE :: dleaf (:) ! chararacteristc legnth of leaf (m) + REAL, ALLOCATABLE :: ejmax (:) ! max pot. electron transp rate top leaf(mol/m2/s) + REAL, ALLOCATABLE :: meth (:) ! method for calculation of canopy fluxes and temp. + REAL, ALLOCATABLE :: frac4 (:) ! fraction of c4 plants + REAL, ALLOCATABLE :: hc (:) ! roughness height of canopy (veg - snow) + REAL, ALLOCATABLE :: vlai (:) ! leaf area index + REAL, ALLOCATABLE :: xalbnir (:) + REAL, ALLOCATABLE :: rp20 (:) ! plant respiration coefficient at 20 C + REAL, ALLOCATABLE :: rpcoef (:) ! temperature coef nonleaf plant respiration (1/C) + REAL, ALLOCATABLE :: rs20 (:) ! soil respiration at 20 C [mol m-2 s-1] + REAL, ALLOCATABLE :: shelrb (:) ! sheltering factor (dimensionless) + REAL, ALLOCATABLE :: vegcf (:) ! kdcorbin, 08/10 + REAL, ALLOCATABLE :: tminvj (:) ! min temperature of the start of photosynthesis + REAL, ALLOCATABLE :: toptvj (:) ! opt temperature of the start of photosynthesis + REAL, ALLOCATABLE :: tmaxvj (:) ! max temperature of the start of photosynthesis + REAL, ALLOCATABLE :: vbeta (:) ! + REAL, ALLOCATABLE :: vcmax (:) ! max RuBP carboxylation rate top leaf (mol/m2/s) + REAL, ALLOCATABLE :: xfang (:) ! leaf angle PARAMETER + REAL, ALLOCATABLE :: extkn (:) ! extinction coef for vertical + REAL, ALLOCATABLE :: vlaimax (:) ! extinction coef for vertical + REAL, ALLOCATABLE :: wai (:) ! wood area index (stem+branches+twigs) + REAL, ALLOCATABLE :: a1gs (:) ! a1 parameter in stomatal conductance model + REAL, ALLOCATABLE :: d0gs (:) ! d0 in stomatal conductance model + REAL, ALLOCATABLE :: alpha (:) ! initial slope of J-Q response curve + REAL, ALLOCATABLE :: convex (:) ! convexity of J-Q response curve + REAL, ALLOCATABLE :: cfrd (:) ! ratio of day respiration to vcmax + REAL, ALLOCATABLE :: gswmin (:) ! minimal stomatal conductance + REAL, ALLOCATABLE :: conkc0 (:) ! Michaelis-menton constant for carboxylase + REAL, ALLOCATABLE :: conko0 (:) ! Michaelis-menton constant for oxygenase + REAL, ALLOCATABLE :: ekc (:) ! activation energy for caroxylagse + REAL, ALLOCATABLE :: eko (:) ! acvtivation enegery for oxygenase + REAL, ALLOCATABLE :: g0 (:) ! Belinda's stomatal model intercept, Ticket #56. + REAL, ALLOCATABLE :: g1 (:) ! Belinda's stomatal model slope, Ticket #56. + + REAL, ALLOCATABLE :: refl (:,:) + REAL, ALLOCATABLE :: taul (:,:) + REAL, ALLOCATABLE :: froot (:,:) ! fraction of root in each soil layer + + ! Additional veg parameters: + REAL(r_2), ALLOCATABLE :: rootbeta (:) ! parameter for estimating vertical root mass distribution (froot) + REAL(r_2), ALLOCATABLE :: gamma (:) ! parameter in root efficiency function (Lai and Katul 2000) + REAL(r_2), ALLOCATABLE :: ZR (:) ! maximum rooting depth (cm) + REAL(r_2), ALLOCATABLE :: F10 (:) ! fraction of roots in top 10 cm + REAL(r_2), ALLOCATABLE :: clitt (:) ! + + ! Additional POP veg param + INTEGER, ALLOCATABLE :: disturbance_interval (:,:) + REAL(r_2), ALLOCATABLE :: disturbance_intensity (:,:) ! + +END TYPE veg_data_type + +TYPE veg_type + + INTEGER, POINTER :: iveg (:) ! vegetation(+nveg) type + INTEGER, POINTER :: iLU (:) ! land use type + LOGICAL, POINTER :: deciduous (:) ! flag used for phenology fix + + REAL, POINTER :: canst1 (:) ! max intercepted water by canopy (mm/LAI) + REAL, POINTER :: dleaf (:) ! chararacteristc legnth of leaf (m) + REAL, POINTER :: ejmax (:) ! max pot. electron transp rate top leaf(mol/m2/s) + REAL, POINTER :: meth (:) ! method for calculation of canopy fluxes and temp. + REAL, POINTER :: frac4 (:) ! fraction of c4 plants + REAL, POINTER :: hc (:) ! roughness height of canopy (veg - snow) + REAL, POINTER :: vlai (:) ! leaf area index + REAL, POINTER :: xalbnir (:) + REAL, POINTER :: rp20 (:) ! plant respiration coefficient at 20 C + REAL, POINTER :: rpcoef (:) ! temperature coef nonleaf plant respiration (1/C) + REAL, POINTER :: rs20 (:) ! soil respiration at 20 C [mol m-2 s-1] + REAL, POINTER :: shelrb (:) ! sheltering factor (dimensionless) + REAL, POINTER :: vegcf (:) ! kdcorbin, 08/10 + REAL, POINTER :: tminvj (:) ! min temperature of the start of photosynthesis + REAL, POINTER :: toptvj (:) ! opt temperature of the start of photosynthesis + REAL, POINTER :: tmaxvj (:) ! max temperature of the start of photosynthesis + REAL, POINTER :: vbeta (:) ! + REAL, POINTER :: vcmax (:) ! max RuBP carboxylation rate top leaf (mol/m2/s) + REAL, POINTER :: xfang (:) ! leaf angle PARAMETER + REAL, POINTER :: extkn (:) ! extinction coef for vertical + REAL, POINTER :: vlaimax (:) ! extinction coef for vertical + REAL, POINTER :: wai (:) ! wood area index (stem+branches+twigs) + REAL, POINTER :: a1gs (:) ! a1 parameter in stomatal conductance model + REAL, POINTER :: d0gs (:) ! d0 in stomatal conductance model + REAL, POINTER :: alpha (:) ! initial slope of J-Q response curve + REAL, POINTER :: convex (:) ! convexity of J-Q response curve + REAL, POINTER :: cfrd (:) ! ratio of day respiration to vcmax + REAL, POINTER :: gswmin (:) ! minimal stomatal conductance + REAL, POINTER :: conkc0 (:) ! Michaelis-menton constant for carboxylase + REAL, POINTER :: conko0 (:) ! Michaelis-menton constant for oxygenase + REAL, POINTER :: ekc (:) ! activation energy for caroxylagse + REAL, POINTER :: eko (:) ! acvtivation enegery for oxygenase + REAL, POINTER :: g0 (:) ! Belinda's stomatal model intercept, Ticket #56. + REAL, POINTER :: g1 (:) ! Belinda's stomatal model slope, Ticket #56. + + REAL, POINTER :: refl (:,:) + REAL, POINTER :: taul (:,:) + REAL, POINTER :: froot (:,:) ! fraction of root in each soil layer + + ! Additional veg parameters: + REAL(r_2), POINTER :: rootbeta (:) ! parameter for estimating vertical root mass distribution (froot) + REAL(r_2), POINTER :: gamma (:) ! parameter in root efficiency function (Lai and Katul 2000) + REAL(r_2), POINTER :: ZR (:) ! maximum rooting depth (cm) + REAL(r_2), POINTER :: F10 (:) ! fraction of roots in top 10 cm + REAL(r_2), POINTER :: clitt (:) ! + + ! Additional POP veg param + INTEGER, POINTER :: disturbance_interval (:,:) + REAL(r_2), POINTER :: disturbance_intensity (:,:) ! + +END TYPE veg_type + +CONTAINS + +SUBROUTINE alloc_veg_type(veg, mp) + +USE grid_constants_mod_cbl, ONLY: nsl ! # soil layers +USE grid_constants_mod_cbl, ONLY: swb ! # Radiation SW bands + +IMPLICIT NONE + +TYPE(veg_data_type), INTENT(INOUT) :: veg +INTEGER, INTENT(IN) :: mp + +ALLOCATE( veg% iveg (mp) ) +ALLOCATE( veg% iLU (mp) ) +ALLOCATE( veg% deciduous (mp) ) +ALLOCATE( veg% canst1 (mp) ) +ALLOCATE( veg% dleaf (mp) ) +ALLOCATE( veg% ejmax (mp) ) +ALLOCATE( veg% meth (mp) ) +ALLOCATE( veg% frac4 (mp) ) +ALLOCATE( veg% hc (mp) ) +ALLOCATE( veg% vlai (mp) ) +ALLOCATE( veg% xalbnir (mp) ) +ALLOCATE( veg% rp20 (mp) ) +ALLOCATE( veg% rpcoef (mp) ) +ALLOCATE( veg% rs20 (mp) ) +ALLOCATE( veg% shelrb (mp) ) +ALLOCATE( veg% vegcf (mp) ) +ALLOCATE( veg% tminvj (mp) ) +ALLOCATE( veg% toptvj (mp) ) +ALLOCATE( veg% tmaxvj (mp) ) +ALLOCATE( veg% vbeta (mp) ) +ALLOCATE( veg% vcmax (mp) ) +ALLOCATE( veg% xfang (mp) ) +ALLOCATE( veg% extkn (mp) ) +ALLOCATE( veg% vlaimax (mp) ) +ALLOCATE( veg% wai (mp) ) +ALLOCATE( veg% a1gs (mp) ) +ALLOCATE( veg% d0gs (mp) ) +ALLOCATE( veg% alpha (mp) ) +ALLOCATE( veg% convex (mp) ) +ALLOCATE( veg% cfrd (mp) ) +ALLOCATE( veg% gswmin (mp) ) +ALLOCATE( veg% conkc0 (mp) ) +ALLOCATE( veg% conko0 (mp) ) +ALLOCATE( veg% ekc (mp) ) +ALLOCATE( veg% eko (mp) ) +ALLOCATE( veg% g0 (mp) ) +ALLOCATE( veg% g1 (mp) ) +ALLOCATE( veg% refl (mp,swb) ) +ALLOCATE( veg% taul (mp,swb) ) +ALLOCATE( veg% froot (mp,nsl) ) +ALLOCATE( veg% rootbeta (mp) ) +ALLOCATE( veg% gamma (mp) ) +ALLOCATE( veg% ZR (mp) ) +ALLOCATE( veg% F10 (mp) ) +ALLOCATE( veg% clitt (mp) ) +ALLOCATE( veg% disturbance_interval (mp,2) ) !jhan:2?? +ALLOCATE( veg% disturbance_intensity (mp,2) ) !jhan:2?? + +veg % iveg (:) = 0.0 +veg % iLU (:) = 0.0 +veg % deciduous (:) = .FALSE. +veg % canst1 (:) = 0.0 +veg % dleaf (:) = 0.0 +veg % ejmax (:) = 0.0 +veg % meth (:) = 0.0 +veg % frac4 (:) = 0.0 +veg % hc (:) = 0.0 +veg % vlai (:) = 0.0 +veg % xalbnir (:) = 0.0 +veg % rp20 (:) = 0.0 +veg % rpcoef (:) = 0.0 +veg % rs20 (:) = 0.0 +veg % shelrb (:) = 0.0 +veg % vegcf (:) = 0.0 +veg % tminvj (:) = 0.0 +veg % toptvj (:) = 0.0 +veg % tmaxvj (:) = 0.0 +veg % vbeta (:) = 0.0 +veg % vcmax (:) = 0.0 +veg % xfang (:) = 0.0 +veg % extkn (:) = 0.0 +veg % vlaimax (:) = 0.0 +veg % wai (:) = 0.0 +veg % a1gs (:) = 0.0 +veg % d0gs (:) = 0.0 +veg % alpha (:) = 0.0 +veg % convex (:) = 0.0 +veg % cfrd (:) = 0.0 +veg % gswmin (:) = 0.0 +veg % conkc0 (:) = 0.0 +veg % conko0 (:) = 0.0 +veg % ekc (:) = 0.0 +veg % eko (:) = 0.0 +veg % g0 (:) = 0.0 +veg % g1 (:) = 0.0 +veg % refl (:,:) = 0.0 +veg % taul (:,:) = 0.0 +veg % froot (:,:) = 0.0 +veg % rootbeta (:) = 0.0 +veg % gamma (:) = 0.0 +veg % ZR (:) = 0.0 +veg % F10 (:) = 0.0 +veg % clitt (:) = 0.0 +veg % disturbance_interval (:,:) = 0.0 +veg % disturbance_intensity (:,:) = 0.0 + +RETURN +END SUBROUTINE alloc_veg_type + +SUBROUTINE dealloc_veg_type(veg) + +TYPE(veg_type), INTENT(inout) :: veg + +DEALLOCATE ( veg % iveg ) +DEALLOCATE ( veg % iLU ) +DEALLOCATE ( veg % deciduous ) +DEALLOCATE ( veg % canst1 ) +DEALLOCATE ( veg % dleaf ) +DEALLOCATE ( veg % ejmax ) +DEALLOCATE ( veg % meth ) +DEALLOCATE ( veg % frac4 ) +DEALLOCATE ( veg % hc ) +DEALLOCATE ( veg % vlai ) +DEALLOCATE ( veg % xalbnir ) +DEALLOCATE ( veg % rp20 ) +DEALLOCATE ( veg % rpcoef ) +DEALLOCATE ( veg % rs20 ) +DEALLOCATE ( veg % shelrb ) +DEALLOCATE ( veg % vegcf ) +DEALLOCATE ( veg % tminvj ) +DEALLOCATE ( veg % toptvj ) +DEALLOCATE ( veg % tmaxvj ) +DEALLOCATE ( veg % vbeta ) +DEALLOCATE ( veg % vcmax ) +DEALLOCATE ( veg % xfang ) +DEALLOCATE ( veg % extkn ) +DEALLOCATE ( veg % vlaimax ) +DEALLOCATE ( veg % wai ) +DEALLOCATE ( veg % a1gs ) +DEALLOCATE ( veg % d0gs ) +DEALLOCATE ( veg % alpha ) +DEALLOCATE ( veg % convex ) +DEALLOCATE ( veg % cfrd ) +DEALLOCATE ( veg % gswmin ) +DEALLOCATE ( veg % conkc0 ) +DEALLOCATE ( veg % conko0 ) +DEALLOCATE ( veg % ekc ) +DEALLOCATE ( veg % eko ) +DEALLOCATE ( veg % g0 ) +DEALLOCATE ( veg % g1 ) +DEALLOCATE ( veg % refl ) +DEALLOCATE ( veg % taul ) +DEALLOCATE ( veg % froot ) +DEALLOCATE ( veg % rootbeta ) +DEALLOCATE ( veg % gamma ) +DEALLOCATE ( veg % ZR ) +DEALLOCATE ( veg % F10 ) +DEALLOCATE ( veg % clitt ) +DEALLOCATE ( veg % disturbance_interval ) +DEALLOCATE ( veg % disturbance_intensity) + +RETURN +END SUBROUTINE dealloc_veg_type + +SUBROUTINE assoc_veg_type(veg, veg_data ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(veg_type), INTENT(IN OUT) :: veg +TYPE(veg_data_type), INTENT(IN OUT), TARGET :: veg_data + +CHARACTER(LEN=*), PARAMETER :: RoutineName='' +!End of header + +CALL nullify_veg_cbl(veg) + +veg% iveg => veg_data% iveg +veg% iLU => veg_data% iLU +veg% deciduous => veg_data% deciduous +veg% canst1 => veg_data% canst1 +veg% dleaf => veg_data% dleaf +veg% ejmax => veg_data% ejmax +veg% meth => veg_data% meth +veg% frac4 => veg_data% frac4 +veg% hc => veg_data% hc +veg% vlai => veg_data% vlai +veg% xalbnir => veg_data% xalbnir +veg% rp20 => veg_data% rp20 +veg% rpcoef => veg_data% rpcoef +veg% rs20 => veg_data% rs20 +veg% shelrb => veg_data% shelrb +veg% vegcf => veg_data% vegcf +veg% tminvj => veg_data% tminvj +veg% toptvj => veg_data% toptvj +veg% tmaxvj => veg_data% tmaxvj +veg% vbeta => veg_data% vbeta +veg% vcmax => veg_data% vcmax +veg% xfang => veg_data% xfang +veg% extkn => veg_data% extkn +veg% vlaimax => veg_data% vlaimax +veg% wai => veg_data% wai +veg% a1gs => veg_data% a1gs +veg% d0gs => veg_data% d0gs +veg% alpha => veg_data% alpha +veg% convex => veg_data% convex +veg% cfrd => veg_data% cfrd +veg% gswmin => veg_data% gswmin +veg% conkc0 => veg_data% conkc0 +veg% conko0 => veg_data% conko0 +veg% ekc => veg_data% ekc +veg% eko => veg_data% eko +veg% g0 => veg_data% g0 +veg% g1 => veg_data% g1 +veg% refl => veg_data% refl +veg% taul => veg_data% taul +veg% froot => veg_data% froot +veg% rootbeta => veg_data% rootbeta +veg% gamma => veg_data% gamma +veg% ZR => veg_data% ZR +veg% F10 => veg_data% F10 +veg% clitt => veg_data% clitt +veg% disturbance_interval => veg_data% disturbance_interval +veg% disturbance_intensity => veg_data% disturbance_intensity + +RETURN +END SUBROUTINE assoc_veg_type + +SUBROUTINE nullify_veg_cbl( veg ) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + +IMPLICIT NONE + +!Arguments +TYPE(veg_type), INTENT(IN OUT) :: veg + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_CBL_TYPES' +!End of header + +NULLIFY( veg % iveg ) +NULLIFY( veg % iLU ) +NULLIFY( veg % deciduous ) +NULLIFY( veg % canst1 ) +NULLIFY( veg % dleaf ) +NULLIFY( veg % ejmax ) +NULLIFY( veg % meth ) +NULLIFY( veg % frac4 ) +NULLIFY( veg % hc ) +NULLIFY( veg % vlai ) +NULLIFY( veg % xalbnir ) +NULLIFY( veg % rp20 ) +NULLIFY( veg % rpcoef ) +NULLIFY( veg % rs20 ) +NULLIFY( veg % shelrb ) +NULLIFY( veg % vegcf ) +NULLIFY( veg % tminvj ) +NULLIFY( veg % toptvj ) +NULLIFY( veg % tmaxvj ) +NULLIFY( veg % vbeta ) +NULLIFY( veg % vcmax ) +NULLIFY( veg % xfang ) +NULLIFY( veg % extkn ) +NULLIFY( veg % vlaimax ) +NULLIFY( veg % wai ) +NULLIFY( veg % a1gs ) +NULLIFY( veg % d0gs ) +NULLIFY( veg % alpha ) +NULLIFY( veg % convex ) +NULLIFY( veg % cfrd ) +NULLIFY( veg % gswmin ) +NULLIFY( veg % conkc0 ) +NULLIFY( veg % conko0 ) +NULLIFY( veg % ekc ) +NULLIFY( veg % eko ) +NULLIFY( veg % g0 ) +NULLIFY( veg % g1 ) +NULLIFY( veg % refl ) +NULLIFY( veg % taul ) +NULLIFY( veg % froot ) +NULLIFY( veg % rootbeta ) +NULLIFY( veg % gamma ) +NULLIFY( veg % ZR ) +NULLIFY( veg % F10 ) +NULLIFY( veg % clitt ) +NULLIFY( veg % disturbance_interval ) +NULLIFY( veg % disturbance_intensity ) + +RETURN + +END SUBROUTINE nullify_veg_cbl + +END MODULE cable_veg_type_mod diff --git a/src/coupled/AM3/control/cable/cable_land/explicit/cable_land_sf_explicit_cbl.F90 b/src/coupled/AM3/control/cable/cable_land/explicit/cable_land_sf_explicit_cbl.F90 new file mode 100644 index 000000000..56fe0626d --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/explicit/cable_land_sf_explicit_cbl.F90 @@ -0,0 +1,2931 @@ +! *****************************COPYRIGHT******************************* +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT******************************* +MODULE cable_land_sf_explicit_mod + +USE um_types, ONLY: real_jlslsm + +IMPLICIT NONE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: & + ModuleName='CABLE_LAND_SF_EXPLICIT_MOD' + +CONTAINS +! SUBROUTINE CABLE_LAND_SF_EXPLICIT --------------------------------- +! +! Purpose: Calculate explicit surface fluxes of heat, moisture and +! momentum over land. Also calculates surface exchange +! coefficients required for implicit update of surface +! fluxes and surface information required by the +! explicit boundary layer routine +! +! +! Documentation: UMDP 24. +! +! !CM3#55 - this routine is derived from jules_land_sf_explicit and +! and modified for the purposes of linking CABLE and JULES together +! in the surf_couple_explicit section - work commencing 6/12/2023 +! +! All edits will be accompanied by comments starting with !CM3#55-x +! referring to the git issue - where possible the included number x will +! refer to sub-issue as per the git discussion +! +!--------------------------------------------------------------------- +! Arguments :- +SUBROUTINE cable_land_sf_explicit ( & +! IN date-related values + curr_day_number, & +! IN values defining field dimensions and subset to be processed : + land_pts, & +! IN parameters for iterative SISL scheme + numcycles, cycleno, & +! IN parameters required from boundary-layer scheme : + bq_1,bt_1,z1_uv,z1_uv_top,z1_tq,z1_tq_top,qw_1,tl_1, & +! IN soil/vegetation/land surface data : + land_index,nsurft,sm_levels,canopy,catch,catch_snow,hcon_soilt, & + ho2r2_orog, flandg, & + snow_surft,sil_orog_land,smvccl_soilt,smvcst_soilt,smvcwt_soilt,sthf_soilt, & + sthu_soilt,z0_surft,z0h_surft_bare, z0m_soil_in, & +! IN input data from the wave model + charnock_w, & +! IN everything not covered so far : + pstar,lw_down,sw_surft,zh,ddmfx, & + co2_mmr,co2_3d,l_co2_interactive,l_phenol, & + asteps_since_triffid,cs_pool_soilt,veg_state,frac,canht_pft, & + photosynth_act_rad,lai_pft, & + l_mr_physics,t_soil_soilt,tsurf_elev_surft,tstar_surft,z_land, & + albsoil_soilt,cos_zenith_angle,l_aero_classic,l_dust,l_dust_diag, & + clay_soilt,o3, l_emis_surft_set, & +! INOUT diagnostics + sf_diag, & +! INOUT data : + emis_surft,gs,gc_corr,g_leaf_acc,npp_pft_acc,resp_w_pft_acc,resp_s_acc_soilt, & + rhostar,fqw_1,ftl_1,t1_sd,q1_sd,vshr,vshr_land, & +! OUT Diagnostic not requiring STASH flags : + ftl_surft, & +! OUT variables for message passing + rhokm_land, cdr10m, & +! OUT data required for mineral dust scheme + u_s_std_surft, & +! OUT data required elsewhere in boundary layer or surface code + alpha1,ashtf_prime_surft,fqw_surft,epot_surft,fraca, & + resfs,resft,rhokh_surft,dtstar_surft,z0h_surft, z0m_surft, & + chr1p5m,smc_soilt,hcons_soilt,gpp,npp,resp_p,g_leaf,gpp_pft,npp_pft, & + resp_p_pft,resp_s_soilt,resp_s_tot_soilt,resp_l_pft,resp_r_pft, & + resp_w_pft,n_leaf,n_root,n_stem,lai_bal,gc_surft,canhc_surft,wt_ext_surft, & + flake,surft_index,surft_pts,tile_frac,fsmc_pft,emis_soil, & +! OUT required for classic aerosols + cd_land,rib_surft,ch_surft_classic,cd_std_classic, & +! OUT required for sea and sea-ice calculations + l_cdr10m_snow, & + !New arguments replacing USE statements + !Fluxes (IN) + t_home_gb, t_growth_gb, & + !urban_param (IN) + emisr_gb, emisw_gb, hwr_gb, & + !jules_mod (IN OUT) + albobs_scaling_surft, & + !jules_chemvars_mod (OUT) + isoprene_gb, isoprene_pft, terpene_gb , terpene_pft, & + methanol_gb, methanol_pft, acetone_gb, acetone_pft, & + !trif_vars_mod (OUT) + fapar_diag_pft, apar_diag_pft, apar_diag_gb, gpp_gb_acc, gpp_pft_acc, & + !crop_vars_mod (IN) + rootc_cpft, sthu_irr_soilt, frac_irr_soilt, frac_irr_surft, dvi_cpft, & + !crop_vars_mod (IN OUT) + resfs_irr_surft, & + !crop_vars_mod (OUT) + gs_irr_surft, smc_irr_soilt, wt_ext_irr_surft, gc_irr_surft, & + !p_s_parms (IN) + bexp_soilt, sathh_soilt, v_close_pft, v_open_pft, & + !urban_param (IN) + wrr_gb, & + !Fluxes (IN OUT) + anthrop_heat_surft, & + !prognostics (IN) + nsnow_surft, sice_surft, sliq_surft, snowdepth_surft, & + tsnow_surft, ds_surft, & + !c_elevate (OUT) + surf_hgt_surft, lw_down_elevcorr_surft, & + !jules_mod (OUT) + snowdep_surft, & + !urban_param (IN) + hgt_gb, disp_gb, & + !lake_mod (IN) + lake_t_ice_gb,lake_t_mxl_gb, lake_h_ice_gb,lake_depth_gb, & + g_dt_gb, non_lake_frac, & + !lake_mod (OUT) + nusselt_gb, ts1_lake_gb, hcon_lake, & + !ancil_info + l_lice_point, l_soil_point, & + !jules_surface_types (IN) + diff_frac, & + !chemvars (OUT) + flux_o3_pft, fo3_pft, & + !CABLE_LSM:CM3 + progs_cbl, work_cbl, pars_io_cbl, progs_cnp, & + mype, timestep_number, satcon_soilt, & + latitude, longitude, u_s, ls_rain, ls_snow ) + +USE ancil_info, ONLY: dim_cslayer, l_lice_surft, nsoilt, rad_nband +USE atm_fields_bounds_mod, ONLY: pdims_s, pdims, tdims +USE bl_option_mod, ONLY: l_quick_ap2 +USE c_elevate, ONLY: l_elev_absolute_height +USE c_z0h_z0m, ONLY: z0h_z0m, z0h_z0m_classic +USE calc_air_dens_mod, ONLY: calc_air_dens +USE can_drag_mod, ONLY: can_drag_z0, can_drag_phi_m_h +USE csigma, ONLY: sbcon +USE dust_param, ONLY: z0_soil +USE elevate_mod, ONLY: elevate +USE fcdch_mod, ONLY: fcdch +USE gen_anthrop_heat_mod, ONLY: generate_anthropogenic_heat +USE heat_con_mod, ONLY: heat_con +USE physiol_mod, ONLY: physiol +USE planet_constants_mod, ONLY: cp, vkman, r, c_virtual,epsil=>repsilon +USE qsat_mod, ONLY: qsat, qsat_mix +USE sf_diags_mod, ONLY: strnewsfdiag +USE sf_flux_mod_cbl, ONLY: sf_flux_cbl +USE sf_orog_mod, ONLY: sf_orog +USE sf_resist_mod, ONLY: sf_resist +USE sf_rib_mod, ONLY: sf_rib +USE sfl_int_mod, ONLY: sfl_int +USE snowtherm_mod, ONLY: snowtherm +USE solinc_data, ONLY: sky, l_skyview +USE stdev1_mod, ONLY: stdev1 +USE stochastic_physics_run_mod, ONLY: l_rp2, i_rp_scheme, i_rp2b, z0hm_pft_rp +USE theta_field_sizes, ONLY: t_i_length,t_j_length +USE tilepts_mod, ONLY: tilepts +USE timestep_mod, ONLY: timestep +USE urban_param_mod, ONLY: z0m_mat +USE urbanz0_mod, ONLY: urbanz0 +USE veg_param, ONLY: secs_per_360days +USE veg3_field_mod, ONLY: veg_state_type +USE water_constants_mod, ONLY: lc, rho_ice, tm + +USE jules_soil_biogeochem_mod, ONLY: & +! imported scalar parameters + soil_model_rothc, & +! imported scalar variables (IN) + soil_bgc_model + +USE jules_soil_mod, ONLY: dzsoil, dzsoil_elev, hcice, hcwat, hcondeep + +USE jules_surface_types_mod, ONLY: npft, nnpft, ntype, & + urban_canyon, urban_roof, soil, lake, ncpft + +#if defined(UM_JULES) +USE atm_step_local, ONLY: dim_cs1, co2_dim_len,co2_dim_row +#else +USE ancil_info, ONLY: dim_cs1, co2_dim_len, co2_dim_row +#endif + +USE jules_snow_mod, ONLY: cansnowtile & + ,rho_snow_const & + ,snow_hcon & + ,l_snowdep_surf & + ,l_snow_nocan_hc & + ,nsmax & + ,unload_rate_u + +USE jules_surface_mod, ONLY: l_aggregate, formdrag, l_anthrop_heat_src, & + i_aggregate_opt, cor_mo_iter, & + use_correct_ustar, iscrntdiag, & + l_flake_model,l_elev_lw_down, & + l_mo_buoyancy_calc, effective_z0, & + IP_ScrnDecpl2, IP_ScrnDecpl3, & + l_vary_z0m_soil, l_elev_land_ice, ls + +USE jules_vegetation_mod, ONLY: can_model, can_rad_mod, ilayers, l_triffid, & + l_vegdrag_surft + +USE jules_irrig_mod, ONLY: l_irrig_dmd + +USE jules_sea_seaice_mod, ONLY: l_ctile, charnock, ip_ss_solid + +USE jules_urban_mod, ONLY: l_moruses_rough_surft, l_moruses_storage + +USE jules_science_fixes_mod, ONLY: ctile_orog_fix, correct_sea_adjust_land, & + l_fix_wind_snow, l_accurate_rho, & + l_fix_moruses_roof_rad_coupling + +USE ereport_mod, ONLY: ereport +USE errormessagelength_mod, ONLY: errormessagelength + +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type ! CABLE intro-ed progs +USE work_vars_mod_cbl, ONLY: work_vars_type ! some kept thru timestep +USE params_io_mod_cbl, ONLY: params_io_data_type +USE progs_cnp_vars_mod, ONLY: progs_cnp_vars_type ! CASA-CNP intro-ed progs +USE cable_explicit_main_mod, ONLY: cable_explicit_main + +IMPLICIT NONE +!----------------------------------------------------------------------- +! Inputs :- +!----------------------------------------------------------------------- +! (a) Defining horizontal grid and subset thereof to be processed. +! Checked for consistency. +INTEGER, INTENT(IN) :: & + curr_day_number, & + ! IN current day of year + land_pts, & + ! IN No of land points being processed. + numcycles, & + ! Number of cycles (iterations) for iterative SISL. + cycleno + ! Iteration no + +! Defining vertical grid of model atmosphere. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + bq_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN A buoyancy parameter + ! (beta q tilde). +,bt_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN A buoyancy parameter + ! (beta T tilde). +,z1_uv(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Height of lowest uv level (m). +,z1_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Height of lowest tq level (m). + ! Note, if the grid used is + ! staggered in the vertical, + ! Z1_UV and Z1_TQ can be + ! different. +,qw_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Total water content +,tl_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + ! IN Ice/liquid water temperature + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + charnock_w(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +! Charnock's coefficient from wave model + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + z1_uv_top(tdims%i_start:tdims%i_end, & + tdims%j_start:tdims%j_end) + ! Height of top of lowest uv-layer +REAL(KIND=real_jlslsm), INTENT(IN) :: & + z1_tq_top(tdims%i_start:tdims%i_end, & + tdims%j_start:tdims%j_end) + ! Height of top of lowest Tq-layer + +! (c) Soil/vegetation/land surface parameters (mostly constant). +LOGICAL, INTENT(IN) :: & + l_co2_interactive & + ! IN Switch for 3D CO2 field +,l_phenol + ! IN Indicates whether phenology + ! in use + +INTEGER, INTENT(IN) :: & + land_index(land_pts) ! IN LAND_INDEX(I)=J => the Jth + ! point in ROW_LENGTH,ROWS is the + ! land point. + +INTEGER, INTENT(IN) :: & + sm_levels & + ! IN No. of soil moisture levels +,nsurft & + ! IN No. of land-surface tiles +,asteps_since_triffid + ! IN Number of atmospheric + ! timesteps since last call + ! to TRIFFID. + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + canopy(land_pts,nsurft) & + ! IN Surface/canopy water for + ! snow-free land tiles (kg/m2) +,catch(land_pts,nsurft) & + ! IN Surface/canopy water capacity + ! of snow-free land tiles (kg/m2). +,catch_snow(land_pts,nsurft) & + ! IN Snow interception capacity of + ! tiles (kg/m2). +,hcon_soilt(land_pts,nsoilt) & + ! IN Soil thermal conductivity + ! (W/m/K). +,snow_surft(land_pts,nsurft) & + ! IN Lying snow on tiles (kg/m2) +,smvccl_soilt(land_pts,nsoilt,sm_levels) & + ! IN Critical volumetric SMC + ! (cubic m per cubic m of soil). +,smvcst_soilt(land_pts,nsoilt,sm_levels) & + ! IN Volumetric saturation point + ! (m3/m3 of soil). +,smvcwt_soilt(land_pts,nsoilt,sm_levels) & + ! IN Volumetric wilting point + ! (cubic m per cubic m of soil). +,sthf_soilt(land_pts,nsoilt,sm_levels) & + ! IN Frozen soil moisture content of + ! each layer as a fraction of + ! saturation. +,sthu_soilt(land_pts,nsoilt,sm_levels) & + ! IN Unfrozen soil moisture content + ! of each layer as a fraction of + ! saturation. +,z0_surft(land_pts,nsurft) & + ! IN Tile roughness lengths (m). +,z0h_surft_bare(land_pts,nsurft) & + ! IN Tile thermal roughness lengths + ! without snow cover(m). +,z0m_soil_in(land_pts) & + ! IN bare soil momentum z0 (m). +,sil_orog_land(land_pts) & + ! IN Silhouette area of unresolved + ! orography per unit horizontal + ! area on land points only. +,ho2r2_orog(land_pts) & + ! IN Standard Deviation of orography. + ! equivilent to peak to trough + ! height of unresolved orography +,flandg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + ! IN Land fraction on all tiles. + ! divided by 2SQRT(2) on land + ! points only (m) + +! (f) Atmospheric + any other data not covered so far, incl control. + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + pstar(pdims%i_start:pdims%i_end,pdims%j_start:pdims%j_end) & + ! IN Surface pressure (Pascals). +,lw_down(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Surface downward LW radiation + ! (W/m2). +,sw_surft(land_pts,nsurft) & + ! IN Surface net SW radiation on + ! land tiles (W/m2). +,zh(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Height above surface of top of + ! boundary layer (metres). +,ddmfx(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Convective downdraught + ! mass-flux at cloud base +,co2_mmr & + ! IN CO2 Mass Mixing Ratio +,co2_3d(co2_dim_len,co2_dim_row) & + ! IN 3D CO2 field if required. +,cs_pool_soilt(land_pts,nsoilt,dim_cslayer,dim_cs1) & + ! IN Soil carbon (kg C/m2). +,frac(land_pts,ntype) & + ! IN Fractions of surface types. +,canht_pft(land_pts,npft) & + ! IN Canopy height (m) +,photosynth_act_rad(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Net downward shortwave radiation + ! in band 1 (w/m2). +,lai_pft(land_pts,npft) & + ! IN Leaf area index +,t_soil_soilt(land_pts,nsoilt,sm_levels) & + ! IN Soil temperatures (K). +,tsurf_elev_surft(land_pts,nsurft) & + ! IN Tiled ice sub-surface temperature (K) +,z_land(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Land height (m). +,albsoil_soilt(land_pts,nsoilt) & + ! IN Soil albedo. +, cos_zenith_angle(tdims%i_start:tdims%i_end, & + tdims%j_start:tdims%j_end) & + ! IN Cosine of the zenith angle +,clay_soilt(land_pts,nsoilt,dim_cslayer) & + ! IN Soil clay fraction. +,o3(land_pts) + ! IN Surface ozone concentration (ppb). + +REAL(KIND=real_jlslsm), INTENT(INOUT) :: & +tstar_surft(land_pts,nsurft) + ! IN Surface tile temperatures + +LOGICAL, INTENT(IN) :: & + l_aero_classic & + ! IN switch for using CLASSIC aerosol + ! scheme +,l_dust & + ! IN switch for mineral dust +,l_dust_diag & + ! IN Switch for diagnostic mineral dust + ! lifting +,l_mr_physics & + ! IN Switch for when mixing ratios are used +,l_emis_surft_set(nsurft) + ! IN Switch for varying grey surface emissivity + +!----------------------------------------------------------------------- +! In/outs :- +!----------------------------------------------------------------------- +!Diagnostics +TYPE (strnewsfdiag), INTENT(IN OUT) :: sf_diag + +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + emis_surft(land_pts,nsurft) & + ! INOUT Emissivity for land tiles +,gs(land_pts) & + ! INOUT "Stomatal" conductance to + ! evaporation (m/s). +,g_leaf_acc(land_pts,npft) & + ! INOUT Accumulated G_LEAF +,npp_pft_acc(land_pts,npft) & + ! INOUT Accumulated NPP_pft +,resp_w_pft_acc(land_pts,npft) & + ! INOUT Accum RESP_W_pft +,resp_s_acc_soilt(land_pts,nsoilt,dim_cslayer,dim_cs1) & + ! INOUT Accumulated RESP_S +,rhostar(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! INOUT Surface air density +,fqw_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! INOUT Moisture flux between layers + ! (kg per square metre per sec). + ! FQW(,1) is total water flux + ! from surface, 'E'. +,ftl_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! INOUT FTL(,K) contains net turbulent + ! sensible heat flux into layer K + ! from below; so FTL(,1) is the + ! surface sensible heat, H.(W/m2) +,t1_sd(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Standard deviation of turbulent + ! fluctuations of layer 1 temp; + ! used in initiating convection. +,q1_sd(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Standard deviation of turbulent + ! flucs of layer 1 humidity; + ! used in initiating convection. +,vshr(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Magnitude of surface-to-lowest + ! atm level wind shear (m per s). +,vshr_land(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + ! OUT Magnitude of surface-to-lowest + ! atm level wind shear (m per s). + +!----------------------------------------------------------------------- +! Outputs :- +!----------------------------------------------------------------------- +!-1 Diagnostic (or effectively so - includes coupled model requisites):- +INTEGER, INTENT(OUT) :: & + surft_index(land_pts,ntype) & + ! OUT Index of tile points +,surft_pts(ntype) ! OUT Number of tile points + +! (a) Calculated anyway (use STASH space from higher level) :- + +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + ftl_surft(land_pts,nsurft) & + ! OUT Surface FTL for land tiles +,u_s_std_surft(land_pts,nsurft) & + ! OUT Surface friction velocity + ! (standard value) + ! for mineral dust +,emis_soil(land_pts) & + ! OUT Emissivity of underlying soil +,rhokm_land(pdims_s%i_start:pdims_s%i_end, & + pdims_s%j_start:pdims_s%j_end), & + cdr10m(pdims_s%i_start:pdims_s%i_end,pdims_s%j_start:pdims_s%j_end) + +! (b) Not passed between lower-level routines (not in workspace at this +! level) :- + +!-2 Genuinely output, needed by other atmospheric routines :- + +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + alpha1(land_pts,nsurft) & + ! OUT Mean gradient of saturated + ! specific humidity with respect + ! to temperature between the + ! bottom model layer and tile + ! surfaces +,ashtf_prime_surft(land_pts,nsurft) & + ! OUT Coefficient to calculate + ! surface heat flux into land + ! tiles. +,fqw_surft(land_pts,nsurft) & + ! OUT Surface FQW for land tiles +,epot_surft(land_pts,nsurft) & + ! OUT Local EPOT for land tiles. +,fraca(land_pts,nsurft) & + ! OUT Fraction of surface moisture + ! flux with only aerodynamic + ! resistance for snow-free land + ! tiles. +,resfs(land_pts,nsurft) & + ! OUT Combined soil, stomatal + ! and aerodynamic resistance + ! factor for fraction (1-FRACA) + ! of snow-free land tiles. +,resft(land_pts,nsurft) & + ! OUT Total resistance factor. + ! FRACA+(1-FRACA)*RESFS for + ! snow-free land, 1 for snow. +,rhokh_surft(land_pts,nsurft) & + ! OUT Surface exchange coefficients + ! for land tiles +,dtstar_surft(land_pts,nsurft) & + ! OUT Change in TSTAR over timestep + ! for land tiles +,z0h_surft(land_pts,nsurft) & + ! OUT Tile roughness lengths for heat + ! and moisture (m). +,z0m_surft(land_pts,nsurft) & + ! OUT Tile roughness lengths for + ! momentum. +,chr1p5m(land_pts,nsurft) & + ! OUT Ratio of coefffs for + ! calculation of 1.5m temp for + ! land tiles. +,smc_soilt(land_pts,nsoilt) & + ! OUT Available moisture in the + ! soil profile (mm). +,hcons_soilt(land_pts,nsoilt) & + ! OUT Soil thermal conductivity + ! including water and ice +,gpp(land_pts) & + ! OUT Gross primary productivity + ! (kg C/m2/s). +,npp(land_pts) & + ! OUT Net primary productivity + ! (kg C/m2/s). +,resp_p(land_pts) & + ! OUT Plant respiration (kg C/m2/s). +,g_leaf(land_pts,npft) & + ! OUT Leaf turnover rate (/360days). +,gpp_pft(land_pts,npft) & + ! OUT Gross primary productivity + ! on PFTs (kg C/m2/s). +,npp_pft(land_pts,npft) & + ! OUT Net primary productivity + ! (kg C/m2/s). +,resp_p_pft(land_pts,npft) & + ! OUT Plant respiration on PFTs + ! (kg C/m2/s). +,resp_s_soilt(land_pts,nsoilt,dim_cslayer,dim_cs1) & + ! OUT Soil respiration (kg C/m2/s). +,resp_s_tot_soilt(land_pts,nsoilt) & + ! OUT Total soil respiration + ! (kg C/m2/s). +,resp_l_pft(land_pts,npft) & + ! OUT Leaf maintenance respiration + ! (kg C/m2/s). +,resp_r_pft(land_pts,npft) & + ! OUT Root maintenance respiration + ! (kg C/m2/s). +,resp_w_pft(land_pts,npft) & + ! OUT Wood maintenance respiration + ! (kg C/m2/s). +,n_leaf(land_pts,npft) & + ! OUT Leaf N content scaled by LAI + ! (kg N/m2). +,n_root(land_pts,npft) & + ! OUT Root N content scaled by LAI_bal + ! (kg N/m2). +,n_stem(land_pts,npft) & + ! OUT Stem N content scaled by LAI_bal + ! (kg N/m2). +,lai_bal(land_pts,npft) & + ! OUT LAI_bal +,gc_surft(land_pts,nsurft) & + ! OUT "Stomatal" conductance to + ! evaporation for land tiles + ! (m/s). +,canhc_surft(land_pts,nsurft) & + ! OUT Areal heat capacity of canopy + ! for land tiles (J/K/m2). +,wt_ext_surft(land_pts,sm_levels,nsurft) & + ! OUT Fraction of evapotranspiration + ! which is extracted from each + ! soil layer by each tile. +,flake(land_pts,nsurft) & + ! OUT Lake fraction. +,tile_frac(land_pts,nsurft) & + ! OUT Tile fractions including + ! snow cover in the ice tile. +,fsmc_pft(land_pts,npft) & + ! OUT Moisture availability factor. +,gc_corr(land_pts,npft) + ! OUT "Stomatal" conductance + ! without bare soil evaporation + +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + cd_land(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Bulk transfer coefficient for + ! momentum over land. +,rib_surft(land_pts,nsurft) & + ! OUT RIB for land tiles. +,ch_surft_classic(land_pts,nsurft) & + ! OUT Bulk transfer coefficient for + ! heat for aerosol deposition. +,cd_std_classic(land_pts,nsurft) + ! OUT Bulk transfer coefficient for + ! momentum for aerosol deposition. +LOGICAL, INTENT(OUT) :: & + l_cdr10m_snow + ! OUT Flag indicating if cdr10m + ! (an interpolation coefficient) is + ! to be calculated for use with + ! snow unloading. + +!New arguments replacing USE statements +!urban_param +REAL(KIND=real_jlslsm), INTENT(IN) :: emisr_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(IN) :: emisw_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(IN) :: hwr_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(IN) :: wrr_gb(land_pts) + +!jules_mod +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + albobs_scaling_surft(land_pts,ntype,rad_nband) + +!p_s_parms (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: bexp_soilt(land_pts,nsoilt,sm_levels) +REAL(KIND=real_jlslsm), INTENT(IN) :: sathh_soilt(land_pts,nsoilt,sm_levels) +REAL(KIND=real_jlslsm), INTENT(IN) :: v_close_pft(land_pts,sm_levels,npft) +REAL(KIND=real_jlslsm), INTENT(IN) :: v_open_pft(land_pts,sm_levels,npft) + +!crop_vars_mod (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: rootc_cpft(land_pts,ncpft) +REAL(KIND=real_jlslsm), INTENT(IN) :: sthu_irr_soilt(land_pts,nsoilt,sm_levels) +REAL(KIND=real_jlslsm), INTENT(IN) :: frac_irr_soilt(land_pts,nsoilt) +REAL(KIND=real_jlslsm), INTENT(IN) :: frac_irr_surft(land_pts,nsurft) +REAL(KIND=real_jlslsm), INTENT(IN) :: dvi_cpft(land_pts,ncpft) +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: resfs_irr_surft(land_pts,nsurft) + +!Fluxes (IN OUT) +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: anthrop_heat_surft(land_pts,nsurft) + +!Fluxes +REAL(KIND=real_jlslsm), INTENT(IN) :: t_home_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(IN) :: t_growth_gb(land_pts) + +!veg_state +TYPE(veg_state_type), INTENT(IN OUT) :: veg_state + +!jules_chemvars_mod +REAL(KIND=real_jlslsm), INTENT(OUT) :: isoprene_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: terpene_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: methanol_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: acetone_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: isoprene_pft(land_pts,npft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: terpene_pft(land_pts,npft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: methanol_pft(land_pts,npft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: acetone_pft(land_pts,npft) + +!trif_vars_mod +REAL(KIND=real_jlslsm), INTENT(OUT) :: fapar_diag_pft(land_pts,npft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: apar_diag_pft(land_pts,npft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: apar_diag_gb(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: gpp_gb_acc(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: gpp_pft_acc(land_pts,npft) + +!crop_vars_mod (OUT) +REAL(KIND=real_jlslsm), INTENT(OUT) :: gs_irr_surft(land_pts,nsurft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: smc_irr_soilt(land_pts,nsoilt) +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + wt_ext_irr_surft(land_pts,sm_levels,nsurft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: gc_irr_surft(land_pts,nsurft) + +!prognostics (IN) +INTEGER, INTENT(IN) :: nsnow_surft(land_pts,nsurft) +REAL(KIND=real_jlslsm), INTENT(IN) :: sice_surft(land_pts,nsurft,nsmax), & + sliq_surft(land_pts,nsurft,nsmax), & + snowdepth_surft(land_pts,nsurft), & + tsnow_surft(land_pts,nsurft,nsmax), & + ds_surft(land_pts,nsurft,nsmax) + +!c_elevate (OUT) +REAL(KIND=real_jlslsm), INTENT(OUT) :: surf_hgt_surft(land_pts,nsurft), & + lw_down_elevcorr_surft(land_pts,nsurft) + +!jules_mod (OUT) +REAL(KIND=real_jlslsm), INTENT(OUT) :: snowdep_surft(land_pts,nsurft) + +!urban_param (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: hgt_gb(land_pts), & + disp_gb(land_pts) + +!lake_mod (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: lake_t_ice_gb(land_pts), & + lake_t_mxl_gb(land_pts), & + lake_h_ice_gb(land_pts), & + lake_depth_gb(land_pts), & + g_dt_gb(land_pts), & + non_lake_frac(land_pts) +REAL(KIND=real_jlslsm), INTENT(OUT) :: ts1_lake_gb(land_pts), & + nusselt_gb(land_pts), & + hcon_lake(land_pts) + +!ancil_info (IN) +LOGICAL, INTENT(IN) :: l_lice_point(land_pts) +LOGICAL, INTENT(IN) :: l_soil_point(land_pts) + +!JULES surface_types_mod (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: diff_frac(t_i_length * t_j_length) + +!chemvars (OUT) +REAL(KIND=real_jlslsm), INTENT(OUT) :: flux_o3_pft(land_pts,npft) +REAL(KIND=real_jlslsm), INTENT(OUT) :: fo3_pft(land_pts,npft) + + +!----------------------------------------------------------------------- +! LOCAL variables +!----------------------------------------------------------------------- +! Workspace :- +REAL(KIND=real_jlslsm) :: work_clay ! working variable + +REAL(KIND=real_jlslsm) :: & + vfrac_surft(land_pts,nsurft) & + ! Fractional canopy coverage for + ! land tiles. +,radnet_surft(land_pts,nsurft) & + ! Surface net radiation on tiles +,csnow(land_pts,nsmax) & + ! Areal heat capacity of snow (J/K/m2) +,ksnow(land_pts,nsmax) & + ! Thermal conductivity of snow (W/m/K) +,hcons_snow(land_pts,nsurft) & + ! Snow thermal conductivity +,resp_frac(land_pts,dim_cslayer) & + ! respired fraction of RESP_S +,gc_stom_surft(land_pts,nsurft) + ! canopy conductance + +REAL(KIND=real_jlslsm) :: & + lh0 ! Latent heat for snow free surface + ! =LS for sea-ice, =LC otherwise + + +! Workspace for sea-ice and marginal ice zone +REAL(KIND=real_jlslsm) :: & + ch_land(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + ! Bulk transfer coefficient for + ! het and moisture over land. + +! Workspace for land tiles +REAL(KIND=real_jlslsm) :: & + cd_std(land_pts,nsurft) & + ! Local drag coefficient for calc + ! of interpolation coefficient +,cd_surft(land_pts,nsurft) & + ! Drag coefficient +,ch_surft(land_pts,nsurft) & + ! Transfer coefficient for heat and + ! moisture +,chn(land_pts,nsurft) & + ! Neutral value of CH. +,dq(land_pts) & + ! Sp humidity difference between + ! surface and lowest atmospheric lev +,epdt(land_pts) & + ! "Potential" Evaporation * Timestep +,pstar_land(land_pts) & + ! Surface pressure for land points. +,qstar_surft(land_pts,nsurft) & + !Surface saturated sp humidity. +,rhokh_can(land_pts,nsurft) & + ! Exchange coefficient for canopy + ! air to surface +,rhokm_1_surft(land_pts,nsurft) & + ! Momentum exchange coefficient. +,tsurf(land_pts,nsurft) & + ! Surface layer temp (snow or soil) ( +,lake_ice_mid_temp(land_pts) & + ! Median temperature of the lake ice (K) +,dzsurf(land_pts,nsurft) & + ! Surface layer thickness + ! (snow or soil) (m) +,canhc_surf(land_pts,nsurft) & + ! Surface layer thickness + ! (snow or soil) (m) +,hcons_surf(land_pts,nsurft) & + ! Thermal conductivity + ! (snow or soil) (W/m/K) +,wind_profile_factor(land_pts,nsurft) & + ! For transforming effective surface + ! transfer coefficients to those + ! excluding form drag. +,z0m_eff_surft(land_pts,nsurft) & + ! Effective momentum roughness length +,db_surft(land_pts,nsurft) & + ! Buoyancy difference for surface + ! tile +,v_s_surft(land_pts,nsurft) & + ! Surface layer scaling velocity + ! for tiles (m/s). +,v_s_std(land_pts,nsurft) & + ! Surface layer scaling velocity + ! for tiles excluding orographic + ! form drag (m/s). +,u_s_iter_surft(land_pts,nsurft) & + ! Scaling velocity from middle of + ! MO scheme - picked up in error by + ! dust code! +,recip_l_mo_surft(land_pts,nsurft) & + ! Reciprocal of the Monin-Obukhov + ! length for tiles (m^-1). +,z0m_soil(land_pts,nsurft) & + ! Bare soil momentum roughness length + ! for use in 1 tile dust scheme +,z0h_soil(land_pts,nsurft) & + ! Bare soil roughness length for heat + ! for use in 1 tile dust scheme +,wind_profile_fac_soil(land_pts,nsurft) & + ! Equivalent of wind_profile_factor + ! for use in 1 tile dust scheme +,cd_surft_soil(land_pts,nsurft), ch_surft_soil(land_pts,nsurft) & +,cd_std_soil(land_pts,nsurft), v_s_surft_soil(land_pts,nsurft) & +,recip_l_mo_surft_soil(land_pts,nsurft) & + ! Dummy output variables from extra + ! call to fcdch needed for + ! 1 tile dust scheme +,v_s_std_soil(land_pts,nsurft) & + ! Bare soil surface layer scaling + ! velocity for tiles excluding + ! orographic form drag (m/s) + ! for use in 1 tile dust scheme +,u_s_iter_soil(land_pts,nsurft) & + ! Bare soil scaling velocity from + ! middle of MO scheme for use in + ! 1 tile dust scheme - picked up in + ! error by dust code +,z0h_surft_classic(land_pts,nsurft) & + ! z0h to be used in calculation for + ! CLASSIC aerosol deposition +,cd_surft_classic(land_pts,nsurft) & +,v_s_surft_classic(land_pts,nsurft) & +,recip_l_mo_surft_classic(land_pts,nsurft) & +,v_s_std_classic(land_pts,nsurft) & +,u_s_iter_classic(land_pts,nsurft) & + ! Dummy output variables from extra + ! call to fcdch needed for aerosol + ! deposition with different z0h +,t_elev(land_pts,nsurft) & + ! Temperature at elevated height (k) +,q_elev(land_pts,nsurft) & + ! Specific humidity at elevated + ! height (kg per kg air) +,qs1_elev(land_pts,nsurft) & + ! Saturated specific humidity at elev + ! height (kg per kg air) +,scaling_urban(land_pts,nsurft) & + ! MORUSES: ground heat flux scaling; + ! canyon tile only coupled to soil +,zdt_surft(land_pts,nsurft) & + ! Difference between the canopy height and + ! displacement height (m) +,phi_m(land_pts) & + ! Monin-Obukhov stability function for momentum + ! integrated to the model's lowest wind level. +,phi_h(land_pts) & + ! Monin-Obukhov stability function for scalars + ! integrated to the model's lowest temperature + ! and humidity level. +,rhostar_mom(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! Surface air density for momentum +,ashtf_surft(land_pts,nsurft) & + ! Coefficient to calculate surface + ! heat flux into soil (W/m2/K). +,lw_down_surftsum(land_pts) & + ! Gridbox sum of elevation corrections to + ! downward longwave radiation +,lw_down_surftabs(land_pts) + ! Gridbox sum of absolution changes to downward + ! longwave radiation from elevation corrections + +! dummy arrays required for sea and se-ice to create universal +! routines for all surfaces +REAL(KIND=real_jlslsm) :: & + array_zero(t_i_length * t_j_length) & + ! Array of zeros +,zdt_dummy(t_i_length * t_j_length) + ! Dummy array for zdt + +!Gridbox mean values calculated from soil tiled versions for FLAKE +REAL(KIND=real_jlslsm) :: & + hcons_mean_soil(land_pts), & + tsoil_mean_soil(land_pts) + + +! Local scalars :- + +INTEGER :: & + i,j & + ! Loop counter (horizontal field index). +,k & + ! Loop counter (tile field index). +,l & + ! Loop counter (land point field index). +,n & + ! Loop counter (tile index). +,nn & + ! Loop counter (soil carbon layers) +,m & + ! Index for soil tile +,n_veg + ! Actual or dummy pointer to array + ! defined only on PFTs + +REAL(KIND=real_jlslsm) :: & + ds_ratio & + ! 2 * snowdepth / depth of top soil layer. +,d_t & + ! Temporary in calculation of alpha1. +,zetam & + ! Temporary in calculation of CHN. +,zetah & + ! Temporary in calculation of CHN. +,zeta1 & + ! Work space +,z0 & + ! yet more workspace + + ! Temporary variables for adjustment of downwelling + ! logwave to elevation tiles and correction back to + ! conserve gridbox mean +,t_rad + +LOGICAL :: & + l_vegdrag_active_here & + ! Logical to indicate whether the vegetative drag scheme + ! is active on the current surface tile in cases where + ! l_vegdrag_surft itself may not be applicable +,l_shallow_lake_depth(land_pts) + ! Logical to indicate unsuitable shallow lake depth + +REAL(KIND=real_jlslsm) :: sea_point + +INTEGER :: n_diag + +INTEGER :: errcode +CHARACTER(LEN=errormessagelength) :: cmessage + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='CABLE_LAND_SF_EXPLICIT' + +!CABLE_LSM:CM2 +!CABLE TYPES containing field data (IN OUT) +TYPE(progs_cbl_vars_type), INTENT(IN OUT) :: progs_cbl +TYPE(work_vars_type), INTENT(IN OUT) :: work_cbl +TYPE(params_io_data_type), INTENT(IN OUT) :: pars_io_cbl +TYPE(progs_cnp_vars_type), INTENT(IN OUT) :: progs_cnp + +INTEGER :: mype, timestep_number +REAL :: satcon_soilt(land_pts, sm_levels) !0:sm_levels +REAL :: latitude(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL :: longitude(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL :: u_s(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL :: ls_rain(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL :: ls_snow(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + + +logical, save :: first_call = .true. +!CABLE_LSM: End + +!CM3#55 As of 6/12/2023 no attempt is being made to tidy up the workspace + + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +!CABLE_LSM:initia;lize intent(OUT) - HOWEVER, most of these won't even be req^d in cable_land_expl AND others will get a value from +!CABLE + +IF( first_call ) THEN + dtstar_surft(:,:) = 0.0 + resp_l_pft(:,:) = 0.0 + resp_r_pft(:,:) = 0.0 + resp_w_pft(:,:) = 0.0 + n_leaf(:,:) = 0.0 + n_root(:,:) = 0.0 + n_stem(:,:) = 0.0 + lai_bal(:,:) = 0.0 + wt_ext_surft(:,:,:) = 0.0 + tile_frac(:,:) = 0.0 + fsmc_pft(:,:) = 0.0 + gc_corr(:,:) = 0.0 + isoprene_gb(:) = 0.0 + terpene_gb(:) = 0.0 + methanol_gb(:) = 0.0 + acetone_gb(:) = 0.0 + isoprene_pft(:,:) = 0.0 + terpene_pft(:,:) = 0.0 + methanol_pft(:,:) = 0.0 + acetone_pft(:,:) = 0.0 + fapar_diag_pft(:,:) = 0.0 + apar_diag_pft(:,:) = 0.0 + apar_diag_gb(:) = 0.0 + gpp_gb_acc(:) = 0.0 + gpp_pft_acc(:,:) = 0.0 + gs_irr_surft(:,:) = 0.0 + smc_irr_soilt(:,:) = 0.0 + wt_ext_irr_surft(:,:,:) = 0.0 + gc_irr_surft(:,:) = 0.0 + flux_o3_pft(:,:) = 0.0 + fo3_pft(:,:) = 0.0 + gpp(:) = 0.0 + npp(:) = 0.0 + smc_soilt(:,:) = 0.0 + gpp_pft(:,:) = 0.0 + resp_p(:) = 0.0 + g_leaf(:,:) = 0.0 + first_call = .FALSE. +END IF + +!----------------------------------------------------------------------- +! 0. Initialisations +!----------------------------------------------------------------------- + +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(i, j, l, n) & +!$OMP SHARED(t_i_length, t_j_length, array_zero, tdims, rhokm_land, cd_land, & +!$OMP ch_land, zdt_dummy, land_pts, lake_ice_mid_temp, l_shallow_lake_depth, & +!$OMP zdt_surft, db_surft, rhokh_can, nsurft,ftl_surft,fqw_surft, & +!$OMP rib_surft,z0m_surft,u_s_std_surft,chr1p5m,resfs,alpha1,radnet_surft, & +!$OMP scaling_urban,snowdep_surft,snowdepth_surft,sf_diag) +!$OMP DO SCHEDULE(STATIC) +DO i = 1,t_i_length * t_j_length + array_zero(i) = 0.0 + zdt_dummy(i) = 0.0 +END DO +!$OMP END DO NOWAIT + +!$OMP DO SCHEDULE(STATIC) +DO j = tdims%j_start,tdims%j_end + DO i = tdims%i_start,tdims%i_end + rhokm_land(i,j) = 0.0 + cd_land(i,j) = 0.0 + ch_land(i,j) = 0.0 + END DO +END DO +!$OMP END DO NOWAIT + +!$OMP DO SCHEDULE(STATIC) +DO l = 1,land_pts + lake_ice_mid_temp(l) = 0.0 + l_shallow_lake_depth(l) = .FALSE. +END DO +!$OMP END DO NOWAIT + +!----------------------------------------------------------------------- +! 1. Initialise FTL_SURFT and RIB_SURFT on all tiles at all points, +! to allow STASH to process these as diagnostics. +!----------------------------------------------------------------------- +DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + ! MORUSES Initialise urban roughness array + ftl_surft(l,n) = 0.0 + fqw_surft(l,n) = 0.0 + rib_surft(l,n) = 0.0 + z0m_surft(l,n) = 0.0 !jh:can't 0 this AND cancel roughness + u_s_std_surft(l,n) = 0.0 + chr1p5m(l,n) = 0.0 + resfs(l,n) = 0.0 + alpha1(l,n) = 0.0 + !CN2ish!radnet_surft(l,n) = 0.0 + scaling_urban(l,n) = 1.0 + zdt_surft(l,n) = 0.0 + db_surft(l,n) = 0.0 + rhokh_can(l,n) = 0.0 + ! Equivalent snowdepth for surface calculations. + snowdep_surft(l,n) = snowdepth_surft(l,n) + + IF (sf_diag%l_et_stom .OR. sf_diag%l_et_stom_surft) THEN + sf_diag%resfs_stom(l,n) = 0.0 + END IF + END DO +!$OMP END DO NOWAIT +END DO +IF (sf_diag%l_tau_surft) THEN + DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + sf_diag%tau_surft(l,n) = 0.0 + END DO +!$OMP END DO NOWAIT + END DO +END IF +!$OMP END PARALLEL + +!----------------------------------------------------------------------- +! Call TILEPTS to calculate surft_pts and surft_index for surface types +!----------------------------------------------------------------------- +CALL tilepts(land_pts, frac, surft_pts, surft_index, l_lice_point) + +!CABLE_LSM: following CM2 - dodge OMP here +DO n = 1,nsurft + DO l = 1,land_pts + canhc_surft(l,n) = 0.0 + vfrac_surft(l,n) = 0.0 + IF( frac(l,n) == 0.0 ) THEN + cd_surft(l,n) = 0.0 + ch_surft(l,n) = 0.0 + z0h_surft(l,n) = 0.0 + z0m_eff_surft(l,n) = 0.0 + !not In 7.1!rhokpm(l,n) = 0.0 !doesnt go anywhere + radnet_surft(l,n) = 0.0 + fraca(l,n) = 0.0 + resfs(l,n) = 0.0 + resft(l,n) = 0.0 + END IF + END DO +END DO +!CABLE_LSM: End + +!CM3#55-1 +!!----------------------------------------------------------------------- +!! Generate the anthropogenic heat for surface calculations +!!----------------------------------------------------------------------- +!IF ( l_anthrop_heat_src .AND. .NOT. l_aggregate ) THEN +! CALL generate_anthropogenic_heat( curr_day_number, land_pts, frac, & +! surft_pts, surft_index, & +! !New arguments replacing USE statements +! !urban_param (IN) +! wrr_gb, & +! !Fluxes (IN OUT) +! anthrop_heat_surft) +!END IF + +!CABLE_LSM:CM2! Even if this is left in, crashes immediately in call to alb_pft.. +!CM2! Even if this is left in, crashes immediately in call to alb_pft.. +!CM2!!----------------------------------------------------------------------- +!CM2!! Call physiology routine to calculate surface conductances and carbon +!CM2!! fluxes. +!CM2!!----------------------------------------------------------------------- +!CM2!CALL physiol ( & +!CM2! land_pts,land_index, & +!CM2! sm_levels,nsurft,surft_pts,surft_index, & +!CM2! dim_cs1, & +!CM2! co2_mmr,co2_3d,co2_dim_len, co2_dim_row,l_co2_interactive, & +!CM2! can_model,cs_pool_soilt,veg_state,frac,canht_pft,photosynth_act_rad, & +!CM2! lai_pft,pstar,qw_1,sthu_soilt,sthf_soilt,t_soil_soilt,tstar_surft, & +!CM2! smvccl_soilt,smvcst_soilt,smvcwt_soilt,vshr,z0_surft,z1_uv,o3, & +!CM2! canhc_surft,vfrac_surft,emis_surft,l_emis_surft_set,emis_soil,flake, & +!CM2! g_leaf,gs,gc_surft,gc_stom_surft,gc_corr,gpp,gpp_pft,npp,npp_pft, & +!CM2! resp_p,resp_p_pft,resp_s_soilt,resp_l_pft, & +!CM2! resp_r_pft,resp_w_pft,n_leaf, & +!CM2! n_root,n_stem,lai_bal, & +!CM2! smc_soilt,wt_ext_surft,fsmc_pft, & +!CM2! albsoil_soilt,cos_zenith_angle, & +!CM2! can_rad_mod,ilayers,flux_o3_pft,fo3_pft,sf_diag,asteps_since_triffid, & +!CM2! non_lake_frac, & +!CM2! !New arguments replacing USE statements +!CM2! !Fluxes (IN) +!CM2! t_home_gb,t_growth_gb, & +!CM2! !urban_param (IN) +!CM2! emisr_gb, emisw_gb, hwr_gb, & +!CM2! !jules_mod (IN OUT) +!CM2! albobs_scaling_surft, & +!CM2! !jules_chemvars_mod (OUT) +!CM2! isoprene_gb, isoprene_pft, terpene_gb , terpene_pft, & +!CM2! methanol_gb, methanol_pft, acetone_gb, acetone_pft, & +!CM2! !trif_vars_mod (OUT) +!CM2! fapar_diag_pft, apar_diag_pft, apar_diag_gb, gpp_gb_acc, gpp_pft_acc, & +!CM2! !crop_vars_mod (IN) +!CM2! rootc_cpft, sthu_irr_soilt, frac_irr_soilt, frac_irr_surft, dvi_cpft, & +!CM2! !crop_vars_mod (OUT) +!CM2! gs_irr_surft, smc_irr_soilt, wt_ext_irr_surft, gc_irr_surft, & +!CM2! !p_s_parms (IN) +!CM2! bexp_soilt, sathh_soilt, v_close_pft, v_open_pft, & +!CM2! !ancil_info +!CM2! l_soil_point, & +!CM2! !jules_surface_types (IN) +!CM2! diff_frac) + +!CM3#55-2 +!! Update gc_surft for canopy snow if using the canopy snow scheme +!IF ( .NOT. l_aggregate .AND. can_model == 4) THEN +! DO n = 1,npft +! IF ( cansnowtile(n) ) THEN +!!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(i, j, k, l) & +!!$OMP SHARED(surft_pts, surft_index, land_index, t_i_length, & +!!$OMP snow_surft, gc_surft, catch_snow, tstar_surft, & +!!$OMP vshr_land, n) SCHEDULE(STATIC) +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! IF (snow_surft(l,n) > 0.0) THEN +! j = (land_index(l) - 1) / t_i_length + 1 +! i = land_index(l) - (j-1) * t_i_length +! gc_surft(l,n) = 0.06 * snow_surft(l,n)**0.6 * catch_snow(l,n)**0.4 & +! * 2.06e-5 * (tm / tstar_surft(l,n))**1.75 & +! * (1.79+3 * SQRT(vshr_land(i,j))) & +! / (2 * rho_ice * 5.0e-4**2) +! END IF +! END DO +!!$OMP END PARALLEL DO +! END IF +! END DO +!END IF + +!CM3#55-3 - note that at some point CASA variables need to make their way +! into these TRIFFID vars for output purposes +!!---------------------------------------------------------------------- +!! If TRIFFID is being used apply any correction to the land-atmosphere +!! fluxes on the first timestep after the last TRIFFID call. Such a +!! correction will typically be associated with a total depletion of +!! carbon or with maintanence of the seed fraction. The corrections +!! are stored in the accumulation variables after the call to TRIFFID. +!! The correction is added to the instantaneous land-atmosphere fluxes +!! (so that the atmospheric carbon budget is corrected) but is not +!! included in the accumulation variables which drive TRIFFID, since +!! this has already been dealt with during the last TRIFFID call. +!!---------------------------------------------------------------------- +!IF (l_triffid .AND. (asteps_since_triffid == 1) & +! .AND. ( cycleno == numcycles .OR. l_quick_ap2) ) THEN +!!jhan +! DO n = 1,nnpft +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!!$OMP SHARED(land_pts, npp_pft, npp_pft_acc, timestep, resp_p_pft, n) +! DO l = 1,land_pts +! npp_pft(l,n) = npp_pft(l,n) + npp_pft_acc(l,n) / timestep +! resp_p_pft(l,n) = resp_p_pft(l,n) - npp_pft_acc(l,n) / timestep +! npp_pft_acc(l,n)=-npp_pft_acc(l,n) +! END DO +!!$OMP END PARALLEL DO +! END DO +! +! ! Here we have assumed that RothC must be used with TRIFFID, and is called +! ! on the same timestep. +! IF ( soil_bgc_model == soil_model_rothc ) THEN +! DO n = 1,dim_cs1 +! DO nn = 1,dim_cslayer +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!!$OMP SHARED(land_pts, resp_s_soilt, resp_s_acc_soilt, timestep, n, nn) +! DO l = 1,land_pts +! !soil tiling is not compatible with triffid. OK to hard-code soil +! !tile index to 1 here +! resp_s_soilt(l,1,nn,n) = resp_s_soilt(l,1,nn,n) & +! + (resp_s_acc_soilt(l,1,nn,n) / timestep) +! resp_s_acc_soilt(l,1,nn,n) = -resp_s_acc_soilt(l,1,nn,n) +! END DO +!!$OMP END PARALLEL DO +! END DO +! END DO +! END IF +! +!END IF + +!CM3#55-4 - note that at some point we need to ensure that CABLE values +! into these JULES vars for output purposes +!!---------------------------------------------------------------------- +!! Increment accumulation of leaf turnover rate. +!! This is required for leaf phenology and/or TRIFFID, either of +!! which can be enabled independently of the other. +!!---------------------------------------------------------------------- +!IF ( cycleno == numcycles .OR. l_quick_ap2 ) THEN +! +! IF (l_phenol .AND. .NOT. l_triffid) THEN +! DO n = 1,nnpft +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!!$OMP SHARED(n, land_pts, g_leaf_acc, g_leaf, timestep) +! DO l = 1,land_pts +! g_leaf_acc(l,n) = g_leaf_acc(l,n) + & +! g_leaf(l,n) * ( timestep / secs_per_360days ) +! END DO +!!$OMP END PARALLEL DO +! END DO +! END IF + +!!jhan +! !---------------------------------------------------------------------- +! ! Increment accumulation prognostics for TRIFFID +! !---------------------------------------------------------------------- +! IF (l_triffid) THEN +! DO n = 1,nnpft +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!!$OMP SHARED(n, land_pts, g_leaf_acc, g_leaf, timestep, & +!!$OMP npp_pft_acc, npp_pft, resp_w_pft_acc, resp_w_pft) +! DO l = 1,land_pts +! g_leaf_acc(l,n) = g_leaf_acc(l,n) + & +! g_leaf(l,n) * ( timestep / secs_per_360days ) +! npp_pft_acc(l,n) = npp_pft_acc(l,n) + npp_pft(l,n) * timestep +! resp_w_pft_acc(l,n) = resp_w_pft_acc(l,n) & +! + resp_w_pft(l,n) * timestep +! END DO +!!$OMP END PARALLEL DO +! END DO +! END IF +! +!IF ( soil_bgc_model == soil_model_rothc ) THEN +! DO n = 1,dim_cs1 +! DO nn = 1,dim_cslayer +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!!$OMP SHARED(n, nn, land_pts,resp_s_soilt, resp_s_acc_soilt, timestep) +! DO l = 1,land_pts +! !soil tiling is not compatible with triffid. OK to hard-code soil +! !tile index to 1 here +! ! calculated before resp_frac applied +! resp_s_acc_soilt(l,1,nn,n) = resp_s_acc_soilt(l,1,nn,n) & +! + resp_s_soilt(l,1,nn,n) * timestep +! END DO +!!$OMP END PARALLEL DO +! END DO +! END DO +! END IF +! +!END IF ! CycleNo == NumCycles + +!CM3#55-5 +!!----------------------------------------------------------------------- +!! calculate CO2:(BIO+HUM) ratio, dependent on soil clay content, and +!! sum soil respiration components +!! (RESP_FRAC here then contains the fraction of soil respiration which +!! is respired to the atmos. the rest is re-partitioned into BIO+HUM) +! +!! resp_s_acc_soilt contains the full amount, and this is carried forward to +!! VEG_CTL for use in updating soil carbon pools. RESP_S_TOT calculated +!! here is passed to BL_TRMIX as the fraction which is respired as CO2 +!! to the atmosphere. RESP_S_TOT, and RESP_S are also passed out for +!! storage in diagnostics 3293, and 3467-470. +! +!!----------------------------------------------------------------------- +!IF ( soil_bgc_model == soil_model_rothc ) THEN +! DO j = 1, nsoilt +! DO i = 1, land_pts +! resp_s_tot_soilt(i,j)=0.0 +! END DO +! END DO +! !soil tiling is not compatible with triffid. OK to hard-code soil tile +! !index to 1 here by setting m = 1 +! m = 1 +! DO nn = 1,dim_cslayer +! DO i = 1,land_pts +! work_clay = EXP(-0.0786 * 100.0 * clay_soilt(i,m,nn)) +! resp_frac(i,nn) = (3.0895+2.672 * work_clay) / & +! (4.0895+2.672 * work_clay) +! resp_s_soilt(i,m,nn,1) = resp_s_soilt(i,m,nn,1) * resp_frac(i,nn) +! resp_s_soilt(i,m,nn,2) = resp_s_soilt(i,m,nn,2) * resp_frac(i,nn) +! resp_s_soilt(i,m,nn,3) = resp_s_soilt(i,m,nn,3) * resp_frac(i,nn) +! resp_s_soilt(i,m,nn,4) = resp_s_soilt(i,m,nn,4) * resp_frac(i,nn) +! resp_s_tot_soilt(i,m) = resp_s_tot_soilt(i,m) & +! + resp_s_soilt(i,m,nn,1) & +! + resp_s_soilt(i,m,nn,2) & +! + resp_s_soilt(i,m,nn,3) & +! + resp_s_soilt(i,m,nn,4) +! END DO ! layers +! END DO ! points +!END IF + +!CM3#55-6 - CABLE always runs with tiles +!!----------------------------------------------------------------------- +!! Reset surft_pts and surft_index and set tile fractions to 1 if aggregate +!! tiles are used (L_AGGREGATE=.T.). +!! Otherwise, set tile fractions to surface type fractions. +!!----------------------------------------------------------------------- +!IF (l_aggregate) THEN +! surft_pts(1) = land_pts +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!!$OMP SHARED(land_pts, tile_frac, surft_index) +! DO l = 1,land_pts +! tile_frac(l,1) = 1.0 +! surft_index(l,1) = l +! END DO +!!$OMP END PARALLEL DO +!ELSE + DO n = 1,ntype +!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!$OMP SHARED(land_pts, tile_frac, frac, n) + DO l = 1, land_pts + tile_frac(l,n) = frac(l,n) + END DO +!$OMP END PARALLEL DO + END DO +!END IF + +IF (land_pts > 0) THEN ! Omit if no land points + + !CM3#55-7 - CABLE needs to provide values for hcons_soilt and hcons_snow + ! retain for now but ideally we'd use CABLE science not JULES science + !----------------------------------------------------------------------- + ! Calculate the thermal conductivity of the top soil layer. + !----------------------------------------------------------------------- + DO m = 1, nsoilt + CALL heat_con (land_pts,hcon_soilt,sthu_soilt(:,m,1), & + sthf_soilt(:,m,1),smvcst_soilt(:,m,1),hcons_soilt(:,m)) + END DO + + ! Thermal conductvity of top snow layer if nsmax > 0 + !CM2!IF (nsmax > 0) THEN + !CM2! DO n = 1,nsurft + !CM2! CALL snowtherm(land_pts,surft_pts(n),nsnow_surft(:,n), & + !CM2! surft_index(:,n),ds_surft(:,n,:),sice_surft(:,n,:), & + !CM2! sliq_surft(:,n,:),csnow,ksnow) + !CM2! DO l = 1,land_pts + !CM2! hcons_snow(l,n) = ksnow(l,1) + !CM2! END DO + !CM2! END DO + !CM2!END IF + +END IF ! End test on land points + +!CM3#55-8 - correctly removed already +!----------------------------------------------------------------------- +! Calculate net radiation on land tiles +!----------------------------------------------------------------------- +!CM2!$OMP PARALLEL & +!CM2!$OMP DEFAULT(NONE) & +!CM2!$OMP PRIVATE(l,k,j,i,n) & +!CM2!$OMP SHARED(surft_pts,surft_index,land_index,pdims,radnet_surft,sw_surft, & +!CM2!$OMP emis_surft,sky,lw_down,tstar_surft,nsurft,l_skyview) +!CABLE_LSM:CM2 +!CM2IF (l_skyview) THEN +!CM2 DO n = 1,nsurft +!CM2!$OMP DO SCHEDULE(STATIC) +!CM2 DO k = 1,surft_pts(n) +!CM2 l = surft_index(k,n) +!CM2 j=(land_index(l) - 1) / pdims%i_end + 1 +!CM2 i = land_index(l) - (j-1) * pdims%i_end +!CM2 radnet_surft(l,n) = sw_surft(l,n) + emis_surft(l,n) * & +!CM2 sky(i,j) * ( lw_down(i,j) - sbcon * tstar_surft(l,n)**4 ) +!CM2 END DO +!CM2!$OMP END DO NOWAIT +!CM2 END DO +!CM2ELSE +!CM2 DO n = 1,nsurft +!CM2!$OMP DO SCHEDULE(STATIC) +!CM2 DO k = 1,surft_pts(n) +!CM2 l = surft_index(k,n) +!CM2 j=(land_index(l) - 1) / pdims%i_end + 1 +!CM2 i = land_index(l) - (j-1) * pdims%i_end +!CM2 radnet_surft(l,n) = sw_surft(l,n) + emis_surft(l,n) * & +!CM2 ( lw_down(i,j) - sbcon * tstar_surft(l,n)**4 ) +!CM2 END DO +!CM2!$OMP END DO NOWAIT +!CM2 END DO +!CM2END IF +!CM2!!$OMP END PARALLEL + + +!----------------------------------------------------------------------- +! 4. Surface turbulent exchange coefficients and "explicit" fluxes +! (P243a, routine SF_EXCH). +! Wind mixing "power" and some values required for other, later, +! diagnostic calculations, are also evaluated if requested. +!----------------------------------------------------------------------- + +!CM3#55-9 +!IF ( l_rp2 .AND. i_rp_scheme == i_rp2b) THEN +! DO n = 1,npft +! z0h_z0m(n) = z0hm_pft_rp(n) +! END DO +!END IF + +!CM3#55-10 - note that snowdep_surft needs to take CABLE value - check + +!$OMP PARALLEL PRIVATE(i,j,l,n) DEFAULT(NONE) IF(land_pts>1) & +!$OMP SHARED(land_pts,nsurft,land_index, flandg,z_land,t_i_length, & +!$OMP can_model,cansnowtile,l_snowdep_surf,snow_surft,rho_snow_const, & +!$OMP snowdep_surft,surf_hgt_surft,ctile_orog_fix,l_ctile) +!DO n = 1,nsurft +! IF ( (can_model == 4) .AND. cansnowtile(n) .AND. l_snowdep_surf ) THEN +!!$OMP DO SCHEDULE(STATIC) +! DO l = 1,land_pts +! snowdep_surft(l,n) = snow_surft(l,n) / rho_snow_const +! END DO +!!$OMP END DO NOWAIT +! END IF +!END DO + +!CM3#55-11 +IF (ctile_orog_fix == correct_sea_adjust_land .AND. l_ctile) THEN +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + IF (flandg(i,j) > 0.0 .AND. flandg(i,j) < 1.0) THEN + ! calculate height of orography relative to grid-box mean + ! limit this to 1000m. z_land already limited to be > 0 + ! in ni_bl_ctl + surf_hgt_surft(l,:) = MIN(z_land(i,j) * (1.0 / flandg(i,j) - 1.0),1000.0) + END IF + END DO +!$OMP END DO NOWAIT +END IF +!$OMP END PARALLEL + +!CM3#55-12 +! Calculate temperature and specific humidity for elevation bands +CALL elevate( & + land_pts,nsurft,surft_pts,land_index,surft_index, & + tl_1,qw_1,pstar,surf_hgt_surft,l_elev_absolute_height,z_land, & + t_elev,q_elev) + + +!----------------------------------------------------------------------- +! 2. Calculate QSAT values required later. +!----------------------------------------------------------------------- +!CM3#55-13 + +!$OMP PARALLEL DO IF(land_pts > 1) DEFAULT(NONE) PRIVATE(i, j, l) & +!$OMP SHARED(land_index, land_pts, pstar, pstar_land, t_i_length) & +!$OMP SCHEDULE(STATIC) +DO l = 1,land_pts + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + pstar_land(l) = pstar(i,j) +END DO +!$OMP END PARALLEL DO + +IF (l_mr_physics) THEN +!$OMP PARALLEL DO IF(nsurft > 1) DEFAULT(NONE) PRIVATE(n) & +!$OMP SHARED(nsurft,qstar_surft,tstar_surft,pstar_land,land_pts, & +!$OMP qs1_elev,t_elev) SCHEDULE(STATIC) + DO n = 1,nsurft + CALL qsat_mix(qstar_surft(:,n),tstar_surft(:,n),pstar_land,land_pts) + CALL qsat_mix(qs1_elev(:,n),t_elev(:,n),pstar_land,land_pts) + END DO +!$OMP END PARALLEL DO +ELSE +!$OMP PARALLEL DO IF(nsurft > 1) DEFAULT(NONE) PRIVATE(n) & +!$OMP SHARED(nsurft,qstar_surft,tstar_surft,pstar_land,land_pts, & +!$OMP qs1_elev,t_elev) SCHEDULE(STATIC) + DO n = 1,nsurft + CALL qsat(qstar_surft(:,n),tstar_surft(:,n),pstar_land,land_pts) + CALL qsat(qs1_elev(:,n),t_elev(:,n),pstar_land,land_pts) + END DO +!$OMP END PARALLEL DO +END IF + +!CM3#55-14 +!----------------------------------------------------------------------- +!! Calculate gradient of saturated specific humidity for use in +!! calculation of surface fluxes +!----------------------------------------------------------------------- +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(k,l,n,d_t, i, j) & +!$OMP SHARED(nsurft,surft_pts,surft_index,tstar_surft,t_elev,alpha1, & +!$OMP qstar_surft,qs1_elev,epsil,c_virtual,r, tdims,rhostar_mom,rhostar) +DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + d_t = tstar_surft(l,n) - t_elev(l,n) + IF (d_t > 0.05 .OR. d_t < -0.05) THEN + alpha1(l,n) = (qstar_surft(l,n) - qs1_elev(l,n)) / d_t + ELSE IF (t_elev(l,n) > tm) THEN + alpha1(l,n) = epsil * lc * qs1_elev(l,n) * & + (1.0 + c_virtual * qs1_elev(l,n)) / & + ( r * t_elev(l,n) * t_elev(l,n)) + ELSE + alpha1(l,n) = epsil * ls * qs1_elev(l,n) * & + (1.0 + c_virtual * qs1_elev(l,n)) / & + ( r * t_elev(l,n) * t_elev(l,n)) + END IF + END DO +!$OMP END DO NOWAIT +END DO + +!----------------------------------------------------------------------- +! If requested, improve accuracy of air density, rhostar +! On input rhostar = pstar/R*Tstar +!----------------------------------------------------------------------- +!$OMP DO SCHEDULE(STATIC) +DO j = tdims%j_start,tdims%j_end + DO i = tdims%i_start,tdims%i_end + ! original approximation for surface air density + rhostar_mom(i,j) = rhostar(i,j) + END DO +END DO +!$OMP END DO +!$OMP END PARALLEL + +IF (l_accurate_rho) THEN + ! More accurate expressions for surface air density. + ! Use bottom level vapour as a better approximation over land + ! than qsat(tstar) + CALL calc_air_dens(l_mr_physics,qw_1,rhostar,rhostar_mom) + +END IF ! l_accurate_rho + +!CM3#55-16 +!! Initialise scaling_urban to 1.0 so that it only affects urban tiles when +!! MORUSES used with no aggregation. +!IF ( .NOT. l_aggregate .AND. l_moruses_storage ) THEN +! n = urban_canyon +!!$OMP PARALLEL DO IF(land_pts > 1) DEFAULT(NONE) PRIVATE(l) SHARED(land_pts, & +!!$OMP n, scaling_urban, tile_frac, urban_roof) SCHEDULE(STATIC) +! DO l = 1, land_pts +! IF ( tile_frac(l,n) > 0.0 ) THEN +! scaling_urban(l,n) = & +! ( tile_frac(l,n) + tile_frac(l,urban_roof) ) / & +! tile_frac(l,n) +! END IF +! END DO +!!$OMP END PARALLEL DO +!END IF + +!CM3#55-17 +!! Calculate average layer temperature and conductivity for lakes. +!! This is a fudge - a layer with average properties won't +!! really behave like a stack of layers with different properties. +!! +!IF ( l_flake_model & +! .AND. ( .NOT. l_aggregate)) THEN +! +! !============================================================================== +! ! *NOTICE REGARDING SOIL TILING** +! ! +! !The following section facilitates the use of soil tiling. As implemented, +! !there are two soil tiling options: +! ! +! !nsoilt == 1 +! !Operate as with a single soil tile, functionally identical to JULES upto +! ! at least vn4.7 (Oct 2016) +! ! This means that a soilt variable being passed 'up' to the surface is +! ! broadcast to the surft variable (with weighting by frac if requred) +! ! +! !nsoilt > 1 +! !Operate with nsoilt = nsurft, with a direct mapping between them +! ! This means that a soilt variable being passed 'up' to the surface is simply +! ! copied into the surft variable +! ! +! ! This will need to be refactored for other tiling approaches. This note +! ! will be replicated elsewhere in the code as required +! ! +! !These comments apply until **END NOTICE REGARDING SOIL TILING** +! !============================================================================== +! +!!$OMP PARALLEL DEFAULT(NONE) PRIVATE(l, m) & +!!$OMP SHARED(l_flake_model, l_aggregate, land_pts, nsoilt, hcon_lake, & +!!$OMP dzsoil, hcons_mean_soil, hcons_soilt, t_soil_soilt, tile_frac, & +!!$OMP lake_h_ice_gb, snow_hcon, lake_depth_gb, nusselt_gb, & +!!$OMP g_dt_gb, ts1_lake_gb, lake_t_mxl_gb, lake_t_ice_gb, & +!!$OMP tsoil_mean_soil, lake_ice_mid_temp, l_shallow_lake_depth) +! +! ! Initialise thermal variables to zero and then set to mean soil values +!!$OMP DO SCHEDULE(STATIC) +! DO l = 1, land_pts +! hcons_mean_soil(l) = 0.0 +! tsoil_mean_soil(l) = 0.0 +! hcon_lake(l) = 0.0 +! ts1_lake_gb(l) = 0.0 +! END DO +!!$OMP END DO +! IF (nsoilt == 1) THEN +! !Just 1 soil tile +! m = 1 +!!$OMP DO SCHEDULE(STATIC) +! DO l = 1, land_pts +! hcons_mean_soil(l) = hcons_soilt(l,m) +! tsoil_mean_soil(l) = t_soil_soilt(l,m,1) +! END DO +!!$OMP END DO +! ELSE +! !Surface tiles map directly on to soil tiles +!!$OMP DO SCHEDULE(STATIC) +! DO m = 1,nsoilt +! DO l = 1, land_pts +! hcons_mean_soil(l) = hcons_mean_soil(l) & +! + (tile_frac(l,m) * hcons_soilt(l,m)) +! tsoil_mean_soil(l) = tsoil_mean_soil(l) & +! + (tile_frac(l,m) * t_soil_soilt(l,m,1)) +! END DO +! END DO +!!$OMP END DO +! END IF +! +! !============================================================================== +! ! *END NOTICE REGARDING SOIL TILING** +! !============================================================================== +! +! IF (dzsoil(1) <= 0.0) THEN +! ! +! ! catch-all for sillies - just use soil value +! ! +!!$OMP DO SCHEDULE(STATIC) +! DO l = 1, land_pts +! hcon_lake(l) = hcons_mean_soil(l) +! ts1_lake_gb(l) = tsoil_mean_soil(l) +! END DO +!!$OMP END DO NOWAIT +! +! ELSE +! +!!$OMP DO SCHEDULE(STATIC) +! DO l = 1, land_pts +! +! IF ( dzsoil(1) <= lake_h_ice_gb(l) ) THEN +! +! ! Near surface layer is entirely within the ice. Set conductivity +! ! to ice value and use piecewise linear interpolation to find +! ! temperature at midpoint of near surface layer. +! hcon_lake(l) = hcice +! ts1_lake_gb(l) = lake_t_ice_gb(l) + (dzsoil(1) / 2.0) * & +! (lake_t_mxl_gb(l) - lake_t_ice_gb(l)) & +! / lake_h_ice_gb(l) +! +! ELSE IF ( (dzsoil(1) > lake_h_ice_gb(l)) & +! .AND. (dzsoil(1) <= (lake_h_ice_gb(l) & +! +lake_depth_gb( l)))) THEN +! +! ! Set conductivity as weighted average of ice and water based upon +! ! realtive thicknesses and the Nusselt number +! nusselt_gb(l) = g_dt_gb(l) * (dzsoil(1) - lake_h_ice_gb(l) ) & +! / ( 2.0 * hcwat ) +! nusselt_gb(l) = MAX( nusselt_gb(l), 1.0 ) +! hcon_lake(l) = ( hcice * lake_h_ice_gb(l) & +! +hcwat * (dzsoil(1) - lake_h_ice_gb(l))) & +! * nusselt_gb(l) & +! / dzsoil(1) +! +! ! Find temperature mid-way through the ice layer +! ! (temperature varies linearly across ice layer) +! lake_ice_mid_temp(l) = lake_t_ice_gb(l) + 0.5 * (lake_t_mxl_gb(l) & +! - lake_t_ice_gb(l)) +! +! ! Calculate temperature as weighted average of temperature in ice layer +! ! and mixed layer temp for near surface water beneath the ice. +! ts1_lake_gb(l) = (lake_ice_mid_temp(l) * lake_h_ice_gb(l) & +! + lake_t_mxl_gb(l) * (dzsoil(1) - lake_h_ice_gb(l))) & +! / dzsoil(1) +! +! ELSE +! +! ! Lake depth is less than first soil layer thickness so set logical +! ! to write our warning message. +! l_shallow_lake_depth(l) = .TRUE. +! +! ! Set conductivity as weighted average of ice and water and soil +! ! based upon realtive thicknesses and the Nusselt number +! ! Use soil value for the temperature +! nusselt_gb(l) = g_dt_gb(l) * lake_depth_gb(l) & +! / ( 2.0 * hcwat ) +! nusselt_gb(l) = MAX( nusselt_gb(l), 1.0 ) +! hcon_lake(l) = ( hcice * lake_h_ice_gb(l) & +! + hcwat * lake_depth_gb(l) * nusselt_gb(l) & +! + hcons_mean_soil(l) * (dzsoil(1) & +! - lake_h_ice_gb(l) - lake_depth_gb(l))) & +! / dzsoil(1) +! ts1_lake_gb(l) = tsoil_mean_soil(l) +! +! END IF +! END DO +!!$OMP END DO NOWAIT +! END IF +!!$OMP END PARALLEL +! +! ! Write out warning message for negative top soil layer thinkness +! ! or lake depth less than first soil layer thinkness +! IF (dzsoil(1) <= 0.0) THEN +! errcode = -1 +! WRITE(cmessage, '(A,F16.4)') 'Negative value of dzsoil = ', dzsoil(1) +! CALL ereport(routinename, errcode, cmessage) +! END IF +! +! IF ( ANY(l_shallow_lake_depth(1:land_pts)) ) THEN +! errcode = -1 +! WRITE(cmessage, '(A,F16.4)') 'Unusual value of lake depth found '// & +! 'when computing hcon_lake. Found ' // & +! 'lake depth comparable to first ' // & +! 'soil layer: dzsoil= ', dzsoil(1) +! CALL ereport(routinename, errcode, cmessage) +! END IF +! +!END IF + +!CM3#55-18 +DO n = 1,nsurft +!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(l) & +!$OMP SHARED(n, land_pts, lw_down_elevcorr_surft) + DO l = 1,land_pts + lw_down_elevcorr_surft(l,n) = 0.0 + END DO +!$OMP END PARALLEL DO +END DO + +!CM3#55-19 - moving the necessary parts to after the call to CABLE +!IF( first_call ) THEN +! emis_surft = 1.0 +! emis_soil = 1.0 +! hcons_snow = hcons_soilt(1,1) +! first_call = .FALSE. +!END IF +!hcons_surf = hcons_soilt(1,1) +!hcons_snow = hcons_soilt(1,1) + +!CM3#55-20 +IF (l_elev_lw_down) THEN + + ! for tiles at different elevations, adjust downwelling longwave + ! according to the anomaly in surface temperature that has been + ! calculated with LW ~ T^4 + DO l = 1,land_pts + lw_down_surftsum(l) = 0.0 + lw_down_surftabs(l) = 0.0 + END DO + + DO n = 1,nsurft + DO l = 1,land_pts + j = (land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + IF (lw_down(i,j) > 0.0) THEN + + ! Adjust radiative temperature and net longwave + t_rad = 0.0 + IF (t_elev(l,n) > 0.0 ) THEN + t_rad = (lw_down(i,j) / sbcon)**(1.0 / 4.0) + t_rad = t_rad + t_elev(l,n) - tl_1(i,j) + lw_down_elevcorr_surft(l,n) = sbcon * (t_rad**4) - lw_down(i,j) + END IF + + ! Keep track of total adjustments to longwave + lw_down_surftsum(l) = lw_down_surftsum(l) + & + lw_down_elevcorr_surft(l,n) * tile_frac(l,n) + lw_down_surftabs(l) = lw_down_surftabs(l) + & + ABS(lw_down_elevcorr_surft(l,n)) * tile_frac(l,n) + END IF + END DO + END DO + + DO l = 1,land_pts + j = (land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + IF (lw_down(i,j) > 0.0) THEN + IF (lw_down_surftabs(l) > EPSILON(0.0)) THEN + ! correct each adjustment to preserve the gridbox mean. + ! size of correction in proportion to the size of adjustment + ! so that unadjusted tiles remain unaffected + DO n = 1,nsurft + lw_down_elevcorr_surft(l,n) = lw_down_elevcorr_surft(l,n) & + - lw_down_surftsum(l) & + * ABS(lw_down_elevcorr_surft(l,n)) & + / lw_down_surftabs(l) + END DO + END IF + END IF + END DO + + !CM3#55-20 - these lines are correctly removed +!CM2! ! Adjust the net radiation +!CM2! DO n = 1,nsurft +!CM2! DO l = 1,land_pts +!CM2! j = (land_index(l) - 1) / t_i_length + 1 +!CM2! i = land_index(l) - (j-1) * t_i_length +!CM2! IF (lw_down(i,j) > 0.0) THEN +!CM2! IF (l_skyview) THEN +!CM2! radnet_surft(l,n) = radnet_surft(l,n) & +!CM2! + sky(i,j) * emis_surft(l,n) & +!CM2! * lw_down_elevcorr_surft(l,n) +!CM2! ELSE +!CM2! radnet_surft(l,n) = radnet_surft(l,n) & +!CM2! + emis_surft(l,n) * lw_down_elevcorr_surft(l,n) +!CM2! END IF +!CM2! END IF +!CM2! END DO +!CM2! END DO +END IF + +!============================================================================= +!CM3#55 - at this point all of the forcing for CABLE has been created - +! so call CABLE and then map remaining values back to JULES variables +! where needed. + +!CABLE_LSM:CM2.5 Oddly tstar_surft is declared as INTENT(IN) above!! +! This is important may need to be followed up as the INTENTs are likely inherited +! - the simplest work around would be to not UNPACK %trad to tstar_surft +! in the explicit section. +! +! However we do NEED to provide a value for dtstar_surft - this is missing +! +! Also we may wish to force cable with lw_down_elevcorr_surft not lw_down +CALL cable_explicit_main( & + ! IN: UM/JULES model/grid parameters, fields, mappings + mype, timestep, timestep_number, tdims%i_end, tdims%j_end, land_pts, & + nsurft, npft, sm_levels, dzsoil, land_index, surft_pts, surft_index, & + cos_zenith_angle, latitude, longitude, Flandg, tile_frac, & + + ! IN: soil parameters !1 is only allowable index in UM + bexp_soilt(:,1,:), hcon_soilt(:,1), satcon_soilt(:,:), & + sathh_soilt(:,1,:), smvcst_soilt(:,1,:), smvcwt_soilt(:,1,:), & + smvccl_soilt(:,1,:), albsoil_soilt(:,1), & + + ! IN: Met forcing: + lw_down, sw_surft, ls_rain, ls_snow, & + tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy, & + ! This an outlier IN here. INOUT @ implicit. (was)OUT at extras + ! I think we are dealing with it OK now but confusion could be removed + snow_surft, & + + ! IN: canopy height, LAI seasonally presecribed, potentially prognostic + ! IN: CO2 mass mixing ratio + canht_pft, lai_pft, co2_mmr, & + + ! TYPEs passed from top_level to maintain scope, access to UM STASH + ! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit + ! INOUT: Carries fields needed by CABLE b/n pathways (rad, explicit etc) + ! Currently carrying CABLE TYPEs (canopy%, rad% etc). + ! IN: pars carries vegin/soilin - potentially redundant + progs_cbl, work_cbl, pars_io_cbl, & + + ! OUT: UM fields UNPACKed from CABLE (@ explicit) + ftl_surft, fqw_surft, tstar_surft, dtstar_surft, u_s, u_s_std_surft, & + cd_surft, ch_surft, radnet_surft, fraca, resfs, resft, z0h_surft, & + z0m_surft, recip_l_MO_surft, epot_surft, npp_pft_acc, resp_w_pft_acc ) + +! hard-wire CABLE emissivities into respective JULES vars - CM3#55-19 +! hcons_surf and hcons_snow should not need filling again +DO l=1,land_pts + emis_soil(l) = 1.0 +END DO + +DO n=1,nsurft + DO l=1,land_pts + emis_surft(l,n) = 1.0 + flake(l,n) = 0.0 !CM2-era overwrite - CM#55-24 + END DO +END DO + +!pass CABLE non-topography impacted values for drag & fr velo into JULES variables +DO n=1,nsurft + DO l=1,land_pts + cd_std(l,n) = cd_surft(l,n) + v_s_surft(l,n) = u_s_std_surft(l,n) !estimate of fr vel with topography + v_s_std(l,n) = u_s_std_surft(l,n) !value of fraction velocity no topography + z0m_eff_surft(l,n) = z0m_surft(l,n) !default topograhic roughness (?needed) + END DO +END DO + + +!CM3#55-22 CM3#55-23 +!recip_l_mo_surft = 1.0 !? +!v_s_std = 1.0e-6 !? +!CM3#55-24 - noting the link to resfs +!flake =0.0 !CABLE_LSM:CM2clobbered flake + +!CM3#55 - from here on goes a set of mappings from CABLE to JULES and/or from +! JULES to JULES given a CABLE variable has been given earlier. +! +! variables that need thought are resft, hcons_soilt, hcons_snow, cd_surft, ch_surft, +! other parts of classic aerosol and dust code, ashtf_surft and ashtf_prime_surft +! +! we are looking to avoid any calls to fcdch (the science is complicated and does not +! follow CABLE science) and sf_flux +!CABLE_LSM: End +!============================================================================== + +!============================================================================== +! *NOTICE REGARDING SOIL TILING** +! +!The following section facilitates the use of soil tiling. As implemented, +!there are two soil tiling options: +! +!nsoilt == 1 +!Operate as with a single soil tile, functionally identical to JULES upto +! at least vn4.7 (Oct 2016) +! This means that a soilt variable being passed 'up' to the surface is +! broadcast to the surft variable (with weighting by frac if requred) +! +!nsoilt > 1 +!Operate with nsoilt = nsurft, with a direct mapping between them +! This means that a soilt variable being passed 'up' to the surface is simply +! copied into the surft variable +! +! This will need to be refactored for other tiling approaches. This note +! will be replicated elsewhere in the code as required +! +!These comments apply until **END NOTICE REGARDING SOIL TILING** +!============================================================================== + +!CM3#55-21 - hoping to be able to set ashtf_surft = 1.0 and ahstf_prime_surft=1.0 +! and bypass all of this +!DO n = 1,nsurft +! +! !Set the current soil tile (see notice above) +! IF (nsoilt == 1) THEN +! !There is only 1 soil tile +! m = 1 +! ELSE ! nsoilt == nsurft +! !Soil tiles map directly on to surface tiles +! m = n +! END IF !nsoilt +! +! ! Set up soil and surface thermal properties +!!$OMP PARALLEL DO IF(land_pts > 1) DEFAULT(NONE) & +!!!$OMP PRIVATE(i, j, l, ds_ratio) & +!!$OMP SHARED(land_pts, land_index, t_i_length, tsurf, t_soil_soilt, t_elev, & +!!$OMP tl_1, & +!!$OMP dzsurf, dzsoil, hcons_surf, hcons_soilt, canhc_surf, canhc_surft, & +!!$OMP nsmax, nsnow_surft, tsnow_surft, ds_surft, hcons_snow, & +!!$OMP cansnowtile, snowdepth_surft, snow_hcon, & +!!$OMP l_snow_nocan_hc, l_flake_model, l_aggregate, lake, & +!!$OMP n, m, ts1_lake_gb, hcon_lake, l_elev_land_ice, l_lice_point, & +!!$OMP tsurf_elev_surft, dzsoil_elev, l_lice_surft, hcondeep, & +!!$OMP l_moruses_storage, urban_roof, l_fix_moruses_roof_rad_coupling, & +!!$OMP vfrac_surft, ashtf_surft, scaling_urban, l_soil_point) & +!!$OMP SCHEDULE(STATIC) +! DO l = 1,land_pts +! j = (land_index(l) - 1) / t_i_length + 1 +! i = land_index(l) - (j-1) * t_i_length +! hcons_surf(l,n) = hcons_soilt(l,m) +! IF (l_elev_land_ice .AND. l_lice_point(l)) THEN +! +! ! Land ice +! tsurf(l,n) = tsurf_elev_surft(l,n) +! dzsurf(l,n) = dzsoil_elev +! canhc_surf(l,n) = 0.0 +! IF (l_lice_surft(n)) THEN +! hcons_surf(l,n) = snow_hcon +! ELSE +! hcons_surf(l,n) = hcondeep +! END IF +! ELSE +! +! ! Soil +! tsurf(l,n) = t_soil_soilt(l,m,1) + t_elev(l,n) - tl_1(i,j) +! dzsurf(l,n) = dzsoil(1) +! hcons_surf(l,n) = hcons_soilt(l,m) +! canhc_surf(l,n) = canhc_surft(l,n) +! END IF +! IF ( (l_flake_model ) & +! .AND. ( .NOT. l_aggregate) & +! .AND. (n == lake )) THEN +! +! ! Lake +! tsurf(l,n) = ts1_lake_gb(l) + t_elev(l,n) - tl_1(i,j) +! hcons_surf(l,n) = hcon_lake(l) +! dzsurf(l,n) = dzsoil(1) +! END IF +! IF ((nsmax > 0) .AND. (nsnow_surft(l,n) > 0)) THEN +! +! ! Snow +! tsurf(l,n) = tsnow_surft(l,n,1) +! ! change the effective surface layer thickness for snow +! dzsurf(l,n) = ds_surft(l,n,1) +! hcons_surf(l,n) = hcons_snow(l,n) +! IF ( ( .NOT. cansnowtile(n)) .AND. l_snow_nocan_hc .AND. & +! (nsmax > 0) .AND. (nsnow_surft(l,n) > 0) ) canhc_surf(l,n) = 0.0 +! END IF +! +! ! MORUSES: Uncouple the roof for perfect insulation. hcons should only be zero +! ! to change the "conductive" coupling to "uncoupled" otherwise it is radiatively +! ! coupled. +! IF ( .NOT. l_aggregate .AND. l_moruses_storage .AND. n == urban_roof ) THEN +! IF ( l_fix_moruses_roof_rad_coupling ) THEN +! IF (vfrac_surft(l,n) == 0.0) THEN +! hcons_surf(l,n) = 0.0 +! END IF +! ELSE +! hcons_surf(l,n) = 0.0 +! END IF +! END IF +! +! ! Set up surface soil condictivity +! ashtf_surft(l,n) = 2.0 *hcons_surf(l,n) / MAX( dzsurf(l,n), dzsoil(1) ) +! ! Except when n == urban_canyon when MORUSES is used +! ! scaling_urban(l) = 1.0 +! ashtf_surft(l,n) = ashtf_surft(l,n) * scaling_urban(l,n) +! +! ! Adjust surface soil condictivity for snow +! IF (snowdepth_surft(l,n) > 0.0 .AND. l_soil_point(l) & +! .AND. nsnow_surft(l,n) == 0 ) THEN +! IF ( l_moruses_storage .AND. n == urban_roof ) THEN +! ! This required as HCONS(L) = 0 in this case. +! ashtf_surft(l,n) = 0.0 +! ELSE +! ds_ratio = 2.0 * snowdepth_surft(l,n) / dzsurf(l,n) +! IF (ds_ratio <= 1.0) THEN +! ashtf_surft(l,n) = ashtf_surft(l,n) / & +! (1.0 + ds_ratio * (hcons_surf(l,n) / snow_hcon - 1.0)) +! ELSE +! ashtf_surft(l,n) = ashtf_surft(l,n) * & +! snow_hcon / hcons_surf(l,n) +! END IF +! END IF +! END IF +! +! END DO +!!$OMP END PARALLEL DO +!END DO +!============================================================================== +! *END NOTICE REGARDING SOIL TILING** +!============================================================================== + + +!----------------------------------------------------------------------- +! 3. Calculation of transfer coefficients and surface layer stability +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! 3.1 Calculate neutral roughness lengths +!----------------------------------------------------------------------- + +! Land tiles +!jh:could be able to dodge all these roughness calcs - test re-instating them +!jh!alla CM2 +!jh! Z0_SURFT contains the appropriate value for land-ice points, but has to +!jh! be modified for snow-cover on non-land-ice points. Thermal roughness +!jh! lengths are set to be proportional to the tiled roughness length in +!jh! the case of multiple tiles, but if tiled properties have already +!jh! been aggregated, an adjustment for snow cover is required. In this case +!jh! a ratio of 0.1 between the thermal and momentum roughness lengths over +!jh! snow is assumed; to do otherwise would require reaggregation. In the +!jh! case of multiple tiles, the assignment is delayed until the urban +!jh! options have been considered. +!jh! +!jh!$OMP PARALLEL DO IF(nsurft > 1) DEFAULT(NONE) PRIVATE(k, l, n, z0, zeta1) & +!jh!$OMP SHARED(nsurft, surft_pts, surft_index, snow_surft, & +!jh!$OMP l_soil_point, z0_surft, snowdep_surft, l_aggregate, & +!jh!$OMP i_aggregate_opt, z0h_surft_bare, z0m_surft, & +!jh!$OMP l_moruses_rough_surft, z0h_z0m, z0h_surft, & +!jh!$OMP z0h_surft_classic, & +!jh!$OMP z0h_z0m_classic) SCHEDULE(STATIC) +!jh +!jh!CM3#55-22 - only need to fill a value for classic stuff here +!jh!DO n = 1,nsurft +!jh !! MORUSES parameterises z0m and z0h differently and are not affected by snow +!jh !! in the same way so are dealt with independently +!jh !IF ( .NOT. l_moruses_rough_surft(n) ) THEN +!jh ! DO k = 1,surft_pts(n) +!jh ! l = surft_index(k,n) +!jh !IF ( snow_surft(l,n) > 0.0 .AND. l_soil_point(l) ) THEN +!jh ! z0 = z0_surft(l,n) - 0.1 * snowdep_surft(l,n) +!jh ! zeta1 = MIN( 5.0e-4 , z0_surft(l,n) ) +!jh ! z0m_surft(l,n) = MAX( zeta1 , z0 ) +!jh ! ! Set z0h_surft explicitly if this option is selected, +!jh ! ! otherwise, it will be set for the first tile below. +!jh ! IF (l_aggregate .AND. i_aggregate_opt == 1) THEN +!jh ! z0 = z0h_surft_bare(l,n) - 0.1 * 0.1 * snowdep_surft(l,n) +!jh ! zeta1 = MIN( 5.0e-5 , z0h_surft_bare(l,n) ) +!jh ! z0h_surft(l,n) = MAX( zeta1 , z0 ) +!jh ! END IF +!jh !ELSE +!jh ! z0m_surft(l,n) = z0_surft(l,n) +!jh ! ! Set z0h_surft explicitly if this option is selected, +!jh ! ! otherwise, it will be set for the first tile below. +!jh ! IF (l_aggregate .AND. i_aggregate_opt == 1) & +!jh ! z0h_surft(l,n) = z0h_surft_bare(l,n) +!jh !END IF +!jh +!jh !! Set the thermal roughness length if aggregation is not being +!jh !! carried out, or if the original scheme is being used. +!jh !! It must be done here for consistency with the urban options. +!jh !IF ( ( .NOT. l_aggregate) .OR. & +!jh ! (l_aggregate .AND. i_aggregate_opt == 0) ) & +!jh ! z0h_surft(l,n) = z0h_z0m(n) * z0m_surft(l,n) +!jh +!jh ! Also set additional roughness length for use in CLASSIC aerosol +!jh ! deposition scheme - CM3 retain - now done later +!jh !z0h_surft_classic(l,n) = z0h_z0m_classic(n) * z0m_surft(l,n) +!jh ! END DO +!jh !END IF +!jh!END DO +!jh!$OMP END PARALLEL DO +!jh +!jh!CM3#55-22 +!jh!! MORUSES does not yet contain a parametrisation for snow, which should not +!jh!! affect the behaviour of bluff bodies. It will instead affect the material +!jh!! roughness of the road & roof and not the walls, which are essentially +!jh!! snow-free. Snow could be added to the material roughness length for +!jh!! momentum before passing to urbanz0, which calculates roughness length for heat +!jh!! Two calls are required; one for urban_canyon and one for urban_roof. +!jh!! +!jh!! If l_aggregate MORUSES roughness lengths are set in the usual way above with +!jh!! z0_surft = ztm in sparm +!jh!IF ( .NOT. l_aggregate ) THEN +!jh! IF ( ANY( l_moruses_rough_surft(1:nsurft) ) ) THEN +!jh! n = urban_canyon +!jh!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(k,l,j,i) & +!jh!!$OMP SHARED(surft_pts,n,surft_index,land_index,t_i_length,z1_uv,z1_tq,hgt_gb, & +!jh!!$OMP hwr_gb,disp_gb,z0m_surft,z0_surft,z0h_surft,urban_roof, & +!jh!!$OMP z0h_surft_classic) +!jh! DO k = 1,surft_pts(n) +!jh! l = surft_index(k,n) +!jh! z0m_surft(l,n) = z0_surft(l,n) +!jh! z0m_surft(l,urban_roof) = z0_surft(l,urban_roof) +!jh! j = ( land_index(l) - 1 ) / t_i_length + 1 +!jh! i = land_index(l) - ( j - 1 ) * t_i_length +!jh! CALL urbanz0( & +!jh! n, z1_uv(i,j), z1_tq(i,j), hgt_gb(l), hwr_gb(l), disp_gb(l), & +!jh! z0m_mat, z0m_surft(l,n), z0h_surft(l,n) ) +!jh! CALL urbanz0( & +!jh! urban_roof, z1_uv(i,j), z1_tq(i,j), hgt_gb(l), hwr_gb(l), disp_gb(l), & +!jh! z0m_mat, z0m_surft(l,urban_roof), z0h_surft(l,urban_roof) ) +!jh! ! Make CLASSIC aerosol roughness length for urban tiles consistent +!jh! ! with those for heat and momentum +!jh! z0h_surft_classic(l,n) = z0h_surft(l,n) +!jh! z0h_surft_classic(l,urban_roof) = z0h_surft(l,urban_roof) +!jh! END DO +!jh!!$OMP END PARALLEL DO +!jh! END IF +!jh!END IF +!jh +!jh!CM3#55-22 +!jh!! Calculate roughness length affected by roughness sublayer in neutral +!jh!! conditions. +!jh!DO n = 1,nsurft +!jh! IF (l_vegdrag_surft(n)) THEN +!jh! CALL can_drag_z0( & +!jh! land_pts, surft_pts(n), surft_index(:,n), & +!jh! array_zero, canht_pft(:,n), lai_pft(:,n), & +!jh! z0m_surft(:,n), z0h_surft(:,n), zdt_surft(:,n)) +!jh! END IF +!jh!END DO + +! Calculate orographic effective parameter for neutral conditions +! if using orographic roughness scheme +IF (formdrag == effective_z0) THEN + DO n = 1,nsurft + CALL sf_orog ( & + land_pts,surft_pts(n),land_index,surft_index(:,n), & + ho2r2_orog,rib_surft(:,n),sil_orog_land,z0m_surft(:,n),z1_uv, & + wind_profile_factor(:,n),z0m_eff_surft(:,n) & + ) + END DO +ELSE + wind_profile_factor(:,:) = 1.0 + z0m_eff_surft(:,:) = z0m_surft(:,:) +END IF + + +!CM3#55 - CABLE now called earlier +!!CABLE_LSM:CM2.5 Oddly tstar_surft is declared as INTENT(IN) above!! +!CALL cable_explicit_main( & +! mype, timestep, timestep_number, & +! tdims%i_end,tdims%j_end, land_pts, nsurft, npft, sm_levels, dzsoil, & +! land_index, surft_pts, surft_index, canht_pft, lai_pft, Flandg, & +! co2_mmr, tile_frac, cos_zenith_angle, latitude, longitude, & +! bexp_soilt(:,1,:), hcon_soilt(:,1), satcon_soilt(:,:), & +! sathh_soilt(:,1,:), smvcst_soilt(:,1,:), smvcwt_soilt(:,1,:), & +! smvccl_soilt(:,1,:), sthu_soilt(:,1,:), albsoil_soilt(:,1), & +! lw_down, sw_surft, & +! ls_rain, ls_snow, & +! !not fully checked. iup to here all IN ! unpacked ? +! tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy, snow_surft, & +! progs_cbl, work_cbl, pars_io_cbl, & +! ftl_surft, fqw_surft, & +! tstar_surft, u_s, u_s_std_surft, cd_surft, ch_surft, & +! radnet_surft, fraca, resfs, resft, z0h_surft, z0m_surft, & +! recip_l_MO_surft, epot_surft, & +! npp_pft_acc, resp_w_pft_acc ) +! +!CD_STD = CD_surft +!V_S_surft = U_S_STD_surft +!V_S_STD = U_S_STD_surft +!z0m_eff_surft(:,:) = z0m_surft(:,:) +! +!recip_l_mo_surft = 1.0 !? +!v_s_std = 1.0e-6 !? +!flake =0.0 !CABLE_LSM:CM2clobbered flake +!!CABLE_LSM: End + +!----------------------------------------------------------------------- +! Calculate RESFT with neutral CH and EPDT = 0 for use in calculation +! of Richardson number. RESFT=1 for snow and land-ice. +!----------------------------------------------------------------------- + +!CM3#55-25 - noting that ideally we'd move the evaluation of resft to earlier +!DO n = 1,nsurft + !IF (l_vegdrag_surft(n)) THEN + ! CALL can_drag_phi_m_h( & + ! land_pts, surft_pts(n), surft_index(:,n), land_index, & + ! array_zero, z1_uv, z1_tq, canht_pft(:,n), lai_pft(:,n), & + ! z0m_surft(:,n), z0h_surft(:,n), & + ! phi_m, phi_h) + ! +!!$OMP PARALLEL DO IF(surft_pts(n)>1) DEFAULT(NONE) & +!!$OMP PRIVATE(i, j, k, l) & +!!$OMP SHARED(surft_pts, surft_index, t_i_length, land_index, & +!!$OMP phi_m, phi_h, chn, wind_profile_factor, dq, qw_1, & +!!$OMP qstar_surft, epdt, n, resft, resfs, flake, fraca) SCHEDULE(STATIC) +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! j=(land_index(l) - 1) / t_i_length + 1 +! i = land_index(l) - (j-1) * t_i_length +! chn(l,n) = vkman**2 / (phi_m(l) * phi_h(l)) * wind_profile_factor(l,n) +! dq(l) = qw_1(i,j) - qstar_surft(l,n) +! epdt(l) = 0.0 +! !CABLE_LSM:CM2 +! resft(l,n) = MIN(1.,flake(l,n) + (1. - flake(l,n)) * & +! ( fraca(l,n) + (1. - fraca(l,n))*resfs(l,n) )) +! END DO +!!$OMP END PARALLEL DO + +! ELSE ! l_vegdrag_surft = F + +!!$OMP PARALLEL DO IF(surft_pts(n)>1) DEFAULT(NONE) & +!!$OMP PRIVATE(i, j, k, l, zetah, zetam) & +!!$OMP SHARED(surft_pts, surft_index, t_i_length, land_index, z1_uv, resft, & +!!$OMP z0m_surft, z1_tq, z0h_surft, chn, wind_profile_factor, dq, qw_1, & +!!$OMP qstar_surft, epdt,resfs,fraca, flake,n) SCHEDULE(STATIC) + !DO k = 1,surft_pts(n) + ! l = surft_index(k,n) + ! j=(land_index(l) - 1) / t_i_length + 1 + ! i = land_index(l) - (j-1) * t_i_length + ! !zetam = LOG ( (z1_uv(i,j) + z0m_surft(l,n)) / z0m_surft(l,n) ) + ! !zetah = LOG ( (z1_tq(i,j) + z0m_surft(l,n)) / z0h_surft(l,n) ) + ! !chn(l,n) = (vkman / zetah) * (vkman / zetam) * & + ! ! wind_profile_factor(l,n) + ! !dq(l) = qw_1(i,j) - qstar_surft(l,n) + ! !epdt(l) = 0.0 + ! !CABLE_LSM: from 8.5 + ! !CM3#55-25 - now done later + ! !resft(l,n) = MIN(1.,flake(l,n) + (1. - flake(l,n)) * & + ! ! ( fraca(l,n) + (1. - fraca(l,n))*resfs(l,n) )) + ! END DO +!!$OMP END PARALLEL DO + +! END IF + +! ! We should only attempt to access sf_diag%resfs_stom(:,n) if it has +! ! been fully allocated. +! IF (sf_diag%l_et_stom .OR. sf_diag%l_et_stom_surft) THEN +! n_diag = n +! ELSE +! n_diag = 1 +! END IF + +!CABLE_LSM:CM2 +!CM2! CALL sf_resist ( & +!CM2! land_pts,surft_pts(n),land_index,surft_index(:,n),cansnowtile(n), & +!CM2! canopy(:,n),catch(:,n),chn(:,n),dq,epdt,flake(:,n),gc_surft(:,n), & +!CM2! gc_stom_surft(:,n),snowdep_surft(:,n),snow_surft(:,n),vshr_land, & +!CM2! fraca(:,n),resfs(:,n),resft(:,n), & +!CM2! sf_diag%resfs_stom(:,n_diag),sf_diag%l_et_stom,sf_diag%l_et_stom_surft) + +!END DO + +!CM3#55-26 +!----------------------------------------------------------------------- +! 3.2 Calculate bulk Richardson number for the lowest model level. +!----------------------------------------------------------------------- + +! Land tiles +DO n = 1,nsurft + CALL sf_rib ( & + land_pts,surft_pts(n),land_index,surft_index(:,n), & + bq_1,bt_1,qstar_surft(:,n),q_elev(:,n),resft(:,n),t_elev(:,n), & + tstar_surft(:,n),vshr_land,z0h_surft(:,n),z0m_surft(:,n),zdt_surft(:,n), & + z1_tq,z1_uv,l_vegdrag_surft(n), & + rib_surft(:,n),db_surft(:,n) & + ) +END DO + +!----------------------------------------------------------------------- +! 3.3 Calculate stability corrected effective roughness length. +! Stability correction only applies to land points. +!----------------------------------------------------------------------- + +IF (formdrag == effective_z0) THEN + DO n = 1,nsurft + CALL sf_orog ( & + land_pts,surft_pts(n),land_index,surft_index(:,n), & + ho2r2_orog,rib_surft(:,n),sil_orog_land,z0m_surft(:,n),z1_uv, & + wind_profile_factor(:,n),z0m_eff_surft(:,n) & + ) + END DO +END IF + +!CM3#53 - once the roughnesses have been fully evaluated including topograhpic effects +!then cd_surft, driction velocities etc. needs to be revised here +! also do ashtf_surft and ashtf_prime_surft here for readability (could go ealier) +! +!what appears to be needed is +! 1. cd_surft needs to be adjusted to reflect topographic effects. +! 2. cd_std remains unimpacted by topography (may not be needed) +! 3. u_s_std_surft needs to be unimpacted by topgraphic effects +! 4. _classic variables need to use the classic values where +! z0h is replaced by z0h_classic and z0m is replaced by z0m_eff +! +! the equations in fcdch() are that +! v_s = v_s_std / windfactor +! cd_surft = cd_std * v_s/v_s_std * windfactor +! where v_s_std and cd_std are those provided by CABLE (tiled, no topography) +! +! and u_s_std_surft = v_s_std +! +! since we don't know whether z0h from CABLE = z0h_classic we will +! need to recalculate the classic outputs but chose to approximate this as +! cd_std_classic = cd_std = cd_surft (from CABLE) but +! ch_surft_classic = ch_surft * log(z1_tq/z0h_surft) / log(z1_tq/z0h_classic) + +! first, evaluations that are needed regardless of configuration +! - these could go earlier +DO n=1,nsurft + DO l=1,land_pts + !fill ashtf_surft and ashtf_prime with default value + !this needs to be non-zero to function with im_sf_pt2 + ashtf_surft(l,n) = 1.0 + ashtf_prime_surft(l,n) = 1.0 + + !fill in resft + resft(l,n) = MIN(1.,flake(l,n) + (1. - flake(l,n)) * & + ( fraca(l,n) + (1. - fraca(l,n))*resfs(l,n) )) + END DO +END DO + +!if topographic form drag enabled revise the tile drag coefficient +IF (formdrag == effective_z0) THEN + DO n=1,nsurft + DO l=1,land_pts + v_s_surft(l,n) = v_s_std(l,n) / wind_profile_factor(l,n) + cd_surft(l,n) = cd_std(l,n) * v_s_surft(l,n) / v_s_std(l,n) * & + wind_profile_factor(l,n) + END DO + END DO +END IF + +!if classic aerosol scheme used evaluate the tile aerosol deposition coefficients +IF (l_aero_classic) THEN + DO n=1,nsurft + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + z0h_surft_classic(l,n) = z0h_z0m_classic(n) * z0m_surft(l,n) + + !using zetam and zetah as temporary vars + zetam = LOG ( (z1_tq(i,j) + z0m_surft(l,n)) / z0h_surft(l,n) ) + zetah = LOG ( (z1_tq(i,j) + z0m_surft(l,n)) / z0h_surft_classic(l,n) ) + + cd_std_classic(l,n) = cd_std(l,n) + ch_surft_classic(l,n) = ch_surft(l,n) * zetam / zetah + END DO + END DO +END IF + + +!----------------------------------------------------------------------- +! 3.4 Calculate CD, CH via routine FCDCH. +!----------------------------------------------------------------------- + +!CABLE_LSM:CM2 +!CM2!! Land tiles +!CM2!DO n = 1,nsurft +!CM2! IF (l_vegdrag_surft(n)) THEN +!CM2! n_veg = n +!CM2! z0m_eff_surft(:,n) = z0m_surft(:,n) +!CM2! ELSE +!CM2! n_veg = 1 +!CM2! END IF +!CM2! CALL fcdch ( & +!CM2! cor_mo_iter,land_pts,surft_pts(n), & +!CM2! surft_index(:,n),land_index, & +!CM2! db_surft(:,n),vshr_land, & +!CM2! z0m_eff_surft(:,n),z0h_surft(:,n),zdt_surft(:,n),zh, & +!CM2! z1_uv,z1_uv_top,z1_tq,z1_tq_top,wind_profile_factor(:,n), & +!CM2! ddmfx,ip_ss_solid,charnock, & +!CM2! charnock_w, & +!CM2! l_vegdrag_surft(n),canht_pft(:,n_veg),lai_pft(:,n_veg), & +!CM2! nsnow_surft(:,n),n,l_mo_buoyancy_calc,cansnowtile(n),l_soil_point, & +!CM2! canopy(:,n),catch(:,n),flake(:,n),gc_surft(:,n), & +!CM2! snowdep_surft(:,n),snow_surft(:,n),canhc_surf(:,n), & +!CM2! dzsurf(:,n),qstar_surft(:,n),q_elev(:,n),radnet_surft(:,n), & +!CM2! snowdepth_surft(:,n),timestep,t_elev(:,n),tsurf(:,n),tstar_surft(:,n), & +!CM2! vfrac_surft(:,n),emis_surft(:,n),emis_soil,anthrop_heat_surft(:,n), & +!CM2! scaling_urban(:,n),alpha1(:,n),hcons_surf(:,n),ashtf_surft(:,n), & +!CM2! rhostar,bq_1,bt_1, & +!CM2! cd_surft(:,n),ch_surft(:,n),cd_std(:,n), & +!CM2! v_s_surft(:,n),v_s_std(:,n),recip_l_mo_surft(:,n), & +!CM2! u_s_iter_surft(:,n) & +!CM2! ) +!CM2!END DO +!CM2! +!CM2!! As roughness length have been changed by vegetation drag effect, effective +!CM2!! roughness length should be updated. +!CM2!DO n = 1,nsurft +!CM2! IF (l_vegdrag_surft(n)) THEN +!CM2! z0m_surft(:,n) = z0m_eff_surft(:,n) +!CM2! IF (formdrag == effective_z0) THEN +!CM2! CALL sf_orog ( & +!CM2! land_pts,surft_pts(n),land_index,surft_index(:,n), & +!CM2! ho2r2_orog,rib_surft(:,n),sil_orog_land,z0m_surft(:,n),z1_uv, & +!CM2! wind_profile_factor(:,n),z0m_eff_surft(:,n) & +!CM2! ) +!CM2! END IF +!CM2! END IF +!CM2!END DO +!CM2! +!CM2!!$OMP PARALLEL IF(nsurft > 1) DEFAULT(NONE) PRIVATE(k, l, n) & +!CM2!!$OMP SHARED(cor_mo_iter, nsurft, surft_pts, surft_index, & +!CM2!!$OMP u_s_iter_surft, u_s_std_surft, v_s_std) +!CM2!IF ( cor_mo_iter >= use_correct_ustar ) THEN +!CM2! ! Use correct "standard" ustar +!CM2!!$OMP DO SCHEDULE(STATIC) +!CM2! DO n = 1,nsurft +!CM2! DO k = 1,surft_pts(n) +!CM2! l = surft_index(k,n) +!CM2! u_s_std_surft(l,n) = v_s_std(l,n) +!CM2! END DO +!CM2! END DO +!CM2!!$OMP END DO +!CM2!ELSE +!CM2! ! Use ustar from mid-iteration +!CM2!!$OMP DO SCHEDULE(STATIC) +!CM2! DO n = 1,nsurft +!CM2! DO k = 1,surft_pts(n) +!CM2! l = surft_index(k,n) +!CM2! u_s_std_surft(l,n) = u_s_iter_surft(l,n) +!CM2! END DO +!CM2! END DO +!CM2!!$OMP END DO +!CM2!END IF +!CM2!!$OMP END PARALLEL + +!----------------------------------------------------------------------- +! 3.5 Recalculate friction velocity for the dust scheme using the +! bare soil roughness length if using only 1 aggregated tile +!----------------------------------------------------------------------- + +!CM3#55-27 +!IF ((l_dust .OR. l_dust_diag) .AND. l_aggregate) THEN +! +! n = 1 +! ! Calculate z0m and z0h for bare soil +! IF (l_vary_z0m_soil) THEN +!!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(k, l) & +!!$OMP SHARED(n, soil, surft_pts, surft_index, z0m_soil_in, & +!!$OMP z0h_soil,z0h_z0m, z0m_soil, wind_profile_fac_soil) & +!!$OMP SCHEDULE(STATIC) +! DO k = 1, surft_pts(n) +! l = surft_index(k,n) +! z0m_soil(l,n) = z0m_soil_in(l) +! z0h_soil(l,n) = z0h_z0m(soil) * z0m_soil(l,n) +! ! Set wind profile factor to 1 as not using orog term in z0m +! wind_profile_fac_soil(l,n) = 1.0 +! END DO +!!$OMP END PARALLEL DO +! ELSE +!!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(k, l) & +!!$OMP SHARED(n, soil, surft_pts, surft_index, z0_soil, z0h_soil, & +!!$OMP z0h_z0m, z0m_soil, wind_profile_fac_soil) & +!!$OMP SCHEDULE(STATIC) +! DO k = 1, surft_pts(n) +! l = surft_index(k,n) +! z0m_soil(l,n) = z0_soil +! z0h_soil(l,n) = z0h_z0m(soil) * z0m_soil(l,n) +! ! Set wind profile factor to 1 as not using orog term in z0m +! wind_profile_fac_soil(l,n) = 1.0 +! END DO +!!$OMP END PARALLEL DO +! END IF + +! ! Call fcdch again to calculate dust friction velocity on bare soil. +! ! The canopy drag scheme is not available on the aggregated tile +! ! and is disabled. +! l_vegdrag_active_here = .FALSE. +! CALL fcdch ( & +! cor_mo_iter,land_pts,surft_pts(n), & +! surft_index(:,n),land_index, & +! db_surft(:,n),vshr_land, & +! z0m_soil(:,n),z0h_soil(:,n),zdt_dummy,zh, & +! z1_uv,z1_uv_top,z1_tq,z1_tq_top,wind_profile_fac_soil(:,n), & +! ddmfx,ip_ss_solid,charnock, & +! charnock_w, & +! l_vegdrag_active_here,array_zero,array_zero, & +! nsnow_surft(:,n),n,.FALSE.,cansnowtile(n),l_soil_point, & +! canopy(:,n),catch(:,n),flake(:,n),gc_surft(:,n), & +! snowdep_surft(:,n),snow_surft(:,n),canhc_surf(:,n), & +! dzsurf(:,n),qstar_surft(:,n),q_elev(:,n),radnet_surft(:,n), & +! snowdepth_surft(:,n),timestep,t_elev(:,n),tsurf(:,n),tstar_surft(:,n), & +! vfrac_surft(:,n),emis_surft(:,n),emis_soil,anthrop_heat_surft(:,n), & +! scaling_urban(:,n),alpha1(:,n),hcons_surf(:,n),ashtf_surft(:,n), & +! rhostar,bq_1,bt_1, & +! ! Following tiled outputs (except v_s_std_soil and u_s_iter_soil) +! ! are dummy variables not needed from this call +! cd_surft_soil(:,n),ch_surft_soil(:,n),cd_std_soil(:,n), & +! v_s_surft_soil(:,n),v_s_std_soil(:,n),recip_l_mo_surft_soil(:,n), & +! u_s_iter_soil(:,n) & +! ) + +!!$OMP PARALLEL IF(nsurft > 1) DEFAULT(NONE) PRIVATE(k, l, n) & +!!$OMP SHARED(cor_mo_iter, nsurft, surft_index, surft_pts, & +!!$OMP u_s_iter_soil, u_s_std_surft, v_s_std_soil) +! IF ( cor_mo_iter >= use_correct_ustar ) THEN +! ! Use correct "standard" ustar +!!$OMP DO SCHEDULE(STATIC) +! DO n = 1,nsurft +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! u_s_std_surft(l,n) = v_s_std_soil(l,n) +! END DO +! END DO +!!$OMP END DO +! ELSE +! ! Use ustar from mid-iteration +!!$OMP DO SCHEDULE(STATIC) +! DO n = 1,nsurft +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! u_s_std_surft(l,n) = u_s_iter_soil(l,n) +! END DO +! END DO +!!$OMP END DO +! END IF +!!$OMP END PARALLEL +! +!END IF + +!----------------------------------------------------------------------- +! 3.6 Recalculate cd, ch etc. using z0h=z0h_classic. The parameters +! calculated using this additional roughness length are for +! CLASSIC aerosol deposition only. +!----------------------------------------------------------------------- +!CM3#55-28 - we've implemented CABLE estimates for this earlier +! remove to facilitate simplification of ashtf evaluations +!IF (l_aero_classic) THEN +! ! The canopy drag scheme is not supported for this aerosol scheme and +! ! is turned off. +! l_vegdrag_active_here = .FALSE. +! ! Land tiles +! DO n = 1,nsurft +! CALL fcdch ( & +! ! Input variables identical to main call except using different z0h +! cor_mo_iter,land_pts,surft_pts(n), & +! surft_index(:,n),land_index, & +! db_surft(:,n),vshr_land, & +! z0m_eff_surft(:,n),z0h_surft_classic(:,n),zdt_dummy,zh, & +! z1_uv,z1_uv_top,z1_tq,z1_tq_top, & +! wind_profile_factor(:,n), & +! ddmfx,ip_ss_solid,charnock, & +! charnock_w, & +! l_vegdrag_active_here,array_zero,array_zero, & +! nsnow_surft(:,n),n,.FALSE.,cansnowtile(n),l_soil_point, & +! canopy(:,n),catch(:,n),flake(:,n),gc_surft(:,n), & +! snowdep_surft(:,n),snow_surft(:,n),canhc_surf(:,n), & +! dzsurf(:,n),qstar_surft(:,n),q_elev(:,n),radnet_surft(:,n), & +! snowdepth_surft(:,n),timestep,t_elev(:,n),tsurf(:,n),tstar_surft(:,n), & +! vfrac_surft(:,n),emis_surft(:,n),emis_soil,anthrop_heat_surft(:,n), & +! scaling_urban(:,n),alpha1(:,n),hcons_surf(:,n),ashtf_surft(:,n), & +! rhostar,bq_1,bt_1, & +! ! Following tiled outputs (except cd_std_classic and ch_surft_classic) +! ! are dummy variables not needed from this call +! cd_surft_classic(:,n),ch_surft_classic(:,n), & +! cd_std_classic(:,n),v_s_surft_classic(:,n), & +! v_s_std_classic(:,n),recip_l_mo_surft_classic(:,n), & +! u_s_iter_classic(:,n) & +! ) +! END DO +!END IF + +!----------------------------------------------------------------------- +! Calculate gridbox-means of transfer coefficients. +!----------------------------------------------------------------------- + +! Land tiles +DO n = 1,nsurft + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + cd_land(i,j) = cd_land(i,j) + tile_frac(l,n) * cd_surft(l,n) + ch_land(i,j) = ch_land(i,j) + tile_frac(l,n) * ch_surft(l,n) + END DO +END DO + +! aerodynamic resistance diagnostic +IF (sf_diag%l_ra) THEN + DO l = 1,land_pts + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + sf_diag%ra(l) = 1.0 / (ch_land(i,j) * vshr_land(i,j)) + END DO +END IF + +!----------------------------------------------------------------------- +! 4.3 Calculate the surface exchange coefficients RHOK(*) and +! resistances for use in CLASSIC aerosol scheme +! (Note that CD_STD, CH and VSHR should never = 0) +! RHOSTAR * CD * VSHR stored for diagnostic output before +! horizontal interpolation. +!----------------------------------------------------------------------- + +! Land tiles +DO n = 1,nsurft + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + rhokm_1_surft(l,n) = rhostar_mom(i,j) * cd_surft(l,n) * vshr_land(i,j) + ! ! P243.124 + rhokm_land(i,j) = rhokm_land(i,j) + & + tile_frac(l,n) * rhokm_1_surft(l,n) + rhokh_surft(l,n) = rhostar_mom(i,j) * ch_surft(l,n) * vshr_land(i,j) + ! ! P243.125 + END DO +END DO + +!----------------------------------------------------------------------- +! Calculate local and gridbox-average surface fluxes of heat and +! moisture. +!----------------------------------------------------------------------- + +! Adjust ASHTF for sens. heat flux to ground beneath coniferous canopy +!CM3#55-missed in first pass - remove as can_model==4 not relevant to CABLE +!IF ( .NOT. l_aggregate .AND. can_model == 4) THEN +! DO n = 1,npft +! IF ( cansnowtile(n) ) THEN +!!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE( k, l, j, i) & +!!$OMP SHARED(n, cd_surft, land_index, rhokh_can, rhostar, surft_pts, & +!!$OMP surft_index, t_i_length, vshr_land, cp) SCHEDULE(STATIC) +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! j=(land_index(l) - 1) / t_i_length + 1 +! i = land_index(l) - (j-1) * t_i_length +! rhokh_can(l,n) = rhostar(i,j) * cp / & +! (43.0 / (SQRT(cd_surft(l,n)) * vshr_land(i,j))) +! END DO +!!$OMP END PARALLEL DO +! END IF +! END DO +!END IF + +!----------------------------------------------------------------------- +! 4.1 Recalculate RESFT using "true" CH and EPDT for land tiles +!----------------------------------------------------------------------- + +lh0 = lc +sea_point = 0.0 + +DO n = 1,nsurft +!!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(i, j, k, l) & +!!$OMP SHARED(ch_surft, land_index, qstar_surft, qw_1, dq, epdt,n, & +!!$OMP rhostar, surft_pts, surft_index, timestep, t_i_length, & +!!$OMP vshr_land) SCHEDULE(STATIC) + + !CM3#55-29 - we do not need ashtf_surft or ashtf_prime_surft to take a true value + ! only non-zero is needed - see above - remove sf_flux_cbl + !! Calcualte humidity gradient and rate of change of potential evaporation + !! with time + !DO k = 1,surft_pts(n) + ! l = surft_index(k,n) + ! j = (land_index(l) - 1) / t_i_length + 1 + ! i = land_index(l) - (j-1) * t_i_length + ! dq(l) = qw_1(i,j) - qstar_surft(l,n) + ! epdt(l) = - rhostar(i,j) * ch_surft(l,n) * vshr_land(i,j) & + ! *dq(l) * timestep + !END DO +!!$OMP END PARALLEL DO + +! ! We should only attempt to access sf_diag%resfs_stom(:,n) if it has +! ! been fully allocated. +! IF (sf_diag%l_et_stom .OR. sf_diag%l_et_stom_surft) THEN +! n_diag = n +! ELSE +! n_diag = 1 +! END IF + +!CABLE_LSM:CM2{ This is all being done above BUT to ashtf_surft - in CM2 we used +!elements of sf_flux to update ashtf_prime and others, however it seems the +!others were unnecessary +!CM2! CALL sf_resist ( & +!CM2! land_pts,surft_pts(n),land_index,surft_index(:,n),cansnowtile(n), & +!CM2! canopy(:,n),catch(:,n),ch_surft(:,n),dq,epdt,flake(:,n),gc_surft(:,n), & +!CM2! gc_stom_surft(:,n),snowdep_surft(:,n),snow_surft(:,n),vshr_land, & +!CM2! fraca(:,n),resfs(:,n),resft(:,n), & +!CM2! sf_diag%resfs_stom(:,n_diag),sf_diag%l_et_stom,sf_diag%l_et_stom_surft) + +! CALL sf_flux_cbl ( & +! land_pts,surft_pts(n), & +! land_index,surft_index(:,n), & +! nsnow_surft(:,n),n,canhc_surf(:,n),dzsurf(:,n),hcons_surf(:,n), & +! ashtf_surft(:,n),qstar_surft(:,n),q_elev(:,n), & +! radnet_surft(:,n),resft(:,n),rhokh_surft(:,n),l_soil_point, & +! snowdepth_surft(:,n),timestep,t_elev(:,n),tsurf(:,n), & +! tstar_surft(:,n),vfrac_surft(:,n),rhokh_can(:,n),z0h_surft(:,n), & +! z0m_eff_surft(:,n),zdt_surft(:,n),z1_tq,lh0,emis_surft(:,n),emis_soil, & +! 1.0,anthrop_heat_surft(:,n),scaling_urban(:,n),l_vegdrag_surft(n), & +! alpha1(:,n),ashtf_prime_surft(:,n),fqw_surft(:,n), & +! epot_surft(:,n),ftl_surft(:,n),dtstar_surft(:,n),sea_point & +! ) + + ! update gridbox means and diagnostics +!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(i, j, k, l) & +!$OMP SHARED(n, surft_pts, surft_index, land_index, t_i_length, & +!$OMP l_irrig_dmd, l_aggregate, can_model, cansnowtile, & +!$OMP snow_surft, resfs_irr_surft, resfs, gc_irr_surft, & +!$OMP ftl_1, flandg, tile_frac, ftl_surft, fqw_1, fqw_surft, & +!$OMP ch_surft, vshr_land) SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j = (land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + + ! Calculate gridbox mean fluxes of heat and moisture + ftl_1(i,j) = ftl_1(i,j) + flandg(i,j) * tile_frac(l,n) * ftl_surft(l,n) + fqw_1(i,j) = fqw_1(i,j) + flandg(i,j) * tile_frac(l,n) * fqw_surft(l,n) + + !CM3#55-29 - may need the OMP directives changed + !! Calculate surface resistance term for irrigated surfaces + !IF (l_irrig_dmd) THEN + ! IF ( .NOT. l_aggregate .AND. can_model == 4 .AND. cansnowtile(n) .AND. & + ! snow_surft(l,n) > 0.0) THEN + ! resfs_irr_surft(l,n) = resfs(l,n) + ! ELSE + ! resfs_irr_surft(l,n) = gc_irr_surft(l,n) / & + ! ( gc_irr_surft(l,n) + ch_surft(l,n) * vshr_land(i,j) ) + ! END IF + !END IF + END DO +!$OMP END PARALLEL DO + +END DO + +! Calculate surface momentum flux +IF (sf_diag%l_tau_surft) THEN + DO n = 1,nsurft +!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(i, j, k, l) & +!$OMP SHARED(n, surft_pts, surft_index, land_index, t_i_length, & +!$OMP rhokm_1_surft, vshr_land, sf_diag) SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j = (land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + sf_diag%tau_surft(l,n) = rhokm_1_surft(l,n) * vshr_land(i,j) + END DO +!$OMP END PARALLEL DO + END DO +END IF + +! Set surface stress on tiles diagnostic +IF (sf_diag%l_tau_1) THEN + DO n = 1,nsurft +!$OMP PARALLEL DO IF(surft_pts(n) > 1) DEFAULT(NONE) PRIVATE(i, j, k, l) & +!$OMP SHARED(n, surft_pts, surft_index, land_index, t_i_length, & +!$OMP flandg, tile_frac, rhokm_1_surft, vshr_land, & +!$OMP sf_diag) SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + sf_diag%tau_1(i,j) = sf_diag%tau_1(i,j) + & + flandg(i,j) * tile_frac(l,n) * & + rhokm_1_surft(l,n) * vshr_land(i,j) + END DO +!$OMP END PARALLEL DO + END DO +END IF + + +!----------------------------------------------------------------------- +! 4.4 Calculate the standard deviations of layer 1 turbulent +! fluctuations of temperature and humidity using approximate +! formulae from first order closure. +!----------------------------------------------------------------------- + +! Land tiles +DO n = 1,nsurft + CALL stdev1 ( & + land_pts,surft_pts(n),land_index,surft_index(:,n),flandg, & + bq_1,bt_1,fqw_surft(:,n),ftl_surft(:,n),rhokm_1_surft(:,n), & + rhostar,vshr_land,z0m_surft(:,n),z1_tq,tile_frac(:,n), & + q1_sd,t1_sd & + ) +END DO + +!----------------------------------------------------------------------- +! Call SFL_INT to calculate CDR10M and CHR1P5M - interpolation coeffs +! used to calculate screen temperature, humidity and 10m winds. +!----------------------------------------------------------------------- + +! Set flag if cdr10m is to be calculated for use with snow unloading. +! If l_fix_wind_snow=F this calculation will depend on the su10 and sv10 +! switches in sf_diag. +l_cdr10m_snow = .FALSE. +!CM3#55-31 +!IF ( l_fix_wind_snow ) THEN +! DO n = 1,nsurft +! IF ( canSnowTile(n) .AND. unload_rate_u(n) /= 0.0 ) l_cdr10m_snow = .TRUE. +! END DO +!END IF + +IF (sf_diag%suv10m_n) THEN +!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(i,j) & +!$OMP SHARED(pdims,sf_diag) + DO j = pdims%j_start,pdims%j_end + DO i = pdims%i_start,pdims%i_end + sf_diag%cdr10m_n(i,j) = 0.0 + sf_diag%cd10m_n(i,j) = 0.0 + END DO + END DO +!$OMP END PARALLEL DO +END IF + +! Land tiles +IF (sf_diag%su10 .OR. sf_diag%sv10 .OR. sf_diag%sq1p5 .OR. & + sf_diag%st1p5 .OR. sf_diag%suv10m_n .OR. & + l_cdr10m_snow .OR. & + (IScrnTDiag == IP_ScrnDecpl2) .OR. & + (IScrnTDiag == IP_ScrnDecpl3) ) THEN + DO n = 1,nsurft + + !CM2!!CABLE_LSM:land_pts=0 crashes + !CM3#55 - need to look at this in more detail - not convinced this is correct + CALL sfl_int ( & + land_pts,surft_pts(n),l_cdr10m_snow,surft_index(:,n),land_index,flandg, & + vshr_land,cd_std(:,n),cd_surft(:,n),ch_surft(:,n), & + tile_frac(:,n), & + z0m_eff_surft(:,n),z0m_surft(:,n),z0h_surft(:,n), & + recip_l_mo_surft(:,n), & + v_s_surft(:,n),v_s_std(:,n), & + z1_uv,z1_tq,db_surft(:,n), & + sf_diag, & + cdr10m,sf_diag%cdr10m_n,sf_diag%cd10m_n,chr1p5m(:,n) & + ) + END DO + +END IF + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) + +RETURN +END SUBROUTINE cable_land_sf_explicit +END MODULE cable_land_sf_explicit_mod diff --git a/src/coupled/AM3/control/cable/cable_land/explicit/sf_flux_mod_cbl.F90 b/src/coupled/AM3/control/cable/cable_land/explicit/sf_flux_mod_cbl.F90 new file mode 100644 index 000000000..0cf1d952f --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/explicit/sf_flux_mod_cbl.F90 @@ -0,0 +1,270 @@ +! *****************************COPYRIGHT******************************* +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT******************************* +! SUBROUTINE SF_FLUX ----------------------------------------------- +! Description: +! Subroutines SF_FLUX to calculate explicit surface fluxes of +! heat and moisture +!----------------------------------------------------------------------- +MODULE sf_flux_mod_cbl +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='SF_FLUX_MOD' + +CONTAINS +SUBROUTINE sf_flux_cbl ( & + points,surft_pts,pts_index,surft_index, & + nsnow,n,canhc,dzsurf,hcons,ashtf,qstar,q_elev,radnet,resft, & + rhokh_1,l_soil_point,snowdepth,timestep, & + t_elev,ts1_elev,tstar,vfrac,rhokh_can, & + z0h,z0m_eff,zdt,z1_tq,lh0,emis_surft,emis_soil, & + salinityfactor,anthrop_heat,scaling_urban,l_vegdrag, & + alpha1,ashtf_prime,fqw_1,epot,ftl_1,dtstar,sea_point & + ) + +USE atm_fields_bounds_mod, ONLY: tdims +USE theta_field_sizes, ONLY: t_i_length + +USE csigma, ONLY: sbcon +USE planet_constants_mod, ONLY: grcp, cp +USE jules_snow_mod, ONLY: snow_hcon +USE jules_surface_mod, ONLY: ls +USE jules_surface_types_mod, ONLY: urban_roof +USE jules_vegetation_mod, ONLY: l_vegcan_soilfx +USE jules_urban_mod, ONLY: l_moruses_storage +USE jules_surface_mod, ONLY: l_aggregate, l_epot_corr +USE jules_science_fixes_mod, ONLY: l_fix_moruses_roof_rad_coupling + +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook +USE um_types, ONLY: real_jlslsm + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: & + points & + ! IN Total number of points. +,surft_pts & + ! IN Number of tile points. +,pts_index(points) & + ! IN Index of points. +,surft_index(points) & + ! IN Index of tile points. +,nsnow(points) & + ! IN Number of snow layers +,n ! IN Tile number. + ! For sea and sea-ice this = 0 + +LOGICAL, INTENT(IN) :: & + l_soil_point(points) & + ! IN Boolean to test for soil points +,l_vegdrag + ! IN Option for vegetation canopy drag scheme. + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + canhc(points) & + ! IN Areal heat capacity of canopy (J/K/m2). +,dzsurf(points) & + ! IN Surface layer thickness (m). +,ashtf(points) & + ! IN Coefficient to calculate surface + ! heat flux into soil (W/m2/K). +,qstar(points) & + ! IN Surface qsat. +,q_elev(points) & + ! IN Total water content of lowest + ! atmospheric layer (kg per kg air). +,radnet(points) & + ! IN Net surface radiation (W/m2) positive + ! downwards +,resft(points) & + ! IN Total resistance factor. +,rhokh_1(points) & + ! IN Surface exchange coefficient. +,snowdepth(points) & + ! IN Snow depth (on ground) (m) +,timestep & + ! IN Timestep (s). +,t_elev(points) & + ! IN Liquid/frozen water temperature for + ! lowest atmospheric layer (K). +,ts1_elev(points) & + ! IN Temperature of surface layer (K). +,tstar(points) & + ! IN Surface temperature (K). +,vfrac(points) & + ! IN Fractional canopy coverage. +,rhokh_can(points) & + ! IN Exchange coefficient for canopy air + ! to surface +,z0h(points) & + ! IN Roughness length for heat and moisture +,z0m_eff(points) & + ! IN Effective roughness length for momentum +,zdt(points) & + ! IN Difference between the canopy height and + ! displacement height (m) +,z1_tq(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Height of lowest atmospheric level (m). +,emis_surft(points) & + ! IN Emissivity for land tiles +,emis_soil(points) & + ! IN Emissivity of underlying soil +,lh0 & + ! IN Latent heat for snow free surface + ! =LS for sea-ice, =LC otherwise +,salinityfactor & + ! IN Factor allowing for the effect of the + ! salinity of sea water on the + ! evaporative flux. +,anthrop_heat(points) & + ! IN Anthropogenic contribution to surface + ! heat flux (W/m2). Zero except for + ! urban and L_ANTHROP_HEAT=.true. + ! or for urban_canyon & urban_roof when + ! l_urban2t=.true. +,scaling_urban(points) & + ! IN MORUSES: ground heat flux scaling; + ! canyon tile only coupled to soil. + ! This equals 1.0 except for urban tiles when + ! MORUSES is used. +,alpha1(points) + ! IN Gradient of saturated specific humidity + ! with respect to temperature between the + ! bottom model layer and the surface. + +REAL(KIND=real_jlslsm) :: & + hcons(points) + ! IN Soil thermal conductivity (W/m/K). + +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + ashtf_prime(points) + ! INOUT Adjusted SEB coefficient + +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + fqw_1(points) & + ! OUT Local surface flux of QW (kg/m2/s). +,epot(points) & + ! OUT +,ftl_1(points) & + ! OUT Local surface flux of TL. +,dtstar(points) ! OUT Change in TSTAR over timestep + +REAL(KIND=real_jlslsm) :: & + sea_point ! =1.0 IF SEA POINT, =0.0 OTHERWISE + + +! Workspace +REAL(KIND=real_jlslsm) :: & +dtstar_pot(points) & + ! Change in TSTAR over timestep that is + ! appropriate for the potential evaporation +,surf_ht_flux ! Flux of heat from surface to sub-surface + +! Scalars +INTEGER :: & + i,j & + ! Horizontal field index. +,k & + ! Tile field index. +,l ! Points field index. + +REAL(KIND=real_jlslsm) :: & + lh ! Latent heat (J/K/kg). + +REAL(KIND=real_jlslsm) :: lambda + ! Attenuation factor for influence of soil + ! temperature + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='SF_FLUX' + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +!jh!!$OMP PARALLEL & +!jh!!$OMP DEFAULT(SHARED) & +!jh!!$OMP PRIVATE(l,k,lambda,lh,surf_ht_flux,i,j) + +!----------------------------------------------------------------------- +!! 0 initialise +!----------------------------------------------------------------------- +!jh!!$OMP DO SCHEDULE(STATIC) +!jh!DO l = 1,points +!jh! ftl_1(l) = 0.0 +!jh! epot(l) = 0.0 +!jh!END DO +!jh!!$OMP END DO + +! If conduction in the soil beneath the vegetative canopy is not +! explicitly considered, the attentuation facor may be set equal +! to 1 everywhere. +lambda = 1.0 + +!jh!!$OMP DO SCHEDULE(STATIC) +DO k = 1,surft_pts + l = surft_index(k) + j=(pts_index(l) - 1) / t_i_length + 1 + i = pts_index(l) - (j-1) * t_i_length + + ! Calculate the attenuation factor if different from 1. + IF (l_vegcan_soilfx) & + lambda = 2.0 * hcons(l) / dzsurf(l) / & + ( 2.0 * hcons(l) / dzsurf(l) + rhokh_can(l) + & + 4.0 * emis_soil(l) * emis_surft(l) * sbcon * & + tstar(l)**3 ) + + lh = lh0 + IF (snowdepth(l) > 0.0) lh = ls + + !jh!IF (l_vegdrag) THEN + !jh! ftl_1(l) = rhokh_1(l) * (tstar(l) - t_elev(l) - & + !jh! grcp * (z1_tq(i,j) + zdt(l) - z0h(l))) + !jh!ELSE + !jh! ftl_1(l) = rhokh_1(l) * (tstar(l) - t_elev(l) - & + !jh! grcp * (z1_tq(i,j) + z0m_eff(l) - z0h(l))) + !jh!END IF + !jh!epot(l) = rhokh_1(l) * (salinityfactor * qstar(l) - q_elev(l)) + !jh!fqw_1(l) = resft(l) * epot(l) + + !jh!surf_ht_flux = ((1.0 - vfrac(l)) * ashtf(l) + & + !jh! vfrac(l) * rhokh_can(l) * lambda ) * & + !jh! (tstar(l) - ts1_elev(l)) + & + !jh! vfrac(l) * emis_soil(l) * emis_surft(l) * sbcon * & + !jh! lambda * (tstar(l)**4.0 - ts1_elev(l)**4.0) + + + ashtf_prime(l) = 4.0 * (1.0 + lambda * emis_soil(l) * vfrac(l)) * & + emis_surft(l) * sbcon * tstar(l)**3.0 + & + lambda * vfrac(l) * rhokh_can(l) + & + (1.0 - vfrac(l)) * ashtf(l) + canhc(l) / timestep + + !jh!dtstar(l) = (radnet(l) + anthrop_heat(l) - cp * ftl_1(l) - & + !jh! lh * fqw_1(l) - surf_ht_flux) / & + !jh! ( rhokh_1(l) * (cp + lh * alpha1(l) * resft(l)) + & + !jh! ashtf_prime(l) ) + + !jh!! Correction to surface fluxes due to change in surface temperature + !jh!ftl_1(l) = ftl_1(l) + rhokh_1(l) * dtstar(l) * (1.0 - sea_point) + !jh!fqw_1(l) = fqw_1(l) + resft(l) * rhokh_1(l) * alpha1(l) * & + !jh! dtstar(l) * (1.0 - sea_point) + + !jh!IF (l_epot_corr) THEN + !jh! dtstar_pot(l) = (radnet(l) + anthrop_heat(l) - cp * ftl_1(l) - & + !jh! lh * epot(l) - surf_ht_flux) / & + !jh! ( rhokh_1(l) * (cp + lh * alpha1(l)) + ashtf_prime(l) ) + !jh! epot(l) = epot(l) + rhokh_1(l) * alpha1(l) * dtstar_pot(l) + !jh!ELSE + !jh! epot(l) = epot(l) + rhokh_1(l) * alpha1(l) * dtstar(l) + !jh!END IF + +END DO +!jh!!$OMP END DO +!jh!!$OMP END PARALLEL + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE sf_flux_cbl +END MODULE sf_flux_mod_cbl diff --git a/src/coupled/AM3/control/cable/cable_land/extra/hydrol_mod_cbl.F90 b/src/coupled/AM3/control/cable/cable_land/extra/hydrol_mod_cbl.F90 new file mode 100644 index 000000000..7545728a0 --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/extra/hydrol_mod_cbl.F90 @@ -0,0 +1,1075 @@ +MODULE hydrol_mod_cbl +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='HYDROL_MOD' + +CONTAINS + +SUBROUTINE hydrol_cbl ( & + land_pts, soil_pts, lice_pts, sm_levels, npft, nsurft, dim_cs1, & + asteps_since_triffid, timestep, & + l_inland, l_pdm, l_soil_sat_down, l_top, stf_sub_surf_roff, & + soil_index, lice_index, & + surft_pts, surft_index, nsnow_surft, & + bexp_soilt, hcap_soilt, hcon_soilt, & + satcon_soilt, sathh_soilt, & + smvcst_soilt, smvcwt_soilt, & + catch_surft, frac_irr_soilt, infil_surft, & + non_lake_frac, slope_gb, tile_frac, & + con_rainfrac_land, con_rain_land, ls_rainfrac_land, ls_rain_land, & + surf_ht_flux_ld, & + ecan_surft, ext_irr_soilt, ext_soilt, & + snowdepth_surft, melt_surft, snow_melt, & + snow_soil_htf, & + a_fsat_soilt, c_fsat_soilt, a_fwet_soilt, c_fwet_soilt, & + fexp_soilt, ti_mean_soilt, & + npp_soilt, inlandout_atm_gb, & + canopy_surft, smcl_soilt, sthf_soilt, & + sthu_soilt, sthu_irr_soilt, tsoil_deep_gb, & + t_soil_soilt, t_soil_soilt_acc, tsurf_elev_surft, & + fsat_soilt, fwetl_soilt, sthzw_soilt, zw_soilt, & + cs_pool_soilt,resp_s_soilt, & + cs_ch4_soilt, fch4_wetl_acc_soilt, & + substr_ch4, mic_ch4, mic_act_ch4, acclim_ch4, & + n_inorg_avail_pft, n_inorg_soilt_lyrs, & + n_leach_gb_acc, & + canopy_gb, smc_soilt, & + drain_soilt, dun_roff_soilt, sub_surf_roff_gb, & + surf_roff_gb, tot_tfall_gb, tot_tfall_surft, & + w_flux_soilt, qbase_soilt, qbase_l_soilt, qbase_zw_soilt, & + fch4_wetl_soilt, fch4_wetl_cs_soilt, & + fch4_wetl_npp_soilt, fch4_wetl_resps_soilt, & + n_leach_soilt, & + progs_snow_surft, snow_mass_gb, work_cbl ) + +!Use in relevant subroutines +USE ancil_info, ONLY: dim_cslayer, nsoilt +USE calc_baseflow_jules_mod, ONLY: calc_baseflow_jules +USE calc_zw_inund_mod, ONLY: calc_zw_inund +USE ch4_wetl_mod, ONLY: ch4_wetl +USE elev_htc_mod, ONLY: elev_htc +USE ereport_mod, ONLY: ereport +USE ice_htc_mod, ONLY: ice_htc +USE n_leach_mod, ONLY: n_leach +USE soil_hyd_wt_mod, ONLY: soil_hyd_wt +USE soil_hyd_update_mod, ONLY: soil_hyd_update +USE soil_hyd_mod, ONLY: soil_hyd +USE soil_htc_mod, ONLY: soil_htc +USE soilmc_mod, ONLY: soilmc +USE soilt_mod, ONLY: soilt +USE surf_hyd_mod, ONLY: surf_hyd +USE um_types, ONLY: real_jlslsm +USE water_constants_mod, ONLY: rho_water ! Density of pure water (kg/m3). + +USE jules_hydrology_mod, ONLY: l_wetland_unfrozen, ti_max, zw_max +USE jules_vegetation_mod, ONLY: l_nitrogen +USE jules_irrig_mod, ONLY: l_irrig_dmd +USE jules_surface_mod, ONLY: l_elev_land_ice + +USE jules_soil_biogeochem_mod, ONLY: & + ! imported scalar parameters + soil_model_ecosse, soil_model_rothc, soil_model_1pool, & + ! imported scalar variables + soil_bgc_model, l_ch4_tlayered, l_layeredc, dim_ch4layer + +USE jules_soil_mod, ONLY: & + dzsoil, & + ! Thicknesses of the soil layers (m). + dzsoil_elev, ns_deep + + +#if !defined(UM_JULES) +USE update_mod, ONLY: l_imogen +USE model_time_mod, ONLY: timestep_len +#endif + +!CABLE_LSM: Make avail CABLE hydrology interface subr to CALL +USE cable_hyd_main_mod, ONLY: cable_hyd_main +USE work_vars_mod_cbl, ONLY: work_vars_type ! and some kept thru timestep + +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!----------------------------------------------------------------------------- +! The order of arguments and declarations should follow UMDP3. +! Within that, where possible variables should be grouped so that related +! variables (e.g. from the same area of science) are together. +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! Scalar arguments with INTENT(IN): +!----------------------------------------------------------------------------- +INTEGER, INTENT(IN) :: & + land_pts, & + ! Number of gridpoints. + soil_pts, & + ! Number of soil points. + lice_pts, & + ! Number of land ice points. + sm_levels, & + ! Number of soil moisture levels. + npft, & + ! Number of plant functional types + nsurft, & + ! Number of tiles + dim_cs1, & + ! Number of soil carbon pools + asteps_since_triffid + ! Number of atmospheric timesteps since last call to TRIFFID. + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + timestep + ! Model timestep (s). + +LOGICAL , INTENT(IN) :: & + l_inland, & + ! True if re-routing inland basin flow to soil moisture. + l_pdm, & + ! Flag for PDM hydrology. + l_soil_sat_down, & + ! Switch controlling direction of movement of + ! soil moisture in excess of saturation. + l_top, & + ! Flag for TOPMODEL-based hydrology. + stf_sub_surf_roff + ! Stash flag for sub-surface runoff. + +TYPE(work_vars_type), INTENT(IN) :: work_cbl +!----------------------------------------------------------------------------- +! Array arguments with INTENT(IN): +!----------------------------------------------------------------------------- +INTEGER, INTENT(IN) :: & + soil_index(land_pts), & + ! Array of soil points. + lice_index(land_pts), & + ! Array of land ice points. + surft_pts(nsurft), & + ! Number of tile points. + surft_index(land_pts,nsurft), & + ! Index of tile points. + nsnow_surft(land_pts,nsurft) + ! Number of snow layers + +! Soil characteristics. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + bexp_soilt(land_pts,nsoilt,sm_levels), & + ! Brooks & Corey exponent. + hcap_soilt(land_pts,nsoilt,sm_levels), & + ! Soil heat capacity (J/K/m3). + hcon_soilt(land_pts,nsoilt,0:sm_levels), & + ! Soil thermal conductivity (W/m/K). + satcon_soilt(land_pts,nsoilt,0:sm_levels), & + ! Saturated hydraulic conductivity (kg/m2/s). + sathh_soilt(land_pts,nsoilt,sm_levels), & + ! Saturated soil water pressure (m). + smvcst_soilt(land_pts,nsoilt,sm_levels), & + ! Volumetric soil moisture concentration at saturation (m3 H2O/m3 soil). + smvcwt_soilt(land_pts,nsoilt,sm_levels) + ! Volumetric soil moisture concentration below which + ! stomata close (m3 H2O/m3 soil). + +! Surface characteristics. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + catch_surft(land_pts,nsurft), & + ! Canopy/surface capacity of land tiles (kg/m2). + frac_irr_soilt(land_pts, nsoilt), & + ! Irrigation fraction for each soil tile. + infil_surft(land_pts,nsurft), & + ! Maximum surface infiltration (kg m-2 s-1). + non_lake_frac(land_pts), & + ! Sum of fractions of surface tiles linked to soil (i.e. not using FLake) + slope_gb(land_pts), & + ! Terrain slope. + tile_frac(land_pts,nsurft) + ! Tile fractions. + +! Precipitation variables and heat fluxes. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + con_rainfrac_land(land_pts), & + ! Convective rain fraction + con_rain_land(land_pts), & + ! Convective rain (kg/m2/s). + ls_rain_land(land_pts), & + ! Large-scale rain (kg/m2/s). + ls_rainfrac_land(land_pts), & + ! large scale rain fraction + surf_ht_flux_ld(land_pts) + ! Net downward surface heat flux (W/m2). + +! Evaporation variables. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + ecan_surft(land_pts,nsurft), & + ! Canopy evaporation from land tiles (kg/m2/s). + ext_irr_soilt(land_pts,nsoilt,sm_levels), & + ! Extraction of water from each soil layer over irrigation (kg m-2 s-1). + ext_soilt(land_pts,nsoilt,sm_levels) + ! Extraction of water from each soil layer (kg/m2/s). + +! Snow and melt +REAL(KIND=real_jlslsm), INTENT(IN) :: & + snowdepth_surft(land_pts,nsurft), & + ! Snow depth (on ground) (m). + melt_surft(land_pts,nsurft), & + ! Snowmelt on tiles (kg/m2/s). + !snow_melt(land_pts), & + ! ! Snowmelt (kg/m2/s). + ! ! for CABLE this needs to be an INOUT var + snow_soil_htf(land_pts,nsurft) + ! Tiled snowpack-> soil heat flux. +REAL(KIND=real_jlslsm), INTENT(INOUT) :: & + snow_melt(land_pts) + ! Snowmelt (kg/m2/s) + +! TOPMODEL variables. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + a_fsat_soilt(land_pts,nsoilt), & + ! Fitting parameter for Fsat in LSH model. + c_fsat_soilt(land_pts,nsoilt), & + ! Fitting parameter for Fsat in LSH model. + a_fwet_soilt(land_pts,nsoilt), & + ! Fitting parameter for Fwet in LSH model. + c_fwet_soilt(land_pts,nsoilt), & + ! Fitting parameter for Fwet in LSH model. + fexp_soilt(land_pts,nsoilt), & + ! Decay factor in Sat. Conductivity in deep LSH/TOPMODEL layer. + ti_mean_soilt(land_pts,nsoilt) + ! Mean topographic index. + +! Variables related to methane calculation. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + npp_soilt(land_pts,nsoilt) + ! Gridbox mean net primary productivity (kg C/m2/s). + +! Other variables. +REAL(KIND=real_jlslsm), INTENT(IN) :: & + inlandout_atm_gb(land_pts) + ! IN TRIP INLAND BASIN OUTFLOW FOR LAND POINTS ONLY,kg/m2/s=mm. +!----------------------------------------------------------------------------- +! Array arguments with INTENT(IN OUT): +!----------------------------------------------------------------------------- + +! Canopy water. +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + canopy_surft(land_pts,nsurft) + ! Canopy water content for land tiles (kg/m2). + +! Soil water and temperature. +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + smcl_soilt(land_pts,nsoilt,sm_levels), & + ! Soil moisture content of each +! ! layer (kg/m2). + sthf_soilt(land_pts,nsoilt,sm_levels), & + ! Frozen soil moisture content of +! ! each layer as a fraction of +! ! saturation. + sthu_soilt(land_pts,nsoilt,sm_levels), & + ! Unfrozen soil moisture content of +! ! each layer as a fraction of +! ! saturation. + sthu_irr_soilt(land_pts, nsoilt, sm_levels), & + ! Unfrozen soil wetness over irrigation. + tsoil_deep_gb(land_pts,ns_deep), & + ! Deep soil temperature (K). + t_soil_soilt(land_pts,nsoilt,sm_levels), & + ! Sub-surface temperatures (K). + t_soil_soilt_acc(land_pts,nsoilt,sm_levels), & + ! Sub-surface temperature on layers and soil tiles + ! accumulated over TRIFFID timestep (K). + tsurf_elev_surft(land_pts,nsurft) + ! Tiled sub-surface temperatures (K). + +! TOPMODEL variables. +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + fsat_soilt(land_pts,nsoilt), & + ! Surface saturation fraction. + fwetl_soilt(land_pts,nsoilt), & + ! Wetland fraction. + sthzw_soilt(land_pts,nsoilt), & + ! Soil moisture fraction in deep LSH/TOPMODEL layer. + zw_soilt(land_pts,nsoilt) + ! Water table depth (m). + +! Soil carbon variables. +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + cs_pool_soilt(land_pts,nsoilt,dim_cslayer,dim_cs1), & + ! Soil carbon (kg C/m2). +! ! For RothC (dim_cs1=4), the pools +! ! are DPM, RPM, biomass and humus. + resp_s_soilt(land_pts,nsoilt,dim_cslayer,dim_cs1) + ! Soil respiration in pools (kg C/m2/s). + +! Methane variables. +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + cs_ch4_soilt(land_pts,nsoilt), & + ! Soil carbon used in CH4 wetlands if TRIFFID is switched off (kg C/m2). + fch4_wetl_acc_soilt(land_pts,nsoilt), & + ! Accumulated scaled wetland methane flux (kg C/m2). + substr_ch4(land_pts,dim_ch4layer), & + ! Dissolved substrate that methaogens consume (kg C/m2) + mic_ch4(land_pts,dim_ch4layer), & + ! Methanogenic biomass (kg C/m2) + mic_act_ch4(land_pts,dim_ch4layer), & + ! Activity level of methanogenic biomass (fraction) + acclim_ch4(land_pts,dim_ch4layer) + ! Acclimation factor for microbial trait adaptation + +! Nitrogen variables. +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + n_inorg_avail_pft(land_pts,npft,dim_cslayer), & + ! Available inorganic N for PFTs (kg N m-2). + n_inorg_soilt_lyrs(land_pts,nsoilt,dim_cslayer), & + ! Inorganic N pool on soil levels (kg N m-2). + n_leach_gb_acc(land_pts) + ! Accumulated leached nitrogen diagnostic on TRIFFID timesteps + ! (kg m-2 (360days)-1). + +!----------------------------------------------------------------------------- +! Array arguments with INTENT(OUT): +!----------------------------------------------------------------------------- +! Canopy water and soil moisture. +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + canopy_gb(land_pts), & + ! Gridbox canopy water content (kg/m2). + smc_soilt(land_pts,nsoilt) + ! Available soil moisture in a layer at the surface (kg/m2) + +REAL(KIND=real_jlslsm), INTENT(INOUT) :: & + tot_tfall_surft(land_pts,nsurft), & + ! Surface-tiled contributions to throughfall. + dun_roff_soilt(land_pts,nsoilt) + ! Dunne part of sfc runoff (kg/m2/s). + +! Water fluxes. +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + drain_soilt(land_pts,nsoilt), & + ! Drainage out of sm_levels'th level (kg/m2/s). + sub_surf_roff_gb(land_pts), & + ! Sub-surface runoff (kg/m2/s). + surf_roff_gb(land_pts), & + ! Surface runoff (kg/m2/s). + tot_tfall_gb(land_pts), & + ! Total throughfall (kg/m2/s). + w_flux_soilt(land_pts,nsoilt,0:sm_levels) + ! Fluxes of water between layers (kg/m2/s). + +! TOPMODEL variables. +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + qbase_soilt(land_pts,nsoilt), & + ! Base flow (kg/m2/s). + qbase_l_soilt(land_pts,nsoilt,sm_levels+1), & + ! Base flow from each level (kg/m2/s). + qbase_zw_soilt(land_pts,nsoilt) + ! Base flow from deep LSH/TOPMODEL layer (kg/m2/s). + +! Methane and nitrigen variables. +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + fch4_wetl_soilt(land_pts,nsoilt), & + ! Scaled wetland methane flux (default substrate) for use in + ! atmos chemistry model (10^-9 kg C/m2/s). + fch4_wetl_cs_soilt(land_pts,nsoilt), & + ! Scaled methane flux (soil carbon substrate) (kg C/m2/s). + fch4_wetl_npp_soilt(land_pts,nsoilt), & + ! Scaled methane flux (npp substrate) (kg C/m2/s). + fch4_wetl_resps_soilt(land_pts,nsoilt), & + ! Scaled methane flux (soil respiration substrate) (kg C/m2/s). + n_leach_soilt(land_pts,nsoilt) + ! Leached N (kg m-2 s-1). + +!CABLE +REAL, INTENT(OUT) :: progs_snow_surft(land_pts,nsurft) +REAL, INTENT(OUT) :: snow_mass_gb(land_pts) ! OUT Gridbox snowmass (kg/m2) +!----------------------------------------------------------------------------- +! Local parameters: +!----------------------------------------------------------------------------- +REAL(KIND=real_jlslsm), PARAMETER :: to_kg_conversion = 1.0e-9 + ! multiplier for converting to kgC for wetland CH4 and IMOGEN + +!----------------------------------------------------------------------------- +! Local scalar variables: +!----------------------------------------------------------------------------- +INTEGER :: & + i, j, & + n, & + ! Counter for soil level. + m, & + ! Counter for soil tile. + errorstatus + +!----------------------------------------------------------------------------- +! Local array variables: +!----------------------------------------------------------------------------- +REAL(KIND=real_jlslsm) :: & + dsmc_dt_soilt(land_pts,nsoilt), & + ! Rate of change of soil moisture due to water falling onto the + ! surface after surface runoff (kg/m2/s). + ksz_soilt(land_pts,nsoilt,0:sm_levels), & + ! Saturated hydraulic conductivity in layer (kg/m2/s). + qbase_unfr_soilt(land_pts,nsoilt), & + ! Base flow in unfrozen soil (kg/m2/s). + qbase_l_unfr_soilt(land_pts,nsoilt,sm_levels+1), & + ! As qbase_l but for unfrozen soil (kg/m2/s). + top_crit_soilt(land_pts,nsoilt), & + ! Critical TI when ZW <=0.0 + dumtop_crit_soilt(land_pts,nsoilt), & + ! Dummy for top_crit_soilt + dumsthf_soilt(land_pts,nsoilt,sm_levels), & + ! Dummy Frozen soil moisture content of each layer as a fraction of + ! saturation (always set to 0). + zdepth(0:sm_levels), & + ! Lower soil layer boundary depth (m). + tsoil_d_soilt(land_pts,nsoilt), & + ! Soil temperature in the top metre + zw_inund_soilt(land_pts,nsoilt), & + ! Water table depth used + wutot_soilt(land_pts,nsoilt), & + ! Ratio of unfrozen to total soil moisture at ZW. + surf_roff_inc_soilt(land_pts,nsoilt), & + ! Increment to tiled surface runoff (kg m-2 s-1). + surf_roff_soilt(land_pts,nsoilt), & + ! Soil-tiled contributions to surface runoff (kg m-2 s-1). + sub_surf_roff_soilt(land_pts,nsoilt), & + ! Soil-tiled contributions to subsurface runoff (kg m-2 s-1). + smcl_old_soilt(land_pts,nsoilt,sm_levels) + ! Retain oriignal soil moisture for leaching code + +! Variables required for irrigation code +REAL(KIND=real_jlslsm) :: & + w_flux_irr_soilt(land_pts,nsoilt,0:sm_levels), & + ! The fluxes of water between layers in irrigated fraction (kg/m2/s). + w_flux_nir_soilt(land_pts,nsoilt,0:sm_levels), & + ! The fluxes of water between layers in non-irrigated fraction (kg/m2/s). + smcl_irr_soilt(land_pts,nsoilt,sm_levels), & + ! Total soil moisture contents of each layer in irrigated + ! fraction (kg/m2). + smcl_nir_soilt(land_pts,nsoilt,sm_levels), & + ! Total soil moisture contents of each layer in non-irrigated + ! fraction (kg/m2). + sthu_nir_soilt(land_pts,nsoilt,sm_levels), & + ! Unfrozen soil moisture content of each layer as a fraction of + ! saturation in irrigated fraction. + ext_nir_soilt(land_pts,nsoilt,sm_levels), & + ! Extraction of water from each soil layer in non-irrigated fraction + ! (kg/m2/s). + smclsat_soilt(land_pts,nsoilt,sm_levels), & + ! The saturation moisture content of each layer (kg/m2). + smclzw_soilt(land_pts,nsoilt), & + ! moisture content in deep layer(kg/m2). + smclsatzw_soilt(land_pts,nsoilt) + ! moisture content in deep layer (kg/m2). + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='HYDROL_cable' + +! End of header-------------------------------------------------------- +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +#if !defined(UM_JULES) + timestep = REAL(timestep_len) +#endif + +canopy_gb = canopy_gb +!CM2.1!!CABLE_LSM: call CABLE hydrology +call cable_hyd_main( land_pts, nsurft, tile_frac, timestep, & + snow_mass_gb, progs_snow_surft, snow_melt, & + surf_roff_gb, sub_surf_roff_gb, & + tot_tfall_gb, work_cbl%snow_surft, melt_surft, & + work_cbl%lying_snow, work_cbl%surf_roff, & + work_cbl%sub_surf_roff, work_cbl%tot_tfall ) + + +! Calculate soil carbon for use in the wetland CH4 scheme only +! (only used if single-pool C model is used): +IF ( soil_bgc_model == soil_model_1pool ) THEN +!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(i,j,m,n) & +!$OMP SHARED(soil_pts, nsoilt, soil_index, cs_ch4_soilt, dim_cslayer, & +!$OMP cs_pool_soilt) + DO m = 1, nsoilt + DO j = 1, soil_pts + i = soil_index(j) + cs_ch4_soilt(i,m) = 0.0 + DO n = 1,dim_cslayer + cs_ch4_soilt(i,m) = cs_ch4_soilt(i,m) + cs_pool_soilt(i,m,n,1) + END DO + END DO + END DO +!$OMP END PARALLEL DO +END IF + +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(i,m,n) & +!$OMP SHARED(sm_levels, nsoilt, smcl_old_soilt, smcl_soilt, w_flux_soilt, & +!$OMP w_flux_irr_soilt, land_pts) +! smcl_old_soilt calculated for leaching code +DO n = 1, sm_levels + DO m = 1, nsoilt +!$OMP DO SCHEDULE(STATIC) + DO i = 1, land_pts + smcl_old_soilt(i,m,n) = smcl_soilt(i,m,n) + END DO +!$OMP END DO NOWAIT + END DO +END DO + +! Initialise w_flux variables that are used in irrigation code +DO n = 0, sm_levels + DO m = 1, nsoilt +!$OMP DO SCHEDULE(STATIC) + DO i = 1, land_pts + w_flux_soilt(i,m,n) = 0.0 + w_flux_irr_soilt(i,m,n) = 0.0 + ! to prevent random values reported over areas + ! that are not included as soil points (i.e. ice points) + END DO +!$OMP END DO NOWAIT + END DO +END DO +!$OMP END PARALLEL +!CABLE_LSM: call CABLE hydrology +!!call cable_hyd_main( npnts, nsurft, lying_snow, snow_surft, surf_roff, & + !! sub_surf_roff, tot_tfall ) + +!CM2 vn starts aboout here +!----------------------------------------------------------------------------- +! Set up variables required for LSH scheme: +!----------------------------------------------------------------------------- +! set level zero depth to 0 +zdepth(0) = 0.0 + +DO n = 1, sm_levels + zdepth(n) = zdepth(n-1) + dzsoil(n) +END DO +!jhan:fudge +dsmc_dt_soilt(:,:) = 0.0 +!----------------------------------------------------------------------------- +! Calculate throughfall and surface runoff, and update the canopy water +! content +!----------------------------------------------------------------------------- +!!CABLE_LSM: omit for CABLE: BUT initialize dsmc_dt for fpe0, otherwise? +!!CALL surf_hyd (land_pts, nsurft, sm_levels, soil_pts, timestep, l_top, l_pdm, & +!! surft_pts, surft_index, soil_index, & +!! catch_surft, ecan_surft, tile_frac, non_lake_frac, infil_surft, & +!! con_rain_land, ls_rain_land, con_rainfrac_land, & +!! ls_rainfrac_land, melt_surft, slope_gb, snow_melt, & +!! fsat_soilt, smvcst_soilt, & +!! sthf_soilt, sthu_soilt, & +!! canopy_surft, canopy_gb, dsmc_dt_soilt, & +!! surf_roff_gb, tot_tfall_gb, tot_tfall_surft, & +!! dun_roff_soilt, surf_roff_soilt) +! +!----------------------------------------------------------------------------- +! Specify the reduction of hydraulic conductivity with depth. +! Initialiase base flow to zero. +!----------------------------------------------------------------------------- +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(i, j, m, n) & +!$OMP SHARED(sm_levels, nsoilt, soil_pts, soil_index, ksz_soilt, satcon_soilt, & +!$OMP smclsat_soilt, qbase_l_soilt, qbase_l_unfr_soilt, dumsthf_soilt, & +!$OMP dzsoil, smvcst_soilt, land_pts, qbase_soilt, & +!$OMP qbase_zw_soilt, wutot_soilt, drain_soilt, qbase_unfr_soilt, & +!$OMP zw_inund_soilt, surf_roff_inc_soilt) +DO n = 0, sm_levels + DO m = 1, nsoilt +!$OMP DO SCHEDULE(STATIC) + DO j = 1, soil_pts + i = soil_index(j) + ksz_soilt(i,m,n) = satcon_soilt(i,m,n) + END DO +!$OMP END DO NOWAIT + END DO +END DO + +DO n = 1, sm_levels + DO m = 1, nsoilt +!$OMP DO SCHEDULE(STATIC) + DO j = 1,soil_pts + i = soil_index(j) + smclsat_soilt(i,m,n) = rho_water * dzsoil(n) * smvcst_soilt(i,m,n) + qbase_l_soilt(i,m,n) = 0.0 + qbase_l_unfr_soilt(i,m,n) = 0.0 + dumsthf_soilt(i,m,n) = 0.0 + END DO +!$OMP END DO NOWAIT + END DO +END DO + +DO m = 1, nsoilt +!$OMP DO SCHEDULE(STATIC) + DO i = 1,land_pts + qbase_soilt(i,m) = 0.0 + qbase_zw_soilt(i,m) = 0.0 + wutot_soilt(i,m) = 0.0 + drain_soilt(i,m) = 0.0 + qbase_unfr_soilt(i,m) = 0.0 + zw_inund_soilt(i,m) = 0.0 + ! Initialise runoff increment. + surf_roff_inc_soilt(i,m) = 0.0 + END DO +!$OMP END DO NOWAIT +END DO +!$OMP END PARALLEL + +!!CABLE_LSM: omit for CABLE +!IF (l_top) THEN +! IF (soil_pts /= 0) THEN +! DO m = 1, nsoilt +! CALL calc_baseflow_jules( & +! land_pts, sm_levels, soil_pts, soil_index, & +! bexp_soilt(:,m,:), fexp_soilt(:,m), sthf_soilt(:,m,:), & +! ti_mean_soilt(:,m), zdepth, zw_soilt(:,m), ksz_soilt(:,m,:), & +! qbase_soilt(:,m), qbase_l_soilt(:,m,:), dumtop_crit_soilt(:,m) ) +! END DO +! +! IF (l_wetland_unfrozen) THEN +! DO m = 1,nsoilt +! CALL calc_zw_inund(land_pts, sm_levels, soil_pts, soil_index, zdepth, & +! bexp_soilt(:,m,:), sathh_soilt(:,m,:), smclsat_soilt(:,m,:), & +! smcl_soilt(:,m,:), sthu_soilt(:,m,:), sthzw_soilt(:,m), & +! zw_soilt(:,m), zw_inund_soilt(:,m), wutot_soilt(:,m)) +! +! ! Now call again to get the unfrozen equivalents to calculate fsat and +! ! fwet: +! CALL calc_baseflow_jules( & +! land_pts, sm_levels, soil_pts, soil_index, & +! bexp_soilt(:,m,:), fexp_soilt(:,m), dumsthf_soilt(:,m,:), & +! ti_mean_soilt(:,m), zdepth, zw_inund_soilt(:,m), ksz_soilt(:,m,:), & +! qbase_unfr_soilt(:,m), qbase_l_unfr_soilt(:,m,:), & +! top_crit_soilt(:,m) ) +! END DO +! ELSE +! DO m = 1, nsoilt +!!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) PRIVATE(i) & +!!$OMP SHARED(m, land_pts, top_crit_soilt, dumtop_crit_soilt) +! DO i = 1,land_pts +! top_crit_soilt(i,m) = dumtop_crit_soilt(i,m) +! END DO +!!$OMP END PARALLEL DO +! END DO +! END IF +! +! END IF +!END IF ! l_top +!!CABLE_LSM:End + +IF (l_inland) THEN + DO i = 1,land_pts + + ! Add inland basin outflow to change in soil moisture store. + ! Note for soil tiling- this is only used by the riv_intctl_1a, which is + ! not compatible with nsoilt > 1. + dsmc_dt_soilt(i,1) = dsmc_dt_soilt(i,1) + inlandout_atm_gb(i) + END DO +END IF + +!----------------------------------------------------------------------------- +! Update the layer soil moisture contents and calculate the +! gravitational drainage. +!----------------------------------------------------------------------------- +!!!CABLE_LSM: omit for CABLE +!!!CM2IF (soil_pts /= 0) THEN +!! +!! !CM2IF (l_irrig_dmd) THEN +!! +!! !CM2 !------------------------------------------------------------------------- +!! !CM2 ! If l_irrig_dmd = TRUE, call soil_hyd separately for irrigated and +!! !CM2 ! non-irrigated fraction +!! !CM2 ! afterwards, call soil_hyd ONLY to update water table/drainage with +!! !CM2 ! gridbox total w_flux_soilt, smcl_soilt +!! !CM2 !------------------------------------------------------------------------- +!! +!! !CM2 !-------------------------------------------------------------------------- +!! !CM2 ! Split tile values into values for irrigated and non-irrigated fractions. +!! !CM2 !-------------------------------------------------------------------------- +!! !CM2 DO n = 1,sm_levels +!! !CM2 DO m = 1, nsoilt +!! !CM2 DO j = 1,soil_pts +!! !CM2 i = soil_index(j) +!! +!! !CM2 ! hadrd - gridbox sthu_soilt is assumed to be combination of +!! !CM2 ! sthu_soilt of non-irrigated fraction and sthu_irr_soilt, i.e. +!! !CM2 ! sthu_soilt = frac_irr_soilt*sthu_irr_soilt + (1-frac_irr_soilt) +!! !CM2 ! *sthu_nir_soilt +!! !CM2 IF ( frac_irr_soilt(i,m) < 1.0 ) THEN +!! !CM2 sthu_nir_soilt(i,m,n) = (sthu_soilt(i,m,n) - frac_irr_soilt(i,m) & +!! !CM2 * sthu_irr_soilt(i,m,n)) & +!! !CM2 / (1.0 - frac_irr_soilt(i,m)) +!! !CM2 ext_nir_soilt(i,m,n) = (ext_soilt(i,m,n) - frac_irr_soilt(i,m) & +!! !CM2 * ext_irr_soilt(i,m,n)) & +!! !CM2 / (1.0 - frac_irr_soilt(i,m)) +!! !CM2 ELSE +!! !CM2 sthu_nir_soilt(i,m,n) = sthu_soilt(i,m,n) +!! !CM2 ext_nir_soilt(i,m,n) = ext_soilt(i,m,n) +!! !CM2 END IF +!! +!! !CM2 smcl_irr_soilt(i,m,n) = smcl_soilt(i,m,n) & +!! !CM2 + (sthu_irr_soilt(i,m,n) & +!! !CM2 - sthu_soilt(i,m,n)) & +!! !CM2 * smclsat_soilt(i,m,n) +!! !CM2 smcl_nir_soilt(i,m,n) = smcl_soilt(i,m,n) & +!! !CM2 + (sthu_nir_soilt(i,m,n) & +!! !CM2 - sthu_soilt(i,m,n)) & +!! !CM2 * smclsat_soilt(i,m,n) +!! !CM2 END DO +!! !CM2 END DO +!! !CM2 END DO +!! +!! !CM2 DO m = 1, nsoilt +!! !CM2 ! First call soil_hyd for non-irrigated fraction. +!! !CM2 ! Note that the values of smclsat_soilt, smclzw_soilt and smclsatzw_soilt +!! !CM2 ! calculated here and in the next call are later replaced by the +!! !CM2 ! recalculated values from soil_hyd_update. +!! !CM2 CALL soil_hyd ( & +!! !CM2 land_pts, sm_levels, soil_pts, timestep, l_top, l_soil_sat_down, & +!! !CM2 soil_index, bexp_soilt(:,m,:), dzsoil, & +!! !CM2 ext_nir_soilt(:,m,:), dsmc_dt_soilt(:,m), ksz_soilt(:,m,:), & +!! !CM2 sathh_soilt(:,m,:), sthzw_soilt(:,m), smvcst_soilt(:,m,:), & +!! !CM2 qbase_l_soilt(:,m,:), zdepth, & +!! !CM2 smcl_nir_soilt(:,m,:), sthu_nir_soilt(:,m,:), smclsat_soilt(:,m,:), & +!! !CM2 w_flux_nir_soilt(:,m,:), smclzw_soilt(:,m), smclsatzw_soilt(:,m)) +!! +!! !CM2 ! Next call soil_hyd for irrigated fraction. +!! !CM2 CALL soil_hyd ( & +!! !CM2 land_pts, sm_levels, soil_pts, timestep, l_top, l_soil_sat_down, & +!! !CM2 soil_index, bexp_soilt(:,m,:), dzsoil, & +!! !CM2 ext_irr_soilt(:,m,:), dsmc_dt_soilt(:,m), ksz_soilt(:,m,:), & +!! !CM2 sathh_soilt(:,m,:), sthzw_soilt(:,m), smvcst_soilt(:,m,:), & +!! !CM2 qbase_l_soilt(:,m,:), zdepth, & +!! !CM2 smcl_irr_soilt(:,m,:), sthu_irr_soilt(:,m,:), smclsat_soilt(:,m,:), & +!! !CM2 w_flux_irr_soilt(:,m,:), smclzw_soilt(:,m), smclsatzw_soilt(:,m)) +!! !CM2 END DO +!! +!! !CM2 !-------------------------------------------------------------------------- +!! !CM2 ! Calculate values for the whole soil tile by combining irrigated and +!! !CM2 ! non-irrigated values. +!! !CM2 !-------------------------------------------------------------------------- +!! !CM2 DO m = 1,nsoilt +!! !CM2 DO n = 0,sm_levels +!! !CM2 DO j = 1,soil_pts +!! !CM2 i = soil_index(j) +!! +!! !CM2 ! Ensure sensible values if irrigation fraction is very small by +!! !CM2 ! using values from the non-irrigated fraction. +!! !CM2 IF ( frac_irr_soilt(i,m) <= EPSILON(1.0) ) THEN +!! !CM2 w_flux_soilt(i,m,n) = w_flux_nir_soilt(i,m,n) +!! !CM2 IF ( n >= 1 ) THEN +!! !CM2 sthu_irr_soilt(i,m,n) = sthu_nir_soilt(i,m,n) +!! !CM2 smcl_soilt(i,m,n) = smcl_nir_soilt(i,m,n) +!! !CM2 sthu_soilt(i,m,n) = sthu_nir_soilt(i,m,n) +!! !CM2 END IF +!! !CM2 ELSE +!! !CM2 w_flux_soilt(i,m,n) = frac_irr_soilt(i,m) & +!! !CM2 * w_flux_irr_soilt(i,m,n) & +!! !CM2 + ( 1.0 - frac_irr_soilt(i,m) ) & +!! !CM2 * w_flux_nir_soilt(i,m,n) +!! !CM2 IF ( n >= 1 ) THEN +!! !CM2 smcl_soilt(i,m,n) = frac_irr_soilt(i,m) * smcl_irr_soilt(i,m,n) & +!! !CM2 + ( 1.0 - frac_irr_soilt(i,m) ) & +!! !CM2 * smcl_nir_soilt(i,m,n) +!! !CM2 sthu_soilt(i,m,n) = frac_irr_soilt(i,m) * sthu_irr_soilt(i,m,n) & +!! !CM2 + ( 1.0 - frac_irr_soilt(i,m) ) & +!! !CM2 * sthu_nir_soilt(i,m,n) +!! !CM2 END IF +!! !CM2 END IF +!! !CM2 END DO ! soil points +!! !CM2 END DO ! layers +!! !CM2 END DO ! tiles +!! +!! !CM2 !-------------------------------------------------------------------------- +!! !CM2 ! Recalculate values for the whole soil tile that were over-written by the +!! !CM2 ! separate calls to soil_hyd above. +!! !CM2 !-------------------------------------------------------------------------- +!! !CM2 DO m = 1, nsoilt +!! !CM2 CALL soil_hyd_update(land_pts, sm_levels, soil_pts, soil_index, dzsoil, & +!! !CM2 smvcst_soilt(:,m,:), zdepth, smclzw_soilt(:,m), & +!! !CM2 sthzw_soilt(:,m), smclsat_soilt(:,m,:), & +!! !CM2 smclsatzw_soilt(:,m)) +!! !CM2 END DO +!! +!! !CM2ELSE +!! ! .NOT. l_irrig_dmd +!! +!! !CM2DO m = 1, nsoilt +!! !CM2 CALL soil_hyd ( & +!! !CM2 land_pts, sm_levels, soil_pts, timestep, l_top, l_soil_sat_down, & +!! !CM2 soil_index, bexp_soilt(:,m,:), dzsoil, & +!! !CM2 ext_soilt(:,m,:), dsmc_dt_soilt(:,m), ksz_soilt(:,m,:), & +!! !CM2 sathh_soilt(:,m,:), sthzw_soilt(:,m), smvcst_soilt(:,m,:), & +!! !CM2 qbase_l_soilt(:,m,:), zdepth, & +!! !CM2 smcl_soilt(:,m,:), sthu_soilt(:,m,:), smclsat_soilt(:,m,:), & +!! !CM2 w_flux_soilt(:,m,:), smclzw_soilt(:,m), smclsatzw_soilt(:,m)) +!! !CM2END DO +!! +!! !CM2END IF ! l_irrig_dmd + + !---------------------------------------------------------------------------- + ! Update further stores and fluxes. + !---------------------------------------------------------------------------- + !!IF (nsoilt == 1) THEN + !! !To maintain bit-comparability, we need to call with the _gb version of + !! !surface runoff. + !! m = 1 + !! CALL soil_hyd_wt ( & + !! land_pts, sm_levels, soil_pts, timestep, stf_sub_surf_roff, & + !! l_top, soil_index, & + !! bexp_soilt(:,m,:), dsmc_dt_soilt(:,m), sathh_soilt(:,m,:), & + !! smclsat_soilt(:,m,:), smclsatzw_soilt(:,m), smvcst_soilt(:,m,:), & + !! w_flux_soilt(:,m,:), smcl_soilt(:,m,:), & + !! surf_roff_gb, & + !! qbase_l_soilt(:,m,:), smclzw_soilt(:,m), zw_soilt(:,m), & + !! sub_surf_roff_soilt(:,m), drain_soilt(:,m), qbase_soilt(:,m), & + !! sthzw_soilt(:,m), surf_roff_inc_soilt(:,m) ) + + !! ! For a single soil tile, simply copy across to the output variable. + !! sub_surf_roff_gb(:) = sub_surf_roff_soilt(:,m) + !! ! Update the tiled surface runoff. + !! surf_roff_soilt(:,m) = surf_roff_soilt(:,m) + surf_roff_inc_soilt(:,m) + !!ELSE + + !! ! Initialise output variable + !! DO i = 1, land_pts + !! sub_surf_roff_gb(i) = 0.0 + !! END DO + !! DO m = 1, nsoilt + !! CALL soil_hyd_wt ( & + !! land_pts, sm_levels, soil_pts, timestep, stf_sub_surf_roff, & + !! l_top, soil_index, & + !! bexp_soilt(:,m,:), dsmc_dt_soilt(:,m), sathh_soilt(:,m,:), & + !! smclsat_soilt(:,m,:), smclsatzw_soilt(:,m), smvcst_soilt(:,m,:), & + !! w_flux_soilt(:,m,:), smcl_soilt(:,m,:), & + !! surf_roff_soilt(:,m), & + !! qbase_l_soilt(:,m,:), smclzw_soilt(:,m), zw_soilt(:,m), & + !! sub_surf_roff_soilt(:,m), drain_soilt(:,m), qbase_soilt(:,m), & + !! sthzw_soilt(:,m), surf_roff_inc_soilt(:,m) ) + + !! ! For multiple soil tiles, add up the contributions, allowing for frac + !! sub_surf_roff_gb(:) = sub_surf_roff_gb(:) & + !! + ( tile_frac(:,m) * sub_surf_roff_soilt(:,m)) + !! surf_roff_gb(:) = surf_roff_gb(:) + tile_frac(:,m) & + !! * surf_roff_inc_soilt(:,m) + + !! END DO + !!END IF !nsoilt == 1 + + !--------------------------------------------------------------------------- + ! Calculate surface saturation and wetland fractions: + !--------------------------------------------------------------------------- + !CM2IF (l_top) THEN + !CM2 DO m = 1, nsoilt + + !CM2 DO i = 1,land_pts + !CM2 fsat_soilt(i,m) = 0.0 + !CM2 fwetl_soilt(i,m) = 0.0 + + !CM2 ! Zero soil porosity over land ice: + !CM2 IF (smvcst_soilt(i,m,sm_levels) <= 0.0) THEN + !CM2 zw_soilt(i,m) = zw_max + !CM2 END IF + !CM2 END DO + + !CM2 DO j = 1,soil_pts + !CM2 i = soil_index(j) + !CM2 qbase_zw_soilt(i,m) = qbase_l_soilt(i,m,sm_levels+1) + + !CM2 !Now use fit for fsat_soilt and fwet: + !CM2 IF (l_wetland_unfrozen) THEN + !CM2 fsat_soilt(i,m) = wutot_soilt(i,m) * a_fsat_soilt(i,m) & + !CM2 * EXP(-c_fsat_soilt(i,m) * top_crit_soilt(i,m)) + !CM2 fwetl_soilt(i,m) = wutot_soilt(i,m) * a_fwet_soilt(i,m) & + !CM2 * EXP(-c_fwet_soilt(i,m) * top_crit_soilt(i,m)) + !CM2 ELSE + !CM2 fsat_soilt(i,m) = a_fsat_soilt(i,m) & + !CM2 * EXP(-c_fsat_soilt(i,m) * top_crit_soilt(i,m)) + !CM2 fwetl_soilt(i,m) = a_fwet_soilt(i,m) & + !CM2 * EXP(-c_fwet_soilt(i,m) * top_crit_soilt(i,m)) + !CM2 END IF + + !CM2 IF (top_crit_soilt(i,m) >= ti_max) THEN + !CM2 fsat_soilt(i,m) = 0.0 + !CM2 fwetl_soilt(i,m) = 0.0 + !CM2 END IF + + !CM2 END DO + !CM2 END DO + !CM2END IF ! l_top + +!CM2ELSE ! soil pts + + !--------------------------------------------------------------------------- + ! If required by STASH flag and there are no soil points, + ! set sub-surface runoff to zero. + !--------------------------------------------------------------------------- + !CM2IF (stf_sub_surf_roff) THEN + !CM2 DO i = 1,land_pts + !CM2 sub_surf_roff_gb(i) = 0.0 + !CM2 END DO + !CM2END IF + +!CM2END IF ! soil_pts + +!----------------------------------------------------------------------------- +! Update the soil temperatures and the frozen moisture fractions +!----------------------------------------------------------------------------- + +!============================================================================= +! *NOTICE REGARDING SOIL TILING** +! +!The following section facilitates the use of soil tiling. As implemented, +!there are two soil tiling options: +! +!nsoilt == 1 +!Operate as with a single soil tile, functionally identical to JULES upto +! at least vn4.7 (Oct 2016) +! This means that a soilt variable being passed 'up' to the surface is +! broadcast to the surft variable (with weighting by frac if requred) +! +!nsoilt > 1 +!Operate with nsoilt = nsurft, with a direct mapping between them +! This means that a soilt variable being passed 'up' to the surface is simply +! copied into the surft variable +! +! This will need to be refactored for other tiling approaches. This note +! will be replicated elsewhere in the code as required +! +!These comments apply until **END NOTICE REGARDING SOIL TILING** +!============================================================================= +!CM2IF (soil_pts /= 0) THEN +!CM2 ! When using soil tiling, we can use the surface tiled version of +!CM2 ! surf_ht_flux_ld, snow_soil_htf. The _ld version is a gridbox mean +!CM2 ! calculated in snow and passed through. +!CM2 IF (nsoilt == 1) THEN +!CM2 m = 1 +!CM2 CALL soil_htc ( & +!CM2 land_pts, sm_levels, nsurft, soil_pts, timestep, soil_index, & +!CM2 surft_pts, surft_index, nsnow_surft, & +!CM2 bexp_soilt(:,m,:), dzsoil, tile_frac, & +!CM2 non_lake_frac, hcap_soilt(:,m,:), hcon_soilt(:,m,:), & +!CM2 sathh_soilt(:,m,:), smcl_soilt(:,m,:), snowdepth_surft, & +!CM2 surf_ht_flux_ld, smvcst_soilt(:,m,:), w_flux_soilt(:,m,:), & +!CM2 sthf_soilt(:,m,:), sthu_soilt(:,m,:), sthu_irr_soilt(:,m,:), & +!CM2 t_soil_soilt(:,m,:), tsoil_deep_gb ) +!CM2 ELSE +!CM2 ! Surface and soil tiles map directly on to each other. +!CM2 DO m = 1, nsoilt +!CM2 n = m +!CM2 CALL soil_htc ( & +!CM2 land_pts, sm_levels, nsurft, soil_pts, timestep, soil_index, & +!CM2 surft_pts, surft_index, nsnow_surft, & +!CM2 bexp_soilt(:,m,:), dzsoil, tile_frac, & +!CM2 non_lake_frac, hcap_soilt(:,m,:), hcon_soilt(:,m,:), & +!CM2 sathh_soilt(:,m,:), smcl_soilt(:,m,:), snowdepth_surft, & +!CM2 snow_soil_htf(:,n), smvcst_soilt(:,m,:), w_flux_soilt(:,m,:), & +!CM2 sthf_soilt(:,m,:), sthu_soilt(:,m,:), sthu_irr_soilt(:,m,:), & +!CM2 t_soil_soilt(:,m,:), tsoil_deep_gb ) +!CM2 END DO +!CM2 END IF +!CM2END IF +!CM2!============================================================================= +!CM2! *END NOTICE REGARDING SOIL TILING** +!CM2!============================================================================= +!CM2 +!CM2!----------------------------------------------------------------------------- +!CM2! Update the sub-surface temperatures for land ice. +!CM2!----------------------------------------------------------------------------- +!CM2IF (lice_pts /= 0) THEN +!CM2 IF ( .NOT. l_elev_land_ice) THEN +!CM2 DO m = 1, nsoilt +!CM2 CALL ice_htc (lice_pts, land_pts, sm_levels, timestep, lice_index, & +!CM2 dzsoil, surf_ht_flux_ld, t_soil_soilt(:,m,:)) +!CM2 END DO +!CM2 ELSE +!CM2 CALL elev_htc (lice_pts, land_pts, nsurft, dzsoil_elev, timestep, & +!CM2 lice_index, snow_soil_htf, tsurf_elev_surft) +!CM2 END IF +!CM2END IF +!CABLE_LSM:End +!jhan:up to here +!----------------------------------------------------------------------------- +! Diagnose the available soil moisture in a layer at the surface. +!----------------------------------------------------------------------------- +DO m = 1, nsoilt + CALL soilmc ( land_pts,sm_levels,soil_pts,soil_index, & + dzsoil,sthu_soilt(:,m,:),smvcst_soilt(:,m,:), & + smvcwt_soilt(:,m,:),smc_soilt(:,m) ) +END DO + +!----------------------------------------------------------------------------- +! Calculate mean soil temperature and scaled CH4 flux: +!----------------------------------------------------------------------------- +DO m = 1, nsoilt + DO i = 1,land_pts + fch4_wetl_soilt(i,m) = 0.0 + fch4_wetl_cs_soilt(i,m) = 0.0 + fch4_wetl_npp_soilt(i,m) = 0.0 + fch4_wetl_resps_soilt(i,m) = 0.0 + END DO +END DO +!!!CABLE_LSM: omit for CABLE +!! IF ( l_top .AND. soil_pts /= 0 ) THEN +!! SELECT CASE ( soil_bgc_model ) +!! CASE ( soil_model_1pool, soil_model_rothc ) +!! IF ( l_ch4_tlayered ) THEN +!! ! This variable is not used with layered CH4 calc. +!! tsoil_d_soilt(:,m) = 0.0 +!! ELSE +!! CALL soilt(land_pts, sm_levels, soil_pts, soil_index, & +!! dzsoil, t_soil_soilt(:,m,:), tsoil_d_soilt(:,m)) +!! END IF +!! CALL ch4_wetl(land_pts, sm_levels, soil_pts, dim_cs1, timestep, & +!! l_ch4_tlayered, soil_index, & +!! t_soil_soilt(:,m,:), tsoil_d_soilt(:,m), cs_ch4_soilt(:,m),& +!! resp_s_soilt(:,m,:,:), npp_soilt(:,m), fwetl_soilt(:,m), & +!! sthu_soilt(:,m,:), bexp_soilt(:,m,:), & +!! fch4_wetl_soilt(:,m), fch4_wetl_cs_soilt(:,m), & +!! fch4_wetl_npp_soilt(:,m), fch4_wetl_resps_soilt(:,m), & +!! substr_ch4, mic_ch4, mic_act_ch4, acclim_ch4, & +!! cs_pool_soilt(:,m,:,:)) +!!#if !defined(UM_JULES) +!! IF (l_imogen) THEN +!! DO i = 1,land_pts +!! ! fch4_wetl_acc_soilt in kg/m2 and fch4_wetl_soilt in 10e9kg/m2/s +!! fch4_wetl_acc_soilt(i,m) = fch4_wetl_acc_soilt(i,m) + & +!! (fch4_wetl_soilt(i,m) * to_kg_conversion * timestep_len) +!! END DO +!! END IF +!!#endif +!! END SELECT +!! END IF +!!END DO ! tiles +!! +!!IF ( (soil_bgc_model == soil_model_rothc .AND. l_layeredc ) & +!! .OR. soil_bgc_model == soil_model_ecosse ) THEN +!! !----------------------------------------------------------------------- +!! !accumulate soil temperature for layered soil carbon and nitrogen +!! !----------------------------------------------------------------------- +!! DO m = 1, nsoilt +!! IF (asteps_since_triffid == 1) THEN +!! t_soil_soilt_acc(:,m,:) = 0.0 +!! END IF +!! DO j = 1,soil_pts +!! i = soil_index(j) +!! t_soil_soilt_acc(i,m,:) = t_soil_soilt_acc(i,m,:) + t_soil_soilt(i,m,:) +!! END DO +!! END DO +!!END IF +!CABLE_LSM: omit for CABLE + +!----------------------------------------------------------------------- +! Calculate Nitrogen Leaching +!----------------------------------------------------------------------- +IF (soil_bgc_model == soil_model_rothc .AND. l_nitrogen) THEN + IF (nsoilt > 1) THEN + errorstatus = 101 + CALL ereport("check hydrol_jls", errorstatus, & + "nsoilt>1 and l_nitrogen - n_leach not currently coded") + END IF + CALL n_leach(land_pts, asteps_since_triffid, dim_cslayer, timestep, & + w_flux_soilt, qbase_l_soilt, sub_surf_roff_gb, smcl_soilt, & + smcl_old_soilt, n_inorg_avail_pft, n_inorg_soilt_lyrs, & + n_leach_gb_acc, n_leach_soilt) +END IF + +!----------------------------------------------------------------------------- +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE hydrol_cbl +END MODULE hydrol_mod_cbl diff --git a/src/coupled/AM3/control/cable/cable_land/implicit/cable_land_sf_implicit_cbl.F90 b/src/coupled/AM3/control/cable/cable_land/implicit/cable_land_sf_implicit_cbl.F90 new file mode 100644 index 000000000..07626e9b4 --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/implicit/cable_land_sf_implicit_cbl.F90 @@ -0,0 +1,931 @@ +MODULE cable_land_sf_implicit_mod + +USE sf_melt_mod, ONLY: sf_melt +USE screen_tq_mod, ONLY: screen_tq +USE sf_evap_mod, ONLY: sf_evap +USE sice_htf_mod, ONLY: sice_htf + +USE um_types, ONLY: real_jlslsm + +IMPLICIT NONE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: & + ModuleName='CABLE_LAND_SF_IMPLICIT_MOD' + +CONTAINS +! SUBROUTINE CABLE_LAND_SF_IMPLICIT -------------------------------- +! +! Purpose: Calculate implicit correction for land point to surface +! fluxes of heat,moisture and momentum, to be used by +! the unconditionally stable and non-oscillatory BL +! numerical solver. +! +! edits associated with creation of CM3 denoted by CM3#56 +!-------------------------------------------------------------------- +! Arguments :- +SUBROUTINE cable_land_sf_implicit ( & +! IN values defining field dimensions and subset to be processed : + land_pts,land_index,nsurft,surft_index,surft_pts,sm_levels, & + canhc_surft,canopy,flake,smc_soilt,tile_frac,wt_ext_surft,fland,flandg, & +! IN everything not covered so far : + lw_down,sw_surft,t_soil_soilt,r_gamma,alpha1,ashtf_prime_surft, & + dtrdz_charney_grid_1,fraca,resfs,resft,rhokh_surft, & + emis_surft,snow_surft,dtstar_surft, & +! INOUT data : + tstar_surft,fqw_surft,fqw_1,ftl_1,ftl_surft,sf_diag, & +! OUT Diagnostic not requiring STASH flags : + ecan,ei_surft,esoil_surft,surf_ht_flux_land,ei_land,surf_htf_surft, & +! OUT data required elsewhere in UM system : + tstar_land,le_surft,radnet_surft,ecan_surft,esoil_soilt, & + ext_soilt,melt_surft,tstar_surft_old,ERROR, & + !New arguments replacing USE statements + ! lake_mod (IN) + lake_h_ice_gb, & + ! lake_mod (OUT) + surf_ht_flux_lake_ij, non_lake_frac, & + ! fluxes (IN) + anthrop_heat_surft, & + ! fluxes (OUT) + surf_ht_store_surft, & + ! c_elevate (IN) + lw_down_elevcorr_surft, & + ! prognostics (IN) + nsnow_surft, & + ! jules_mod (IN) + snowdep_surft, & + ! JULES Types containing field data (IN OUT) + crop_vars, & +!!!CABLE_LSM: + progs_cbl, work_cbl, progs_cnp, & + !CM3: + cycleno, numcycles, npft, dim_cs1, smvcst, & + ls_rain, ls_snow, con_rain, con_snow, & + tl_1, dtl1_1, qw_1, dqw1_1, ctctq1, & + canopy_gb, canopy_surft, smcl_soilt, sthf_soilt, sthu_soilt, & + gs, gs_surft, & + npp_gb, npp_PFT, npp_acc_pft, gpp_gb, gpp_pft, & + resp_s, resp_s_tot, & !resp_s_tile, !Kathy intro-ed as diag & + resp_p, resp_p_pft, g_leaf_pft ) +!!!CABLE_LSM: End + +!TYPE definitions +USE crop_vars_mod, ONLY: crop_vars_type + +USE csigma, ONLY: sbcon + +USE planet_constants_mod, ONLY: cp + +USE atm_fields_bounds_mod, ONLY: tdims, pdims + +USE theta_field_sizes, ONLY: t_i_length, t_j_length + +USE jules_surface_mod, ONLY: l_aggregate, l_flake_model, ls + +USE jules_snow_mod, ONLY: & + nsmax, rho_snow_const, cansnowtile, l_snow_nocan_hc + +USE jules_surface_types_mod, ONLY: lake + +USE sf_diags_mod, ONLY: strnewsfdiag + +#if defined(UM_JULES) +USE timestep_mod, ONLY: timestep, timestep_number +USE submodel_mod, ONLY: atmos_im +USE UM_parcore, ONLY: mype +#else +USE model_time_mod, ONLY: timestep_number => timestep +USE model_time_mod, ONLY: timestep => timestep_len +USE model_grid_mod, ONLY: latitude, longitude +#endif + +USE ancil_info, ONLY: nsoilt + +USE jules_surface_mod, ONLY: l_neg_tstar + +USE water_constants_mod, ONLY: lc, lf, rho_ice + +USE solinc_data, ONLY: sky, l_skyview + +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +USE jules_print_mgr, ONLY: jules_message, jules_print + +! In general CABLE utilizes a required subset of tbe JULES types, however; +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type ! CABLE requires extra progs +USE work_vars_mod_cbl, ONLY: work_vars_type ! and some kept thru timestep +USE progs_cnp_vars_mod, ONLY: progs_cnp_vars_type ! CASA requires extra progs +!CABLE_LSM:Make avail call to CABLE implicit version +USE cable_implicit_main_mod, ONLY: cable_implicit_main + +IMPLICIT NONE +!-------------------------------------------------------------------- +! Inputs :- +! (a) Defining horizontal grid and subset thereof to be processed. +! Checked for consistency. +!-------------------------------------------------------------------- +INTEGER, INTENT(IN) :: & + land_pts ! IN No of land points + +! (c) Soil/vegetation/land surface parameters (mostly constant). +INTEGER, INTENT(IN) :: & + land_index(land_pts) ! IN LAND_INDEX(I)=J => the Jth + ! point in ROW_LENGTH,ROWS is the + ! Ith land point. + +INTEGER, INTENT(IN) :: & + sm_levels & + ! IN No. of soil moisture levels +,nsurft & + ! IN No. of land tiles +,surft_index(land_pts,nsurft) & + ! IN Index of tile points +,surft_pts(nsurft) + ! IN Number of tile points + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + canhc_surft(land_pts,nsurft) & + ! IN Areal heat capacity of canopy + ! for land tiles (J/K/m2). +,canopy(land_pts,nsurft) & + ! IN Surface/canopy water for + ! snow-free land tiles (kg/m2) +,flake(land_pts,nsurft) & + ! IN Lake fraction. +,smc_soilt(land_pts,nsoilt) & + ! IN Available soil moisture (kg/m2). +,tile_frac(land_pts,nsurft) & + ! IN Tile fractions including + ! snow cover in the ice tile. +,wt_ext_surft(land_pts,sm_levels,nsurft) & + ! IN Fraction of evapotranspiration + ! extracted from each soil layer + ! by each tile. +,fland(land_pts) & + ! IN Land fraction on land pts. +,flandg(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Land fraction on all pts. +,emis_surft(land_pts,nsurft) + ! IN Emissivity for land tiles + ! IN Lying snow on tiles (kg/m2) + + +! (f) Atmospheric + any other data not covered so far, incl control. + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + lw_down(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! IN Surface downward LW radiation + ! (W/m2). +,sw_surft(land_pts,nsurft) + ! IN Surface net SW radiation on + ! land tiles (W/m2). + +REAL(KIND=real_jlslsm), INTENT(IN) :: r_gamma + ! IN implicit weight in level 1 + +REAL(KIND=real_jlslsm), INTENT(IN) :: & + alpha1(land_pts,nsurft) & + ! IN Mean gradient of saturated + ! specific humidity with respect + ! to temperature between the + ! bottom model layer and tile + ! surfaces +,ashtf_prime_surft(land_pts,nsurft) & + ! IN Adjusted SEB coefficient for + ! land tiles. +,dtrdz_charney_grid_1(pdims%i_start:pdims%i_end, & + pdims%j_start:pdims%j_end) & + ! IN -g.dt/dp for model layers. +,fraca(land_pts,nsurft) & + ! IN Fraction of surface moisture + ! flux with only aerodynamic + ! resistance for snow-free land + ! tiles. +,resfs(land_pts,nsurft) & + ! IN Combined soil, stomatal + ! and aerodynamic resistance + ! factor for fraction (1-FRACA) of + ! snow-free land tiles. +,resft(land_pts,nsurft) & + ! IN Total resistance factor. + ! FRACA+(1-FRACA)*RESFS for + ! snow-free land, 1 for snow. +,rhokh_surft(land_pts,nsurft) + ! IN Surface exchange coefficients + ! for land tiles + + +REAL(KIND=real_jlslsm), INTENT(OUT) :: t_soil_soilt(land_pts,nsoilt,sm_levels) + ! Soil temperatures (K). +REAL(KIND=real_jlslsm), INTENT(OUT) :: snow_surft(land_pts,nsurft) +!!!CABLE_LSM: +INTEGER, INTENT(IN) :: npft +INTEGER, INTENT(IN) :: dim_cs1 +INTEGER, INTENT(IN) :: cycleno, numcycles +REAL, INTENT(IN) :: smvcst(land_pts,sm_levels) + ! IN Volumetric saturation point +!forcing +REAL, INTENT(IN) :: ls_rain(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL, INTENT(IN) :: ls_snow(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL, INTENT(IN) :: con_rain(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL, INTENT(IN) :: con_snow(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) +REAL, INTENT(IN) :: tl_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) ! temperature +REAL, INTENT(IN) :: qw_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) ! humidity +REAL, INTENT(IN) :: dtl1_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) ! increment to temp +REAL, INTENT(IN) :: dqw1_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) ! increment to humidity +REAL, INTENT(IN) :: ctctq1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) ! temp/humidity increment +!re-declared as IN OUT as CABLE OUTs dtstar +REAL, INTENT(IN OUT) :: dtstar_surft(land_pts,nsurft) + ! Change in TSTAR over timestep +!!!CABLE_LSM: End + +!-------------------------------------------------------------------- +! In/outs :- +!-------------------------------------------------------------------- +TYPE (strnewsfdiag), INTENT(IN OUT) :: sf_diag +REAL(KIND=real_jlslsm), INTENT(IN OUT) :: & + tstar_surft(land_pts,nsurft) & + ! INOUT Surface tile temperatures +,fqw_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! INOUT Moisture flux between layers + ! (kg per square metre per sec) + ! FQW(,1) is total water flux + ! from surface, 'E'. +,ftl_1(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! INOUT FTL(,K) contains net + ! turbulent sensible heat flux + ! into layer K from below; so + ! FTL(,1) is the surface + ! sensible heat, H.(W/m2) +,ftl_surft(land_pts,nsurft) & + ! INOUT Surface FTL for land tiles +,fqw_surft(land_pts,nsurft) + ! INOUT Surface FQW for land tiles + +!!!CABLE_LSM:CM3 +!CM3#56 Potentially problematically - while these additional variables are available +! some of the CNP vars would not be available in the implicit sectio. This implies +! either partner changes through the UM boundary-layer scheme, USE of data modules +! and/or the work_cbl TYPE to pass stuff around in the longer term. +! +! As of 12/12/2023 - INH thinks it's okay +REAL(KIND=real_jlslsm), INTENT(INOUT) :: smcl_soilt(land_pts,nsoilt,sm_levels) + ! INOUT Soil Moisture +REAL(KIND=real_jlslsm), INTENT(INOUT) :: sthf_soilt(land_pts,nsoilt,sm_levels) + ! INOUT Soil Frozen fraction +REAL(KIND=real_jlslsm), INTENT(INOUT) :: sthu_soilt(land_pts,nsoilt,sm_levels) + ! INOUT Soil Unfrozen +REAL(KIND=real_jlslsm), INTENT(INOUT) ::ext_soilt(land_pts,nsoilt,sm_levels) + ! OUT Extraction of water from each + ! soil layer (kg/m2/s). +REAL, INTENT(OUT) :: canopy_gb(land_pts) +REAL, INTENT(OUT) :: canopy_surft(land_pts, nsurft) +REAL, INTENT(OUT) :: gs( land_pts ) +REAL, INTENT(OUT) :: gs_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: npp_acc_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: npp_gb(land_pts) +REAL, INTENT(OUT) :: npp_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: gpp_gb(land_pts) +REAL, INTENT(OUT) :: gpp_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: resp_s(land_pts, dim_cs1) ! Soil respiration (kg C/m2/s) +REAL, INTENT(OUT) :: resp_s_tot(land_pts) ! Total soil resp'n (kg C/m2/s) +REAL, INTENT(OUT) :: resp_p(land_pts) +REAL, INTENT(OUT) :: resp_p_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: g_leaf_pft(land_pts,npft) +!CABLE TYPES containing field data (IN OUT) +TYPE(progs_cbl_vars_type), INTENT(IN OUT) :: progs_cbl +TYPE(work_vars_type), INTENT(IN OUT) :: work_cbl +TYPE(progs_cnp_vars_type), INTENT(IN OUT) :: progs_cnp +!!!CABLE_LSM: End + +!-------------------------------------------------------------------- +! Outputs :- +!-1 Diagnostic (or effectively so - includes coupled model requisites):- + +! (a) Calculated anyway (use STASH space from higher level) :- +!-------------------------------------------------------------------- +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + ecan(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Gridbox mean evaporation from + ! canopy/surface store (kg/m2/s). + ! Zero over sea. +,esoil_surft(land_pts,nsurft) & + ! OUT ESOIL for snow-free land tiles +,surf_ht_flux_land(tdims%i_start:tdims%i_end, & + tdims%j_start:tdims%j_end) & + ! OUT Net downward heat flux at + ! surface over land + ! fraction of gridbox (W/m2). +,ei_land(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Sublimation from lying snow + ! (kg/m2/s). +,surf_htf_surft(land_pts,nsurft) + ! OUT Net downward surface heat flux + ! on tiles (W/m2) + +!-2 Genuinely output, needed by other atmospheric routines :- + +REAL(KIND=real_jlslsm), INTENT(OUT) :: & + tstar_land(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) & + ! OUT Land mean sfc temperature (K) +,le_surft(land_pts,nsurft) & + ! OUT Surface latent heat flux for + ! land tiles +,radnet_surft(land_pts,nsurft) & + ! OUT Surface net radiation on + ! land tiles (W/m2) +,ei_surft(land_pts,nsurft) & + ! OUT EI for land tiles. +,ecan_surft(land_pts,nsurft) & + ! OUT ECAN for snow-free land tiles +,esoil_soilt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end,nsoilt) & + ! OUT Surface evapotranspiration + ! from soil moisture store + ! (kg/m2/s). +,melt_surft(land_pts,nsurft) & + ! OUT Snowmelt on land tiles (kg/m2/s +,tstar_surft_old(land_pts,nsurft) & + ! OUT Tile surface temperatures at + ! beginning of timestep. +,non_lake_frac(land_pts) + ! OUT total tile fraction for surface types + ! other than inland water + +INTEGER, INTENT(OUT) :: & + ERROR ! OUT 0 - AOK; + ! 1 to 7 - bad grid definition detected; + +!New arguments replacing USE statements +! lake_mod (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: lake_h_ice_gb(land_pts) +! lake_mod (OUT) +REAL(KIND=real_jlslsm) :: surf_ht_flux_lake_ij(t_i_length,t_j_length) +! fluxes (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: anthrop_heat_surft(land_pts,nsurft) +! fluxes (OUT) +REAL(KIND=real_jlslsm), INTENT(OUT) :: surf_ht_store_surft(land_pts,nsurft) +! c_elevate (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: lw_down_elevcorr_surft(land_pts,nsurft) +! prognostics (IN) +INTEGER, INTENT(IN) :: nsnow_surft(land_pts,nsurft) +! jules_mod (IN) +REAL(KIND=real_jlslsm), INTENT(IN) :: snowdep_surft(land_pts,nsurft) + +!TYPES containing field data (IN OUT) +TYPE(crop_vars_type), INTENT(IN OUT) :: crop_vars + +!-------------------------------------------------------------------- +! Workspace :- +!-------------------------------------------------------------------- +REAL(KIND=real_jlslsm) :: & + elake_surft(land_pts,nsurft) & + ! Lake evaporation. +,melt_ice_surft(land_pts,nsurft) & + ! Ice melt on FLake lake tile (kg/m2/s) +,lake_ice_mass(land_pts) & + ! areal density equivalent to + ! lake ice of a given depth (kg/m2) +,snowmelt(tdims%i_start:tdims%i_end,tdims%j_start:tdims%j_end) + ! Snowmelt (kg/m2/s). + +REAL(KIND=real_jlslsm) :: & + canhc_surf(land_pts) + ! Areal heat capacity of canopy + ! for land tiles (J/K/m2). + +! Local scalars :- + +INTEGER :: & + i,j & + ! LOCAL Loop counter (horizontal field index). +,k & + ! LOCAL Tile pointer +,l & + ! LOCAL Land pointer +,n & + ! LOCAL Loop counter (tile index). +,m + ! Loop counter for soil tiles + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='CABLE_LAND_SF_IMPLICIT' + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +!----------------------------------------------------------------------- + +! Calculate surface scalar fluxes, temperatures only at the 1st call +! of the subroutine (first stage of the new BL solver) using standard +! MOSES2 physics and equations. These are the final values for this +! timestep and there is no need to repeat the calculation. +!----------------------------------------------------------------------- + +ERROR = 0 + +!----------------------------------------------------------------------- +! 6.1 Convert FTL to sensible heat flux in Watts per square metre. +!----------------------------------------------------------------------- + +DO n = 1,nsurft + DO k = 1,surft_pts(n) + l = surft_index(k,n) + ftl_surft(l,n) = cp * ftl_surft(l,n) + END DO +END DO + +!----------------------------------------------------------------------- +! Land surface calculations +!----------------------------------------------------------------------- +!CABLE_LSM:likely unecessary initialization of radnet_surft +! initialise diagnostics to 0 to avoid packing problems +DO n = 1, nsurft + DO l = 1, land_pts + radnet_surft(l,n) = 0.0 + le_surft(l,n) = 0.0 + END DO +END DO + + + +!----------------------------------------------------------------------- +! Land surface calculations +!----------------------------------------------------------------------- +!CABLE_LSM: +DO N=1,Nsurft + DO L=1,LAND_PTS + MELT_surft(L,N) = 0. + ENDDO +ENDDO +!CABLE_LSM: End + +!CM3#56 - need to take a copy of tstart_surft prior to CABLE +! not needed to evaluate surf_ht_store_surft BUT it is an output needed by the UM +DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + tstar_surft_old(l,n) = tstar_surft(l,n) + END DO +!$OMP END DO NOWAIT +END DO + +!CM3#56 - use of REAL() in the call +! - ideally map %fe to the output le_surft in the unpack +! - check whether dtstar_surft is needed +! - this impacts on the CABLE redeclaration so cannot be a long-term fix +! - at some point we will need to sort out the CASA variables +call cable_implicit_main( tdims%i_end, tdims%j_end, land_pts, nsurft, npft, & + sm_levels, dim_cs1, cycleno, numcycles, & + timestep, timestep_number, land_index, & + surft_pts, surft_index, & + Fland, tile_frac, smvcst, & + ls_rain, ls_snow, con_rain, con_snow, & + tl_1, dtl1_1, qw_1, dqw1_1, ctctq1, & + canopy_gb, canopy_surft, t_soil_soilt(:,1,:), & + smcl_soilt(:,1,:), sthf_soilt(:,1,:), & + sthu_soilt(:,1,:), snow_surft, & + !returned fluxes etc + ftl_1, ftl_surft, fqw_1, fqw_surft, le_surft, & + tstar_surft, dtstar_surft, surf_ht_flux_land, surf_htf_surft, & + ecan_surft, esoil_surft, ei_surft, radnet_surft, & + gs, gs_surft, sf_diag% t1p5m_surft, & + sf_diag% q1p5m_surft, melt_surft, & + npp_gb, npp_pft, npp_acc_pft, gpp_gb, gpp_pft, & + resp_s, resp_s_tot, resp_p, resp_p_pft, g_leaf_pft, & + progs_cbl, work_cbl ) + +!!CABLE_LSM:End + +!$OMP PARALLEL & +!$OMP DEFAULT(NONE) & +!$OMP PRIVATE(l,n,j,i,k) & +!$OMP SHARED(tdims,nsurft,surft_pts,surft_index, & +!$OMP ftl_surft,nsoilt,land_pts,t_soil_soilt, & +!$OMP tstar_surft_old,tstar_surft,dtstar_surft,cp,error,tile_frac, & +!$OMP non_lake_frac,lake,l_flake_model,l_aggregate) + + +!----------------------------------------------------------------------- +! Optional error check : test for negative top soil layer temperature +!----------------------------------------------------------------------- +IF (l_neg_tstar) THEN + DO m = 1,nsoilt +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + IF (t_soil_soilt(l,m,1) < 0) THEN + ERROR = 1 + WRITE(jules_message,*) & + '*** ERROR DETECTED BY ROUTINE JULES_LAND_SF_IMPLICIT ***' + CALL jules_print('jules_land_sf_implicit_jls',jules_message) + WRITE(jules_message,*) 'NEGATIVE TEMPERATURE IN TOP SOIL LAYER AT ' + CALL jules_print('jules_land_sf_implicit_jls',jules_message) + WRITE(jules_message,*) 'LAND POINT ',l + CALL jules_print('jules_land_sf_implicit_jls',jules_message) + END IF + END DO +!$OMP END DO NOWAIT + END DO +END IF + +!----------------------------------------------------------------------- +! Diagnose the land surface temperature +!----------------------------------------------------------------------- + +!CM3#56 - if needed this evaluation of tstart_surft_old should be before cable. +!DO n = 1,nsurft +!!$OMP DO SCHEDULE(STATIC) +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! tstar_surft_old(l,n) = tstar_surft(l,n) +!!CABLE_LSM: use CABLE's tstar_tile +!!C! tstar_surft(l,n) = tstar_surft_old(l,n) + dtstar_surft(l,n) +! END DO +!!$OMP END DO NOWAIT +!END DO + +!----------------------------------------------------------------------- +! Calculate non_lake_frac +!----------------------------------------------------------------------- +!CM3#56 - this needs some thought and follow through as to where non_lake_frac is used +! - this appears to be linked solely to use of FLAKE so should remain as 1.0 +!$OMP DO SCHEDULE(STATIC) +DO l = 1,land_pts + ! initialise the non-lake fraction to one, not zero, + ! in case there should ever be more than one lake tile, see below + non_lake_frac(l) = 1.0 +END DO +!$OMP END DO NOWAIT + +!IF ( ( l_flake_model ) .AND. ( .NOT. l_aggregate) ) THEN +!!$OMP DO SCHEDULE(STATIC) +! DO l = 1,land_pts +! ! Remove FLake tile fraction. +! non_lake_frac(l) = non_lake_frac(l) - tile_frac(l,lake) +! END DO +!!$OMP END DO NOWAIT +!END IF + +!$OMP END PARALLEL + +!----------------------------------------------------------------------- +! 7. Surface evaporation components and updating of surface +! temperature (P245, routine SF_EVAP). +!----------------------------------------------------------------------- +!CABLE_LSM: +!CM2!CALL sf_evap ( & +!CM2! land_pts,nsurft, & +!CM2! land_index,surft_index,surft_pts,sm_levels,fland, & +!CM2! ashtf_prime_surft,canopy,dtrdz_charney_grid_1,flake,fraca, & +!CM2! snow_surft,resfs,resft,rhokh_surft,tile_frac,smc_soilt,wt_ext_surft, & +!CM2! timestep,r_gamma,fqw_1,fqw_surft,ftl_1,ftl_surft,tstar_surft, & +!CM2! ecan,ecan_surft,elake_surft,esoil_soilt,esoil_surft,ei_surft,ext_soilt, & +!CM2! sf_diag, non_lake_frac, & +!CM2! ! crop_vars_mod (IN) +!CM2! crop_vars%frac_irr_soilt, crop_vars%frac_irr_surft, & +!CM2! crop_vars%wt_ext_irr_surft, crop_vars%resfs_irr_surft, & +!CM2! ! crop_vars_mod (IN OUT) +!CM2! crop_vars%smc_irr_soilt, & +!CM2! ! crop_vars_mod (OUT) +!CM2! crop_vars%ext_irr_soilt) + +DO N=1,Nsurft + DO L=1,LAND_PTS + ELAKE_surft(L,N) = 0. + ENDDO +ENDDO + +DO j=tdims%j_start,tdims%j_end + DO i=tdims%i_start,tdims%i_end + ecan(i,j) = 0. + esoil_soilt(i,j,1) = 0. + ENDDO +ENDDO + +DO N=1,Nsurft + DO K=1,surft_PTS(N) + L = surft_INDEX(K,N) + j=(land_index(l)-1)/tdims%i_end + 1 + i = land_index(l) - (j-1)*tdims%i_end + ecan(i,j) = ecan(i,j) + tile_frac(l,n)*ecan_surft(l,n) + esoil_soilt(i,j,1) = esoil_soilt(i,j,1) + tile_frac(l,n)*esoil_surft(l,n) + ENDDO +ENDDO +!CABLE_LSM:End + +!----------------------------------------------------------------------- +! Surface melting of sea-ice and snow on land tiles. +!----------------------------------------------------------------------- + +!$OMP PARALLEL & +!$OMP DEFAULT(NONE) & +!$OMP PRIVATE(l,n,j,i) & +!$OMP SHARED(tdims,ei_land,snowmelt,nsurft,land_pts,melt_ice_surft) + +!$OMP DO SCHEDULE(STATIC) +DO j = tdims%j_start,tdims%j_end + DO i = tdims%i_start,tdims%i_end + ei_land(i,j) = 0.0 + snowmelt(i,j) = 0.0 + END DO +END DO +!$OMP END DO NOWAIT + +! Lake initialisation +DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + melt_ice_surft(l,n) = 0.0 + END DO +!$OMP END DO NOWAIT +END DO + +!$OMP END PARALLEL + +!CABLE_LSM: +DO n = 1,nsurft +!CM2! CALL sf_melt ( & +!CM2! land_pts,land_index, & +!CM2! surft_index(:,n),surft_pts(n),flandg, & +!CM2! alpha1(:,n),ashtf_prime_surft(:,n),dtrdz_charney_grid_1, & +!CM2! resft(:,n),rhokh_surft(:,n),tile_frac(:,n),timestep,r_gamma, & +!CM2! ei_surft(:,n),fqw_1,ftl_1,fqw_surft(:,n),ftl_surft(:,n), & +!CM2! tstar_surft(:,n),snow_surft(:,n),snowdep_surft(:,n), & +!CM2! melt_surft(:,n) & +!CM2! ) +!CM2! +!CM2! !----------------------------------------------------------------------- +!CM2! ! thermodynamic, flux contribution of melting ice on the FLake lake tile +!CM2! !----------------------------------------------------------------------- +!CM2! IF ( (l_flake_model ) & +!CM2! .AND. ( .NOT. l_aggregate) & +!CM2! .AND. (n == lake ) ) THEN +!CM2! +!CM2! ! lake_h_ice_gb is only initialised if FLake is on. +!CM2! +!CM2!!$OMP PARALLEL DO & +!CM2!!$OMP SCHEDULE(STATIC) & +!CM2!!$OMP DEFAULT(NONE) & +!CM2!!$OMP PRIVATE(l) & +!CM2!!$OMP SHARED(land_pts,lake_ice_mass,lake_h_ice_gb) +!CM2! DO l = 1, land_pts +!CM2! lake_ice_mass(l) = lake_h_ice_gb(l) * rho_ice +!CM2! END DO +!CM2!!$OMP END PARALLEL DO +!CM2! +!CM2! CALL sf_melt ( & +!CM2! land_pts,land_index, & +!CM2! surft_index(:,n),surft_pts(n),flandg, & +!CM2! alpha1(:,n),ashtf_prime_surft(:,n),dtrdz_charney_grid_1, & +!CM2! resft(:,n),rhokh_surft(:,n),tile_frac(:,n),timestep,r_gamma, & +!CM2! ei_surft(:,n),fqw_1,ftl_1,fqw_surft(:,n),ftl_surft(:,n), & +!CM2! tstar_surft(:,n),lake_ice_mass,lake_ice_mass / rho_snow_const, & +!CM2! melt_ice_surft(:,n) & +!CM2! ) +!CM2! END IF + + !----------------------------------------------------------------------- + ! Increment snow by sublimation and melt + !----------------------------------------------------------------------- + +!$OMP PARALLEL DO & +!$OMP SCHEDULE(STATIC) & +!$OMP DEFAULT(NONE) & +!$OMP PRIVATE(k,l,j,i) & +!$OMP SHARED(surft_pts,surft_index,land_index,t_i_length,ei_land,tile_frac, & +!$OMP ei_surft,snowmelt,melt_surft,n) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + ei_land(i,j) = ei_land(i,j) + tile_frac(l,n) * ei_surft(l,n) + snowmelt(i,j) = snowmelt(i,j) + & + tile_frac(l,n) * melt_surft(l,n) + END DO +!$OMP END PARALLEL DO + +END DO + +!$OMP PARALLEL & +!$OMP DEFAULT(SHARED) & +!$OMP PRIVATE(l,n,j,i,k) + +IF (sf_diag%smlt) THEN +!$OMP DO SCHEDULE(STATIC) + DO j = tdims%j_start,tdims%j_end + DO i = tdims%i_start,tdims%i_end + sf_diag%snomlt_surf_htf(i,j) = lf * snowmelt(i,j) + END DO + END DO +!$OMP END DO NOWAIT +END IF + +!$OMP DO SCHEDULE(STATIC) +DO j = tdims%j_start,tdims%j_end + DO i = tdims%i_start,tdims%i_end + surf_ht_flux_land(i,j) = 0.0 + END DO +END DO +!$OMP END DO NOWAIT + +!CM3#56 - remove FLAKE model +!IF ( (l_flake_model ) & +! .AND. ( .NOT. l_aggregate) ) THEN +!!$OMP DO SCHEDULE(STATIC) +! DO j = tdims%j_start,tdims%j_end +! DO i = tdims%i_start,tdims%i_end +! surf_ht_flux_lake_ij(i,j) = 0.0 +! END DO +! END DO +!!$OMP END DO NOWAIT +!END IF + +!$OMP DO SCHEDULE(STATIC) +DO l = 1,land_pts + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + tstar_land(i,j) = 0.0 +END DO +!$OMP END DO NOWAIT + +!CABLE_LSM: +! initialise diagnostics to 0 to avoid packing problems +IF (sf_diag%l_lw_surft) THEN + DO n = 1, nsurft +!$OMP DO SCHEDULE(STATIC) + DO l = 1, land_pts + sf_diag%lw_up_surft(l,n) = 0.0 + sf_diag%lw_down_surft(l,n) = 0.0 + END DO +!$OMP END DO NOWAIT + END DO +END IF + +!$OMP BARRIER + +!CM3#56 - remove option for skyview +!IF (l_skyview) THEN +!CABLE_LSM: +!CM2! DO n = 1,nsurft +!CM2!!$OMP DO SCHEDULE(STATIC) +!CM2! DO k = 1,surft_pts(n) +!CM2! l = surft_index(k,n) +!CM2! j=(land_index(l) - 1) / tdims%i_end + 1 +!CM2! i = land_index(l) - (j-1) * tdims%i_end +!CM2! radnet_surft(l,n) = sw_surft(l,n) + emis_surft(l,n) * & +!CM2! sky(i,j) * ( lw_down(i,j) + lw_down_elevcorr_surft(l,n) & +!CM2! - sbcon * tstar_surft(l,n)**4 ) +!CM2! END DO +!CM2!!$OMP END DO +!CM2! END DO +! IF (sf_diag%l_lw_surft) THEN +! DO n = 1,nsurft +!!$OMP DO SCHEDULE(STATIC) +! DO k = 1,surft_pts(n) +! l = surft_index(k,n) +! j=(land_index(l) - 1) / tdims%i_end + 1 +! i = land_index(l) - (j-1) * tdims%i_end +! sf_diag%lw_up_surft(l,n) = emis_surft(l,n) * sky(i,j) * & +! sbcon * tstar_surft(l,n)**4 & +! + (1.0 - emis_surft(l,n)) * & +! sky(i,j) * (lw_down(i,j) + & +! lw_down_elevcorr_surft(l,n)) +! sf_diag%lw_down_surft(l,n) = sky(i,j) * (lw_down(i,j) + & +! lw_down_elevcorr_surft(l,n)) +! END DO +!!$OMP END DO +! END DO +! END IF +!ELSE +!CABLE_LSM: +!! DO n = 1,nsurft +!!!$OMP DO SCHEDULE(STATIC) +!! DO k = 1,surft_pts(n) +!! l = surft_index(k,n) +!! j=(land_index(l) - 1) / tdims%i_end + 1 +!! i = land_index(l) - (j-1) * tdims%i_end +!! radnet_surft(l,n) = sw_surft(l,n) + emis_surft(l,n) * & +!! ( lw_down(i,j) + lw_down_elevcorr_surft(l,n) & +!! - sbcon * tstar_surft(l,n)**4 ) +!! END DO +!!!$OMP END DO +!! END DO + IF (sf_diag%l_lw_surft) THEN + DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / tdims%i_end + 1 + i = land_index(l) - (j-1) * tdims%i_end + sf_diag%lw_up_surft(l,n) = emis_surft(l,n) * sbcon * & + tstar_surft(l,n)**4 & + + (1.0 - emis_surft(l,n)) * & + (lw_down(i,j) + & + lw_down_elevcorr_surft(l,n)) + sf_diag%lw_down_surft(l,n) = lw_down(i,j) + & + lw_down_elevcorr_surft(l,n) + END DO +!$OMP END DO + END DO + END IF +!END IF !CM3#56 + +!CM3#56 - remove surf_ht_store_surft and look to fill inside CABLE if needed +! - remove FLAKE code +! - remove evaluation of any tiled flux and look to fill from CABLE +DO n = 1,nsurft +!$OMP DO SCHEDULE(STATIC) + DO k = 1,surft_pts(n) + l = surft_index(k,n) + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + !canhc_surf(l) = canhc_surft(l,n) + !IF ( ( .NOT. cansnowtile(n)) .AND. l_snow_nocan_hc .AND. & + ! (nsmax > 0) .AND. (nsnow_surft(l,n) > 0) ) canhc_surf(l) = 0.0 + + !CM3#56 - set to zero for now - should be coming from CABLE anyway + surf_ht_store_surft(l,n) = 0.0 +! surf_ht_store_surft(l,n) = (canhc_surf(l) / timestep) * & +! (tstar_surft(l,n) - tstar_surft_old(l,n)) +!!!CABLE_LSM: Replaced with CABLE field +!! surf_htf_surft(l,n) = radnet_surft(l,n) + anthrop_heat_surft(l,n) - & +!! ftl_surft(l,n) - & +!! le_surft(l,n) - & +!! lf * (melt_surft(l,n) + melt_ice_surft(l,n)) - & +!! surf_ht_store_surft(l,n) + ! separate out the lake heat flux for FLake + ! and replace the snow-melt (NSMAX=0 only) and ice-melt heat fluxes + ! so Flake can do its melting + !IF ( (l_flake_model ) & + ! .AND. ( .NOT. l_aggregate) & + ! .AND. (n == lake ) ) THEN + ! IF (nsmax == 0) THEN + ! surf_ht_flux_lake_ij(i,j) = surf_htf_surft(l,n) & + ! + lf * (melt_surft(l,n) + melt_ice_surft(l,n)) + ! ELSE + ! surf_ht_flux_lake_ij(i,j) = surf_htf_surft(l,n) & + ! + lf * melt_ice_surft(l,n) + ! END IF + !ELSE + surf_ht_flux_land(i,j) = surf_ht_flux_land(i,j) & + + tile_frac(l,n) * surf_htf_surft(l,n) + !END IF + tstar_land(i,j) = tstar_land(i,j) & + + tile_frac(l,n) * tstar_surft(l,n) + END DO +!$OMP END DO +END DO + + ! normalise the non-lake surface heat flux +!CABLE_LSM: +!CM2!IF ( l_flake_model .AND. ( .NOT. l_aggregate) ) THEN +!CM2!!$OMP DO SCHEDULE(STATIC) +!CM2! DO l = 1,land_pts +!CM2! j=(land_index(l) - 1) / t_i_length + 1 +!CM2! i = land_index(l) - (j-1) * t_i_length +!CM2! ! be careful about gridboxes that are all lake +!CM2! IF (non_lake_frac(l) > EPSILON(0.0)) THEN +!CM2! surf_ht_flux_land(i,j) = surf_ht_flux_land(i,j) / non_lake_frac(l) +!CM2! END IF +!CM2! END DO +!CM2!!$OMP END DO +!CM2!END IF + +IF (sf_diag%l_lh_land) THEN +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + sf_diag%lh_land(l) = SUM((tile_frac(l,:) * le_surft(l,:))) + END DO +!$OMP END DO +END IF + +!----------------------------------------------------------------------- +! Optional error check : test for negative surface temperature +!----------------------------------------------------------------------- +!CM3#56 revise to refer to CABLE not JULES +IF (l_neg_tstar) THEN +!$OMP DO SCHEDULE(STATIC) + DO l = 1,land_pts + j=(land_index(l) - 1) / t_i_length + 1 + i = land_index(l) - (j-1) * t_i_length + IF (tstar_land(i,j) < 0) THEN + ERROR = 1 + WRITE(jules_message,*) & + '*** ERROR DETECTED BY ROUTINE CABLE_LAND_SF_IMPLICIT ***' + CALL jules_print('cable_land_sf_implicit_cbl',jules_message) + WRITE(jules_message,*) 'NEGATIVE SURFACE TEMPERATURE AT LAND POINT ',l + CALL jules_print('cable_land_sf_implicit_cbl',jules_message) + END IF + END DO +!$OMP END DO +END IF + +!$OMP END PARALLEL + + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE cable_land_sf_implicit +END MODULE cable_land_sf_implicit_mod diff --git a/src/coupled/AM3/control/cable/cable_land/implicit/poop_diff b/src/coupled/AM3/control/cable/cable_land/implicit/poop_diff new file mode 100644 index 000000000..f54dbcc2e --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/implicit/poop_diff @@ -0,0 +1,29 @@ +--- cable_land_sf_implicit_cbl.F90.revised 2024-01-08 22:42:11.000000000 +1100 ++++ cable_land_sf_implicit_cbl.F90 2024-01-08 22:54:16.000000000 +1100 +@@ -357,7 +357,7 @@ + ! lake_mod (IN) + REAL(KIND=real_jlslsm), INTENT(IN) :: lake_h_ice_gb(land_pts) + ! lake_mod (OUT) +-REAL(KIND=real_jlslsm) :: surf_ht_flux_lake_ij(t_i_length,t_j_length) ++REAL(KIND=real_jlslsm), INTENT(OUT) :: surf_ht_flux_lake_ij(t_i_length,t_j_length) + ! fluxes (IN) + REAL(KIND=real_jlslsm), INTENT(IN) :: anthrop_heat_surft(land_pts,nsurft) + ! fluxes (OUT) +@@ -477,7 +477,7 @@ + ! - at some point we will need to sort out the CASA variables + call cable_implicit_main( tdims%i_end, tdims%j_end, land_pts, nsurft, npft, & + sm_levels, dim_cs1, cycleno, numcycles, & +- timestep, timestep_number, land_index, & ++ REAL(timestep), timestep_number, land_index, & + surft_pts, surft_index, & + Fland, tile_frac, smvcst, & + ls_rain, ls_snow, con_rain, con_snow, & +@@ -581,7 +581,7 @@ + L = surft_INDEX(K,N) + j=(land_index(l)-1)/tdims%i_end + 1 + i = land_index(l) - (j-1)*tdims%i_end +- ecan(i,j) = ecan(i,j) + tile_frac(l,n)*ecan_surft(l,n) ++ ECAN(I,J) = ECAN(I,J) + TILE_FRAC(L,N)*ECAN_surft(L,N) + esoil_soilt(i,j,1) = esoil_soilt(i,j,1) + tile_frac(l,n)*esoil_surft(l,n) + ENDDO + ENDDO diff --git a/src/coupled/AM3/control/cable/cable_land/radiation/alloc_rad_albedo_vars_cbl.F90 b/src/coupled/AM3/control/cable/cable_land/radiation/alloc_rad_albedo_vars_cbl.F90 new file mode 100644 index 000000000..7c30b5c02 --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/radiation/alloc_rad_albedo_vars_cbl.F90 @@ -0,0 +1,267 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE alloc_rad_albedo_vars_mod + +!----------------------------------------------------------------------------- +! Description: +! Allocate and deallocate variables in the rad structure +! +! This MODULE is USEd in: +! cable_land_albedo_mod_cbl.F90 (JULES) +! +! This MODULE contains 2 public Subroutine: +! alloc_local_vars, +! flush_local_vars +! +! Code owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE +PUBLIC :: alloc_local_vars +PUBLIC :: flush_local_vars +PRIVATE + +CONTAINS + +! Allocate vars in mp format +SUBROUTINE alloc_local_vars( EffSurfRefl_beam, EffSurfRefl_dif, mp, nrb, & + reducedLAIdue2snow, HeightAboveSnow, coszen, & + ExtCoeff_beam, ExtCoeff_dif, EffExtCoeff_beam, & + EffExtCoeff_dif, CanopyTransmit_beam, & + CanopyTransmit_dif, CanopyRefl_beam, & + CanopyRefl_dif, RadFbeam, RadAlbedo, AlbSnow, c1, & + rhoch, xk, metDoY, SnowDepth, SnowDensity, & + SoilTemp, SnowAge, SW_down, veg_mask ) + +! Description: +! Allocate variables in the rad structure + +IMPLICIT NONE + +INTEGER :: mp, nrb +REAL, INTENT(OUT), ALLOCATABLE :: EffSurfRefl_dif(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: EffSurfRefl_beam(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: SnowDepth(:) +REAL, INTENT(OUT), ALLOCATABLE :: SnowDensity(:) +REAL, INTENT(OUT), ALLOCATABLE :: SoilTemp(:) +REAL, INTENT(OUT), ALLOCATABLE :: SnowAge( :) +REAL, INTENT(OUT), ALLOCATABLE :: reducedLAIdue2snow(:) ! Eff. LAI given snow +REAL, INTENT(OUT), ALLOCATABLE :: HeightAboveSnow(:) ! Canopy hgt above snow +REAL, INTENT(OUT), ALLOCATABLE :: coszen(:) +REAL, INTENT(OUT), ALLOCATABLE :: ExtCoeff_beam(:) +REAL, INTENT(OUT), ALLOCATABLE :: ExtCoeff_dif(:) +REAL, INTENT(OUT), ALLOCATABLE :: EffExtCoeff_beam(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: EffExtCoeff_dif(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: CanopyTransmit_dif(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: CanopyTransmit_beam(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: CanopyRefl_dif(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: CanopyRefl_beam(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: AlbSnow(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: c1(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: rhoch(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: xk(:,:) +! these are dummies in JULES rad call but req'd to load arg lists +REAL, INTENT(OUT), ALLOCATABLE :: SW_down(:,:) ! dummy +REAL, INTENT(OUT), ALLOCATABLE :: RadFbeam(:,:) +REAL, INTENT(OUT), ALLOCATABLE :: RadAlbedo(:,:) +INTEGER, INTENT(OUT), ALLOCATABLE :: metDoY(:) ! can pass DoY from current_time +! vegetated mask required on albedo pathway +LOGICAL, INTENT(OUT), ALLOCATABLE :: veg_mask(:) + +IF ( .NOT. ALLOCATED(reducedLAIdue2snow) ) THEN + ALLOCATE( reducedLAIdue2snow(mp) ) +END IF +IF ( .NOT. ALLOCATED(HeightAboveSnow) ) THEN + ALLOCATE( HeightAboveSnow(mp) ) +END IF +IF ( .NOT. ALLOCATED(coszen) ) THEN + ALLOCATE( coszen(mp) ) +END IF +IF ( .NOT. ALLOCATED(EffSurfRefl_dif) ) THEN + ALLOCATE( EffSurfRefl_dif(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(EffSurfRefl_beam) ) THEN + ALLOCATE( EffSurfRefl_beam(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(SnowDepth) ) THEN + ALLOCATE( SnowDepth(mp) ) +END IF +IF ( .NOT. ALLOCATED(SnowDensity) ) THEN + ALLOCATE( SnowDensity(mp) ) +END IF +IF ( .NOT. ALLOCATED(SoilTemp) ) THEN + ALLOCATE( SoilTemp(mp) ) +END IF +IF ( .NOT. ALLOCATED(SnowAge) ) THEN + ALLOCATE( SnowAge(mp) ) +END IF +IF ( .NOT. ALLOCATED(ExtCoeff_beam) ) THEN + ALLOCATE( ExtCoeff_beam(mp) ) +END IF +IF ( .NOT. ALLOCATED(ExtCoeff_dif) ) THEN + ALLOCATE( ExtCoeff_dif(mp) ) +END IF +IF ( .NOT. ALLOCATED(EffExtCoeff_beam) ) THEN + ALLOCATE( EffExtCoeff_beam(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(EffExtCoeff_dif) ) THEN + ALLOCATE( EffExtCoeff_dif(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(CanopyTransmit_dif) ) THEN + ALLOCATE( CanopyTransmit_dif(mp, nrb)) +END IF +IF ( .NOT. ALLOCATED(CanopyTransmit_beam) ) THEN + ALLOCATE( CanopyTransmit_beam(mp,nrb) ) +END IF +IF ( .NOT. ALLOCATED(CanopyRefl_dif) ) THEN + ALLOCATE( CanopyRefl_dif(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(CanopyRefl_beam) ) THEN + ALLOCATE( CanopyRefl_beam(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(AlbSnow) ) THEN + ALLOCATE( AlbSnow(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(c1) ) THEN + ALLOCATE( c1(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(rhoch) ) THEN + ALLOCATE( rhoch(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(xk) ) THEN + ALLOCATE( xk(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(metDoY) ) THEN + ALLOCATE( metDoY(mp) ) +END IF +IF ( .NOT. ALLOCATED(SW_down) ) THEN + ALLOCATE( SW_down(mp,nrb) ) +END IF +IF ( .NOT. ALLOCATED(RadFbeam) ) THEN + ALLOCATE( RadFbeam(mp, nrb) ) +END IF +IF ( .NOT. ALLOCATED(RadAlbedo) ) THEN + ALLOCATE( RadAlbedo(mp, nrb) ) +END IF +IF (.NOT. ALLOCATED(veg_mask) ) THEN + ALLOCATE( veg_mask(mp) ) +END IF + +EffSurfRefl_dif(:,:) = 0.0 +EffSurfRefl_beam(:,:) = 0.0 +SnowDepth = 0.0 +SnowDensity = 0.0 +SoilTemp = 0.0 +SnowAge = 0.0 +coszen(:) = 0.0 +reducedLAIdue2snow(:) = 0.0 +HeightAboveSnow(:) = 0.0 +ExtCoeff_beam(:) = 0.0 +ExtCoeff_dif(:) = 0.0 +EffExtCoeff_beam(:,:) = 0.0 +EffExtCoeff_dif(:,:) = 0.0 +CanopyTransmit_dif(:,:) = 0.0 +CanopyTransmit_beam(:,:) = 0.0 +CanopyRefl_dif(:,:) = 0.0 +CanopyRefl_beam(:,:) = 0.0 +AlbSnow(:,:) = 0.0 +rhoch(:,:) = 0.0 +xk(:,:) = 0.0 +c1(:,:) = 0.0 +RadFbeam(:,:) = 0.0 +RadAlbedo(:,:) = 0.0 +SW_down(:,:) = 0.0 +metDoY(:) = 0 !can pass DoY from current_time% +veg_mask(:) = .FALSE. + +RETURN + +END SUBROUTINE alloc_local_vars + +!flush memory +SUBROUTINE flush_local_vars( EffSurfRefl_beam, EffSurfRefl_dif, SnowDepth, & + SnowDensity, SoilTemp, SnowAge, & + reducedLAIdue2snow, HeightAboveSnow, coszen, & + ExtCoeff_beam, ExtCoeff_dif, EffExtCoeff_beam, & + EffExtCoeff_dif, CanopyTransmit_beam, & + CanopyTransmit_dif, CanopyRefl_beam, & + CanopyRefl_dif, RadFbeam, RadAlbedo, AlbSnow, c1, & + rhoch, xk, metDoY, SW_down, veg_mask ) + +! Description: +! Deallocate variables in the rad structure + +IMPLICIT NONE + +REAL, INTENT(IN OUT), ALLOCATABLE :: EffSurfRefl_dif(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: EffSurfRefl_beam(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: SnowDepth(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: SnowDensity(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: SoilTemp(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: SnowAge( :) +REAL, INTENT(IN OUT), ALLOCATABLE :: reducedLAIdue2snow(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: HeightAboveSnow(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: coszen(:) +!these local to CABLE and can be flushed every timestep +REAL, INTENT(IN OUT), ALLOCATABLE :: ExtCoeff_beam(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: ExtCoeff_dif(:) +REAL, INTENT(IN OUT), ALLOCATABLE :: EffExtCoeff_beam(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: EffExtCoeff_dif(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: CanopyTransmit_dif(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: CanopyTransmit_beam(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: CanopyRefl_dif(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: CanopyRefl_beam(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: RadFbeam(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: RadAlbedo(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: AlbSnow(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: c1(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: rhoch(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: xk(:,:) +REAL, INTENT(IN OUT), ALLOCATABLE :: SW_down(:,:) ! dummy +LOGICAL, INTENT(IN OUT), ALLOCATABLE :: veg_mask(:) +INTEGER, INTENT(IN OUT), ALLOCATABLE :: metDoY(:) ! pass DoY from current_time + +IF ( ALLOCATED(EffSurfRefl_dif) ) DEALLOCATE ( EffSurfRefl_dif ) +IF ( ALLOCATED(EffSurfRefl_beam) ) DEALLOCATE ( EffSurfRefl_beam ) +IF ( ALLOCATED(SnowDepth) ) DEALLOCATE( SnowDepth ) +IF ( ALLOCATED(SnowDensity) ) DEALLOCATE( SnowDensity ) +IF ( ALLOCATED(SoilTemp) ) DEALLOCATE( SoilTemp ) +IF ( ALLOCATED(SnowAge) ) DEALLOCATE( SnowAge ) +IF ( ALLOCATED(reducedLAIdue2snow) ) DEALLOCATE( reducedLAIdue2snow ) +IF ( ALLOCATED(HeightAboveSnow) ) DEALLOCATE( HeightAboveSnow ) +IF ( ALLOCATED(coszen) ) DEALLOCATE( coszen ) +IF ( ALLOCATED (ExtCoeff_beam) ) DEALLOCATE (ExtCoeff_beam ) +IF ( ALLOCATED (ExtCoeff_dif) ) DEALLOCATE (ExtCoeff_dif ) +IF ( ALLOCATED (EffExtCoeff_beam) ) DEALLOCATE (EffExtCoeff_beam ) +IF ( ALLOCATED (EffExtCoeff_dif) ) DEALLOCATE (EffExtCoeff_dif ) +IF ( ALLOCATED (CanopyTransmit_dif) ) DEALLOCATE (CanopyTransmit_dif ) +IF ( ALLOCATED (CanopyTransmit_beam)) DEALLOCATE (CanopyTransmit_beam ) +IF ( ALLOCATED (CanopyRefl_dif) ) DEALLOCATE (CanopyRefl_dif ) +IF ( ALLOCATED (CanopyRefl_beam) ) DEALLOCATE (CanopyRefl_beam ) +IF ( ALLOCATED (RadFbeam) ) DEALLOCATE (RadFbeam ) +IF ( ALLOCATED (RadAlbedo) ) DEALLOCATE (RadAlbedo ) +IF ( ALLOCATED (AlbSnow) ) DEALLOCATE (AlbSnow ) +IF ( ALLOCATED (c1) ) DEALLOCATE (c1 ) +IF ( ALLOCATED (rhoch) ) DEALLOCATE (rhoch ) +IF ( ALLOCATED (xk) ) DEALLOCATE (xk ) +IF ( ALLOCATED (SW_down) ) DEALLOCATE (SW_down ) +IF ( ALLOCATED (MetDoY) ) DEALLOCATE (MetDoY ) +IF ( ALLOCATED (veg_mask) ) DEALLOCATE (veg_mask) + +RETURN +END SUBROUTINE flush_local_vars + +END MODULE alloc_rad_albedo_vars_mod diff --git a/src/coupled/AM3/control/cable/cable_land/radiation/cable_land_albedo_mod_cbl.F90 b/src/coupled/AM3/control/cable/cable_land/radiation/cable_land_albedo_mod_cbl.F90 new file mode 100644 index 000000000..b4ef968e8 --- /dev/null +++ b/src/coupled/AM3/control/cable/cable_land/radiation/cable_land_albedo_mod_cbl.F90 @@ -0,0 +1,386 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE cable_land_albedo_mod + +!----------------------------------------------------------------------------- +! Description: +! Computes the albedo for CABLE and returns it to JULES +! +! This MODULE is USEd in: +! surf_couple_radiation_mod.F90 (JULES) +! +! This MODULE contains 1 public Subroutine: +! cable_land_albedo +! Other Subroutines: +! cable_pack_Albsoil, +! cable_pack_progs +! +! Code owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE +PUBLIC :: cable_land_albedo +PRIVATE + +CONTAINS + +SUBROUTINE cable_land_albedo ( & + !OUT: JULES (per rad band) albedos [GridBoxMean & per tile albedo] + land_albedo , alb_surft, & + !IN: JULES dimensions and associated + row_length, rows, land_pts, nsurft, npft, & + surft_pts, surft_index, land_index, & + !IN: JULES Surface descriptions generally parametrized + tile_frac, LAI_pft_um, HGT_pft_um, soil_alb, & + !IN: JULES timestep varying fields + cosine_zenith_angle, snow_tile, & + !IN:CABLE dimensions from grid_constants_cbl + nrb, nrs, mp, & + !IN: CABLE specific surface_type indexes + ICE_Surfacetype, lakes_SurfaceType, ICE_SoilType, & + !IN: CABLE constants + Cz0surf_min, Clai_thresh, Ccoszen_tols, Cgauss_w, Cpi, Cpi180, & + !IN: CABLE prognostics. decl in progs_cbl_vars_mod.F90 + SoilTemp_CABLE, OneLyrSnowDensity_CABLE, SnowAge_CABLE, work, pars & +) +!------------------------------------------------------------------------------- +! Description: +! Provide (return) albedo(s) to JULES [land_albedo , alb_surft] +! per rad stream (VIS/NIR, Direct&Diffuse) [GridBoxMean & per tile albedo] +! Three main sections: +! 1. Pack CABLE variables from those passed from surf_couple_radiation() +! 2. Call CABLE's radiation/albedo scheme +! 3. Unpack albedos to send back to JULES +!------------------------------------------------------------------------------- + +! USE subroutines +! Route into CABLE & UNPACKING what we have computed for JULES +USE cable_rad_driv_mod, ONLY: cable_rad_driver +USE cable_rad_unpack_mod, ONLY: cable_rad_unpack + +! PACKING from JULES array dims to CABLE active tile 1-D vector +USE init_active_tile_mask_mod, ONLY: init_active_tile_mask_cbl +USE cable_pack_mod, ONLY: cable_pack_rr + +! Define CABLE grid, sunlit/veg masks & initialize surface type params +USE map_cable_parms_mod, ONLY: map_cable_parms +USE alloc_rad_albedo_vars_mod, ONLY: alloc_local_vars, flush_local_vars +USE cbl_masks_mod, ONLY: fveg_mask + +!Compute canopy exposed above (potential) snow +USE cbl_LAI_canopy_height_mod, ONLY: limit_HGT_LAI +USE hruff_eff_LAI_mod_cbl, ONLY: HgtAboveSnow, LAI_eff + +USE work_vars_mod_cbl, ONLY: work_vars_type ! and some kept thru timestep + +USE jules_soil_mod, ONLY: dzsoil +USE grid_constants_mod_cbl, ONLY: nsl +USE params_io_mod_cbl, ONLY: params_io_data_type + +IMPLICIT NONE +! re-decl dims necessary to declare OUT fields +!-- IN: JULES model dimensions +INTEGER, INTENT(IN) :: row_length, rows !# grid cell x, y +INTEGER, INTENT(IN) :: nsurft !# surface types, PFTS +INTEGER, INTENT(IN) :: land_pts !# land points on x,y grid +!--- IN: CABLE declared in grid_cell_constants_cbl +INTEGER, INTENT(IN) :: nrs !# rad streams + !(:,:,1) direct beam VIS + !(:,:,2) diffuse visible + !(:,:,3) direct beam NIR + !(:,:,4) diffuse NIR +!--- OUT: JULES (per rad band) albedos [GridBoxMean & per tile albedo] +REAL, INTENT(OUT) :: land_albedo(row_length,rows,nrs) ! [land_albedo_ij] +REAL, INTENT(OUT) :: alb_surft(Land_pts,nsurft,nrs) ! [alb_tile] + +!-- IN: JULES model dimensions +INTEGER, INTENT(IN) :: npft !# surface types, PFTS + +!---IN: JULES model associated +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per PFT +INTEGER, INTENT(IN) :: surft_index(land_pts,nsurft) ! Index in land_pts array +INTEGER, INTENT(IN) :: land_index(land_pts) ! Index in (x,y) array + +!-- IN: JULES Surface descriptions generally parametrized +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) ! fraction of each surf type +REAL, INTENT(IN) :: LAI_pft_um(land_pts, npft) ! Leaf area index. +REAL, INTENT(IN) :: HGT_pft_um(land_pts, npft) ! Canopy height +REAL, INTENT(IN) :: soil_alb(land_pts) ! Snow-free, soil albedo + +!---IN: JULES timestep varying fields +REAL, INTENT(IN) :: cosine_zenith_angle(row_length,rows) ! zenith angle of sun +REAL, INTENT(IN) :: snow_tile(land_pts,nsurft) ! snow depth (units?) + +!--- IN: CABLE declared in grid_cell_constants_cbl +INTEGER, INTENT(IN) :: nrb !# rad bands VIS/NIR + Legacy LW +INTEGER, INTENT(OUT) :: mp ! curr. NOT requ'd OUT, however it likely will + +!--- IN: CABLE specific Surface/Soil type indexes +INTEGER, INTENT(IN) :: ICE_SurfaceType +INTEGER, INTENT(IN) :: lakes_SurfaceType +INTEGER, INTENT(IN) :: ICE_SoilType + +!---IN: CABLE constants +REAL, INTENT(IN) :: Cz0surf_min ! the minimum roughness of bare soil +REAL, INTENT(IN) :: Clai_thresh ! min. LAI signalling a cell is vegetated +REAL, INTENT(IN) :: Cgauss_w(nrb) ! Gaussian integration weights +REAL, INTENT(IN) :: Cpi ! PI +REAL, INTENT(IN) :: Cpi180 ! PI in radians +REAL, INTENT(IN) :: Ccoszen_tols ! sun rise/set threshold for zenith angle + ! signals daylit + +!---IN: CABLE prognostics. decl in progs_cbl_vars_mod.F90 +REAL, INTENT(IN) :: SoilTemp_CABLE(land_pts, nsurft ) +REAL, INTENT(IN) :: OneLyrSnowDensity_CABLE(land_pts, nsurft ) +REAL, INTENT(IN) :: SnowAge_CABLE(land_pts, nsurft ) + +TYPE(work_vars_type), INTENT(IN OUT) :: work +TYPE(params_io_data_type), INTENT(IN) :: pars + + +!--- local vars - Neither IN nor OUT (passed to subrs) + +LOGICAL, ALLOCATABLE :: L_tile_pts(:,:) ! TRUE where tile_frac > 0 + +! Albedos req'd by JULES - Effective Surface Relectance as seen by atmosphere +REAL, ALLOCATABLE :: EffSurfRefl_dif(:,:) +REAL, ALLOCATABLE :: EffSurfRefl_beam(:,:) + +! vegetated mask required on albedo pathway +LOGICAL, ALLOCATABLE :: veg_mask(:) + +! Formerly canopy%vlaiw, rough%hruff SAVEd after explicit call to CABLE +REAL, ALLOCATABLE :: reducedLAIdue2snow(:) ! Eff. LAI IF snow [canopy%vlaiw] +REAL, ALLOCATABLE :: HeightAboveSnow(:) ! Canopy Hgt above snow (rough%hruff) + +! arrays to map IN progs to CABLE vector length +REAL, ALLOCATABLE :: SnowDepth(:) ! Total Snow depth - water eqivalent - + ! ssnow%snowd +REAL, ALLOCATABLE :: SnowDensity(:) ! Total Snow density (assumes 1 layer +REAL, ALLOCATABLE :: SoilTemp(:) ! Soil Temperature of top layer (soil%tgg) +REAL, ALLOCATABLE :: SnowAge(:) ! Snow age (assumes 1 layer describes snow + ! ssnow%isflag + +REAL, ALLOCATABLE :: coszen(:) + +REAL, ALLOCATABLE :: ExtCoeff_beam(:) +REAL, ALLOCATABLE :: ExtCoeff_dif(:) +REAL, ALLOCATABLE :: EffExtCoeff_beam(:,:) +REAL, ALLOCATABLE :: EffExtCoeff_dif(:,:) +REAL, ALLOCATABLE :: CanopyTransmit_dif(:,:) +REAL, ALLOCATABLE :: CanopyTransmit_beam(:,:) +REAL, ALLOCATABLE :: CanopyRefl_dif(:,:) +REAL, ALLOCATABLE :: CanopyRefl_beam(:,:) +REAL, ALLOCATABLE :: RadFbeam(:,:) +REAL, ALLOCATABLE :: RadAlbedo(:,:) +REAL, ALLOCATABLE :: AlbSnow(:,:) +REAL, ALLOCATABLE :: c1(:,:) +REAL, ALLOCATABLE :: rhoch(:,:) +REAL, ALLOCATABLE :: xk(:,:) +! used in Calc of Beam calculation NOT on rad/albedo path. +! However Needed to fulfill arg list with dummy +REAL, ALLOCATABLE :: SW_down(:, :) ! NA at surf_couple_rad layer +INTEGER, ALLOCATABLE :: metDoY(:) ! can pass DoY from current_time + +LOGICAL :: jls_standalone = .FALSE. +LOGICAL :: jls_radiation = .TRUE. !um_radiation = jls_radiation +LOGICAL, SAVE :: first_call = .TRUE. !only initialize params on first call + +INTEGER :: i +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_rad_main" +! End header + +! initialise INTENT(OUT) fields +land_albedo = 0.0; alb_surft = 0.0 + +! Determine the number of active tiles +mp = SUM(surft_pts) + +! Define mapping mask. i.e. l_tile_pts =TRUE (active) , where tile_frac > 0 +CALL init_active_tile_mask_cbl(l_tile_pts, land_pts, nsurft, tile_frac ) + +! alloc/zero each timestep +! metDoY, SW_down, RadFbeaam, RadAlbedo NOT used on rad/albedo path. +! Nevertheless, need to fulfill later arg list(s) with dumies +CALL alloc_local_vars( EffSurfRefl_beam, EffSurfRefl_dif, mp, nrb, & + reducedLAIdue2snow, HeightAboveSnow, coszen, & + ExtCoeff_beam, ExtCoeff_dif, EffExtCoeff_beam, & + EffExtCoeff_dif, CanopyTransmit_beam, & + CanopyTransmit_dif, CanopyRefl_beam, CanopyRefl_dif, & + RadFbeam, RadAlbedo, AlbSnow, c1, rhoch, xk, metDoY, & + SnowDepth, SnowDensity, SoilTemp, SnowAge, & + SW_down, veg_mask ) +! ----------------------------------------------------------------------------- +! 1. PACK CABLE fields +! ----------------------------------------------------------------------------- + +! map PFT/soil parameters to mp format +IF( first_call) THEN + CALL map_cable_parms( mp, nsl, nrb, land_pts, nsurft, l_tile_pts, & + ICE_SurfaceType,ICE_SoilType, dzsoil, work%veg, & + work%soil, pars, tile_frac ) + + ! Pack UM spatial (per landpoint) bare soil albedo to mp vector for CABLE + CALL cable_pack_Albsoil( work%soil%albsoil, soil_alb, mp, nrb, l_tile_pts, & + nsurft, land_pts ) + + first_call = .FALSE. +END IF +! Pack UM spatial (per cell) zenith angle to mp vector for CABLE +CALL cable_pack_rr( coszen, cosine_zenith_angle, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +! Pack UM spatial (per landpoint,ntile) CABLE prognostics to mp vector +CALL cable_pack_progs( SnowDepth, SnowDensity, SoilTemp, SnowAge, mp, & + land_pts, nsurft, l_tile_pts, snow_tile, & + OneLyrSnowDensity_CABLE, SoilTemp_CABLE, SnowAge_CABLE ) +! ----------------------------------------------------------------------------- + +! limit IN height, LAI and initialize some existing cable % types +CALL limit_HGT_LAI( work%veg%vlai, work%veg%hc, mp, land_pts, nsurft, npft, & + surft_pts, surft_index, tile_frac, l_tile_pts, & + LAI_pft_um, HGT_pft_um, CLAI_thresh ) + +! set Height of Canopy above snow (rough%hruff) +CALL HgtAboveSnow( HeightAboveSnow, mp, Cz0surf_min, work%veg%hc, & + SnowDepth, SnowDensity ) + +! set Effective LAI considering potential snow coverage [cabopy%vlaiw] +CALL LAI_eff( mp, work%veg%vlai, work%veg%hc, HeightAboveSnow, reducedLAIdue2snow) + +! Define logical mask for vegetated mp cell +CALL fveg_mask( veg_mask, mp, Clai_thresh, reducedLAIdue2snow ) + +work%reducedLAIdue2snow(1:mp) = reducedLAIdue2snow(:) + +!------------------------------------------------------------------------------ +! 2. Call CABLE_rad_driver to run specific and necessary components of CABLE +!------------------------------------------------------------------------------ +CALL cable_rad_driver( EffSurfRefl_beam, EffSurfRefl_dif, land_pts, & + mp, nrb, ICE_SoilType, lakes_SurfaceType, Clai_thresh, & + Ccoszen_tols, CGauss_w, Cpi, Cpi180, Cz0surf_min, & + veg_mask, jls_standalone, jls_radiation, work%veg%iveg, & + work%soil%isoilm, work%veg%vlai, work%veg%hc, & + SnowDepth, SnowDensity, SoilTemp, SnowAge, & + work%soil%albsoil, coszen, work%veg%Xfang, & + work%veg%Taul, work%veg%Refl, HeightAboveSnow, & + reducedLAIdue2snow, ExtCoeff_beam, ExtCoeff_dif, & + EffExtCoeff_beam, EffExtCoeff_dif, CanopyTransmit_beam,& + CanopyTransmit_dif, CanopyRefl_beam,CanopyRefl_dif, c1, & + rhoch, xk, AlbSnow, RadFbeam, RadAlbedo, metDoY, SW_down) + +!------------------------------------------------------------------------------ +! 3. Unpack variables (CABLE computed albedos) to JULES +!------------------------------------------------------------------------------ +CALL cable_rad_unpack( land_albedo, alb_surft, mp, nrs, row_length, rows, & + land_pts, nsurft, surft_pts, surft_index, & + land_index, tile_frac, l_tile_pts, & + EffSurfRefl_beam, EffSurfRefl_dif ) + +CALL flush_local_vars( EffSurfRefl_beam, EffSurfRefl_dif,SnowDepth, & + SnowDensity, SoilTemp, SnowAge, reducedLAIdue2snow, & + HeightAboveSnow, coszen, ExtCoeff_beam, ExtCoeff_dif, & + EffExtCoeff_beam, EffExtCoeff_dif, CanopyTransmit_beam, & + CanopyTransmit_dif, CanopyRefl_beam, CanopyRefl_dif, & + RadFbeam, RadAlbedo, AlbSnow, c1, rhoch, xk, metDoY, & + SW_down, veg_mask ) + +! for completeness flick switches before leaving +jls_radiation= .FALSE. + +RETURN + +END SUBROUTINE cable_land_albedo + +!============================================================================== +SUBROUTINE cable_pack_Albsoil( AlbSoil, soil_alb, mp, nrb, l_tile_pts, & + nsurft, land_pts ) + +! Description: +! Pack spatial UM bare soil albedo to CABLE dimensions, HOWEVER limited by +! JULES typically has one soil type per cell & no distiction b//n rad bands + +IMPLICIT NONE + +REAL, INTENT(OUT) :: AlbSoil(:, :) +INTEGER, INTENT(IN) :: mp, nsurft, land_pts, nrb +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) +REAL, INTENT(IN) :: soil_alb(land_pts) +!local vars: +REAL :: fvar(land_pts, nsurft) +INTEGER :: n,l + +AlbSoil(:,:) = 0.0 ! albsoil(:,3) stays = 0.0 +fvar(:, :) = 0.0 + +DO n = 1, nsurft + DO l = 1, land_pts + fvar(l,n) = soil_alb(l) + END DO +END DO + +AlbSoil(:,1) = PACK(fvar, l_tile_pts) +AlbSoil(:,2) = AlbSoil(:,1) + +RETURN +END SUBROUTINE cable_pack_Albsoil + +SUBROUTINE cable_pack_progs( SnowDepth, SnowDensity,SoilTemp, SnowAge, & + mp, land_pts, nsurft, l_tile_pts, & + snow_tile, OneLyrSnowDensity_CABLE, & + SoilTemp_CABLE, SnowAge_CABLE ) + +! Description: +! Pack CABLE prognostics n CABLE dimensions from passed JULES vars + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: land_pts, nsurft, mp + +! map IN progs to CABLE veector length +REAL, INTENT(OUT), ALLOCATABLE :: SnowDepth(:) ! Tot Snow depth - water eqiv. +REAL, INTENT(OUT), ALLOCATABLE :: SnowDensity(:) ! Snow density-assumes 1 layer +REAL, INTENT(OUT), ALLOCATABLE :: SoilTemp(:) ! Soil Temp. of top layer +REAL, INTENT(OUT), ALLOCATABLE :: SnowAge(:) ! Snow age (assumes 1 layer) + +LOGICAL, INTENT(IN) :: l_tile_pts(land_pts, nsurft ) + +!---IN: CABLE prognostics. decl in progs_cbl_vars_mod.F90 +REAL, INTENT(IN) :: SoilTemp_CABLE(land_pts, nsurft ) +REAL, INTENT(IN) :: OneLyrSnowDensity_CABLE(land_pts, nsurft ) +REAL, INTENT(IN) :: SnowAge_CABLE(land_pts, nsurft ) +REAL, INTENT(IN) :: snow_tile(land_pts,nsurft) ! snow depth (units?) + +IF ( .NOT. ALLOCATED(SnowDepth) ) ALLOCATE( SnowDepth(mp) ) +IF ( .NOT. ALLOCATED(SnowDensity) ) ALLOCATE( SnowDensity(mp) ) +IF ( .NOT. ALLOCATED(SoilTemp) ) ALLOCATE( SoilTemp(mp) ) +IF ( .NOT. ALLOCATED(SnowAge) ) ALLOCATE( SnowAge(mp) ) + +!Store Snow Depth from previous timestep. Treat differently on 1st timestep +SnowDepth = PACK( snow_tile, l_tile_pts ) +SnowDensity = PACK( OneLyrSnowDensity_CABLE, l_tile_pts ) + +!Surface skin/top layer Soil/Snow temperature +SoilTemp = PACK( SoilTemp_CABLE(:,:), l_tile_pts ) +SnowAge = PACK( SnowAge_CABLE(:,:), l_tile_pts ) + +RETURN + +END SUBROUTINE cable_pack_progs + +END MODULE cable_land_albedo_mod + diff --git a/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_driver.F90 b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_driver.F90 new file mode 100644 index 000000000..ef2d3d401 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_driver.F90 @@ -0,0 +1,280 @@ +MODULE cable_explicit_driv_mod + +CONTAINS + +SUBROUTINE cable_explicit_driver( & + ! IN: UM/JULES/CABLE model/grid parameters, fields, mappings + mype, row_length, rows, land_pts, nsurft, npft, sm_levels, dzsoil, & + timestep, timestep_number, mp, nrb, land_index, surft_pts, surft_index, & + l_tile_pts, latitude, longitude, cos_zenith_angle, Fland, tile_frac, & + + ! IN: soil parameters !1 is only allowable index in UM + bexp, hcon, satcon, sathh, smvcst, smvcwt, smvccl, albsoil, & + + ! IN: SW forcing: manipulated for CABLE + sw_down_VIS, sw_down_NIR, beamFrac_VIS, beamFrac_NIR, beamFrac_TOT, & + + ! IN: Met forcing: + lw_down, ls_rain, ls_snow, & + tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy_tile, & + ! This an outlier IN here. INOUT @ implicit. (was)OUT at extras + ! I think we are dealing with it OK now but confusion could be removed + snow_tile, & + + ! IN: canopy height, LAI seasonally presecribed, potentially prognostic + ! IN: CO2 mass mixing ratio + canht_pft, lai_pft, CO2_MMR, & + + ! IN: carries vegin/soilin - potentially redundant + pars, & + + ! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit + progs_soiltemp, progs_soilmoisture, progs_FrozenSoilFrac, & + progs_ThreeLayerSnowFlag, progs_SnowDepth, progs_SnowMass, & + progs_SnowTemp, progs_SnowDensity, progs_snowage, progs_snowosurft, & + progs_OneLyrSnowDensity, & + + ! INOUT: CABLE TYPEs roughly grouped fields per module + rad, met, rough, canopy, veg, soil, ssnow, bal, air, bgc, sum_flux, & + + !OUT: currently being passed back to UM in veg%iveg, soil%isoilm + SurfaceType, SoilType, & + !OUT: currently being passed back to UM in veg%hc, veg%vlai + HGT_pft_cbl, LAI_pft_cbl, & + + !IN: currently being passed from prev radiation call through work% + ! jhan:quirky, snow (in turn reduced LAI due to snow) can evolve through a + ! constant rad dt. However reducedLAIdue2snow used ubiquitously as trigger + ! Further, snow does NOT evolve in explicit AND reducedLAIdue2snow absent + ! in implicit + reducedLAIdue2snow, & + + !GW + !visc_sublayer_depth, smgw_tile, slope_avg, slope_std, + !dz_gw, perm_gw, drain_gw, + !casa progs + !CPOOL_TILE, NPOOL_TILE, PPOOL_TILE, SOIL_ORDER, NIDEP, + !NIFIX, PWEA, PDUST, GLAI, PHENPHASE, + + !IN: if not passed a dangling argument would ensue + npp_pft_acc, resp_w_pft_acc ) + +! subrs called +USE cbl_um_init_mod, ONLY: init_data +USE cbl_um_update_mod, ONLY: update_data +USE cable_cbm_module, ONLY: cbm_expl + +! data +USE grid_constants_mod_cbl, ONLY: ICE_SoilType, nsl, nsnl +USE cable_phys_constants_mod, ONLY: density_liq, density_ice, tfrz +USE cable_surface_types_mod, ONLY: ICE_SurfaceType => ICE_cable + + +USE params_io_mod_cbl, ONLY: params_io_data_type +USE params_io_mod_cbl, ONLY: params_io_type + + +USE cable_def_types_mod, ONLY : climate_type +USE cable_def_types_mod, ONLY : met_type, radiation_type, veg_parameter_type, & + soil_parameter_type, roughness_type, & + canopy_type, soil_snow_type, balances_type, & + air_type, bgc_pool_type, sum_flux_type + +!--- processor number, timestep number, timestep width !ultimately get rid of these - pass %runtime through parent +USE cable_common_module, ONLY : knode_gl, ktau_gl, kwidth_gl, cable_runtime, cable_user, redistrb, satuparam,wiltparam +!block!USE casavariable +!block!USE casa_types_mod + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mype +INTEGER, INTENT(IN) :: timestep_number +REAL, INTENT(IN) :: timestep +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +INTEGER, INTENT(IN) :: sm_levels ! # soil layers +REAL, INTENT(IN) :: dzsoil(sm_levels) ! soil layer thicknesses +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nrb ! # radiation bands +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points on each tile +INTEGER, INTENT(IN) :: land_index(land_pts) ! index of land points +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! index of tile points +LOGICAL, INTENT(IN) :: l_tile_pts(land_pts, nsurft) + +REAL, INTENT(IN) :: canht_pft(land_pts, npft) +REAL, INTENT(IN) :: lai_pft(land_pts, npft) +REAL, INTENT(IN) :: fland(land_pts) + +REAL, INTENT(IN) :: co2_mmr +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) +REAL, INTENT(IN) :: cos_zenith_angle(row_length,rows) + +REAL, INTENT(IN) :: latitude(row_length,rows) +REAL, INTENT(IN) :: longitude(row_length,rows) + +REAL, INTENT(IN) :: bexp (land_pts, sm_levels) + ! => parameter b in Campbell equation +REAL, INTENT(IN) :: satcon(land_pts, sm_levels) + ! hydraulic conductivity @ saturation [mm/s] +REAL, INTENT(IN) :: sathh(land_pts, sm_levels) +REAL, INTENT(IN) :: smvcst(land_pts, sm_levels) +REAL, INTENT(IN) :: smvcwt(land_pts, sm_levels) +REAL, INTENT(IN) :: smvccl(land_pts, sm_levels) + +REAL, INTENT(IN) :: hcon(land_pts) ! Soil thermal conductivity (W/m/K). +REAL, INTENT(IN) :: albsoil(land_pts) +REAL, INTENT(IN) :: reducedLAIdue2snow(mp) + +TYPE(params_io_data_type), INTENT(IN) :: pars +TYPE(met_type), INTENT(OUT) :: met +TYPE(radiation_type), INTENT(OUT) :: rad +TYPE(roughness_type), INTENT(OUT) :: rough +TYPE(soil_snow_type), INTENT(OUT) :: ssnow +TYPE(balances_type), INTENT(OUT) :: bal +TYPE(canopy_type), INTENT(OUT) :: canopy +TYPE(air_type), INTENT(OUT) :: air +TYPE(bgc_pool_type), INTENT(OUT) :: bgc +TYPE(sum_flux_type), INTENT(OUT) :: sum_flux +TYPE(veg_parameter_type), INTENT(OUT) :: veg ! vegetation parameters +TYPE(soil_parameter_type), INTENT(OUT) :: soil ! soil parameters + +! "forcing" +REAL, INTENT(IN) :: lw_down(row_length,rows) +REAL, INTENT(IN) :: ls_rain(row_length,rows) +REAL, INTENT(IN) :: ls_snow(row_length,rows) +REAL, INTENT(IN) :: tl_1(row_length,rows) +REAL, INTENT(IN) :: qw_1(row_length,rows) +REAL, INTENT(IN) :: vshr_land(row_length,rows) +REAL, INTENT(IN) :: pstar(row_length,rows) +REAL, INTENT(IN) :: z1_tq(row_length,rows) +REAL, INTENT(IN) :: z1_uv(row_length,rows) + +REAL, INTENT(IN) :: sw_down_VIS(row_length,rows) +REAL, INTENT(IN) :: sw_down_NIR(row_length,rows) +REAL, INTENT(IN) :: beamFrac_VIS(row_length,rows) +REAL, INTENT(IN) :: beamFrac_NIR(row_length,rows) +REAL, INTENT(IN) :: beamFrac_TOT(row_length,rows) + +! prognostics +REAL, INTENT(IN) :: canopy_tile(land_pts, nsurft) +REAL, INTENT(IN) :: snow_tile(land_pts, nsurft) +REAL, INTENT(IN) :: progs_soiltemp(land_pts, nsurft, sm_levels) +REAL, INTENT(IN) :: progs_soilmoisture(land_pts, nsurft, sm_levels) +REAL, INTENT(IN) :: progs_FrozenSoilFrac(land_pts, nsurft, sm_levels) +REAL, INTENT(IN) :: progs_SnowDepth(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: progs_SnowTemp(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: progs_SnowMass(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: progs_SnowDensity(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: progs_snowosurft(land_pts, nsurft) +REAL, INTENT(IN) :: progs_OneLyrSnowDensity(land_pts, nsurft) +REAL, INTENT(IN) :: progs_snowage(land_pts, nsurft) +INTEGER, INTENT(IN) :: progs_ThreeLayerSnowFlag(land_pts, nsurft) + +INTEGER, INTENT(IN) :: SurfaceType(mp) !CABLE surface tile PFT/nveg +INTEGER, INTENT(IN) :: SoilType(mp) !CABLE soil type per tile +REAL, INTENT(OUT) :: HGT_pft_cbl(mp) +REAL, INTENT(OUT) :: LAI_pft_cbl(mp) + +!!jh:8/23 this was a problem BUT was never an issue because it is defined before it is used in soilsnow() +!!snow_cond, & +!GW progs: +!! REAL, DIMENSION(land_pts) :: & +!! slope_avg,& +!! slope_std,& +!! dz_gw,sy_gw,perm_gw,drain_gw +!!REAL :: smgw_tile(land_pts,nsurft) +!!REAL, DIMENSION(land_pts, nsurft) :: & +!! !visc_sublayer_depth +!GW progs: End + +!CASA progs: +!!REAL, DIMENSION(land_pts,nsurft,10) :: & +!! CPOOL_TILE, & ! Carbon Pools +!! NPOOL_TILE ! Nitrogen Pools + +!!REAL, DIMENSION(land_pts,nsurft,12) :: & +!! PPOOL_TILE ! Phosphorus Pools + +!!REAL, DIMENSION(land_pts) :: & +!! SOIL_ORDER, & ! Soil Order (1 to 12) +!! NIDEP, & ! Nitrogen Deposition +!! NIFIX, & ! Nitrogen Fixation +!! PWEA, & ! Phosphorus from Weathering +!! PDUST ! Phosphorus from Dust + +!! GLAI, & ! Leaf Area Index for Prognostics LAI +!! PHENPHASE, & ! Phenology Phase for Casa-CNP +REAL, INTENT(IN) :: npp_pft_acc(land_pts,npft) +REAL, INTENT(IN) :: resp_w_pft_acc(land_pts,npft) +!CASA progs: End + +!___ local vars +!jhan: this can be moved and USEd - needed to pass arg +TYPE (climate_type) :: climate ! climate variables +REAL :: rho_water, rho_ice + +LOGICAL, SAVE :: first_call = .TRUE. +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_explicit_driver" + +rho_water = density_liq +rho_ice = density_liq + +IF (cable_user%GW_model) then + rho_ice = density_ice +ENDIF + +IF(first_call) THEN + !--- fill CABLE fields from UM ancillaries/fields, CABLE prognostics + CALL init_data( row_length, rows, land_pts, nsurft, npft, sm_levels, & + nsnl, dzsoil, mp, nrb, CO2_MMR, tfrz, ICE_SurfaceType, & + ICE_SoilType, land_index, surft_pts, surft_index, tile_frac, & + L_tile_pts, albsoil, bexp, hcon, satcon, sathh, smvcst, & + smvcwt, smvccl, pars, tl_1, snow_tile, progs_soiltemp, & + progs_soilmoisture, progs_FrozenSoilFrac, & + progs_OneLyrSnowDensity, progs_snowage, & + progs_ThreeLayerSnowFlag, progs_SnowDensity, progs_SnowDepth,& + progs_SnowTemp, progs_SnowMass, rad%trad, met%tk, veg, soil, & + canopy, ssnow, bgc, sum_flux, SurfaceType, SoilType, & + npp_pft_acc,resp_w_pft_acc ) + + !CALL init_data_sci( nsl, nsnl, soil%zse, mp, tfrz, ICE_SoilType, rad%trad, & + ! met%tk, veg, soil, canopy, ssnow ) + + first_call = .FALSE. + +ENDIF + +!--- update CABLE fields from UM forcings and equivalent fields at tis timestep + +CALL update_data( row_length, rows, land_pts, nsurft, npft, sm_levels, & + nsnl, timestep, timestep_number, mp, nrb, CO2_MMR, canht_pft,& + lai_pft, land_index, surft_pts, surft_index, tile_frac, & + L_tile_pts, cos_zenith_angle, latitude, longitude, & + sw_down_VIS, sw_down_NIR, beamFrac_VIS, beamFrac_NIR, & + beamFrac_TOT, lw_down, ls_rain, ls_snow, tl_1, qw_1, & + vshr_land, pstar, z1_tq, z1_uv, canopy_tile, rad, met, & + veg, soil, rough, canopy, ssnow, HGT_pft_cbl, LAI_pft_cbl, & + reducedLAIdue2snow ) + +!CALL update_data_sci( mp, rad, met, veg, soil, canopy, ssnow, & +! canopy%vlaiw ) + +!---------------------------------------------------------------------! +!--- Feedback prognostic vcmax and daily LAI from casaCNP to CABLE ---! +!---------------------------------------------------------------------! +!block!IF(l_vcmaxFeedbk) call casa_feedback(ktau_gl,veg,casabiome,casapool,casamet) +!block!IF(l_laiFeedbk) veg%vlai(:) = casamet%glai(:) + +!---------------------------------------------------------------------! +!--- cbm "mainly" controls the calling of model components ---! +!---------------------------------------------------------------------! +CALL cbm_expl( mp, nrb, timestep_number, timestep, air, bgc, canopy, met, bal, & + rad, rough, soil, ssnow, sum_flux, veg, climate ) + +RETURN +END SUBROUTINE cable_explicit_driver + +END MODULE cable_explicit_driv_mod diff --git a/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90 b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90 new file mode 100644 index 000000000..7c57e032f --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90 @@ -0,0 +1,385 @@ +MODULE cable_explicit_main_mod + +CONTAINS + +SUBROUTINE cable_explicit_main( & + ! IN: UM/JULES model/grid parameters, fields, mappings + mype, timestep_len, timestep_number, row_length, rows, land_pts, & + nsurft, npft, sm_levels, dzsoil, land_index, surft_pts, surft_index, & + cosine_zenith_angle, latitude, longitude, Fland, tile_frac, & + + ! IN: soil parameters !1 is only allowable index in UM + bexp, hcon, satcon, sathh, smvcst, smvcwt, smvccl, albsoil, & + + ! IN: Met forcing: + lw_down, sw_surft, ls_rain, ls_snow, & + tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy_tile, & + ! This an outlier IN here. INOUT @ implicit. (was)OUT at extras + ! I think we are dealing with it OK now but confusion could be removed + snow_tile, & + + ! IN: canopy height, LAI seasonally presecribed, potentially prognostic + ! IN: CO2 mass mixing ratio + canht_pft, lai_pft, CO2_MMR, & + + ! TYPEs passed from top_level to maintain scope, access to UM STASH + ! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit + ! INOUT: Carries fields needed by CABLE b/n pathways (rad, explicit etc) + ! Currently carrying CABLE TYPEs (canopy%, rad% etc). + ! IN: pars carries vegin/soilin - potentially redundant + progs, work, pars, & + + ! OUT: UM fields UNPACKed from CABLE (@ explicit) + ftl_tile, fqw_tile, tstar_tile, dtstar_surft, & + u_s, u_s_std_tile, cd_tile, ch_tile, & + radnet_tile, fraca, resfs, resft, z0h_tile, z0m_tile, & + recip_l_mo_tile, epot_tile, npp_pft_acc, resp_w_pft_acc ) + +! subrs +USE cable_explicit_driv_mod, ONLY: cable_explicit_driver +USE cable_expl_unpack_mod, ONLY: cable_expl_unpack +USE init_active_tile_mask_mod, ONLY: init_active_tile_mask_cbl + +! data: TYPE definitions of passed asarguments +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type ! CABLE requires extra progs +USE work_vars_mod_cbl, ONLY: work_vars_type ! and some kept thru timestep +USE params_io_mod_cbl, ONLY: params_io_data_type +USE params_io_mod_cbl, ONLY: params_io_type + +! data: Scalars +USE grid_constants_mod_cbl, ONLY: nrb, nrs, mp +USE cable_common_module, ONLY: knode_gl, ktau_gl, kwidth_gl, cable_runtime, & + cable_user, redistrb, satuparam, wiltparam, & + l_casacnp_cd => l_casacnp +USE cable_model_env_opts_mod, ONLY: icycle ! 0=No CASA- [1=C,2=CN,3=CNP] +USE cable_model_env_opts_mod, ONLY: l_casacnp +USE casadimension, ONLY: icycle_cd => icycle +!Leave for reference +!! USE atm_fields_real_mod, ONLY : soil_temp_cable, soil_moist_cable, etc & +!! C_pool_casa, N_pool_casa, P_pool_casa, & +!! SOIL_ORDER_casa, N_DEP_casa, N_FIX_casa, & +!! P_DUST_casa, P_weath_casa, LAI_casa, & +!! PHENPHASE_casa, NPP_PFT_ACC, RSP_W_PFT_ACC, & +!! aquifer_moist_cable,aquifer_thickness_cable, & +!! slope_avg_cable,slope_std_cable,& +!! visc_sublayer_depth,aquifer_perm_cable,& +!! aquifer_draindens_cable + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mype ! # processor +REAL, INTENT(IN) :: timestep_len ! # seconds (cucurrently 1200) +INTEGER, INTENT(IN) :: timestep_number ! # timestep (cucurrently 3 per hr) +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +INTEGER, INTENT(IN) :: sm_levels ! # soil layers +REAL, INTENT(IN) :: dzsoil(sm_levels) ! soil layer thicknesses + +INTEGER, INTENT(IN) :: land_index(land_pts) ! land point indices + ! recipe back to (i,j) cell +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! tile points indices + ! recipe back to land_index + +REAL, INTENT(IN) :: canht_pft(land_pts, npft) ! canopy height (seasonal) +REAL, INTENT(IN) :: lai_pft(land_pts, npft) ! LAI (seasonal) +REAL, INTENT(IN) :: fland(land_pts) ! land fraction (<1 for coastal) +REAL, INTENT(IN) :: co2_mmr ! prescribed MMR +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) ! tile fraction + +REAL, INTENT(IN) :: cosine_zenith_angle(row_length,rows) +REAL, INTENT(IN) :: latitude (row_length,rows) +REAL, INTENT(IN) :: longitude(row_length,rows) + +! soil parameters +REAL, INTENT(IN) :: bexp (land_pts, sm_levels) ! parameter b in Campbell eqn +REAL, INTENT(IN) :: sathh(land_pts, sm_levels) ! +REAL, INTENT(IN) :: smvcst(land_pts, sm_levels) ! +REAL, INTENT(IN) :: smvcwt(land_pts, sm_levels) ! +REAL, INTENT(IN) :: smvccl(land_pts, sm_levels) ! +REAL, INTENT(IN) :: hcon(land_pts) ! Soil thermal conductivity (W/m/K). +REAL, INTENT(IN) :: albsoil(land_pts) ! bare soil albedo +REAL, INTENT(IN) :: satcon(land_pts, sm_levels) ! hydraulic conductivity + ! @ saturation [mm/s] + +! "forcing" +REAL, INTENT(IN) :: lw_down(row_length,rows) +REAL, INTENT(IN) :: ls_rain(row_length,rows) +REAL, INTENT(IN) :: ls_snow(row_length,rows) +REAL, INTENT(IN) :: sw_surft(land_pts, nsurft) +REAL, INTENT(IN) :: tl_1(row_length,rows) +REAL, INTENT(IN) :: qw_1(row_length,rows) +REAL, INTENT(IN) :: vshr_land(row_length,rows) +REAL, INTENT(IN) :: pstar(row_length,rows) +REAL, INTENT(IN) :: z1_tq(row_length,rows) +REAL, INTENT(IN) :: z1_uv(row_length,rows) + +! prognostics +REAL, INTENT(IN) :: canopy_tile(land_pts, nsurft) +REAL, INTENT(IN) :: snow_tile(land_pts, nsurft) ! Lying snow [kg/m2] + +! TYPEs passed from top_level to maintain scope, access to UM STASH +! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit +! INOUT: Carries fields needed by CABLE b/n pathways (rad, explicit etc) +! Currently carrying CABLE TYPEs (canopy%, rad% etc). +! IN: pars carries vegin/soilin - potentially redundant +TYPE(progs_cbl_vars_type), INTENT(IN) :: progs +TYPE(params_io_data_type), INTENT(IN) :: pars +TYPE(work_vars_type), INTENT(INOUT) :: work + +! OUT: UM fields UNPACKed from CABLE (@ explicit) +REAL, INTENT(OUT) :: ftl_tile(land_pts,nsurft) ! surface FTL for land tiles +REAL, INTENT(OUT) :: fqw_tile(land_pts,nsurft) ! surface FQW for land tiles +REAL, INTENT(OUT) :: tstar_tile(land_pts,nsurft) ! radiative surf. temperature +REAL, INTENT(OUT) :: dtstar_surft(land_pts,nsurft) ! +REAL, INTENT(OUT) :: u_s(row_length,rows) ! friction velocity (m/s) +REAL, INTENT(OUT) :: u_s_std_tile(land_pts,nsurft)! +REAL, INTENT(OUT) :: cd_tile(land_pts,nsurft) ! Drag coefficient +REAL, INTENT(OUT) :: ch_tile(land_pts,nsurft) ! Transfer coefficient +REAL, INTENT(OUT) :: radnet_tile(land_pts,nsurft) ! Surface net radiation +REAL, INTENT(OUT) :: z0h_tile(land_pts,nsurft) ! roughness +REAL, INTENT(OUT) :: z0m_tile(land_pts,nsurft) ! roughness +REAL, INTENT(OUT) :: epot_tile(land_pts,nsurft) ! +REAL, INTENT(OUT) :: recip_l_mo_tile(land_pts,nsurft) ! Reciprocal:Monin-Obukhov + ! length for tiles (m^-1) +REAL, INTENT(OUT) :: fraca(land_pts,nsurft) ! Fraction - surface moisture +REAL, INTENT(OUT) :: RESFS(land_pts,nsurft) + ! Combined soil, stomatal & aerodynamic resistance + ! factor for fraction (1-FRACA) of snow-free land tiles +REAL, INTENT(OUT) :: RESFT(land_pts,nsurft) + ! Total resistance factor. + ! FRACA+(1-FRACA)*RESFS for snow-free l_tile_pts, + ! 1 for snow. +REAL, INTENT(IN) :: npp_pft_acc(land_pts,npft) +REAL, INTENT(IN) :: resp_w_pft_acc (land_pts,npft) + +!___ local vars, may be passed as args downstream +LOGICAL :: cbl_standalone = .FALSE. !needs to be set from namelist +LOGICAL :: jls_standalone = .FALSE. !needs to be set from namelist +LOGICAL :: jls_radiation = .FALSE. !needs to be set from n amelist + +INTEGER :: isnow_flg_cable(land_pts, nsurft) +REAL :: radians_degrees +REAL :: latitude_deg(row_length,rows) +REAL :: longitude_deg(row_length,rows) +REAL :: sw_down_ij(row_length,rows,nrs) +REAL :: sw_down_TOT(row_length,rows) +REAL :: sw_down_DIR(row_length,rows) +REAL :: sw_down_VIS(row_length,rows) +REAL :: sw_down_NIR(row_length,rows) +REAL :: beamFrac_VIS(row_length,rows) +REAL :: beamFrac_NIR(row_length,rows) +REAL :: beamFrac_TOT(row_length,rows) + +LOGICAL, ALLOCATABLE :: l_tile_pts(:,:) + +INTEGER :: i,j,k,l,n +LOGICAL, SAVE :: zero_points_warning = .TRUE. + +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_explicit_main" + +IF( land_pts == 0 ) THEN + IF( zero_points_warning ) THEN + WRITE(6,*) "Reached CABLE ", subr_name, & + " even though zero land_points on processor ", mype + END IF + zero_points_warning = .FALSE. + RETURN +END IF + +!--- Set up some cable-globals ------------------------------------------------- +cable_runtime%um = .TRUE. +cable_runtime%um_explicit = .TRUE. + +! this done every call (maybe we hould pass this through work%) +!------------------------------------------------------------------------------ +! Determine the number of active tiles +mp = SUM(surft_pts) + +IF( .NOT. ALLOCATED(l_tile_pts) ) ALLOCATE( l_tile_pts(land_pts, nsurft) ) + +! Define mapping mask. i.e. l_tile_pts =TRUE (active) , where tile_frac > 0 +CALL init_active_tile_mask_cbl( l_tile_pts, land_pts, nsurft, tile_frac ) +!------------------------------------------------------------------------------- + +!!extracted from ap/um/rose-app.conf au-aa809@2729 +![namelist:cable] +cable_user%diag_soil_resp='ON' +cable_user%fwsoil_switch='Haverd2013' +cable_user%gs_switch='medlyn' +cable_user%gw_model=.false. +cable_user%l_rev_corr=.true. +cable_user%l_revised_coupling=.true. +cable_user%or_evap=.false. +!cable_user%soil_thermal_fix=.true. +cable_user%soil_thermal_fix=.false.! fudge - worked to dt=4 +cable_user%ssnow_potev='HDM' +redistrb=.false. +satuparam=0.8 +wiltparam=0.5 +! set icycle/lcasacnp seen thru-out model from namelist read version +icycle_cd = icycle +l_casacnp_cd = l_casacnp + +! initialize processor number, timestep len +knode_gl = mype +kwidth_gl = INT(timestep_len) +ktau_gl = timestep_number + +!--- Convert lat/long to degrees +radians_degrees = 180.0 / ( 4.0*atan(1.0) ) ! 180 / PI +latitude_deg = latitude * radians_degrees +longitude_deg = longitude * radians_degrees + +isnow_flg_cable = INT(progs%ThreeLayerSnowFlag_CABLE) + +!--- Fix SW for CABLE ---------------------------------------------------------------------------- +sw_down_ij(:,:,:) = 0.0 +sw_down_TOT(:,:) = 0.0 +sw_down_DIR(:,:) = 0.0 +sw_down_VIS(:,:) = 0.0 +sw_down_NIR(:,:) = 0.0 +beamFrac_VIS(:,:) = 0.0 +beamFrac_NIR(:,:) = 0.0 +beamFrac_TOT(:,:) = 0.0 + +IF(jls_standalone) THEN + + DO n = 1, nsurft + ! loop over number of points per tile + DO k = 1, surft_pts(n) + l = surft_index(k, n) + j = (land_index(l) - 1) / row_length + 1 + i = land_index(l) - (j-1) * row_length + sw_down_VIS(i, j) = sw_surft(l,n) / 2.0 + END DO + END DO + sw_down_NIR(:,:) = sw_down_VIS(:,:) + +ELSE + + ! in all cases zenith angle needs to be applied + DO n = 1, nrs + sw_down_ij(:,:,n) = work%sw_down_ij(:,:,n) * cosine_zenith_angle(:,:) + END DO + + ! SUM over ALL components of sw_down_ij + sw_down_TOT(:,:) = sw_down_ij(:,:,1) + sw_down_ij(:,:,2) + & + sw_down_ij(:,:,3) + sw_down_ij(:,:,4) + + ! SUM DIRect components of sw_down_ij(in VIS & NIR ) + sw_down_DIR(:,:) = sw_down_ij(:,:,1) + sw_down_ij(:,:,3) + + ! SUM VIS components of sw_down_ij(incl DIR & DIF ) + sw_down_VIS(:,:) = sw_down_ij(:,:,1) + sw_down_ij(:,:,2) + + ! SUM NIR components of sw_down_ij(incl DIR & DIF ) + sw_down_NIR(:,:) = sw_down_ij(:,:,3) + sw_down_ij(:,:,4) + + ! beam(DIR) fraction in VISible spectrum + beamFrac_VIS(:,:) = sw_down_ij(:,:,1) / MAX( 0.1, sw_down_VIS(:,:) ) + + ! beam(DIR) fraction in NIR spectrum + beamFrac_NIR(:,:) = sw_down_ij(:,:,3) / MAX( 0.1, sw_down_NIR(:,:) ) + + ! beam(DIR) fraction for all solar + beamFrac_TOT(:,:) = sw_down_DIR(:,:) / MAX( 0.1, sw_down_TOT(:,:) ) + +ENDIF + +!---------------------------------------------------------------------------- +!--- CALL _driver to run specific and necessary components of CABLE with IN - +!--- args PACKED to force CABLE +!------------------------------------------------------------------------------- +CALL cable_explicit_driver( & + ! IN: UM/JULES/CABLE model/grid parameters, fields, mappings + mype, row_length, rows, land_pts, nsurft, npft, sm_levels, dzsoil, & + timestep_len, timestep_number, mp, nrb, land_index, surft_pts, surft_index, & + l_tile_pts, latitude_deg, longitude_deg, cosine_zenith_angle, Fland, & + tile_frac, & + + ! IN: soil parameters !1 is only allowable index in UM + bexp, hcon, satcon, sathh, smvcst, smvcwt, smvccl, albsoil, & + + ! IN: SW forcing: manipulated for CABLE + sw_down_VIS, sw_down_NIR, beamFrac_VIS, beamFrac_NIR, beamFrac_TOT, & + + ! IN: Met forcing: + lw_down, ls_rain, ls_snow, & + tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy_tile, & + ! This an outlier IN here. INOUT @ implicit. (was)OUT at extras + ! I think we are dealing with it OK now but confusion could be removed + snow_tile, & + + ! IN: canopy height, LAI seasonally presecribed, potentially prognostic + ! IN: CO2 mass mixing ratio + canht_pft, lai_pft, CO2_MMR, & + + ! IN: carries vegin/soilin - potentially redundant + pars, & + + ! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit + progs%soiltemp_CABLE, progs%soilmoisture_CABLE, progs%FrozenSoilFrac_CABLE, & + isnow_flg_cable, progs%SnowDepth_CABLE, progs%SnowMass_CABLE, & + progs%SnowTemp_CABLE, progs%SnowDensity_CABLE, progs%snowage_CABLE, & + progs%snowosurft, progs%OneLyrSnowDensity_CABLE, & + + ! INOUT: CABLE TYPEs roughly grouped fields per module + work%rad, work%met, work%rough, work%canopy, work%veg, work%soil, & + work%ssnow, work%bal, work%air, work%bgc, work%sum_flux, & + + !IN: persistent veg%iveg, soil%isoilm are initialized on first rad/alb call + work%veg%iveg, work%soil%isoilm, & + !OUT: currently being passed back to UM in veg%hc, veg%vlai + work%veg%hc, work%veg%vlai, & + + !IN: currently being passed from prev radiation call through work% + ! jhan:quirky, snow (in turn reduced LAI due to snow) can evolve through a + ! constant rad dt. However reducedLAIdue2snow used ubiquitously as trigger + ! Further, snow does NOT evolve in explicit AND reducedLAIdue2snow absent + ! in implicit + work%reducedLAIdue2snow, & + + !GW + !visc_sublayer_depth, smgw_tile, slope_avg, slope_std, + !dz_gw, perm_gw, drain_gw, + !casa progs + !CPOOL_TILE, NPOOL_TILE, PPOOL_TILE, SOIL_ORDER, NIDEP, + !NIFIX, PWEA, PDUST, GLAI, PHENPHASE, + + !IN: if not passed a dangling argument would ensue + npp_pft_acc, resp_w_pft_acc ) + +!---------------------------------------------------------------------------- +!--- CALL _unpack to unpack variables from CABLE back to UM format to return +!---------------------------------------------------------------------------- +call cable_expl_unpack( & + ! IN: UM/JULES/CABLE model/grid parameters, fields, mappings + row_length, rows, land_pts, nsurft, npft, mp, land_index, surft_pts, & + surft_index, l_tile_pts, fland, tile_frac, latitude, longitude, & + + !OUT: UM fields to be updated + ftl_tile, fqw_tile, tstar_tile, dtstar_surft , u_s, u_s_std_tile, cd_tile, & + ch_tile, radnet_tile, fraca, resfs, resft, z0h_tile, z0m_tile, & + recip_l_mo_tile, epot_tile, & + + !IN: UM fields to be updated FROM these CABLE fields + work%canopy%fh, work%canopy%fes, work%canopy%fev, work%canopy%us, & + work%canopy%cdtq,work%canopy%fwet, work%canopy%wetfac_cs, & + work%canopy%rnet, work%canopy%zetar, work%canopy%epot, work%rad%trad, & + work%rad%otrad, work%rad%transd, work%rough%z0m, work%rough%zref_tq, & + + !IN: UM fields used in derivation of fields to be updated + work%ssnow%snowd, work%ssnow%cls, work%air%rlam, work%air%rho, work%met%ua ) + +cable_runtime%um_explicit = .FALSE. + +RETURN + +END SUBROUTINE cable_explicit_main + +END MODULE cable_explicit_main_mod + diff --git a/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90.cnp b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90.cnp new file mode 100644 index 000000000..f5e4263f6 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_main.F90.cnp @@ -0,0 +1,401 @@ +MODULE cable_explicit_main_mod + +CONTAINS + +SUBROUTINE cable_explicit_main( & + ! IN: UM/JULES model/grid parameters, fields, mappings + mype, timestep_len, timestep_number, row_length, rows, land_pts, & + nsurft, npft, sm_levels, dzsoil, land_index, surft_pts, surft_index, & + cosine_zenith_angle, latitude, longitude, Fland, tile_frac, & + + ! IN: soil parameters !1 is only allowable index in UM + bexp, hcon, satcon, sathh, smvcst, smvcwt, smvccl, albsoil, & + + ! IN: Met forcing: + lw_down, sw_surft, ls_rain, ls_snow, & + tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy_tile, & + ! This an outlier IN here. INOUT @ implicit. (was)OUT at extras + ! I think we are dealing with it OK now but confusion could be removed + snow_tile, & + + ! IN: canopy height, LAI seasonally presecribed, potentially prognostic + ! IN: CO2 mass mixing ratio + canht_pft, lai_pft, CO2_MMR, & + + ! TYPEs passed from top_level to maintain scope, access to UM STASH + ! ------------------------------------------------------------------ + ! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit + ! INOUT: Carries fields needed by CABLE b/n pathways (rad, explicit etc) + ! Currently carrying CABLE TYPEs (canopy%, rad% etc). + ! IN: pars carries vegin/soilin - potentially redundant + progs, work, pars, & + + ! IN: CASA-CNP prognostics - IN here. INOUT @ implicit + progs_cnp, & + + ! OUT: UM fields UNPACKed from CABLE (@ explicit) + ftl_tile, fqw_tile, tstar_tile, dtstar_surft, & + u_s, u_s_std_tile, cd_tile, ch_tile, & + radnet_tile, fraca, resfs, resft, z0h_tile, z0m_tile, & + recip_l_mo_tile, epot_tile, npp_pft_acc, resp_w_pft_acc ) + +! subrs +USE cable_explicit_driv_mod, ONLY: cable_explicit_driver +USE cable_expl_unpack_mod, ONLY: cable_expl_unpack +USE init_active_tile_mask_mod, ONLY: init_active_tile_mask_cbl + +! data: TYPE definitions of passed asarguments +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type ! CABLE requires extra progs +USE work_vars_mod_cbl, ONLY: work_vars_type ! and some kept thru timestep +USE params_io_mod_cbl, ONLY: params_io_data_type +USE params_io_mod_cbl, ONLY: params_io_type +USE progs_cnp_vars_mod, ONLY: progs_cnp_vars_type ! CASA requires progs + +! data: Scalars +USE grid_constants_mod_cbl, ONLY: nrb, nrs, mp +USE cable_common_module, ONLY: knode_gl, ktau_gl, kwidth_gl, cable_runtime, & + cable_user, redistrb, satuparam, wiltparam, & + l_casacnp +USE casadimension, ONLY: icycle ! 0=No CASA- [1=C,2=CN,3=CNP] +!Leave for reference +!! USE atm_fields_real_mod, ONLY : +!! NPP_PFT_ACC, RSP_W_PFT_ACC, & +!! aquifer_moist_cable,aquifer_thickness_cable, & +!! slope_avg_cable,slope_std_cable,& +!! visc_sublayer_depth,aquifer_perm_cable,& +!! aquifer_draindens_cable + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mype ! # processor +REAL, INTENT(IN) :: timestep_len ! # seconds (cucurrently 1200) +INTEGER, INTENT(IN) :: timestep_number ! # timestep (cucurrently 3 per hr) +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +INTEGER, INTENT(IN) :: sm_levels ! # soil layers +REAL, INTENT(IN) :: dzsoil(sm_levels) ! soil layer thicknesses + +INTEGER, INTENT(IN) :: land_index(land_pts) ! land point indices + ! recipe back to (i,j) cell +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! tile points indices + ! recipe back to land_index + +REAL, INTENT(IN) :: canht_pft(land_pts, npft) ! canopy height (seasonal) +REAL, INTENT(IN) :: lai_pft(land_pts, npft) ! LAI (seasonal) +REAL, INTENT(IN) :: fland(land_pts) ! land fraction (<1 for coastal) +REAL, INTENT(IN) :: co2_mmr ! prescribed MMR +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) ! tile fraction + +REAL, INTENT(IN) :: cosine_zenith_angle(row_length,rows) +REAL, INTENT(IN) :: latitude (row_length,rows) +REAL, INTENT(IN) :: longitude(row_length,rows) + +! soil parameters +REAL, INTENT(IN) :: bexp (land_pts, sm_levels) ! parameter b in Campbell eqn +REAL, INTENT(IN) :: sathh(land_pts, sm_levels) ! +REAL, INTENT(IN) :: smvcst(land_pts, sm_levels) ! +REAL, INTENT(IN) :: smvcwt(land_pts, sm_levels) ! +REAL, INTENT(IN) :: smvccl(land_pts, sm_levels) ! +REAL, INTENT(IN) :: hcon(land_pts) ! Soil thermal conductivity (W/m/K). +REAL, INTENT(IN) :: albsoil(land_pts) ! bare soil albedo +REAL, INTENT(IN) :: satcon(land_pts, sm_levels) ! hydraulic conductivity + ! @ saturation [mm/s] + +! "forcing" +REAL, INTENT(IN) :: lw_down(row_length,rows) +REAL, INTENT(IN) :: ls_rain(row_length,rows) +REAL, INTENT(IN) :: ls_snow(row_length,rows) +REAL, INTENT(IN) :: sw_surft(land_pts, nsurft) +REAL, INTENT(IN) :: tl_1(row_length,rows) +REAL, INTENT(IN) :: qw_1(row_length,rows) +REAL, INTENT(IN) :: vshr_land(row_length,rows) +REAL, INTENT(IN) :: pstar(row_length,rows) +REAL, INTENT(IN) :: z1_tq(row_length,rows) +REAL, INTENT(IN) :: z1_uv(row_length,rows) + +! prognostics +REAL, INTENT(IN) :: canopy_tile(land_pts, nsurft) +REAL, INTENT(IN) :: snow_tile(land_pts, nsurft) ! Lying snow [kg/m2] + +! TYPEs passed from top_level to maintain scope, access to UM STASH +! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit +! INOUT: Carries fields needed by CABLE b/n pathways (rad, explicit etc) +! Currently carrying CABLE TYPEs (canopy%, rad% etc). +! IN: pars carries vegin/soilin - potentially redundant +TYPE(progs_cbl_vars_type), INTENT(IN) :: progs +TYPE(params_io_data_type), INTENT(IN) :: pars +TYPE(work_vars_type), INTENT(INOUT) :: work +! IN: CASA-CNP prognostics - IN here. INOUT @ implicit +TYPE(progs_cnp_vars_type), INTENT(IN) :: progs_cnp + +! OUT: UM fields UNPACKed from CABLE (@ explicit) +REAL, INTENT(OUT) :: ftl_tile(land_pts,nsurft) ! surface FTL for land tiles +REAL, INTENT(OUT) :: fqw_tile(land_pts,nsurft) ! surface FQW for land tiles +REAL, INTENT(OUT) :: tstar_tile(land_pts,nsurft) ! radiative surf. temperature +REAL, INTENT(OUT) :: dtstar_surft(land_pts,nsurft) ! +REAL, INTENT(OUT) :: u_s(row_length,rows) ! friction velocity (m/s) +REAL, INTENT(OUT) :: u_s_std_tile(land_pts,nsurft)! +REAL, INTENT(OUT) :: cd_tile(land_pts,nsurft) ! Drag coefficient +REAL, INTENT(OUT) :: ch_tile(land_pts,nsurft) ! Transfer coefficient +REAL, INTENT(OUT) :: radnet_tile(land_pts,nsurft) ! Surface net radiation +REAL, INTENT(OUT) :: z0h_tile(land_pts,nsurft) ! roughness +REAL, INTENT(OUT) :: z0m_tile(land_pts,nsurft) ! roughness +REAL, INTENT(OUT) :: epot_tile(land_pts,nsurft) ! +REAL, INTENT(OUT) :: recip_l_mo_tile(land_pts,nsurft) ! Reciprocal:Monin-Obukhov + ! length for tiles (m^-1) +REAL, INTENT(OUT) :: fraca(land_pts,nsurft) ! Fraction - surface moisture +REAL, INTENT(OUT) :: RESFS(land_pts,nsurft) + ! Combined soil, stomatal & aerodynamic resistance + ! factor for fraction (1-FRACA) of snow-free land tiles +REAL, INTENT(OUT) :: RESFT(land_pts,nsurft) + ! Total resistance factor. + ! FRACA+(1-FRACA)*RESFS for snow-free l_tile_pts, + ! 1 for snow. +REAL, INTENT(IN) :: npp_pft_acc(land_pts,npft) +REAL, INTENT(IN) :: resp_w_pft_acc (land_pts,npft) + +!___ local vars, may be passed as args downstream +LOGICAL :: cbl_standalone = .FALSE. !needs to be set from namelist +LOGICAL :: jls_standalone = .FALSE. !needs to be set from namelist +LOGICAL :: jls_radiation = .FALSE. !needs to be set from n amelist + +INTEGER :: isnow_flg_cable(land_pts, nsurft) +REAL :: radians_degrees +REAL :: latitude_deg(row_length,rows) +REAL :: longitude_deg(row_length,rows) +REAL :: sw_down_ij(row_length,rows,nrs) +REAL :: sw_down_TOT(row_length,rows) +REAL :: sw_down_DIR(row_length,rows) +REAL :: sw_down_VIS(row_length,rows) +REAL :: sw_down_NIR(row_length,rows) +REAL :: beamFrac_VIS(row_length,rows) +REAL :: beamFrac_NIR(row_length,rows) +REAL :: beamFrac_TOT(row_length,rows) + +LOGICAL, ALLOCATABLE :: l_tile_pts(:,:) + +INTEGER :: i,j,k,l,n +LOGICAL, SAVE :: zero_points_warning = .TRUE. + +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_explicit_main" + +IF( land_pts == 0 ) THEN + IF( zero_points_warning ) THEN + WRITE(6,*) "Reached CABLE ", subr_name, & + " even though zero land_points on processor ", mype + END IF + zero_points_warning = .FALSE. + RETURN +END IF + +!--- Set up some cable-globals ------------------------------------------------- +cable_runtime%um = .TRUE. +cable_runtime%um_explicit = .TRUE. + +! this done every call (maybe we hould pass this through work%) +!------------------------------------------------------------------------------ +! Determine the number of active tiles +mp = SUM(surft_pts) + +IF( .NOT. ALLOCATED(l_tile_pts) ) ALLOCATE( l_tile_pts(land_pts, nsurft) ) + +! Define mapping mask. i.e. l_tile_pts =TRUE (active) , where tile_frac > 0 +CALL init_active_tile_mask_cbl( l_tile_pts, land_pts, nsurft, tile_frac ) +!------------------------------------------------------------------------------- + +!!extracted from ap/um/rose-app.conf au-aa809@2729 +![namelist:cable] +cable_user%diag_soil_resp='ON' +cable_user%fwsoil_switch='Haverd2013' +cable_user%gs_switch='medlyn' +cable_user%gw_model=.false. +cable_user%l_rev_corr=.true. +cable_user%l_revised_coupling=.true. +cable_user%or_evap=.false. +!cable_user%soil_thermal_fix=.true. +cable_user%soil_thermal_fix=.false.! fudge - worked to dt=4 +cable_user%ssnow_potev='HDM' +icycle=3 !previously blocked?? +l_casacnp=.true. !previously blocked?? +redistrb=.false. +satuparam=0.8 +wiltparam=0.5 + +! initialize processor number, timestep len +knode_gl = mype +kwidth_gl = INT(timestep_len) +ktau_gl = timestep_number + +!--- Convert lat/long to degrees +radians_degrees = 180.0 / ( 4.0*atan(1.0) ) ! 180 / PI +latitude_deg = latitude * radians_degrees +longitude_deg = longitude * radians_degrees + +isnow_flg_cable = INT(progs%ThreeLayerSnowFlag_CABLE) + +!--- Fix SW for CABLE ---------------------------------------------------------------------------- +sw_down_ij(:,:,:) = 0.0 +sw_down_TOT(:,:) = 0.0 +sw_down_DIR(:,:) = 0.0 +sw_down_VIS(:,:) = 0.0 +sw_down_NIR(:,:) = 0.0 +beamFrac_VIS(:,:) = 0.0 +beamFrac_NIR(:,:) = 0.0 +beamFrac_TOT(:,:) = 0.0 + +IF(jls_standalone) THEN + + DO n = 1, nsurft + ! loop over number of points per tile + DO k = 1, surft_pts(n) + l = surft_index(k, n) + j = (land_index(l) - 1) / row_length + 1 + i = land_index(l) - (j-1) * row_length + sw_down_VIS(i, j) = sw_surft(l,n) / 2.0 + END DO + END DO + sw_down_NIR(:,:) = sw_down_VIS(:,:) + +ELSE + + ! in all cases zenith angle needs to be applied + DO n = 1, nrs + sw_down_ij(:,:,n) = work%sw_down_ij(:,:,n) * cosine_zenith_angle(:,:) + END DO + + ! SUM over ALL components of sw_down_ij + sw_down_TOT(:,:) = sw_down_ij(:,:,1) + sw_down_ij(:,:,2) + & + sw_down_ij(:,:,3) + sw_down_ij(:,:,4) + + ! SUM DIRect components of sw_down_ij(in VIS & NIR ) + sw_down_DIR(:,:) = sw_down_ij(:,:,1) + sw_down_ij(:,:,3) + + ! SUM VIS components of sw_down_ij(incl DIR & DIF ) + sw_down_VIS(:,:) = sw_down_ij(:,:,1) + sw_down_ij(:,:,2) + + ! SUM NIR components of sw_down_ij(incl DIR & DIF ) + sw_down_NIR(:,:) = sw_down_ij(:,:,3) + sw_down_ij(:,:,4) + + ! beam(DIR) fraction in VISible spectrum + beamFrac_VIS(:,:) = sw_down_ij(:,:,1) / MAX( 0.1, sw_down_VIS(:,:) ) + + ! beam(DIR) fraction in NIR spectrum + beamFrac_NIR(:,:) = sw_down_ij(:,:,3) / MAX( 0.1, sw_down_NIR(:,:) ) + + ! beam(DIR) fraction for all solar + beamFrac_TOT(:,:) = sw_down_DIR(:,:) / MAX( 0.1, sw_down_TOT(:,:) ) + +ENDIF + +!---------------------------------------------------------------------------- +!--- CALL _driver to run specific and necessary components of CABLE with IN - +!--- args PACKED to force CABLE +!------------------------------------------------------------------------------- +CALL cable_explicit_driver( & + ! IN: UM/JULES/CABLE model/grid parameters, fields, mappings + mype, row_length, rows, land_pts, nsurft, npft, sm_levels, dzsoil, & + timestep_len, timestep_number, mp, nrb, land_index, surft_pts, surft_index, & + l_tile_pts, latitude_deg, longitude_deg, cosine_zenith_angle, Fland, & + tile_frac, L_casacnp, & + + ! IN: soil parameters !1 is only allowable index in UM + bexp, hcon, satcon, sathh, smvcst, smvcwt, smvccl, albsoil, & + + ! IN: SW forcing: manipulated for CABLE + sw_down_VIS, sw_down_NIR, beamFrac_VIS, beamFrac_NIR, beamFrac_TOT, & + + ! IN: Met forcing: + lw_down, ls_rain, ls_snow, & + tl_1, qw_1, vshr_land, pstar, z1_tq, z1_uv, canopy_tile, & + ! This an outlier IN here. INOUT @ implicit. (was)OUT at extras + ! I think we are dealing with it OK now but confusion could be removed + snow_tile, & + + ! IN: canopy height, LAI seasonally presecribed, potentially prognostic + ! IN: CO2 mass mixing ratio + canht_pft, lai_pft, CO2_MMR, & + + ! IN: carries vegin/soilin - potentially redundant + pars, & + + ! IN: tiled soil/snow prognostics - IN here. INOUT @ implicit + progs%soiltemp_CABLE, progs%soilmoisture_CABLE, progs%FrozenSoilFrac_CABLE, & + isnow_flg_cable, progs%SnowDepth_CABLE, progs%SnowMass_CABLE, & + progs%SnowTemp_CABLE, progs%SnowDensity_CABLE, progs%snowage_CABLE, & + progs%snowosurft, progs%OneLyrSnowDensity_CABLE, & + + ! IN: casa-CNP prognostics - IN here. INOUT @ implicit + progs_cnp% C_pool_casa, progs_cnp% N_pool_casa, progs_cnp% P_pool_casa, & + progs_cnp% soil_order_casa, & + progs_cnp% N_dep_casa, progs_cnp% N_fix_casa, & + progs_cnp% P_dust_casa, progs_cnp% P_weath_casa, & + progs_cnp% LAI_casa, progs_cnp% phenphase_casa, & + progs_cnp% wood_flux_C, progs_cnp% wood_flux_N, progs_cnp% wood_flux_P, & + progs_cnp% wood_hvest_C, progs_cnp% wood_hvest_N, progs_cnp% wood_hvest_P, & + progs_cnp% thinning, & + + ! INOUT: CABLE TYPEs roughly grouped fields per module + work%rad, work%met, work%rough, work%canopy, work%veg, work%soil, & + work%ssnow, work%bal, work%air, work%bgc, work%sum_flux, & + + ! INOUT: CASA TYPEs roughly grouped fields per module + work%casapool, work%casaflux, & + work%sum_casapool, work%sum_casaflux, work%casabiome, & + work%casamet, work%casabal, work%phen, & + + !IN: persistent veg%iveg, soil%isoilm are initialized on first rad/alb call + work%veg%iveg, work%soil%isoilm, & + !OUT: currently being passed back to UM in veg%hc, veg%vlai + work%veg%hc, work%veg%vlai, & + + !IN: currently being passed from prev radiation call through work% + ! jhan:quirky, snow (in turn reduced LAI due to snow) can evolve through a + ! constant rad dt. However reducedLAIdue2snow used ubiquitously as trigger + ! Further, snow does NOT evolve in explicit AND reducedLAIdue2snow absent + ! in implicit + work%reducedLAIdue2snow, & + + !GW + !visc_sublayer_depth, smgw_tile, slope_avg, slope_std, + !dz_gw, perm_gw, drain_gw, + !casa progs + !CPOOL_TILE, NPOOL_TILE, PPOOL_TILE, SOIL_ORDER, NIDEP, + !NIFIX, PWEA, PDUST, GLAI, PHENPHASE, + + !IN: if not passed a dangling argument would ensue + npp_pft_acc, resp_w_pft_acc ) + +!---------------------------------------------------------------------------- +!--- CALL _unpack to unpack variables from CABLE back to UM format to return +!---------------------------------------------------------------------------- +call cable_expl_unpack( & + ! IN: UM/JULES/CABLE model/grid parameters, fields, mappings + row_length, rows, land_pts, nsurft, npft, mp, land_index, surft_pts, & + surft_index, l_tile_pts, fland, tile_frac, latitude, longitude, & + + !OUT: UM fields to be updated + ftl_tile, fqw_tile, tstar_tile, dtstar_surft , u_s, u_s_std_tile, cd_tile, & + ch_tile, radnet_tile, fraca, resfs, resft, z0h_tile, z0m_tile, & + recip_l_mo_tile, epot_tile, & + + !IN: UM fields to be updated FROM these CABLE fields + work%canopy%fh, work%canopy%fes, work%canopy%fev, work%canopy%us, & + work%canopy%cdtq,work%canopy%fwet, work%canopy%wetfac_cs, & + work%canopy%rnet, work%canopy%zetar, work%canopy%epot, work%rad%trad, & + work%rad%otrad, work%rad%transd, work%rough%z0m, work%rough%zref_tq, & + + !IN: UM fields used in derivation of fields to be updated + work%ssnow%snowd, work%ssnow%cls, work%air%rlam, work%air%rho, work%met%ua ) + +cable_runtime%um_explicit = .FALSE. + +RETURN + +END SUBROUTINE cable_explicit_main + +END MODULE cable_explicit_main_mod + diff --git a/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_unpack.F90 b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_unpack.F90 new file mode 100644 index 000000000..2a2f650c4 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/explicit/cable_explicit_unpack.F90 @@ -0,0 +1,195 @@ +!============================================================================== +! This source code is part of the +! Australian Community Atmosphere Biosphere Land Exchange (CABLE) model. +! This work is licensed under the CABLE Academic User Licence Agreement +! (the "Licence"). +! You may not use this file except in compliance with the Licence. +! A copy of the Licence and registration form can be obtained from +! http://www.accessimulator.org.au/cable +! You need to register and read the Licence agreement before use. +! Please contact cable_help@nf.nci.org.au for any questions on +! registration and the Licence. +! +! Unless required by applicable law or agreed to in writing, +! software distributed under the Licence is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the Licence for the specific language governing permissions and +! limitations under the Licence. +! ============================================================================== +! +! Purpose: Passes UM variables to CABLE, calls cbm, passes CABLE variables +! back to UM. 'Explicit' is the first of two routines that call cbm at +! different parts of the UM timestep. +! +! Called from: cable_explicit_driver +! +! Contact: Jhan.Srbinovsky@csiro.au +! +! History: Developed for CABLE v1.8 +! +! +! ============================================================================== + +MODULE cable_expl_unpack_mod + +!---------------------------------------------------------------------! +!--- pass land-surface quantities calc'd by CABLE in explicit call ---! +!--- back to UM. ---! +!---------------------------------------------------------------------! + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE cable_expl_unpack( & + + ! IN: UM/JULES/CABLE model/grid parameters, fields, mappings + row_length, rows, land_pts, nsurft, npft, mp, land_index, surft_pts, & + surft_index, l_tile_pts, fland, tile_frac, latitude, longitude, & + + !OUT: UM fields to be updated + ftl_tile, fqw_tile, tstar_tile, dtstar_tile , u_s, u_s_std_tile, cd_tile, & + ch_tile, radnet_tile, fraca, resfs, resft, z0h_tile, z0m_tile, & + recip_l_mo_tile, epot_tile, & + + !IN: UM fields to be updated FROM these CABLE fields + canopy_fh, canopy_fes, canopy_fev, canopy_us, canopy_cdtq, canopy_fwet, & + canopy_wetfac_cs, canopy_rnet, canopy_zetar, canopy_epot, & + rad_trad, rad_otrad, rad_transd, rough_z0m, rough_zref_tq, & + + !IN: CABLE fields used in derivation of fields to be updated + ssnow_snowd, ssnow_cls, air_rlam, air_rho, met_ua ) + +USE cable_def_types_mod, ONLY : NITER +USE cable_phys_constants_mod, ONLY: CAPP + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: land_index(land_pts) ! land point indices + ! recipe back to (i,j) cell +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! tile points indices + ! recipe back to land_index +LOGICAL, INTENT(IN) :: l_tile_pts(land_pts, nsurft) +REAL, INTENT(IN) :: fland(land_pts) ! Land fraction +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) +REAL, INTENT(IN) :: latitude(row_length,rows) +REAL, INTENT(IN) :: longitude(row_length,rows) + +!___ return fluxes UM vars recieve unpacked CABLE vars +REAL, INTENT(OUT) :: tstar_tile(land_pts,nsurft) ! surface temperature +REAL, INTENT(OUT) :: dtstar_tile(land_pts,nsurft) ! surface temperature +REAL, INTENT(OUT) :: ftl_tile(land_pts,nsurft) ! Surface FTL for land tiles +REAL, INTENT(OUT) :: fqw_tile(land_pts,nsurft) ! Surface FQW for land tiles +REAL, INTENT(OUT) :: z0h_tile(land_pts,nsurft) ! roughness +REAL, INTENT(OUT) :: z0m_tile(land_pts,nsurft) ! roughness +REAL, INTENT(OUT) :: cd_tile(land_pts,nsurft) ! Drag coefficient +REAL, INTENT(OUT) :: ch_tile(land_pts,nsurft) ! Transfer coefficient for heat & moisture +REAL, INTENT(OUT) :: u_s_std_tile(land_pts,nsurft) ! Surface friction velocity +REAL, INTENT(OUT) :: radnet_tile(land_pts,nsurft) ! Surface net radiation +REAL, INTENT(OUT) :: resfs(land_pts,nsurft) ! Combined soil, stomatal & aero resistance + ! factor for fraction (1-FRACA) of snow-free land tiles +REAL, INTENT(OUT) :: RESFT(land_pts,nsurft) ! Total resistance factor. + ! FRACA+(1-FRACA)*RESFS where NO snow + ! 1 for snow. +REAL, INTENT(OUT) :: FRACA(land_pts,nsurft) ! Fraction of surface moisture +REAL, INTENT(OUT) :: RECIP_L_MO_TILE(land_pts,nsurft) ! Reciprocal Monin-Obukhov len (m^-1) +REAL, INTENT(OUT) :: EPOT_TILE(land_pts,nsurft) +REAL, INTENT(OUT) :: U_S(row_length,rows) ! Surface friction velocity (m/s) + +!___ CABLE variables to be unpacked +REAL, INTENT(IN) :: rad_trad(mp) ! +REAL, INTENT(IN) :: rad_otrad(mp) ! +REAL, INTENT(IN) :: rad_transd(mp) ! rad. temp. (soil and veg) +REAL, INTENT(IN) :: canopy_fh(mp) ! total sensible heat (W/m2) +REAL, INTENT(IN) :: canopy_fes(mp) ! +REAL, INTENT(IN) :: canopy_fev(mp) ! +REAL, INTENT(IN) :: canopy_fwet(mp) ! fraction of canopy wet +REAL, INTENT(IN) :: canopy_wetfac_cs(mp) ! fraction of canopy wet +REAL, INTENT(IN) :: canopy_us(mp) ! friction velocity +REAL, INTENT(IN) :: canopy_cdtq(mp) ! drag coefficient for momentum +REAL, INTENT(IN) :: canopy_rnet(mp) ! net rad. absorbed by surface (W/m2) +REAL, INTENT(IN) :: canopy_epot(mp) ! total potential evaporation +REAL, INTENT(IN) :: rough_z0m(mp) ! roughness length +REAL, INTENT(IN) :: rough_zref_tq(mp) ! Reference height for met forcing +REAL, INTENT(IN) :: canopy_zetar(mp,niter) ! stability correction + +!IN: CABLE fields used in derivation of fields to be updated +REAL, INTENT(IN) :: ssnow_snowd(mp) ! snow depth (liquid water) +REAL, INTENT(IN) :: ssnow_cls(mp) ! factor for latent heat +REAL, INTENT(IN) :: met_ua(mp) ! surface wind speed (m/s) +REAL, INTENT(IN) :: air_rlam(mp) ! latent heat for water (j/kg) +REAL, INTENT(IN) :: air_rho(mp) ! dry air density (kg m-3) + +!___ local vars +REAL :: u_s_tile(land_pts,nsurft) +REAL :: dtrad(mp) ! change in rad%trad over time step +REAL :: cdcab(mp) +REAL :: thetast(mp) +REAL :: fraca_cab(mp) +REAL :: rfsfs_cab(mp) +REAL :: reciplmotile(mp) +REAL :: fe_dlh(mp) +REAL :: miss = 0.0 +REAL :: miss_tiny = 1.0e-9 +INTEGER :: i,j,k,n,L +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_explicit_unpack" + +!-------- Unique subroutine body ----------- +!___return fluxes +ftl_tile = UNPACK(canopy_fh, l_tile_pts, miss) +ftl_tile = ftl_tile / CAPP +fe_dlh = ( canopy_fes/(air_rlam*ssnow_cls) ) + ( canopy_fev/air_rlam ) +fqw_tile = UNPACK(fe_dlh, l_tile_pts, miss) + +!___return surface temp and roughness +tstar_tile = UNPACK(rad_trad, l_tile_pts, miss ) +dtrad = rad_trad - rad_otrad +dtstar_tile = UNPACK(dtrad, l_tile_pts, miss ) +z0m_tile = UNPACK(rough_z0m, l_tile_pts, miss_tiny) +z0h_tile = z0m_tile + +!___return friction velocities/drags/ etc +u_s_tile = UNPACK( canopy_us, l_tile_pts, miss) +cdcab = canopy_us**2 / met_ua**2 ! met%ua is always above umin = 0.1m/s +cd_tile = UNPACK( cdcab,l_tile_pts, miss) +ch_tile = UNPACK( canopy_cdtq,l_tile_pts, miss) + +u_s_std_tile=u_s_tile + +u_s = 0.0 +DO n=1, nsurft + DO k=1,surft_pts(n) + l = surft_index(K,N) + j = (land_index(l)-1) / row_length + 1 + i = land_index(l) - (j-1)*row_length + u_s(i,j) = u_s(i,j)+fland(l)*tile_frac(l,n)*u_s_tile(l,n) + ENDDO +ENDDO + +!___return miscelaneous +fraca_cab = canopy_fwet * (1.-rad_transd) +WHERE( ssnow_snowd > 1.0 ) fraca_cab = 1.0 + +rfsfs_cab = MIN( 1., MAX( 0.01, canopy_wetfac_cs - fraca_cab ) / & + MAX( 0.01, 1.0 - fraca_cab ) ) +fraca = UNPACK( fraca_cab, l_tile_pts, miss ) +resft = UNPACK( canopy_wetfac_cs,l_tile_pts, miss ) +resfs = UNPACK( rfsfs_cab , l_tile_pts, miss ) +radnet_tile = UNPACK( canopy_rnet , l_tile_pts, miss ) +thetast = ABS( canopy_fh ) / ( air_rho * capp*canopy_us ) +reciplmotile = canopy_zetar(:,niter) / rough_zref_tq +recip_l_mo_tile = UNPACK( reciplmotile, l_tile_pts, miss ) +epot_tile = UNPACK( canopy_epot, l_tile_pts, miss ) + +RETURN + +END SUBROUTINE cable_expl_unpack + +END MODULE cable_expl_unpack_mod diff --git a/src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_driver.F90 b/src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_driver.F90 new file mode 100644 index 000000000..63feee8cf --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_driver.F90 @@ -0,0 +1,38 @@ +MODULE cable_hyd_driv_mod + +CONTAINS + +SUBROUTINE cable_hyd_driver( land_pts, ntiles, tile_frac, lying_snow, SNOW_TILE, SURF_ROFF,& + SUB_SURF_ROFF, TOT_TFALL ) + + implicit none + + !___ re-decl input args + + integer :: land_pts, ntiles + + + REAL, INTENT(OUT), DIMENSION(LAND_PTS,NTILES) :: & + SNOW_TILE ! IN Lying snow on tiles (kg/m2) + + REAL, INTENT(OUT), DIMENSION(LAND_PTS) :: & + LYING_SNOW, & ! OUT Gridbox snowmass (kg/m2) + SUB_SURF_ROFF, & ! + SURF_ROFF, & ! + TOT_TFALL ! + + !___ local vars + + + REAL :: miss =0. + + +return + +END SUBROUTINE cable_hyd_driver + + +End module cable_hyd_driv_mod + + + diff --git a/src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_main.F90 b/src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_main.F90 new file mode 100644 index 000000000..b13eeed40 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/hydrology/cable_hyd_main.F90 @@ -0,0 +1,150 @@ +MODULE Cable_hyd_main_mod + +CONTAINS + +SUBROUTINE cable_hyd_main(land_pts, nsurft, tile_frac, timestep_len, & + lying_snow, snow_surft, & + snow_melt_gb, surf_roff, sub_surf_roff, & + tot_tfall, work_snow_surft, & + melt_surft, work_lying_snow, work_surf_roff, & + work_sub_surf_roff, work_tot_tfall) + +! This routine passes some of CABLE's hydrology variables to JULES for purpose +! of output. + +USE cable_common_module, ONLY : cable_runtime +USE cable_common_module, ONLY : knode_gl + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: land_pts, nsurft +REAL, INTENT(IN) :: timestep_len +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) +REAL, INTENT(IN) :: work_snow_surft(land_pts,nsurft) +REAL, INTENT(IN) :: melt_surft(land_pts,nsurft) ! tile snow melt (from implicit) +REAL, INTENT(IN) :: work_lying_snow(land_pts) ! Gridbox snowmass (kg/m2) +REAL, INTENT(IN) :: work_sub_surf_roff(land_pts) ! Sub-surface runoff (kg/m2/s). +REAL, INTENT(IN) :: work_surf_roff(land_pts) ! Surface runoff (kg/m2/s). +REAL, INTENT(IN) :: work_tot_tfall(land_pts) ! Total throughfall (kg/m2/s). + +REAL, INTENT(OUT) :: snow_surft(land_pts,nsurft) +REAL, INTENT(OUT) :: snow_melt_gb(land_pts) ! OUT gridbox snow melt (kg/m2/s) +REAL, INTENT(OUT) :: lying_snow(land_pts) ! OUT Gridbox snowmass (kg/m2) +REAL, INTENT(OUT) :: sub_surf_roff(land_pts) ! OUT Sub-surface runoff (kg/m2/s). +REAL, INTENT(OUT) :: surf_roff(land_pts) ! OUT Surface runoff (kg/m2/s). +REAL, INTENT(OUT) :: tot_tfall(land_pts) ! OUT Total throughfall (kg/m2/s). + +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_hyd_main" +LOGICAL, SAVE :: zero_points_warning = .true. + +IF( land_pts == 0 ) THEN + IF( zero_points_warning ) THEN + WRITE(6,*) "Reached CABLE ", subr_name, & + " even though zero land_points on processor ", knode_gl + END IF + zero_points_warning = .FALSE. + RETURN +END IF + +!--- initialize cable_runtime% switches +cable_runtime%um = .TRUE. +cable_runtime%um_hydrology =.TRUE. + +!jhan:This is all very dubious - mixing up depth and mass +!snow_surft = work_snow_surft !this is overwriting with zero +lying_snow = work_lying_snow + +surf_roff = work_surf_roff +sub_surf_roff = work_sub_surf_roff +tot_tfall = work_tot_tfall + +!CM3 new variables +! melt_surft unpacked in cable_implicit from ssnow%smelt +snow_melt_gb = SUM(tile_frac * melt_surft,2) + +cable_runtime%um_hydrology =.FALSE. + +RETURN + +END SUBROUTINE cable_hyd_main + +!!jhan:we'll have to organize ho we will get the right thigs here +! For CM2 we have to pass mp & %totwblake and TILE_FRAC down through argument list from *extras* +SUBROUTINE cable_lakesrivers(land_pts, nsurft, mp, totwblake, TILE_FRAC, & + TOT_WB_LAKE, L_tile_pts) + + IMPLICIT NONE + + !routine extracts daily integrated ssnow%totwblake - water added to keep + !lake tiles saturated - and grid cell averages (over land fraction) + !for use in river flow scaling routines + + !This routine is called from riv_intcl-riv_ic1a + + INTEGER, INTENT(IN) :: land_pts, nsurft, mp + LOGICAL :: l_tile_pts(land_pts, nsurft) + REAL, INTENT(INOUT), DIMENSION(mp) :: totwblake + REAL, INTENT(IN) :: TILE_FRAC(land_pts, nsurft) + REAL, INTENT(OUT), DIMENSION(land_pts) :: TOT_WB_LAKE + + !working variables + REAL :: miss = 0. + REAL, DIMENSION(LAND_PTS, nsurft) :: TOT_WB_LAKE_TILE + + !CM2 era code + !TOT_WB_LAKE_TILE = UNPACK(ssnow%totwblake, L_TILE_PTS, miss) + + !updated for CM3 + TOT_WB_LAKE_TILE = UNPACK(totwblake, L_TILE_PTS, miss) + TOT_WB_LAKE = SUM(TILE_FRAC * TOT_WB_LAKE_TILE,2) + + !zero the current integration + totwblake = 0. + +END SUBROUTINE cable_lakesrivers + + +End module cable_hyd_main_mod + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/coupled/AM3/control/cable/interface/hydrology/cable_wblake_fix.F90 b/src/coupled/AM3/control/cable/interface/hydrology/cable_wblake_fix.F90 new file mode 100644 index 000000000..e96981671 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/hydrology/cable_wblake_fix.F90 @@ -0,0 +1,19 @@ +module cable_wblake_mod + implicit none + + real :: wblake_ratio ! ratio of wblake/subroff + + real, allocatable, save :: & + WBLAKE_cable(:,:), TOT_WBLAKE_cable(:), TOT_SUBRUN_cable(:) + +contains + +subroutine cable_wblake_fix_alloc( land_points, ntiles ) + integer :: land_points, ntiles + + if(.NOT. allocated( wblake_cable ) ) & + allocate ( WBLAKE_cable(land_points,ntiles) ) + +End subroutine cable_wblake_fix_alloc + +End module cable_wblake_mod diff --git a/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_driver.F90 b/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_driver.F90 new file mode 100644 index 000000000..af137d28d --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_driver.F90 @@ -0,0 +1,249 @@ +MODULE Cable_implicit_driv_mod + +CONTAINS + +SUBROUTINE cable_implicit_driver( cycleno, numcycles, i_day_number, & + timestep, timestep_number, row_length, & + rows, land_pts, nsurft, npft, sm_levels, & + dim_cs1, mp, nrb, land_index, surft_pts, & + surft_index, l_tile_pts, ls_rain, conv_rain, & + ls_snow, conv_snow, tl_1, qw_1, ftl_1,fqw_1, & + dtl1_1, dqw1_1, ctctq1, rad, met, rough, & + canopy, veg, soil, ssnow, bal, air, bgc, & + sum_flux ) + !CPOOL_TILE, NPOOL_TILE, PPOOL_TILE, & + !GLAI, PHENPHASE) + + +!subrs called +USE cable_pack_mod, ONLY: cable_pack_rr +USE cable_cbm_module, ONLY: cbm_impl + +! data: TYPE definitions of passed asarguments +USE cable_def_types_mod, ONLY : met_type, radiation_type, veg_parameter_type, & + soil_parameter_type, roughness_type, & + canopy_type, soil_snow_type, balances_type, & + air_type, bgc_pool_type, sum_flux_type, & + climate_type + +! data: Scalars +USE cable_def_types_mod, ONLY: msn, ncs, ncp +USE cable_phys_constants_mod, ONLY: TFRZ, CAPP +USE cable_common_module, ONLY: l_casacnp, l_vcmaxFeedbk, knode_gl, & + ktau_gl, kend_gl + +USE cable_common_module, ONLY : cable_runtime, cable_user !jhan:have to sort this out for JAC + +!jhan: Leave for reference +!USE casavariable +!USE phenvariable +!USE casa_types_mod +!USE casa_um_inout_mod +!use POP_TYPES, only : pop_type +!CM3-standaloneUSE river_inputs_mod, ONLY: river_step + +!CM3 - updating CABLE-JULES rivers +USE jules_rivers_mod, ONLY: nstep_rivers + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: cycleno +INTEGER, INTENT(IN) :: numcycles +INTEGER, INTENT(IN) :: i_day_number ! day of year (1:365) counter for CASA-CNP +REAL , INTENT(IN) :: timestep ! timestep length [s] +INTEGER, INTENT(IN) :: timestep_number +INTEGER, INTENT(IN) :: row_length,rows, land_pts, nsurft, npft, sm_levels +INTEGER, INTENT(IN) :: dim_cs1 +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: nrb + +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER, INTENT(IN) :: land_index(land_pts) ! tangled cell index of land_pt +LOGICAL, INTENT(IN) :: l_tile_pts(:,:) + +REAL, INTENT(IN) :: ls_rain(row_length,rows) ! Large scale rain +REAL, INTENT(IN) :: ls_snow(row_length,rows) ! Large scale snow +REAL, INTENT(IN) :: conv_rain(row_length,rows) ! Convective rain +REAL, INTENT(IN) :: conv_snow(row_length,rows) ! Convective snow +REAL, INTENT(IN) :: tl_1(row_length,rows) ! +REAL, INTENT(IN) :: qw_1(row_length,rows) ! +REAL, INTENT(IN) :: dtl1_1(row_length,rows) ! Level 1 increment to T field +REAL, INTENT(IN) :: dqw1_1(row_length,rows) ! Level 1 increment to q field +REAL, INTENT(IN) :: ctctq1(row_length,rows) ! information needed for increment to T an q field +REAL, INTENT(IN) :: ftl_1(row_length,rows) ! sensible heat flux to layer 1 H.(W/m2) +REAL, INTENT(IN) :: fqw_1(row_length,rows) ! Moisture flux to layer 1 (kg/m^2/sec). + +TYPE(met_type), INTENT(INOUT) :: met +TYPE(radiation_type), INTENT(INOUT) :: rad +TYPE(roughness_type), INTENT(INOUT) :: rough +TYPE(soil_snow_type), INTENT(INOUT) :: ssnow +TYPE(balances_type), INTENT(INOUT) :: bal +TYPE(canopy_type), INTENT(INOUT) :: canopy +TYPE(air_type), INTENT(INOUT) :: air +TYPE(bgc_pool_type), INTENT(INOUT) :: bgc +TYPE(sum_flux_type), INTENT(INOUT) :: sum_flux +TYPE(veg_parameter_type), INTENT(INOUT) :: veg ! vegetation parameters +TYPE(soil_parameter_type), INTENT(INOUT) :: soil ! soil parameters +TYPE (climate_type) :: climate ! climate variables + +!jhan: Leave for reference +!REAL, INTENT(OUT) :: CPOOL_TILE(LAND_PTS,nsurft,10) +!REAL, INTENT(OUT) :: NPOOL_TILE(LAND_PTS,nsurft,10) +!REAL, INTENT(OUT) :: PPOOL_TILE(LAND_PTS,nsurft,12) +!REAL, INTENT(OUT) :: GLAI(LAND_PTS,nsurft) +!REAL, INTENT(OUT) :: PHENPHASE(LAND_PTS,nsurft) + +INTEGER :: & + ktauday, & ! day counter for CASA-CNP + idoy ! day of year (1:365) counter for CASA-CNP +INTEGER, SAVE :: & + kstart = 1 + +REAL :: dtl_mp(mp) +REAL :: dqw_mp(mp) +!Ticket 132 - need ctctq1, incoming values of ftl_1 and fqw_1 on tiles +REAL :: ctctq1_mp(mp) ! UM boundary layer coefficient +REAL :: ftl1_mp(mp) ! grid box averaged FTL +REAL :: fqw1_mp(mp) ! gird box averaged FQW + + REAL, DIMENSION(LAND_PTS) :: & + LYING_SNOW, & ! OUT Gridbox snowmass (kg/m2) + SUB_SURF_ROFF, & ! + SURF_ROFF, & ! + TOT_TFALL ! +!this is NA for single-site standalone +INTEGER, parameter :: river_step = 1 + +!___ local vars +!jhan: Leave for reference +!This is a quick fix. These can be organised through namelists +LOGICAL :: spinup=.FALSE., spinconv=.FALSE., & + dump_read=.FALSE., dump_write=.FALSE. +INTEGER :: loy=365, lalloc=0 + +!___ 1st call in RUN (!=ktau_gl -see below) +REAL, ALLOCATABLE:: fwork(:,:,:) +REAL :: dummy_rr(row_length,rows) + +LOGICAL, SAVE :: first_cable_call = .TRUE. +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_implicit_driver" + +!Prog Bank copies all prognostic and other variables whose +!values need to be retain from UM timestep to UM timestep. +!NOTE that canopy%cansto is a prognostic variable but is handled +!differently through the canopy%oldcansto variable + +!-------- Unique subroutine body ----------- + +dtl_mp = 0. ; dqw_mp = 0. + +!--- All these subrs do is pack a CABLE var with a UM var. +!------------------------------------------------------------------- +!--- UM met forcing vars needed by CABLE which have UM dimensions +!---(rowlength,rows)[_rr], which is no good to CABLE. These have to be +!--- re-packed in a single vector of active tiles. Hence we use +!--- conditional "mask" l_tile_pts(land_pts,nsurft) which is .true. +!--- if the land point is/has an active tile +!--- generic format: +!--- cable_pack_rr( UM var, default value for snow tile, CABLE var, mask ) +!--- where mask tells cable_pack_rr whether or not to use default value +!--- for snow tile +!------------------------------------------------------------------- + +dummy_rr(:,:) = 0.0 +dummy_rr(:,:) = ( ls_rain(:,:) + conv_rain(:,:) ) * timestep +CALL cable_pack_rr( met%precip, dummy_rr, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +dummy_rr(:,:) = 0.0 +dummy_rr(:,:) = ( ls_snow(:,:) + conv_snow(:,:) ) * timestep +CALL cable_pack_rr( met%precip_sn, dummy_rr, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%tk, TL_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%qv, QW_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( dtl_mp, dtl1_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( dqw_mp, dqw1_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +!Ticket #132 implementation +!dtl_mp, dqw_mp found on tiles above - these are the corrected dtl_mp and dqw_mp +IF (cable_user%l_revised_coupling) THEN + + CALL cable_pack_rr( ctctq1_mp, ctctq1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + + CALL cable_pack_rr( ftl1_mp, ftl_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + + CALL cable_pack_rr( fqw1_mp, fqw_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + + dtl_mp = dtl_mp - ctctq1_mp * ftl1_mp/CAPP !NB FTL_1 is in W/m2 hence / CAPP + dqw_mp = dqw_mp - ctctq1_mp * fqw1_mp + +ENDIF + +met%precip = met%precip + met%precip_sn +met%tk = met%tk + dtl_mp +met%qv = met%qv + dqw_mp +met%tvair = met%tk +met%tvrad = met%tk + +CALL cbm_impl( cycleno, numcycles, mp, nrb, timestep_number, timestep, & + air, bgc, canopy, met, bal, rad, rough, & + soil, ssnow, sum_flux, veg, climate ) + +! Integrate wb_lake over the river timestep. +! Used to scale river flow within ACCESS +! Zeroed each river step in subroutine cable_lakesriver and on restarts. +! ssnow_wb_lake in kg/m^2 +! CM3 - updated to use JULES7.x vars +if (cycleno == numcycles) THEN + ssnow%totwblake = ssnow%totwblake + ssnow%wb_lake/nstep_rivers +end if + + ! Lestevens - temporary ? + ktauday = int(24.0*3600.0/TIMESTEP) + idoy=i_day_number + + !Jan 2018: Only call carbon cycle prognostics updates on the last call to + !cable_implicit per atmospheric time step + if (cycleno==numcycles) then + !Call CASA-CNP + !CM2!if (l_casacnp) & + !CM2! CALL bgcdriver(ktau_gl,kstart,kend_gl,timestep,met,ssnow,canopy,veg,soil, & + !CM2! climate,casabiome,casapool,casaflux,casamet,casabal,phen, & + !CM2! pop, spinConv,spinup, ktauday, idoy,loy, dump_read, & + !CM2! dump_write, LALLOC) + + !CM2!CALL sumcflux(ktau_gl,kstart,kend_gl,TIMESTEP,bgc,canopy,soil,ssnow, & + !CM2! sum_flux,veg,met,casaflux,l_vcmaxFeedbk) + endif + +!GLAI = 0.0 +!PHENPHASE = 0.0 + ! Only call carbon cycle prognostics updates on the last call to + ! cable_implicit per atmospheric time step + ! Call CASA-CNP collect pools + !block!if (cycleno==numcycles .AND. l_casacnp) & + !block! CALL casa_poolout_unpk(casapool,casaflux,casamet,casabal,phen, & + !block! CPOOL_TILE,NPOOL_TILE,PPOOL_TILE, & + !block! GLAI,PHENPHASE) + + !-------- End Unique subroutine body ----------- + +!End Testing puroses: + +RETURN + +END SUBROUTINE cable_implicit_driver + +END module cable_implicit_driv_mod diff --git a/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_main.F90 b/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_main.F90 new file mode 100644 index 000000000..87e1d3e60 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_main.F90 @@ -0,0 +1,242 @@ +MODULE cable_implicit_main_mod + +CONTAINS + +SUBROUTINE Cable_implicit_main( row_length, rows, land_pts, nsurft, npft, & + sm_levels, dim_cs1, cycleno, numcycles, & + timestep, timestep_number, land_index, & + surft_pts, surft_index, & + Fland, tile_frac, smvcst, & + ls_rain, ls_snow, conv_rain, conv_snow, & + tl_1, dtl1_1, qw_1, dqw1_1, ctctq1, & + canopy_gb, canopy_surft, t_soil, & + smcl, sthf, sthu, snow_surft, & + ftl_1, ftl_surft, fqw_1, fqw_surft, le_surft, & + tstar_surft, dtstar_surft, & + surf_ht_flux_land, surf_htf_surft, & + ecan_surft, esoil_surft, ei_surft, & + radnet_surft, gs, gs_surft, & + t1p5m_surft, q1p5m_surft, melt_surft, & + NPP_gb, NPP_pft, NPP_acc_pft, GPP_gb, GPP_pft, & + resp_s, resp_s_tot, resp_p, resp_p_pft, & + g_leaf_pft, &!RESP_S_TILE, !Kathy-ed as diag + progs, work) + +!subrs called +USE cable_implicit_driv_mod, ONLY: cable_implicit_driver +USE cable_implicit_unpack_mod, ONLY: implicit_unpack +USE prognostic_bank_mod_cbl, ONLY: cable_reinstate_prognostics +USE prognostic_bank_mod_cbl, ONLY: cable_store_prognostics +USE init_active_tile_mask_mod, ONLY: init_active_tile_mask_cbl + +! data: TYPE definitions of passed asarguments +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type ! CABLE's extra progs +USE work_vars_mod_cbl, ONLY: work_vars_type ! CABLE's types etc + ! kept thru timestep +USE prognostic_bank_mod_cbl, ONLY: ProgBank + +! data: Scalars +USE cable_common_module, ONLY: knode_gl +USE grid_constants_mod_cbl, ONLY: nrb, nsnl, mp +USE grid_constants_mod_cbl, ONLY: nsCs ! # soil carbon stores +USE grid_constants_mod_cbl, ONLY: nvCs ! # vegetation carbon stores + +USE cable_common_module, ONLY : cable_runtime !jhan:have to sort this out for JAC +!jhan: Leave for reference +!# if defined(UM_JULES) +! ! CABLE prognostics declared at top_level +! USE atm_fields_real_mod, ONLY : soil_temp_cable, soil_moist_cable, & +! soil_froz_frac_cable, snow_dpth_cable, & +! snow_mass_cable, snow_temp_cable, & +! snow_rho_cable, +! snow_age_cable, snow_flg_cable, & +! aquifer_moist_cable +! ! CASA prognostics declared at top_level +! USE atm_fields_real_mod, ONLY : C_pool_casa, N_pool_casa, P_pool_casa, & +! SOIL_ORDER_casa, N_DEP_casa, N_FIX_casa, & +! P_DUST_casa, P_weath_casa, LAI_casa, & +! PHENPHASE_casa, RSP_W_PFT_ACC +! !UM: time info +! USE model_time_mod, ONLY: target_end_stepim, i_day + +! USE atmos_physics2_alloc_mod, ONLY : resp_s_tile + +# if defined(UM_JULES) +USE model_time_mod, ONLY: i_day_number +#else +USE model_time_mod, ONLY: timesteps_in_day +#endif + +IMPLICIT NONE + +!___ re-decl input args (INTENT?) +INTEGER :: row_length, rows, land_pts, nsurft, npft, sm_levels +INTEGER :: dim_cs1 +INTEGER :: cycleno, numcycles +REAL :: timestep +INTEGER :: timestep_number +INTEGER :: surft_pts(nsurft) ! # land points per tile +INTEGER :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER :: land_index(land_pts) ! tangled cell index of land_pt + +REAL :: tile_frac(land_pts, nsurft) +REAL :: Fland(land_pts) +REAL :: smvcst(land_pts,sm_levels) + ! IN Volumetric saturation point + +REAL :: ls_rain(row_length,rows) !forcing%rain precip: large scale +REAL :: ls_snow(row_length,rows) !forcing%snow precip: large scale +REAL :: conv_rain(row_length,rows) !forcing%rain precip: convective +REAL :: conv_snow(row_length,rows) !forcing%snow precip: convective + +!prog: canopy water stores +REAL :: canopy_gb(land_pts) !prog: aggregate over tiles +REAL :: canopy_surft(land_pts, nsurft) !prog: per tile + +REAL :: tl_1(row_length,rows) !forcing: temp +REAL :: qw_1(row_length,rows) !forcing: humidity +REAL :: dtl1_1(row_length,rows) !forcing: increment to temp +REAL :: dqw1_1(row_length,rows) !forcing: increment to humidity +!Ticket #132 needs ctctq1 +REAL :: ctctq1(row_length,rows) !forcing: temp/humidity increment + +REAL :: ftl_1(row_length,rows) +REAL :: fqw_1(row_length,rows) + +REAL, INTENT(OUT) :: ftl_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: fqw_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: le_surft ( land_pts, nsurft ) ! latent heat flux + +!prog: UM soil quantities, per land_pt +REAL, INTENT(OUT) :: t_soil(land_pts,sm_levels) +REAL, INTENT(OUT) :: smcl(land_pts,sm_levels) +REAL, INTENT(OUT) :: sthf(land_pts,sm_levels) +REAL, INTENT(OUT) :: sthu(land_pts,sm_levels) +REAL, INTENT(OUT) :: snow_surft( land_pts, nsurft ) ! Lying snow [kg/m2] + +REAL, INTENT(OUT) :: tstar_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: dtstar_surft( land_pts, nsurft ) + +REAL, INTENT(OUT) :: surf_htf_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: surf_ht_flux_land(row_length,rows) +REAL, INTENT(OUT) :: ecan_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: esoil_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: ei_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: radnet_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: gs_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: t1p5m_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: q1p5m_surft( land_pts, nsurft ) +REAL, INTENT(OUT) :: melt_surft( land_pts, nsurft ) + +REAL, INTENT(OUT) :: gs( land_pts ) ! conductance for use in dust scheme + +REAL, INTENT(OUT) :: npp_acc_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: npp_gb(land_pts) +REAL, INTENT(OUT) :: npp_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: gpp_gb(land_pts) +REAL, INTENT(OUT) :: gpp_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: resp_s(land_pts, dim_cs1) ! Soil respiration (kg C/m2/s) +REAL, INTENT(OUT) :: resp_s_tot(land_pts) ! Total soil resp'n (kg C/m2/s) +REAL, INTENT(OUT) :: resp_p(land_pts) +REAL, INTENT(OUT) :: resp_p_pft(land_pts,nsurft) +REAL, INTENT(OUT) :: g_leaf_pft(land_pts,npft) + +TYPE(progs_cbl_vars_type), INTENT(IN OUT) :: progs +TYPE(work_vars_type), INTENT(IN OUT) :: work + +!___ local vars +!Instantiate prognostic storage (bank) +TYPE (ProgBank) :: pb + +# if !defined(UM_JULES) +INTEGER :: i_day_number +#endif +REAL, ALLOCATABLE :: dtrad(:) +LOGICAL, ALLOCATABLE :: l_tile_pts(:,:) +LOGICAL, SAVE :: first_call = .true. +LOGICAL, SAVE :: zero_points_warning= .true. +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_implicit_main" + +IF( land_pts == 0 ) THEN + IF( zero_points_warning ) THEN + WRITE(6,*) "Reached CABLE ", subr_name, & + " even though zero land_points on processor ", knode_gl + END IF + zero_points_warning = .FALSE. + RETURN +END IF + +cable_runtime%um = .TRUE. +cable_runtime%um_implicit = .TRUE. + +! this done every call (maybe we hould pass this through work%) +!------------------------------------------------------------------------------ +! Determine the number of active tiles +mp = SUM(surft_pts) + +IF( .NOT. ALLOCATED(l_tile_pts) ) ALLOCATE( l_tile_pts(land_pts, nsurft) ) + +! Define mapping mask. i.e. l_tile_pts =TRUE (active) , where tile_frac > 0 +CALL init_active_tile_mask_cbl(l_tile_pts, land_pts, nsurft, tile_frac ) +!------------------------------------------------------------------------------ + +IF( .NOT. ALLOCATED(dtrad) ) ALLOCATE( dtrad(mp) ) + +# if !defined(UM_JULES) +i_day_number = FLOOR( REAL(timestep_number) / REAL(timesteps_in_day) ) +#endif + +!Due to ENDGAME, CABLE(any LSM) is called twice on implicit step. +CALL cable_store_prognostics( pb, mp, sm_levels, nsCs,nvCs, work%ssnow, & + work%canopy, work%bgc ) + +!jhan:check - in CM2 but left out here? do this closer to evaluation +IF (first_call ) THEN + T1P5M_surft = 0.0 + Q1P5M_surft = 0.0 +ENDIF + +CALL cable_implicit_driver( cycleno, numcycles, i_day_number, & + timestep, timestep_number, & + row_length, rows, land_pts, nsurft, npft, & + sm_levels, dim_cs1, mp, nrb, & + land_index, surft_pts, surft_index, l_tile_pts, & + ls_rain, conv_rain, ls_snow, conv_snow, & + tl_1, qw_1, ftl_1, fqw_1, dtl1_1, dqw1_1, ctctq1, & + work%rad, work%met, work%rough, work%canopy, & + work%veg, work%soil, work%ssnow, work%bal, & + work%air, work%bgc, work%sum_flux ) + !CPOOL_TILE, NPOOL_TILE, PPOOL_TILE, & + !GLAI, PHENPHASE) + +IF (cycleno .NE. numcycles ) THEN + CALL cable_reinstate_prognostics( pb, work%ssnow, work%canopy, work%bgc ) +ENDIF + +CALL implicit_unpack( cycleno, row_length, rows, land_pts, nsurft, npft, & + sm_levels, dim_cs1, timestep, mp, nsnl, land_index, & + surft_pts, surft_index, tile_frac, l_tile_pts, smvcst, & + t_soil, smcl, sthf, sthu, snow_surft, & + FTL_1, FTL_surft, FQW_1, FQW_surft, le_surft, & + TSTAR_surft, SURF_HT_FLUX_LAND, ECAN_surft, & + ESOIL_surft, EI_surft, RADNET_surft, & + canopy_surft, gs, gs_surft, t1p5m_surft, q1p5m_surft, & + canopy_gb, fland, melt_surft, & + NPP_gb, npp_pft, GPP_gb, GPP_pft, resp_s, resp_s_tot, & + RESP_P, resp_p_pft, g_leaf_pft, & + NPP_acc_pft, surf_htf_surft, & + dtstar_surft, progs, work, & + work%rad, work%met, work%rough, work%canopy, & + work%veg, work%soil, work%ssnow, work%bal, & + work%air, work%bgc, work%sum_flux ) + +first_call = .FALSE. +cable_runtime%um_implicit = .FALSE. + +RETURN + +END SUBROUTINE cable_implicit_main + +END MODULE cable_implicit_main_mod + + diff --git a/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_unpack.F90 b/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_unpack.F90 new file mode 100644 index 000000000..ff4360a0c --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/implicit/cable_implicit_unpack.F90 @@ -0,0 +1,400 @@ +MODULE cable_implicit_unpack_mod + +CONTAINS + +SUBROUTINE implicit_unpack( cycleno, row_length, rows, land_pts, nsurft, npft, & + sm_levels, dim_cs1, timestep, mp, nsnl, land_index,& + surft_pts, surft_index, tile_frac, l_tile_pts, & + smvcst, tsoil, smcl, sthf, sthu, snow_surft, & + ftl_1, ftl_tile, fqw_1, fqw_tile, le_surft, & + tstar_tile, surf_ht_flux_land, ecan_tile, & + esoil_tile, ei_tile, radnet_tile, canopy_tile, & + gs, gs_tile, t1p5m_tile, q1p5m_tile, canopy_gb, & + fland, melt_tile, npp, npp_ft, gpp, gpp_ft, & + resp_s, resp_s_tot, resp_p, resp_p_ft, g_leaf, & + npp_ft_acc, surf_htf_tile, dtstar_tile, & + progs, work, rad, met, rough, canopy, veg, soil, & + ssnow, bal, air, bgc, sum_flux ) + +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type ! CABLE requires extra progs +USE work_vars_mod_cbl, ONLY: work_vars_type ! and some kept thru timestep + +!processor number, timestep number / width, endstep +USE cable_common_module, ONLY : knode_gl, ktau_gl, kwidth_gl, kend_gl +USE cable_common_module, ONLY : cable_runtime +USE cable_common_module!, ONLY : cable_runtime, cable_user, fudge_out, & + ! L_fudge, ktau_gl +USE cable_def_types_mod, ONLY: air_type, bgc_pool_type, met_type, & + balances_type, radiation_type, roughness_type, & + soil_parameter_type, soil_snow_type, & + sum_flux_type, veg_parameter_type, canopy_type + +USE cable_phys_constants_mod, ONLY: density_liq, density_ice, tfrz + +IMPLICIT NONE + +!___ re-decl input args +INTEGER, INTENT(IN) :: cycleno +INTEGER, INTENT(IN) :: row_length,rows, land_pts, nsurft, npft, sm_levels +INTEGER, INTENT(IN) :: dim_cs1 +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: nsnl +REAL, INTENT(IN) :: timestep + +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER, INTENT(IN) :: land_index(land_pts) ! tangled cell index of land_pt +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) +LOGICAL, INTENT(IN) :: l_tile_pts(:,:) + +TYPE(progs_cbl_vars_type), INTENT(OUT) :: progs +TYPE(work_vars_type), INTENT(INOUT) :: work + +REAL, INTENT(IN) :: smvcst(land_pts,sm_levels) ! IN Volumetric saturation point + +REAL, INTENT(IN) :: fland(land_pts) ! IN Land fraction on land tiles +REAL, INTENT(OUT) :: gs(land_pts) ! OUT "Stomatal" conductance to + +!--- FQW(,1) is total water flux from surface, 'E'. +!--- Moisture flux between layers. (kg/m^2/sec). +REAL, INTENT(OUT) :: fqw_1(row_length,rows) + +!--- FTL(,K) =net turbulent sensible heat flux into layer K +!--- from below; so FTL(,1) = surface sensible heat, H.(W/m2) +REAL, INTENT(OUT) :: ftl_1(row_length,rows) + +!--- Net downward heat flux at surface over land. +!--- fraction of gridbox (W/m2). +REAL :: SURF_HT_FLUX_LAND(ROW_LENGTH,ROWS) + +REAL, INTENT(OUT) :: melt_tile(land_pts,nsurft) +REAL, INTENT(OUT) :: smcl(land_pts,sm_levels) +REAL, INTENT(OUT) :: sthf(land_pts,sm_levels) +REAL, INTENT(OUT) :: sthu(land_pts,sm_levels) +REAL, INTENT(OUT) :: tsoil(land_pts,sm_levels) +REAL, INTENT(OUT) :: snow_surft(land_pts,nsurft) +REAL, INTENT(OUT) :: le_surft( land_pts, nsurft ) ! latent heat flux + + REAL, DIMENSION(land_pts,nsurft) :: & + SURF_HTF_TILE,& + !___Surface FTL, FQL for land tiles + FTL_TILE, FQW_TILE, & + !___(tiled) latent heat flux, melting, stomatatal conductance + GS_TILE, & + RADNET_TILE, & ! INOUT Surface net radiation on tiles (W/m2) + EI_TILE, & ! OUT EI for land tiles. + ECAN_TILE, & ! OUT ECAN for snow-free land tiles + ESOIL_TILE, & ! evapotranspiration from soil moisture store (kg/m2/s) + RESP_P_FT, & ! + G_LEAF, & ! + GPP_FT, & ! + NPP_FT, & ! + NPP_FT_ACC, & ! sresp for CASA-CNP + CANOPY_TILE, & ! + T1P5M_TILE, & + Q1P5M_TILE, & + TSTAR_TILE, & + RESP_S_TILE, & + DTSTAR_TILE !change in tstar_tile over time step + + REAL, dimension(land_pts) :: & + RESP_P, & ! + NPP, & ! + GPP, & ! + SNOW_GRD, & + CANOPY_GB, & + T1P5M + + !___(tiled, 3 layer) Snow depth (m), mass, density, temp., conductivity + REAL, dimension(land_pts,nsurft) :: & + NEE_TILE + + REAL :: & + RESP_S(LAND_PTS,DIM_CS1), & ! + RESP_S_old(LAND_PTS,DIM_CS1), & ! + RESP_S_TOT(land_pts) ! + + !___ local vars + REAL :: DTRAD(mp) ! CABLE change in rad%trad over time step + + INTEGER :: i,j,l,k,n,m + !___(tiled) soil prognostics: as above + REAL :: smcl_tile(land_pts,nsurft,sm_levels) + REAL :: sthu_tile(land_pts,nsurft,sm_levels) + REAL :: sthf_tile(land_pts,nsurft,sm_levels) + REAL :: tsoil_tile(land_pts,nsurft,sm_levels) + REAL :: smcl_ln(land_pts,nsurft,sm_levels) + REAL :: sthu_ln(land_pts,nsurft,sm_levels) + REAL :: sthf_ln(land_pts,nsurft,sm_levels) + REAL :: tsoil_ln(land_pts,nsurft,sm_levels) + REAL :: SNOW_COND(land_pts,nsurft,nsnl) + + REAL :: TOT_ALB(land_pts,nsurft) ! total albedo + REAL :: RESP_W_FT_ACC(land_pts,nsurft) ! presp for CASA-CNP + REAL :: SURF_CAB_ROFF(land_pts,nsurft) + REAL :: canopy_through_UM(land_pts,nsurft) + REAL :: TOT_TFALL_TILE(land_pts,nsurft) + +TYPE(met_type) :: met +TYPE(radiation_type) :: rad +TYPE(roughness_type) :: rough +TYPE(soil_snow_type) :: ssnow +TYPE(balances_type) :: bal +TYPE(canopy_type) :: canopy +TYPE(air_type) :: air +TYPE(bgc_pool_type) :: bgc +TYPE(sum_flux_type) :: sum_flux +TYPE(veg_parameter_type) :: veg ! vegetation parameters +TYPE(soil_parameter_type) :: soil ! soil parameters + +REAL :: fe_dlh(mp) +REAL :: fes_dlh(mp) +REAL :: fev_dlh(mp) + +!--- Local buffer surface FTL, FQL @ prev dt +REAL :: ftl_tile_old(land_pts,nsurft) +REAL :: fqw_tile_old(land_pts,nsurft) + +INTEGER:: i_miss = 0 +REAL :: miss = 0.0 +INTEGER :: isnow_flg_cable(land_pts,nsurft) +REAL :: dmdA_liq +REAL :: dmdA_ice +REAL :: gpp_ft_mp(mp) + +!-------- Unique subroutine body ----------- +!jhan: should fland be applied or not? - maybe we shouldnt even be dealing with +!any i,j fields +smcl = 0.0 +sthf = 0.0 +sthu = 0.0 +tsoil = 0.0 +smcl_tile = 0.0 +sthf_tile = 0.0 +sthu_tile = 0.0 +tsoil_tile = 0.0 +snow_cond = 0.0 +!smgw_tile = 0.0 + +DO j = 1,sm_levels + + tsoil_tile(:,:,j)= UNPACK( ssnow%tgg(:,j), L_tile_pts, miss) + !liquid mass first + smcl_tile(:,:,j) = UNPACK( REAL( ssnow%wbliq(:,j)), L_tile_pts, miss) + smcl_tile(:,:,j) = smcl_tile(:,:,j) * soil%zse(j) * density_liq + !ice volumetric + sthf_tile(:,:,j) = UNPACK( REAL( ssnow%wbice(:,j)), L_tile_pts, miss) + +ENDDO ! SM_LEVELS + +DO j = 1,sm_levels + !calcualte sthu_tilebefore smcl_tile incoudes ice mass + DO N=1,Nsurft + + DO K=1,surft_PTS(N) + + I = surft_INDEX(K,N) + + ! Exclude permanent ice + IF ( SMVCST(I,j) > 0. ) & !liq mass relaative to max + STHU_TILE(I,N,J)= MAX( 0., SMCL_TILE(I,N,J) / & + (soil%zse(j)*SMVCST(I,j)*density_liq ) ) + + !add ice mass to liq mass + SMCL_TILE(I,N,j) = SMCL_TILE(I,N,j) + & + STHF_TILE(I,N,j) * soil%zse(j) * density_ice + !relative ice vol + IF ( SMVCST(I,j) > 0. ) & + STHF_TILE(I,N,j)= STHF_TILE(I,N,j)/SMVCST(I,j) + + ENDDO ! TILE_PTS(N) + + ENDDO ! NTILES + + SMCL(:,j) = SUM(TILE_FRAC * SMCL_TILE(:,:,j),2) + TSOIL(:,j) = SUM(TILE_FRAC * TSOIL_TILE(:,:,j),2) + + STHF(:,J) = SUM(TILE_FRAC * STHF_TILE(:,:,J),2) + STHU(:,J) = SUM(TILE_FRAC * STHU_TILE(:,:,J),2) + +ENDDO ! SM_LEVELS + + +progs%SoilMoisture_CABLE(:,:,:) = smcl_tile(:,:,:) +progs%FrozenSoilFrac_CABLE(:,:,:) = sthf_tile(:,:,:) +progs%SoilTemp_CABLE(:,:,:) = tsoil_tile(:,:,:) + +isnow_flg_cable = UNPACK(ssnow%isflag, L_TILE_PTS, i_miss) +progs%OneLyrSnowDensity_CABLE = UNPACK(ssnow%ssdnn, l_tile_pts, miss) +progs%ThreeLayerSnowFlag_CABLE(:,:) = REAL( isnow_flg_cable(:,:) ) + +!--- unpack layered snow vars +DO k = 1,3 + progs%SnowTemp_CABLE(:,:,k) = UNPACK(ssnow%tggsn(:,k), L_TILE_PTS, miss) + progs%SnowMass_CABLE(:,:,k) = UNPACK(ssnow%smass(:,k), L_TILE_PTS, miss) + progs%SnowDensity_CABLE(:,:,k) = UNPACK(ssnow%ssdn(:,k), L_TILE_PTS, miss) + progs%SnowDepth_CABLE(:,:,k) = UNPACK(ssnow%sdepth(:,k),L_TILE_PTS,miss) + progs%SnowAge_CABLE(:,:) = UNPACK(ssnow%snage, L_TILE_PTS, miss) + !snow_cond(:,:,k) = UNPACK(ssnow%sconds(:,k),L_TILE_PTS,miss)i !this + !doesn't go anywhere +END DO + +!--- unpack snow vars +melt_tile = UNPACK(ssnow%smelt, l_tile_pts, miss) +snow_surft = UNPACK(ssnow%snowd, l_tile_pts, miss) +snow_grd = SUM(tile_frac * snow_surft,2) ! gridbox snow mass & snow below canopy + +work%lying_snow(:) = snow_grd(:) !jh:this sis done twice AND differently +canopy%gswx_T = canopy%gswx_T/air%cmolar +gs_tile = UNPACK(canopy%gswx_T,L_TILE_PTS,miss) +gs = SUM(tile_frac * GS_TILE,2) + +!---preserve fluxes from the explicit step for the coastal grids +ftl_tile_old = ftl_tile +fqw_tile_old = fqw_tile + +fes_dlh = canopy%fes / ( air%rlam * ssnow%cls ) +fev_dlh = canopy%fev / air%rlam +fe_dlh = fev_dlh + fes_dlh + +ftl_tile = UNPACK(canopy%fh, l_tile_pts, miss) +le_surft = UNPACK(canopy%fe, l_tile_pts, miss) +fqw_tile = UNPACK(fe_dlh, l_tile_pts, miss) + +!retain sea/ice contribution and remove land contribution j +!anymore +DO n=1,nsurft + DO k=1,surft_pts(n) + l = surft_index(K,N) + j=(land_index(l)-1)/row_length + 1 + i = land_index(l) - (j-1)*row_length + + IF( fland(l) == 1.0) THEN + ftl_1(i,j) = 0.0 + fqw_1(i,j) = 0.0 + ELSE + ftl_1(i,j) = ftl_1(i,j) - ( fland(l)* tile_frac(l,n) * ftl_tile_old(l,n) ) + fqw_1(i,j) = fqw_1(i,j) - ( fland(l)* tile_frac(l,n) * fqw_tile_old(l,n) ) + ENDIF + + ENDDO !surft_pts(n) +ENDDO !nsurft +!update with this ftl +DO n=1,nsurft + DO k=1,surft_pts(n) + l = surft_index(K,N) + j=(land_index(l)-1)/row_length + 1 + i = land_index(l) - (j-1)*row_length + + ftl_1(i,j) = ftl_1(i,j) + ( fland(l)* tile_frac(l,n) * ftl_tile(l,n) ) + fqw_1(i,j) = fqw_1(i,j) + ( fland(l)* tile_frac(l,n) * fqw_tile(l,n) ) + + ENDDO !surft_pts(n) +ENDDO !nsurft + +tstar_tile = UNPACK(rad%trad, l_tile_pts, miss) +radnet_tile = UNPACK( canopy%rnet , l_tile_pts, miss) +ecan_tile = UNPACK(fev_dlh, L_TILE_PTS, miss) + +! need to split %fes into evaporation and sublimation +fes_dlh = 0. +WHERE (ssnow%cls==1.) fes_dlh = canopy%fes/(air%rlam*ssnow%cls) +esoil_tile = UNPACK(fes_dlh, L_tile_pts, miss) + +fes_dlh = 0. +WHERE (ssnow%cls==1.1335) fes_dlh = canopy%fes/(air%rlam*ssnow%cls) +ei_tile = UNPACK(fes_dlh, L_TILE_PTS, miss) + +dtrad = rad%trad - rad%otrad +dtstar_tile = UNPACK(dtrad, L_tile_pts, miss) + +!CM3 - internal diag only +!CM3 TRANSP_TILE = UNPACK(canopy%fevc, L_TILE_PTS, miss) +tot_alb = UNPACK(rad%albedo_T,L_TILE_PTS, miss) + +!unpack screen level (1.5m) variables - Convert back to K +t1p5m_tile = UNPACK(canopy%tscrn+tfrz, L_TILE_PTS, miss) +q1p5m_tile = UNPACK(canopy%qscrn, L_TILE_PTS, miss) + +canopy_tile = UNPACK(canopy%cansto, L_TILE_PTS, miss) +canopy_gb = SUM(tile_frac * canopy_tile,2) !fland? + + +!initialse full land grids and retain coastal grid fluxes +!initialse full land grids and retain coastal grid fluxes + +surf_htf_tile = UNPACK(canopy%ga,L_TILE_PTS,miss) +surf_ht_flux_land(:,:) = 0. +!fland? +DO n=1,nsurft + DO K=1,surft_pts(N) + + l = surft_index(K,N) + j=(land_index(l)-1)/row_length + 1 + i = land_index(l) - (j-1)*row_length + + surf_ht_flux_land(i,j) = surf_ht_flux_land(i,j) + & + tile_frac(l,n) * surf_htf_tile(l,n) + + ENDDO +ENDDO + +! Initialise grid-cell carbon fields that are accumulated over tiles +resp_p = 0.; npp = 0.; gpp = 0.; resp_s = 0. + +resp_s_tile = UNPACK(canopy%frs, L_tile_pts, miss) !see ISSUE#51 +nee_tile = UNPACK(canopy%fnee, L_tile_pts, miss) +npp_ft = UNPACK(canopy%fnpp, L_tile_pts, miss) +g_leaf = UNPACK(canopy%frday,L_tile_pts, miss) +resp_p_ft = UNPACK(canopy%frp, L_tile_pts, miss) +gpp_ft_mp = canopy%fnpp + canopy%frp + canopy%frday +gpp_ft = UNPACK(gpp_ft_mp, L_tile_pts, miss) + +! convert from CABLE units (gC/m2/s) to UM units (kgC/m2/s) +resp_s_tile = resp_s_tile * 1.e-3 +g_leaf = g_leaf * 1.e-3 +npp_ft = npp_ft * 1.e-3 +gpp_ft = gpp_ft * 1.e-3 +resp_p_ft = resp_p_ft * 1.e-3 + +! If CASA-CNP used, plant and soil resp need to be passed into +! variables that are dumped to restart, because CASA-CNP only run daily +npp_ft_acc = resp_s_tile !see ISSUE#51 +resp_w_ft_acc = resp_p_ft !see ISSUE#51 +!fland ? +DO n=1,nsurft + DO k=1,surft_pts(N) + l = surft_index(K,N) + npp(l)=npp(l)+fland(l)*tile_frac(l,n)*npp_ft(l,n) + gpp(l)=gpp(l)+fland(l)*tile_frac(l,n)*gpp_ft(l,n) + resp_p(l)=resp_p(l)+fland(l)*tile_frac(l,n)*resp_p_ft(l,n) + + !loop for soil resp. although DIM_CS1=1 (not 1 for triffid) + DO i=1,dim_cs1 + resp_s(l,i) = resp_s(l,i) + & + fland(l)*tile_frac(l,n)*resp_s_tile(l,n) + ENDDO + resp_s_tot(l)=SUM(resp_s(l,:)) !in CM2 this doesnt actually do anything !see ISSUE#51 + t1p5m(L)=SUM(t1p5m_tile(L,:)) + ENDDO +ENDDO +!jhan?fland? +work%lying_snow = SUM(TILE_FRAC * snow_surft,2) !gridbox snow mass + +surf_cab_roff = UNPACK(ssnow%rnof1, L_tile_pts, miss) +work%surf_roff = SUM(tile_frac * surf_cab_roff,2) + +surf_cab_roff = UNPACK(ssnow%rnof2, L_TILE_PTS, miss) +work%sub_surf_roff = SUM(tile_frac * surf_cab_roff,2) + +! %through is /dels in UM app. for STASH output +canopy_through_UM = UNPACK(canopy%through, L_tile_pts, miss) +tot_tfall_tile = canopy_through_UM / timestep +work%tot_tfall = SUM(tile_frac * tot_tfall_tile,2) + + +RETURN + +END SUBROUTINE Implicit_unpack + +End module cable_implicit_unpack_mod diff --git a/src/coupled/AM3/control/cable/interface/implicit/cbl_prognostic_bank.F90 b/src/coupled/AM3/control/cable/interface/implicit/cbl_prognostic_bank.F90 new file mode 100644 index 000000000..ec5b0f866 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/implicit/cbl_prognostic_bank.F90 @@ -0,0 +1,167 @@ +MODULE prognostic_bank_mod_cbl + +TYPE ProgBank + + REAL, DIMENSION(:,:), ALLOCATABLE :: & + tsoil, smcl, sthf, & + snow_depth, & + snow_mass, snow_tmp, snow_rho , & + sli_s, sli_tsoil, sli_sconds, sli_snowliq, & + cplant, csoil !carbon variables + + REAL, DIMENSION(:), ALLOCATABLE :: & + snow_rho1l, snow_age, snow_tile, & + ocanopy, & + fes_cor,fhs_cor, osnowd,owetfac,otss,gwwb,tss0, & + puddle, rtsoil, wblake, gwaq, & + sli_h0, sli_tsurf + + INTEGER, DIMENSION(:), ALLOCATABLE :: & + snow_flg3l, sli_nsnow + +END TYPE ProgBank + +CONTAINS + +SUBROUTINE cable_store_prognostics( pb, mp, nsl, nsCs,nvCs, ssnow, canopy, bgc ) + +USE cable_common_module, ONLY: cable_user +USE cable_def_types_mod, ONLY: soil_snow_type, bgc_pool_type +USE cable_canopy_type_mod, ONLY: canopy_type + +IMPLICIT NONE +INTEGER, INTENT(IN) :: mp ! # active tiles +INTEGER, INTENT(IN) :: nsl ! # soil layers +INTEGER, INTENT(IN) :: nsCs ! # soil carbon stores +INTEGER, INTENT(IN) :: nvCs ! # vegetation carbon stores + +TYPE (ProgBank), INTENT(INOUT):: pb +TYPE(soil_snow_type), INTENT(INOUT) :: ssnow +TYPE(canopy_type), INTENT(INOUT) :: canopy +TYPE(bgc_pool_type), INTENT(INOUT) :: bgc + +IF (.NOT. ALLOCATED(pb%tsoil) ) then + + ALLOCATE( pb%tsoil(mp,nsl) ) + ALLOCATE( pb%smcl(mp,nsl) ) + ALLOCATE( pb%sthf(mp,nsl) ) + ALLOCATE( pb%snow_depth(mp,3) ) + ALLOCATE( pb%snow_mass(mp,3) ) + ALLOCATE( pb%snow_tmp(mp,3) ) + ALLOCATE( pb%snow_rho(mp,3) ) + ALLOCATE( pb%snow_rho1l(mp) ) + ALLOCATE( pb%snow_age(mp) ) + ALLOCATE( pb%snow_flg3l(mp) ) + ALLOCATE( pb%snow_tile(mp) ) + ALLOCATE( pb%puddle(mp) ) + ALLOCATE( pb%owetfac(mp) ) + ALLOCATE( pb%rtsoil(mp) ) + ALLOCATE( pb%wblake(mp) ) + ALLOCATE(pb%tss0(mp) ) + ALLOCATE( pb%ocanopy(mp) ) + ALLOCATE( pb%fes_cor(mp) ) + !carbon variables - may not be needed unless CASA + ALLOCATE( pb%cplant(mp,nvcs) ) + ALLOCATE( pb%csoil(mp,nscs) ) + !GW model variables no need to test always has a value + !so do not introduce issues with restarting a GW run + ALLOCATE (pb%GWaq(mp) ) + + !SLI variables - Jhan please check the second dimension + IF (cable_user%soil_struc=='sli') THEN + ALLOCATE(pb%sli_nsnow(mp) ) + ALLOCATE(pb%sli_s(mp,nsl) ) + ALLOCATE(pb%sli_tsoil(mp,nsl) ) + ALLOCATE(pb%sli_sconds(mp,3) ) + ALLOCATE(pb%sli_h0(mp) ) + ALLOCATE(pb%sli_tsurf(mp) ) + ALLOCATE(pb%sli_snowliq(mp,3) ) + ENDIF + +ENDIF !.NOT. allocated + +pb%tsoil = ssnow%tgg +pb%smcl = ssnow%wb +pb%sthf = ssnow%wbice +pb%snow_depth = ssnow%sdepth +pb%snow_mass = ssnow%smass +pb%snow_tmp = ssnow%tggsn +pb%snow_rho = ssnow%ssdn +pb%snow_rho1l = ssnow%ssdnn +pb%snow_age = ssnow%snage +pb%snow_flg3l = ssnow%isflag +pb%snow_tile = ssnow%snowd +pb%puddle = ssnow%pudsto +pb%rtsoil = ssnow%rtsoil !?needed in restart? +pb%owetfac = ssnow%owetfac +pb%wblake = ssnow%wb_lake +pb%tss0 = ssnow%tss +pb%ocanopy = canopy%oldcansto +pb%fes_cor = canopy%fes_cor +pb%cplant = bgc%cplant ! may not be needed unless CASA +pb%csoil = bgc%csoil ! may not be needed unless CASA +pb%gwaq = ssnow%gwwb !GW model ?issues with restarting? + +!SLI variables +IF (cable_user%soil_struc=='sli') THEN + pb%sli_nsnow = ssnow%nsnow + pb%sli_s = ssnow%s + pb%tsoil = ssnow%tsoil + pb%sli_sconds = ssnow%sconds + pb%sli_h0 = ssnow%h0 + pb%sli_Tsurf = ssnow%tsurface + pb%sli_snowliq = ssnow%snowliq +ENDIF + +RETURN +END SUBROUTINE cable_store_prognostics + +SUBROUTINE cable_reinstate_prognostics( pb, ssnow, canopy, bgc ) + +USE cable_def_types_mod, ONLY: soil_snow_type, bgc_pool_type +USE cable_canopy_type_mod, ONLY: canopy_type +USE cable_common_module, ONLY: cable_user + +IMPLICIT NONE +TYPE (ProgBank), INTENT(INOUT) :: pb +TYPE(soil_snow_type), INTENT(INOUT) :: ssnow +TYPE(canopy_type), INTENT(INOUT) :: canopy +TYPE(bgc_pool_type), INTENT(INOUT) :: bgc + +ssnow%tgg = pb%tsoil +ssnow%wb = pb%smcl +ssnow%wbice = pb%sthf +ssnow%sdepth = pb%snow_depth +ssnow%smass = pb%snow_mass +ssnow%tggsn = pb%snow_tmp +ssnow%ssdn = pb%snow_rho +ssnow%ssdnn = pb%snow_rho1l +ssnow%snage = pb%snow_age +ssnow%isflag = pb%snow_flg3l +ssnow%snowd = pb%snow_tile +ssnow%pudsto = pb%puddle +ssnow%rtsoil = pb%rtsoil !?needed +ssnow%owetfac = pb%owetfac +ssnow%wb_lake = pb%wblake +ssnow%tss = pb%tss0 +canopy%oldcansto = pb%ocanopy +canopy%fes_cor = pb%fes_cor +bgc%cplant = pb%cplant ! may not be needed unless CASA +bgc%csoil = pb%csoil ! may not be needed unless CASA +ssnow%GWwb = pb%GWaq! GW model variables + +!SLI variables +IF (cable_user%soil_struc=='sli') THEN + ssnow%nsnow = pb%sli_nsnow + ssnow%S = pb%sli_s + ssnow%Tsoil = pb%sli_tsoil + ssnow%sconds = pb%sli_sconds + ssnow%h0 = pb%sli_h0 + ssnow%Tsurface = pb%sli_tsurf + ssnow%snowliq = pb%sli_snowliq +ENDIF + +RETURN +END SUBROUTINE cable_reinstate_prognostics + +END MODULE prognostic_bank_mod_cbl diff --git a/src/coupled/AM3/control/cable/interface/radiation/rad_driver_cbl.F90 b/src/coupled/AM3/control/cable/interface/radiation/rad_driver_cbl.F90 new file mode 100644 index 000000000..29befd375 --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/radiation/rad_driver_cbl.F90 @@ -0,0 +1,192 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE cable_rad_driv_mod + +!----------------------------------------------------------------------------- +! Description: +! Initialises radiation specific variables and computes the albedo for +! CABLE. +! +! This MODULE is USEd in: +! cable_land_albedo_mod_cbl.F90 (JULES) +! +! This MODULE contains 1 public Subroutine: +! cable_rad_driver +! +! Code owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE +PUBLIC :: cable_rad_driver + +CONTAINS + +SUBROUTINE cable_rad_driver( EffSurfRefl_beam, EffSurfRefl_dif, land_pts, & + mp, nrb, ICE_SoilType, lakes_type, Clai_thresh, & + Ccoszen_tols, CGauss_w, Cpi, Cpi180, z0surf_min, & + veg_mask, jls_standalone, jls_radiation, & + SurfaceType, SoilType, & + LAI_pft_cbl, HGT_pft_cbl, SnowDepth, & + SnowDensity, SoilTemp, SnowAge, AlbSoil, & + coszen, VegXfang, VegTaul, VegRefl, & + HeightAboveSnow, reducedLAIdue2snow, & + ExtCoeff_beam, ExtCoeff_dif, EffExtCoeff_beam, & + EffExtCoeff_dif, CanopyTransmit_beam, & + CanopyTransmit_dif, CanopyRefl_beam, & + CanopyRefl_dif, c1, rhoch, xk, AlbSnow, RadFbeam, & + RadAlbedo, metDoY, SW_down ) + +! Description: +! Nothing further to add to module description. + +!subrs: +USE cbl_albedo_mod, ONLY: albedo +USE cbl_init_radiation_module, ONLY: init_radiation +USE cable_common_module, ONLY : cable_runtime +USE UM_ParCore, ONLY: mype + +IMPLICIT NONE + +!model dimensions +INTEGER, INTENT(IN) :: land_pts !# land points on x,y grid +INTEGER, INTENT(IN) :: mp ! total number of "tiles" (calc. in cable_land) +INTEGER, INTENT(IN) :: nrb ! # radiation bands[ 1=VIS,2=NIR,3=LW(legacy) + +! Albedos req'd by JULES - Effective Surface Relectance as seen by atmosphere +REAL, INTENT(OUT) :: EffSurfRefl_dif(mp,nrb) ! Refl to Diffuse component of rad + ! formerly rad%reffdf +REAL, INTENT(OUT) :: EffSurfRefl_beam(mp,nrb) ! Refl to Beam component of rad + ! formerly rad%reffbm + +!--- IN: CABLE specific surface_type indexes +INTEGER, INTENT(IN) :: ICE_SoilType +INTEGER, INTENT(IN) :: lakes_type + +!constants +REAL, INTENT(IN) :: Ccoszen_tols ! threshold cosine of sun's zenith angle, + ! below which considered SUNLIT +REAL, INTENT(IN) :: Cgauss_w(nrb) ! Gaussian integration weights +REAL, INTENT(IN) :: Clai_thresh ! The minimum LAI below which a "cell" is + ! considred NOT vegetated +REAL, INTENT(IN) :: Cpi ! PI +REAL, INTENT(IN) :: Cpi180 ! PI in radians +REAL, INTENT(IN) :: z0surf_min ! the minimum roughness of bare soil + +LOGICAL, INTENT(IN) :: jls_standalone ! local runtime switch for JULES(/UM) run +LOGICAL, INTENT(IN) :: jls_radiation ! local runtime switch for radiation path + +!masks +LOGICAL, INTENT(IN) :: veg_mask(:) ! vegetated (uses min LAI) + +!recieved as spatial maps from the UM. remapped to "mp" +REAL, INTENT(IN) :: LAI_pft_cbl(mp) ! LAI - "limited" and remapped +REAL, INTENT(IN) :: HGT_pft_cbl(mp) ! canopy height - "limited", remapped +REAL, INTENT(IN) :: coszen(mp) ! cosine zenith angle (met%coszen) +REAL, INTENT(IN) :: AlbSoil(mp, nrb) ! soil%AlbSoil + +!computed for CABLE model +REAL, INTENT(IN):: HeightAboveSnow(mp) ! Height of Canopy above snow + ! (rough%hruff) computed from + ! z0surf_min, HGT_pft_cbl, + ! SnowDepth, SnowDensity +REAL, INTENT(IN) :: reducedLAIdue2snow(mp) ! Reduced LAI given snow coverage + +!Prognostics !recieved as spatial maps from the UM. remapped to "mp" +REAL, INTENT(IN) :: SnowDepth(mp) ! Total Snow depth - water eqivalent - + ! packed from snow_surft (ssnow%snowd) + ! this timestep (ssnow%Osnowd) +REAL, INTENT(IN) :: SnowDensity(mp) ! Total Snow density (assumes 1 layer + ! describes snow cover) (ssnow%ssdnn) +REAL, INTENT(IN) :: SoilTemp(mp) ! Soil Temperature of top layer (soil%tgg) +REAL, INTENT(IN) :: SnowAge(mp) ! Snow age (assumes 1 layer describes snow + ! cover) (ssnow%snage) + +!Vegetation parameters !recieved as per PFT params from the UM. remapped to "mp" +INTEGER, INTENT(IN) :: SurfaceType(mp) +INTEGER, INTENT(IN) :: SoilType(mp) +REAL, INTENT(IN) :: VegXfang(mp) ! leaf angle PARAMETER (veg%xfang) +REAL, INTENT(IN) :: VegTaul(mp,nrb) ! PARAM leaf transmisivity (veg%taul) +REAL, INTENT(IN) :: VegRefl(mp,nrb) ! PARAM leaf reflectivity (veg%refl) + +!local to Rad/Albedo pathway: +REAL, INTENT(IN OUT) :: ExtCoeff_beam(mp) ! nee. rad%extkb, +REAL, INTENT(IN OUT) :: ExtCoeff_dif(mp) ! nee. rad%extkd +REAL, INTENT(IN OUT) :: EffExtCoeff_beam(mp, nrb) ! nee. rad%extkbm +REAL, INTENT(IN OUT) :: EffExtCoeff_dif(mp, nrb) ! nee. rad%extkdm, +REAL, INTENT(IN OUT) :: CanopyTransmit_dif(mp, nrb) ! nee. rad%cexpkdm +REAL, INTENT(IN OUT) :: CanopyTransmit_beam(mp, nrb) ! nee. rad%cexpkbm +REAL, INTENT(IN OUT) :: CanopyRefl_dif(mp, nrb) ! nee. rad%rhocdf +REAL, INTENT(IN OUT) :: CanopyRefl_beam(mp, nrb) ! nee. rad%rhocbm +REAL, INTENT(IN OUT) :: RadFbeam(mp, nrb) ! nee. rad%fbeam +REAL, INTENT(IN OUT) :: RadAlbedo(mp, nrb) ! nee. rad%albedo +REAL, INTENT(IN OUT) :: AlbSnow(mp, nrb) ! nee. ssnow%AlbSoilsn +REAL, INTENT(IN OUT) :: c1(mp, nrb) ! common rad scalings +REAL, INTENT(IN OUT) :: rhoch(mp, nrb) ! common rad scalings +REAL, INTENT(IN OUT) :: xk(mp, nrb) ! common rad scalings +! used in Calc of Beam calculation NOT on rad/albedo path. +! However Needed to fulfill arg list with dummy +INTEGER, INTENT(IN OUT) :: metDoY(mp) ! can pass DoY from current_time +REAL, INTENT(IN OUT) :: SW_down(mp, nrb) ! NA at surf_couple_rad layer + +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_rad_driver" +LOGICAL :: cbl_standalone = .FALSE. +LOGICAL, SAVE :: zero_points_warning = .true. + +IF( land_pts == 0 ) THEN + IF( zero_points_warning ) THEN + WRITE(6,*) "Reached CABLE ", subr_name, & + " even though zero land_points on processor ", mype + END IF + zero_points_warning = .FALSE. + RETURN +END IF + +cable_runtime%um = .TRUE. +cable_runtime%um_radiation = .TRUE. + +!Defines Extinction Coefficients to use in calculation of Canopy +!Reflectance/Transmitance. +CALL init_radiation( ExtCoeff_beam, ExtCoeff_dif, EffExtCoeff_beam, & + EffExtCoeff_dif, RadFbeam, c1, rhoch, xk, & + mp,nrb, Clai_thresh, Ccoszen_tols, CGauss_w, Cpi, Cpi180, & + cbl_standalone, jls_standalone, jls_radiation, subr_name, & + veg_mask, VegXfang, VegTaul, VegRefl, coszen, metDoY, & + SW_down, reducedLAIdue2snow ) + +!Finally call albedo to get what we really need to fulfill contract with JULES +!Defines 4-stream albedos [VIS/NIR bands. direct beam/diffuse components] from +!considering albedo of Ground (snow?) and Canopy Reflectance/Transmitance. +CALL Albedo( AlbSnow, AlbSoil, & + mp, nrb, ICE_SoilType, lakes_type, jls_radiation, veg_mask, & + Ccoszen_tols, cgauss_w, & + SurfaceType, SoilType ,VegRefl, VegTaul, & + coszen, reducedLAIdue2snow, & + SnowDepth, SnowDensity, SoilTemp, SnowAge, & + xk, c1, rhoch, & + RadFbeam, RadAlbedo, & + ExtCoeff_beam, ExtCoeff_dif, & + EffExtCoeff_beam, EffExtCoeff_dif, & + CanopyRefl_beam, CanopyRefl_dif, & + CanopyTransmit_beam, CanopyTransmit_dif, & + EffSurfRefl_beam, EffSurfRefl_dif) + +cable_runtime%um_radiation = .FALSE. +RETURN + +END SUBROUTINE cable_rad_driver + +END MODULE cable_rad_driv_mod + diff --git a/src/coupled/AM3/control/cable/interface/radiation/rad_unpack_cbl.F90 b/src/coupled/AM3/control/cable/interface/radiation/rad_unpack_cbl.F90 new file mode 100644 index 000000000..5bbe78c9b --- /dev/null +++ b/src/coupled/AM3/control/cable/interface/radiation/rad_unpack_cbl.F90 @@ -0,0 +1,137 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE cable_rad_unpack_mod + +!----------------------------------------------------------------------------- +! Description: +! Unpack JULES variables into CABLE variables as needed for the +! radiation calculations. +! +! This MODULE is USEd in: +! cable_land_albedo_mod_cbl.F90 (JULES) +! +! This MODULE contains 1 public Subroutine: +! cable_rad_unpack +! +! Code owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE +PUBLIC :: cable_rad_unpack + +CONTAINS + +SUBROUTINE cable_rad_unpack( land_albedo, alb_surft, & + mp, nrs, row_length, rows, land_pts, & + nsurft, tile_pts, tile_index, & + land_index, tile_frac, L_tile_pts, & + EffSurfRefl_beam, EffSurfRefl_dif) + +! Description: +! Nothing further to add to module description. + +IMPLICIT NONE + +! Model(field) dimensions +INTEGER, INTENT(IN) :: mp !total number of "tiles" +INTEGER, INTENT(IN) :: nrs !# rad bands VIS,NIR. 3rd WAS LW +INTEGER, INTENT(IN) :: row_length !grid cell x +INTEGER, INTENT(IN) :: rows !grid cell y +INTEGER, INTENT(IN) :: land_pts !grid cell land points -x,y grid +INTEGER, INTENT(IN) :: nsurft !grid cell # surface types + +! Return Albedos CABLE to fulfill contract with JULES +REAL, INTENT(OUT) :: land_albedo(row_length,rows,nrs) +REAL, INTENT(OUT) :: alb_surft(land_pts,nsurft,nrs) + +! Inherited dimensions from JULES +INTEGER, INTENT(IN) :: tile_pts(nsurft) !Number of land points per PFT +INTEGER, INTENT(IN) :: land_index(land_pts) !land point Index in (x,y) array +INTEGER, INTENT(IN) :: tile_index(land_pts,nsurft) !Index of land point in (land_pts) array + +!recieved as spatial maps from the UM. +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) !fraction of each surface type per land point +LOGICAL, INTENT(IN) :: L_tile_pts( land_pts, nsurft ) !mask:=TRUE where tile_frac>0, else FALSE. pack mp according to this mask + +! Albedos +REAL, INTENT(IN) :: EffSurfRefl_beam(mp,nrs) !Effective Surface Relectance as seen by atmosphere [Direct Beam SW] (rad%reffbm) +REAL, INTENT(IN) :: EffSurfRefl_dif(mp,nrs) !Effective Surface Relectance as seen by atmosphere [Diffuse SW] (rad%reffdf) + +!___ local vars +INTEGER :: i,j,k,l,n +REAL :: miss = 0.0 + +! std template args +CHARACTER(LEN=*), PARAMETER :: subr_name = "cable_rad_unpack" +REAL :: Sumreffbm(mp) +REAL :: Sumreffdf(mp) + +! UNPACK Albedo (per rad stream) per surface tile +alb_surft(:,:,:) = 0.0 ! guarantee flushed +! Direct beam, visible / near-IR +alb_surft(:,:,1) = UNPACK(EffSurfRefl_beam(:,1),l_tile_pts, miss) +alb_surft(:,:,3) = UNPACK(EffSurfRefl_beam(:,2),l_tile_pts, miss) +! Diffuse, visible / near-IR +alb_surft(:,:,2) = UNPACK(EffSurfRefl_dif(:,1),l_tile_pts, miss) +alb_surft(:,:,4) = UNPACK(EffSurfRefl_dif(:,2),l_tile_pts, miss) + +! ERROR trap: Model stopped as albedo is unphysical +DO i = 1,land_pts + DO j = 1,nsurft + + IF ( alb_surft(i,j,1) > 1.0 .OR. alb_surft(i,j,1) < 0.0) THEN + WRITE(6,*) 'albedo(i,j,1) is unphysical ',alb_surft(i,j,1) + STOP 'CABLE ERROR' + ELSE IF ( alb_surft(i,j,2) > 1.0 .OR. alb_surft(i,j,2) < 0.0) THEN + WRITE(6,*) 'albedo(i,j,2) is unphysical ',alb_surft(i,j,2) + STOP 'CABLE ERROR' + ELSE IF ( alb_surft(i,j,3) > 1.0 .OR. alb_surft(i,j,3) < 0.0) THEN + WRITE(6,*) 'albedo(i,j,3) is unphysical ',alb_surft(i,j,3) + STOP 'CABLE ERROR' + ELSE IF ( alb_surft(i,j,4) > 1.0 .OR. alb_surft(i,j,4) < 0.0) THEN + WRITE(6,*) 'albedo(i,j,4) is unphysical ',alb_surft(i,j,4) + STOP 'CABLE ERROR' + END IF + + END DO +END DO + +! Aggregate albedo (per rad stream) OVER surface tiles to get per cell value +land_albedo(:,:,:) = 0.0 ! guarantee flushed +DO n = 1,nsurft + DO k = 1,tile_pts(n) + + l = tile_index(k,n) + j=(land_index(l) - 1) / row_length + 1 + i = land_index(l) - (j-1) * row_length + + ! Direct beam, visible + land_albedo(i,j,1) = land_albedo(i,j,1) + tile_frac(l,n) * ALB_surft(l,n,1) + ! Diffuse, visible + land_albedo(i,j,2) = land_albedo(i,j,2) + tile_frac(l,n) * ALB_surft(l,n,2) + ! Direct beam, nearinfrared + land_albedo(i,j,3) = land_albedo(i,j,3) + tile_frac(l,n) * ALB_surft(l,n,3) + ! Diffuse, nearinfrared + land_albedo(i,j,4) = land_albedo(i,j,4) + tile_frac(l,n) * ALB_surft(l,n,4) + + END DO +END DO + +RETURN + +END SUBROUTINE cable_rad_unpack + +END MODULE cable_rad_unpack_mod diff --git a/src/coupled/AM3/control/cable/shared/LAI_canopy_height_cbl.F90 b/src/coupled/AM3/control/cable/shared/LAI_canopy_height_cbl.F90 new file mode 100644 index 000000000..2d305c0ab --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/LAI_canopy_height_cbl.F90 @@ -0,0 +1,100 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE cbl_LAI_canopy_height_mod + +!----------------------------------------------------------------------------- +! Description: +! Restricts the range of canopy height and LAI inherited from JULES/UM +! spatial maps +! +! This MODULE is USEd by: +! cable_land_albedo_mod_cbl.F90 +! +! This MODULE contains 1 public Subroutine: +! limit_HGT_LAI +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE +PUBLIC :: limit_HGT_LAI +PRIVATE + +CONTAINS + +SUBROUTINE limit_HGT_LAI( LAI_pft_cbl, HGT_pft_cbl, mp, land_pts, ntiles, & + npft, tile_pts, tile_index, tile_frac,L_tile_pts, & + LAI_pft, HGT_pft, CLAI_thresh ) + +! Description: +! Nothing further to add to module description. + +IMPLICIT NONE +INTEGER, INTENT(IN) :: mp +REAL, INTENT(OUT) :: LAI_pft_cbl(mp) +REAL, INTENT(OUT) :: HGT_pft_cbl(mp) +INTEGER, INTENT(IN) :: land_pts, ntiles, npft +REAL, INTENT(IN) :: LAI_pft(land_pts, npft) +REAL, INTENT(IN) :: HGT_pft(land_pts, npft) +REAL, INTENT(IN):: tile_frac(land_pts,ntiles) +REAL, INTENT(IN) :: Clai_thresh !The minimum LAI below which a "cell" is considred NOT vegetated +INTEGER, INTENT(IN) :: tile_pts(ntiles) +INTEGER, INTENT(IN):: tile_index(land_pts,ntiles) +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts,ntiles) + +!local vars +REAL :: HGT_pft_temp(land_pts,ntiles) ! needed to filter spatail map +REAL :: LAI_pft_temp(land_pts,ntiles) ! needed to filter spatail map + +INTEGER :: i,j, n + +! init everywhere, even where tile_frac=0 +LAI_pft_temp(:,:) = 0.0 +HGT_pft_temp(:,:) = 0.0 + +DO n=1,ntiles + DO j=1,tile_pts(n) + + i = tile_index(j,n) ! It must be landpt index + + IF ( tile_frac(i,n) > 0.0 ) THEN + + ! hard-wired vegetation type numbers need to be removed + ! LAI set either just below threshold OR from INput field + IF (n < 14) THEN + LAI_pft_temp(i,n) = MAX(CLAI_thresh*.99,LAI_pft(i,n)) + ENDIF + + ! sse. height + IF (n < 5 ) THEN + HGT_pft_temp(i,n) = MAX(1.0,HGT_pft(i,n)) ! trees + ELSE IF (n > 4 .AND. n < 14 ) THEN + HGT_pft_temp(i,n) = MAX(0.1, HGT_pft(i,n)) ! shrubs/grass + END IF + + END IF + + END DO +END DO + +! pack filtered JULE/UM maps to CABLE variables +LAI_pft_cbl = PACK(LAI_pft_temp, l_tile_pts) +HGT_pft_cbl = PACK(HGT_pft_temp, l_tile_pts) + +END SUBROUTINE limit_HGT_LAI + +END MODULE cbl_LAI_canopy_height_mod + diff --git a/src/coupled/AM3/control/cable/shared/cable_fields_mod.F90 b/src/coupled/AM3/control/cable/shared/cable_fields_mod.F90 new file mode 100644 index 000000000..323b211fd --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/cable_fields_mod.F90 @@ -0,0 +1,61 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE cable_fields_mod + +!------------------------------------------------------------------------------ +! Description: +! Module containing instances of the data types for CABLE in jules standalone +! analagous to jules_fields_mod. This is the central place where ubiquitous +! fields are distributed and USEd from throughout the model are instantiated. +! Currently only prognostic fields are here but many more are on the way +! +! This MODULE is USEd by: +! surf_couple_radiation_mod.F90, +! jules.F90, +! init_soilin_cbl.inc, +! init_vegin_cbl.inc, +! populate_var.inc +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!------------------------------------------------------------------------------ + + +!type definitions +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type, & + progs_cbl_vars_data_type +USE work_vars_mod_cbl, ONLY: work_vars_data_type, & + work_vars_type +!These are dimensionally in per PFT format +USE params_io_mod_cbl, ONLY: params_io_type, & + params_io_data_type + +PUBLIC + +!TYPES to hold the data +TYPE(progs_cbl_vars_data_type), TARGET :: progs_cbl_vars_data +TYPE(work_vars_data_type), TARGET :: work_vars_data_cbl +!These are dimensionally in per PFT format +TYPE(params_io_data_type), TARGET :: pars_io_data_cbl + +!TYPES we pass around. These happen to be pointers to the data types above +!but this should be transparent +TYPE(progs_cbl_vars_type) :: progs_cbl_vars +TYPE(work_vars_type) :: work_vars_cbl +!These are dimensionally in per PFT format +TYPE(params_io_type) :: pars_io_cbl + +END MODULE cable_fields_mod diff --git a/src/coupled/AM3/control/cable/shared/cable_model_env.F90 b/src/coupled/AM3/control/cable/shared/cable_model_env.F90 new file mode 100644 index 000000000..66b47fb43 --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/cable_model_env.F90 @@ -0,0 +1,105 @@ +MODULE cable_model_env_mod + +USE cable_model_env_opts_mod, ONLY: icycle + +IMPLICIT NONE + +NAMELIST / cable_model_environment / & + icycle + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='CABLE_MODEL_ENV_MOD' + +CONTAINS + +SUBROUTINE set_derived_variables_cable_model_env + +USE cable_model_env_opts_mod, ONLY: l_casacnp + +IMPLICIT NONE + +IF( icycle == 1 ) THEN + l_casacnp = .TRUE. + WRITE(6,*) "CABLE-CASA-CNP configured for Carbon cycle" +ELSEIF( icycle == 2 ) THEN + l_casacnp = .TRUE. + WRITE(6,*) "CABLE-CASA-CNP configured for Carbon, Nitrogen cycle" +ELSEIF( icycle == 3 ) THEN + l_casacnp = .TRUE. + WRITE(6,*) "CABLE-CASA-CNP configured for Carbon, Nitrogen, Phosphorus cycle" +ELSE + l_casacnp = .FALSE. + WRITE(6,*) "CABLE-CASA-CNP configured for NO biogeochemical cycle" +ENDIF + +RETURN + +END SUBROUTINE set_derived_variables_cable_model_env + +SUBROUTINE read_nml_cable_model_env(unitnumber) + +! Description: +! Read the cable_model_env namelist + +USE setup_namelist, ONLY: setup_nml_type +USE check_iostat_mod, ONLY: check_iostat +USE UM_parcore, ONLY: mype +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook +USE errormessagelength_mod, ONLY: errormessagelength + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: unitnumber +INTEGER :: my_comm +INTEGER :: mpl_nml_type +INTEGER :: ErrorStatus +INTEGER :: icode +CHARACTER(LEN=errormessagelength) :: iomessage +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='READ_NML_CABLE_MODEL_ENV' +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 + +! set number of each type of variable in my_namelist type +INTEGER, PARAMETER :: no_of_types = 1 +INTEGER, PARAMETER :: n_int = 1 + +TYPE my_namelist + !!SEQUENCE + INTEGER :: icycle +END TYPE my_namelist + +TYPE (my_namelist) :: my_nml + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL gc_get_communicator(my_comm, icode) + +CALL setup_nml_type(no_of_types, mpl_nml_type, n_int_in = n_int) + +IF (mype == 0) THEN + + READ (UNIT = unitnumber, NML = cable_model_environment, IOSTAT = errorstatus, & + IOMSG = iomessage) + CALL check_iostat(errorstatus, "namelist cable_model_environment",iomessage) + + my_nml % icycle = icycle +END IF + +CALL mpl_bcast(my_nml,1,mpl_nml_type,0,my_comm,icode) + +IF (mype /= 0) THEN + + icycle = my_nml % icycle + +END IF + +CALL mpl_type_free(mpl_nml_type,icode) + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE read_nml_cable_model_env + +END MODULE cable_model_env_mod + diff --git a/src/coupled/AM3/control/cable/shared/cable_surface_types_mod.F90 b/src/coupled/AM3/control/cable/shared/cable_surface_types_mod.F90 new file mode 100644 index 000000000..1c1f808c0 --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/cable_surface_types_mod.F90 @@ -0,0 +1,377 @@ +! *****************************COPYRIGHT******************************* +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT******************************* + +MODULE cable_surface_types_mod + +!----------------------------------------------------------------------------- +! Description: +! Contains CABLE surface type information and a namelist for setting them +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in TECHNICAL +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +USE max_dimensions, ONLY: & + elev_tile_max, & + ntype_max + +USE missing_data_mod, ONLY: imdi + +!----------------------------------------------------------------------------- +! Module variables. +!----------------------------------------------------------------------------- +USE jules_surface_types_mod, ONLY: & + nnpft, & + ncpft, & + npft, & + nnvg, & + ntype, & + urban, & + lake, & + soil, & + ice + +IMPLICIT NONE + +! Index of the various surface types used by CABLE" +INTEGER :: & + evergreen_needleleaf = imdi, & + evergreen_broadleaf = imdi, & + deciduous_needleleaf = imdi, & + deciduous_broadleaf = imdi, & + shrub_cable = imdi, & + c3_grassland = imdi, & + c4_grassland = imdi, & + tundra = imdi, & + c3_cropland = imdi, & + c4_cropland = imdi, & + wetland = imdi, & + empty1 = imdi, & + empty2 = imdi, & + barren_cable = imdi, & + urban_cable = imdi, & + lakes_cable = imdi, & + ice_cable = imdi + +!----------------------------------------------------------------------------- +! Single namelist definition for UM and standalone +!----------------------------------------------------------------------------- +NAMELIST / cable_surface_types/ & + npft, nnvg, & + evergreen_needleleaf, evergreen_broadleaf, deciduous_needleleaf, & + deciduous_broadleaf, shrub_cable, c3_grassland, c4_grassland, & + tundra, c3_cropland, c4_cropland, wetland, empty1, empty2, & + barren_cable, urban_cable, lakes_cable, ice_cable + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='CABLE_SURFACE_TYPES_MOD' + +CONTAINS + +SUBROUTINE check_surface_type_value ( surface_type, surface_type_name, & + min_value, max_value, RoutineName, errorstatus, nchecks ) + +USE jules_print_mgr, ONLY: jules_print + +IMPLICIT NONE + +INTEGER :: surface_type, min_value, max_value, errorstatus, nchecks +CHARACTER(LEN=*) :: surface_type_name, RoutineName + +IF ( surface_type > 0 ) THEN + nchecks = nchecks + 1 + IF ( surface_type < min_value .OR. surface_type > max_value ) THEN + errorstatus = 101 + CALL jules_print(RoutineName, & + TRIM(surface_type_name) // " tile is given but is out of range") + END IF +END IF + +END SUBROUTINE check_surface_type_value + +SUBROUTINE print_nlist_cable_surface_types() + +USE jules_print_mgr, ONLY: jules_print + +IMPLICIT NONE + +INTEGER :: i, n ! Loop counter + +CHARACTER(LEN=50000) :: lineBuffer + + +!----------------------------------------------------------------------------- +! This needs to be implemented corresponding to cable_surface_types +CALL jules_print('cable_surface_types', & + 'Contents of namelist cable_surface_types') + +!WRITE(lineBuffer, *) ' npft = ', npft +!CALL jules_print('cable_surface_types', lineBuffer) + +!IF ( brd_leaf > 0 ) THEN +! WRITE(lineBuffer, *) ' brd_leaf = ', brd_leaf +! CALL jules_print('cable_surface_types', lineBuffer) +!END IF + +!WRITE(lineBuffer, *) ' = ', +!CALL jules_print('cable_surface_types', lineBuffer) + +!IF ( > 0 ) THEN +! WRITE(lineBuffer, *) ' = ', +! CALL jules_print('cable_surface_types', lineBuffer) +!END IF + +CALL jules_print('cable_surface_types', & + '- - - - - - end of namelist - - - - - -') + +END SUBROUTINE print_nlist_cable_surface_types + + + +SUBROUTINE set_derived_variables_cable_surface_types() + +USE jules_print_mgr, ONLY: jules_print, jules_message + +IMPLICIT NONE + +!----------------------------------------------------------------------------- +! Derive ntype and nnpft from the namelist values +!----------------------------------------------------------------------------- +ntype = npft + nnvg +nnpft = npft - ncpft + +CALL jules_print('set_derived_variables_cable_surface_types', & + 'Derived variables from cable_surface_types') + +!WRITE(jules_message, *) ' ntype = ', ntype +!CALL jules_print('set_derived_variables_cable_surface_types', jules_message) +! +!WRITE(jules_message, *) ' nnpft = ', nnpft +!CALL jules_print('set_derived_variables_cable_surface_types', jules_message) + +CALL jules_print('set_derived_variables_cable_surface_types', & + '- - - - - - end of derived variables - - - - - -') + +RETURN + +END SUBROUTINE set_derived_variables_cable_surface_types + + + +SUBROUTINE check_cable_surface_types() + +USE max_dimensions, ONLY: npft_max, ncpft_max, nnvg_max + +USE ereport_mod, ONLY: ereport +USE jules_print_mgr, ONLY: jules_print, jules_message + +!----------------------------------------------------------------------------- +! Description: +! Checks cable_surface_types namelist for consistency +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in TECHNICAL +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE + +INTEGER :: i, nchecks ! Loop counter + +INTEGER :: errorstatus + +CHARACTER(LEN=*), PARAMETER :: & + RoutineName = 'CHECK_CABLE_SURFACE_TYPES' +!----------------------------------------------------------------------------- +! Check that the given values are less than the fixed values for IO +!----------------------------------------------------------------------------- +IF ( npft > npft_max ) THEN + errorstatus = 101 + CALL ereport(RoutineName, errorstatus, & + "npft > npft_max - increase npft_max and recompile") +END IF + +IF ( nnvg > nnvg_max ) THEN + errorstatus = 101 + CALL ereport(RoutineName, errorstatus, & + "nnvg > nnvg_max - increase nnvg_max and recompile") +END IF + +!----------------------------------------------------------------------------- +! Check values for the specific surface types are sensible +!----------------------------------------------------------------------------- +! PFTs +errorstatus = 0 +nchecks = 0 + +!!CALL check_surface_type_value ( brd_leaf, "brd_leaf", 1, npft, & +!! RoutineName, errorstatus, nchecks ) +!!CALL check_surface_type_value ( , "", 1, npft, & +!! RoutineName, errorstatus, nchecks ) +! +!! PFT surface types must come before non-veg types, so if urban, lake, soil, +!! ice, urban_canyon or urban_roof are given (i.e. > 0) then they must be > npft +!! A soil type is required +!!CALL check_surface_type_value ( urban, "urban", npft+1, ntype, & +!! RoutineName, errorstatus, nchecks ) +!!CALL check_surface_type_value ( , "", npft+1, ntype, & +!! RoutineName, errorstatus, nchecks ) + +!jhan:this will need to be properly implemented +nchecks = 17 +! Check that all present surface types have been checked for range compliance +! This check should also ensure that a check is added for each new surface type +IF ( nchecks /= ntype ) THEN + errorstatus = 101 + CALL jules_print(RoutineName, & + "At least one surface type in namelist does not have a range check.") + WRITE(jules_message,'(A,I0,A,I0)') & + "These should be the same; ntype = ", ntype, ", nchecks = ", nchecks + CALL jules_print(RoutineName, jules_message) +END IF + +! Now that all surface types have been checked issue abort if required +IF ( errorstatus > 0 ) THEN + CALL ereport(RoutineName, errorstatus, & + "Error(s) found. Please see job.out for information ") +END IF + +END SUBROUTINE check_cable_surface_types + +SUBROUTINE read_nml_cable_surface_types (unitnumber) + +! Description: +! Read the CABLE_SURFACE_TYPES namelist + +USE setup_namelist, ONLY: setup_nml_type +USE check_iostat_mod, ONLY: check_iostat +USE UM_parcore, ONLY: mype +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook +USE errormessagelength_mod, ONLY: errormessagelength + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: unitnumber +INTEGER :: my_comm +INTEGER :: mpl_nml_type +INTEGER :: ErrorStatus +INTEGER :: icode +CHARACTER(LEN=errormessagelength) :: iomessage +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='READ_NML_CABLE_SURFACE_TYPES' +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 + +! set number of each type of variable in my_namelist type +INTEGER, PARAMETER :: no_of_types = 1 +INTEGER, PARAMETER :: n_int = 19 !+ ntype_max + +TYPE my_namelist + !!SEQUENCE + INTEGER :: npft + INTEGER :: nnvg + INTEGER :: evergreen_needleleaf + INTEGER :: evergreen_broadleaf + INTEGER :: deciduous_needleleaf + INTEGER :: deciduous_broadleaf + INTEGER :: shrub_cable + INTEGER :: c3_grassland + INTEGER :: c4_grassland + INTEGER :: tundra + INTEGER :: c3_cropland + INTEGER :: c4_cropland + INTEGER :: wetland + INTEGER :: empty1 + INTEGER :: empty2 + INTEGER :: barren_cable + INTEGER :: urban_cable + INTEGER :: lakes_cable + INTEGER :: ice_cable + !INTEGER :: tile_map_ids(ntype_max) +END TYPE my_namelist + +TYPE (my_namelist) :: my_nml + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL gc_get_communicator(my_comm, icode) + +CALL setup_nml_type(no_of_types, mpl_nml_type, n_int_in = n_int) + +IF (mype == 0) THEN + + READ (UNIT = unitnumber, NML = cable_surface_types, IOSTAT = errorstatus, & + IOMSG = iomessage) + CALL check_iostat(errorstatus, "namelist cable_surface_types",iomessage) + + my_nml % npft = npft + my_nml % nnvg = nnvg + my_nml % evergreen_needleleaf = evergreen_needleleaf + my_nml % evergreen_broadleaf = evergreen_broadleaf + my_nml % deciduous_needleleaf = deciduous_needleleaf + my_nml % deciduous_broadleaf = deciduous_broadleaf + my_nml % shrub_cable = shrub_cable + my_nml % c3_grassland = c3_grassland + my_nml % c4_grassland = c4_grassland + my_nml % tundra = tundra + my_nml % c3_cropland = c3_cropland + my_nml % c4_cropland = c4_cropland + my_nml % wetland = wetland + my_nml % empty1 = empty1 + my_nml % empty2 = empty2 + my_nml % barren_cable = barren_cable + my_nml % urban_cable = urban_cable + my_nml % lakes_cable = lakes_cable + my_nml % ice_cable = ice_cable + +END IF + +CALL mpl_bcast(my_nml,1,mpl_nml_type,0,my_comm,icode) + +IF (mype /= 0) THEN + + npft = my_nml % npft + nnvg = my_nml % nnvg + evergreen_needleleaf = my_nml % evergreen_needleleaf + evergreen_broadleaf = my_nml % evergreen_broadleaf + deciduous_needleleaf = my_nml % deciduous_needleleaf + deciduous_broadleaf = my_nml % deciduous_broadleaf + shrub_cable = my_nml % shrub_cable + c3_grassland = my_nml % c3_grassland + c4_grassland = my_nml % c4_grassland + tundra = my_nml % tundra + c3_cropland = my_nml % c3_cropland + c4_cropland = my_nml % c4_cropland + wetland = my_nml % wetland + empty1 = my_nml % empty1 + empty2 = my_nml % empty2 + barren_cable = my_nml %barren_cable + urban_cable = my_nml % urban_cable + lakes_cable = my_nml % lakes_cable + ice_cable = my_nml % ice_cable + +END IF + +CALL mpl_type_free(mpl_nml_type,icode) + +soil = barren_cable +ice = ice_cable +lake = lakes_cable +urban = urban_cable + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE read_nml_cable_surface_types + +END MODULE cable_surface_types_mod diff --git a/src/coupled/AM3/control/cable/shared/land_tile_ids_mod_cbl.F90 b/src/coupled/AM3/control/cable/shared/land_tile_ids_mod_cbl.F90 new file mode 100644 index 000000000..7d9f0f80d --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/land_tile_ids_mod_cbl.F90 @@ -0,0 +1,121 @@ +! *****************************COPYRIGHT******************************* +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT******************************* +! +! Module setting Tile ID numbers, which are used to identify which land +! surface tiles are present. + +! Code Description: +! Language: FORTRAN 90 +! This code is written to UMDP3 v8.2 programming standards. + +MODULE land_tile_ids_mod_cbl + +USE max_dimensions, ONLY: & + ntype_max, & + snow_layers_max, & + elev_tile_max + +USE missing_data_mod, ONLY: imdi + +IMPLICIT NONE + +!----------------------------------------------------------------------- + +INTEGER, PRIVATE :: i ! Loop counter + +INTEGER :: surface_type_ids(ntype_max) = imdi + ! Array which maps pseudo levels to tile types + +INTEGER :: ml_snow_type_ids(ntype_max * snow_layers_max) = imdi + ! Array which maps pseudo levels to tile types + +INTEGER :: tile_ids_in(ntype_max * snow_layers_max) = imdi + ! Tile IDs in the input header + +CONTAINS + +SUBROUTINE set_surface_type_ids_cbl( ) +USE ereport_mod, ONLY: ereport + +USE jules_print_mgr, ONLY: & + jules_message, & + jules_print, & + jules_format + +USE errormessagelength_mod, ONLY: errormessagelength + +USE cable_surface_types_mod, ONLY: & + ntype, & + evergreen_needleleaf, & + evergreen_broadleaf, & + deciduous_needleleaf, & + deciduous_broadleaf, & + shrub_cable, & + c3_grassland, & + c4_grassland, & + tundra, & + c3_cropland, & + c4_cropland, & + wetland, & + empty1, & + empty2, & + barren_cable, & + urban_cable, & + lakes_cable, & + ice_cable + +IMPLICIT NONE + +INTEGER :: i ! Loop counter +INTEGER :: errorstatus +CHARACTER(LEN=18), PARAMETER :: routinename='set_tile_id_arrays' + +!There is presently no other option for CABLE surface type indexing +surface_type_ids( evergreen_needleleaf ) = 1 +surface_type_ids( evergreen_broadleaf ) = 2 +surface_type_ids( deciduous_needleleaf ) = 3 +surface_type_ids( deciduous_broadleaf ) = 4 +surface_type_ids( shrub_cable ) = 5 +surface_type_ids( c3_grassland ) = 6 +surface_type_ids( c4_grassland ) = 7 +surface_type_ids( tundra ) = 8 +surface_type_ids( c3_cropland ) = 9 +surface_type_ids( c4_cropland ) = 10 +surface_type_ids( wetland ) = 11 +surface_type_ids( empty1 ) = 12 +surface_type_ids( empty2 ) = 13 +surface_type_ids( barren_cable ) = 14 +surface_type_ids( urban_cable ) = 15 +surface_type_ids( lakes_cable ) = 16 +surface_type_ids( ice_cable ) = 17 + +! Print the surface types that are present +WRITE(jules_format,'(a3,i3,a8)') '(a,',ntype,'(1x,i6))' +WRITE(jules_message,jules_format) ' Surface types present =', & + surface_type_ids(1:ntype) +CALL jules_print(routinename, jules_message) + +! Check that all surface types have been specified +IF ( ANY( surface_type_ids(1:ntype) == imdi ) ) THEN + errorstatus = 30 + WRITE(jules_message, '(A,I6)') & + ' All surface types need to be specified. Please see job.out.' + CALL ereport ( routinename, errorstatus, jules_message ) +END IF + +! Check that tile IDs are unique +DO i = 1, ntype + IF ( COUNT( surface_type_ids(:) == surface_type_ids(i) ) /= 1 ) THEN + errorstatus = 30 + WRITE(jules_message, '(A,I6)') & + ' Surface type ID not unique :', surface_type_ids(i) + CALL ereport ( routinename, errorstatus, jules_message ) + END IF +END DO + +END SUBROUTINE set_surface_type_ids_cbl + +END MODULE land_tile_ids_mod_cbl diff --git a/src/coupled/AM3/control/cable/shared/params_io_cbl.F90 b/src/coupled/AM3/control/cable/shared/params_io_cbl.F90 new file mode 100644 index 000000000..68e206a4f --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/params_io_cbl.F90 @@ -0,0 +1,355 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE params_io_mod_cbl + +!----------------------------------------------------------------------------- +! Description: +! Defines variable types and variables for veg and soil parameters. +! We only define the pointer associations relevant to TYPES to be parssed +! around (following JULES params*_io). The allocation is unecessary as these +! input parameters are read in from namelist (following JULES params *_io), +! these are initialized in corresponding section +! Based on cable_def_types_mod.F90 from the CABLE trunk. +! +! This MODULE is USEd by: +! cable_fields_mod.F90, +! init_vegin_cbl.inc +! +! This MODULE contains 2 public Subroutines: +! params_io_assoc_cbl, +! params_io_nullify_cbl +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +USE grid_constants_mod_cbl, ONLY: & + ntype_max, & ! # veg types [13],non-veg=4,ntiles=17 + nsoil_max, & ! # of soil types [9] + nrb, & ! # spectral bANDS VIS/NIR/(LW-not used) + nsl, & ! # soil layers + nscs, & ! # soil carbon stores + nvcs ! # vegetation carbon stores + +PUBLIC :: params_io_data_type +PUBLIC :: params_io_type +PUBLIC :: params_io_assoc_cbl + +PRIVATE +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='PARAMS_IO_MOD_CBL' + +! Vegetation/Soil parameters I/O: +TYPE :: params_io_data_type + + ! Veg parameters I/O: + REAL :: & + vegin_canst1(ntype_max), & + vegin_dleaf(ntype_max), & + vegin_length(ntype_max), & + vegin_width(ntype_max), & + vegin_vcmax(ntype_max), & + vegin_ejmax(ntype_max), & + vegin_hc(ntype_max), & + vegin_xfang(ntype_max), & + vegin_rp20(ntype_max), & + vegin_rpcoef(ntype_max), & + vegin_rs20(ntype_max), & + vegin_wai(ntype_max), & + vegin_rootbeta(ntype_max), & + vegin_shelrb(ntype_max), & + vegin_vegcf(ntype_max), & + vegin_frac4(ntype_max), & + vegin_xalbnir(ntype_max), & + vegin_extkn(ntype_max), & + vegin_tminvj(ntype_max), & + vegin_tmaxvj(ntype_max), & + vegin_vbeta(ntype_max), & + vegin_a1gs(ntype_max), & + vegin_d0gs(ntype_max), & + vegin_alpha(ntype_max), & + vegin_convex(ntype_max), & + vegin_cfrd(ntype_max), & + vegin_gswmin(ntype_max), & + vegin_conkc0(ntype_max), & + vegin_conko0(ntype_max), & + vegin_ekc(ntype_max), & + vegin_eko(ntype_max), & + vegin_g0(ntype_max), & + vegin_g1(ntype_max), & + vegin_zr(ntype_max), & + vegin_clitt(ntype_max), & + vegin_froot(nsl,ntype_max), & + vegin_csoil(nscs,ntype_max), & + vegin_ratecs(nscs,ntype_max), & + vegin_cplant(nvcs,ntype_max), & + vegin_ratecp(nvcs,ntype_max), & + vegin_refl(nrb,ntype_max), & + vegin_taul(nrb,ntype_max) + + ! Soil parameters I/O: + REAL :: & + soilin_silt(nsoil_max), & + soilin_clay(nsoil_max), & + soilin_sand(nsoil_max), & + soilin_swilt(nsoil_max), & + soilin_sfc(nsoil_max), & + soilin_ssat(nsoil_max), & + soilin_bch(nsoil_max), & + soilin_hyds(nsoil_max), & + soilin_sucs(nsoil_max), & + soilin_rhosoil(nsoil_max), & + soilin_css(nsoil_max) + +END TYPE params_io_data_type + +TYPE :: params_io_type + + ! Veg parameters I/O: + REAL, POINTER, PUBLIC :: & + vegin_canst1(:), & + vegin_dleaf(:), & + vegin_length(:), & + vegin_width(:), & + vegin_vcmax(:), & + vegin_ejmax(:), & + vegin_hc(:), & + vegin_xfang(:), & + vegin_rp20(:), & + vegin_rpcoef(:), & + vegin_rs20(:), & + vegin_wai(:), & + vegin_rootbeta(:), & + vegin_shelrb(:), & + vegin_vegcf(:), & + vegin_frac4(:), & + vegin_xalbnir(:), & + vegin_extkn(:), & + vegin_tminvj(:), & + vegin_tmaxvj(:), & + vegin_vbeta(:), & + vegin_a1gs(:), & + vegin_d0gs(:), & + vegin_alpha(:), & + vegin_convex(:), & + vegin_cfrd(:), & + vegin_gswmin(:), & + vegin_conkc0(:), & + vegin_conko0(:), & + vegin_ekc(:), & + vegin_eko(:), & + vegin_g0(:), & + vegin_g1(:), & + vegin_zr(:), & + vegin_clitt(:), & + vegin_froot(:,:), & + vegin_csoil(:,:), & + vegin_ratecs(:,:), & + vegin_cplant(:,:), & + vegin_ratecp(:,:), & + vegin_refl(:,:), & + vegin_taul(:,:) + + ! Soil parameters I/O: + REAL, POINTER, PUBLIC :: & + soilin_silt(:), & + soilin_clay(:), & + soilin_sand(:), & + soilin_swilt(:), & + soilin_sfc(:), & + soilin_ssat(:), & + soilin_bch(:), & + soilin_hyds(:), & + soilin_sucs(:), & + soilin_rhosoil(:), & + soilin_css(:) + +END TYPE params_io_type + +CONTAINS +!============================================================================== +SUBROUTINE params_io_assoc_cbl(pars_io, pars_io_data) + +! Description: +! Associate veg. and soil parameters pointer types + + !No USE statements other than Dr Hook +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(params_io_type), INTENT(IN OUT) :: pars_io +TYPE(params_io_data_type), INTENT(IN OUT), TARGET :: pars_io_data +!local:needed by dr_hook +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle +CHARACTER(LEN=*), PARAMETER :: RoutineName='PARAMS_IO_ASSOC_CBL' +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL params_io_nullify_cbl(pars_io) + +! Veg parameters I/O: +pars_io % vegin_canst1 => pars_io_data % vegin_canst1 +pars_io % vegin_dleaf => pars_io_data % vegin_dleaf +pars_io % vegin_length => pars_io_data % vegin_length +pars_io % vegin_width => pars_io_data % vegin_width +pars_io % vegin_vcmax => pars_io_data % vegin_vcmax +pars_io % vegin_ejmax => pars_io_data % vegin_ejmax +pars_io % vegin_hc => pars_io_data % vegin_hc +pars_io % vegin_xfang => pars_io_data % vegin_xfang +pars_io % vegin_rp20 => pars_io_data % vegin_rp20 +pars_io % vegin_rpcoef => pars_io_data % vegin_rpcoef +pars_io % vegin_rs20 => pars_io_data % vegin_rs20 +pars_io % vegin_wai => pars_io_data % vegin_wai +pars_io % vegin_rootbeta => pars_io_data % vegin_rootbeta +pars_io % vegin_shelrb => pars_io_data % vegin_shelrb +pars_io % vegin_vegcf => pars_io_data % vegin_vegcf +pars_io % vegin_frac4 => pars_io_data % vegin_frac4 +pars_io % vegin_xalbnir => pars_io_data % vegin_xalbnir +pars_io % vegin_extkn => pars_io_data % vegin_extkn +pars_io % vegin_tminvj => pars_io_data % vegin_tminvj +pars_io % vegin_tmaxvj => pars_io_data % vegin_tmaxvj +pars_io % vegin_vbeta => pars_io_data % vegin_vbeta +pars_io % vegin_a1gs => pars_io_data % vegin_a1gs +pars_io % vegin_d0gs => pars_io_data % vegin_d0gs +pars_io % vegin_alpha => pars_io_data % vegin_alpha +pars_io % vegin_convex => pars_io_data % vegin_convex +pars_io % vegin_cfrd => pars_io_data % vegin_cfrd +pars_io % vegin_gswmin => pars_io_data % vegin_gswmin +pars_io % vegin_conkc0 => pars_io_data % vegin_conkc0 +pars_io % vegin_conko0 => pars_io_data % vegin_conko0 +pars_io % vegin_ekc => pars_io_data % vegin_ekc +pars_io % vegin_eko => pars_io_data % vegin_eko +pars_io % vegin_g0 => pars_io_data % vegin_g0 +pars_io % vegin_g1 => pars_io_data % vegin_g1 +pars_io % vegin_zr => pars_io_data % vegin_zr +pars_io % vegin_clitt => pars_io_data % vegin_clitt +pars_io % vegin_froot => pars_io_data % vegin_froot +pars_io % vegin_csoil => pars_io_data % vegin_csoil +pars_io % vegin_ratecs => pars_io_data % vegin_ratecs +pars_io % vegin_cplant => pars_io_data % vegin_cplant +pars_io % vegin_ratecp => pars_io_data % vegin_ratecp +pars_io % vegin_refl => pars_io_data % vegin_refl +pars_io % vegin_taul => pars_io_data % vegin_taul + +! Soil params_io_type % parameters I/O: +pars_io % soilin_silt => pars_io_data % soilin_silt +pars_io % soilin_clay => pars_io_data % soilin_clay +pars_io % soilin_sand => pars_io_data % soilin_sand +pars_io % soilin_swilt => pars_io_data % soilin_swilt +pars_io % soilin_sfc => pars_io_data % soilin_sfc +pars_io % soilin_ssat => pars_io_data % soilin_ssat +pars_io % soilin_bch => pars_io_data % soilin_bch +pars_io % soilin_hyds => pars_io_data % soilin_hyds +pars_io % soilin_sucs => pars_io_data % soilin_sucs +pars_io % soilin_rhosoil => pars_io_data % soilin_rhosoil +pars_io % soilin_css => pars_io_data % soilin_css + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) + +RETURN +END SUBROUTINE params_io_assoc_cbl + +SUBROUTINE params_io_nullify_cbl(pars_io) + +! Description: +! Nullify veg. and soil parameters pointer types + +!No USE statements other than Dr Hook +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(params_io_type), INTENT(IN OUT) :: pars_io +!local:needed by dr_hook +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle +CHARACTER(LEN=*), PARAMETER :: RoutineName='PARAMS_IO_NULLIFY_CBL' +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +! Veg parameters I/O: +NULLIFY( pars_io%vegin_canst1 ) +NULLIFY( pars_io%vegin_dleaf ) +NULLIFY( pars_io%vegin_length ) +NULLIFY( pars_io%vegin_width ) +NULLIFY( pars_io%vegin_vcmax ) +NULLIFY( pars_io%vegin_ejmax ) +NULLIFY( pars_io%vegin_hc ) +NULLIFY( pars_io%vegin_xfang ) +NULLIFY( pars_io%vegin_rp20 ) +NULLIFY( pars_io%vegin_rpcoef ) +NULLIFY( pars_io%vegin_rs20 ) +NULLIFY( pars_io%vegin_wai ) +NULLIFY( pars_io%vegin_rootbeta ) +NULLIFY( pars_io%vegin_shelrb ) +NULLIFY( pars_io%vegin_vegcf ) +NULLIFY( pars_io%vegin_frac4 ) +NULLIFY( pars_io%vegin_xalbnir ) +NULLIFY( pars_io%vegin_extkn ) +NULLIFY( pars_io%vegin_tminvj ) +NULLIFY( pars_io%vegin_tmaxvj ) +NULLIFY( pars_io%vegin_vbeta ) +NULLIFY( pars_io%vegin_a1gs ) +NULLIFY( pars_io%vegin_d0gs ) +NULLIFY( pars_io%vegin_alpha ) +NULLIFY( pars_io%vegin_convex ) +NULLIFY( pars_io%vegin_cfrd ) +NULLIFY( pars_io%vegin_gswmin ) +NULLIFY( pars_io%vegin_conkc0 ) +NULLIFY( pars_io%vegin_conko0 ) +NULLIFY( pars_io%vegin_ekc ) +NULLIFY( pars_io%vegin_eko ) +NULLIFY( pars_io%vegin_g0 ) +NULLIFY( pars_io%vegin_g1 ) +NULLIFY( pars_io%vegin_zr ) +NULLIFY( pars_io%vegin_clitt ) +NULLIFY( pars_io%vegin_froot ) +NULLIFY( pars_io%vegin_csoil ) +NULLIFY( pars_io%vegin_ratecs ) +NULLIFY( pars_io%vegin_cplant ) +NULLIFY( pars_io%vegin_ratecp ) +NULLIFY( pars_io%vegin_refl ) +NULLIFY( pars_io%vegin_taul ) + +! Soil parameters I/O: +NULLIFY( pars_io%soilin_silt ) +NULLIFY( pars_io%soilin_clay ) +NULLIFY( pars_io%soilin_sand ) +NULLIFY( pars_io%soilin_swilt ) +NULLIFY( pars_io%soilin_sfc ) +NULLIFY( pars_io%soilin_ssat ) +NULLIFY( pars_io%soilin_bch ) +NULLIFY( pars_io%soilin_hyds ) +NULLIFY( pars_io%soilin_sucs ) +NULLIFY( pars_io%soilin_rhosoil ) +NULLIFY( pars_io%soilin_css ) + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) + +RETURN +END SUBROUTINE params_io_nullify_cbl + +END MODULE params_io_mod_cbl + + diff --git a/src/coupled/AM3/control/cable/shared/progs_cbl_vars_mod.F90 b/src/coupled/AM3/control/cable/shared/progs_cbl_vars_mod.F90 new file mode 100644 index 000000000..2dcd3f7d3 --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/progs_cbl_vars_mod.F90 @@ -0,0 +1,386 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE progs_cbl_vars_mod + +!------------------------------------------------------------------------------ +! Description: +! Declares/(de)allocates/assigns CABLE prognostic variables +! +! This MODULE is USEd by: +! cable_fields_mod.F90, +! surf_couple_explicit_mod.F90, +! surf_couple_implicit_mod.F90, +! surf_couple_radiation_mod.F90, +! control.F90, +! init_cable_progs.F90, +! init.F90 +! +! This MODULE contains 4 public Subroutines: +! progs_cbl_vars_alloc, +! progs_cbl_vars_dealloc, +! progs_cbl_vars_assoc, +! progs_cbl_vars_nullify +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!------------------------------------------------------------------------------ + +IMPLICIT NONE + +PUBLIC :: progs_cbl_vars_alloc +PUBLIC :: progs_cbl_vars_assoc +PUBLIC :: progs_cbl_vars_data_type +PUBLIC :: progs_cbl_vars_type +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='PROGS_CBL_VARS_MOD' +! Tiled soil prognostics to be initialized from IO +TYPE :: progs_cbl_vars_data_type + + REAL, ALLOCATABLE, PUBLIC :: & + SoilTemp_CABLE(:,:,:), & + SoilMoisture_CABLE(:,:,:), & + FrozenSoilFrac_CABLE(:,:,:), & + SnowDepth_CABLE(:,:,:), & + SnowMass_CABLE(:,:,:), & + SnowTemp_CABLE(:,:,:), & + SnowDensity_CABLE(:,:,:), & + ThreeLayerSnowFlag_CABLE(:,:), & + OneLyrSnowDensity_CABLE(:,:), & + SnowAge_CABLE(:,:), & + snowOsurft(:,:) + +END TYPE progs_cbl_vars_data_type + +TYPE :: progs_cbl_vars_type + + REAL, POINTER, PUBLIC :: & + SoilTemp_CABLE(:,:,:), & + SoilMoisture_CABLE(:,:,:), & + FrozenSoilFrac_CABLE(:,:,:), & + SnowDepth_CABLE(:,:,:), & + SnowMass_CABLE(:,:,:), & + SnowTemp_CABLE(:,:,:), & + SnowDensity_CABLE(:,:,:), & + ThreeLayerSnowFlag_CABLE(:,:), & + OneLyrSnowDensity_CABLE(:,:), & + SnowAge_CABLE(:,:), & + snowOsurft(:,:) +END TYPE progs_cbl_vars_type + +CONTAINS + +!=============================================================================== +SUBROUTINE progs_cbl_vars_alloc(land_pts, nsurft, sm_levels, lsm_id, cable, & + progs_cbl_vars_data ) + +! Description: +! Allocate the CABLE prognostic data variables in the derived type structure + +!Replacements for the argument list +USE grid_constants_mod_cbl, ONLY: nsnl + +!Common Non-science modules +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook +USE jules_print_mgr, ONLY: jules_message, jules_print, PrNorm +USE ereport_mod, ONLY: ereport + +IMPLICIT NONE + +!Arguments +INTEGER, INTENT(IN) :: land_pts, nsurft,sm_levels +INTEGER, INTENT(IN) :: lsm_id, cable + +TYPE(progs_cbl_vars_data_type), INTENT(IN OUT) :: progs_cbl_vars_data + +!----------------------------------------------------------------------- +! Local variables for error trapping +!----------------------------------------------------------------------- +INTEGER :: & + ERROR = 0, & + ! Variable for trapping the error from each + ! individual call to allocate + error_sum = 0, & + + ! Variable to track the sum of all errors + ! resulting from calls to allocate. Hence we + ! know that everything was successful if and + ! only if this is zero at the end + errcode + ! Variable to use in error report + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='PROGS_CBL_VARS_ALLOC' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +! CABLE vars to be initialized via JULES i/o +IF ( lsm_id == cable ) THEN + + ALLOCATE( progs_cbl_vars_data%SoilTemp_CABLE(land_pts, nsurft, sm_levels), & + STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SoilMoisture_CABLE(land_pts, nsurft, & + sm_levels), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%FrozenSoilFrac_CABLE(land_pts, nsurft, & + sm_levels), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowDepth_CABLE(land_pts, nsurft, nsnl), & + STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowMass_CABLE(land_pts,nsurft, nsnl), & + STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowTemp_CABLE(land_pts, nsurft, nsnl), & + STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowDensity_CABLE(land_pts,nsurft,nsnl), & + STAT = ERROR) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%ThreeLayerSnowFlag_CABLE(land_pts,nsurft), & + STAT = ERROR) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%OneLyrSnowDensity_CABLE(land_pts,nsurft), & + STAT = ERROR) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowAge_CABLE(land_pts, nsurft), & + STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%snowOsurft(land_pts, nsurft), STAT = ERROR ) + error_sum = error_sum + ERROR + + !----------------------------------------------------------------------- + ! Write out an error if there was one + !----------------------------------------------------------------------- + IF ( error_sum /= 0 ) & + CALL ereport(RoutineName, errcode, & + "Error allocating CABLE prognostic array") + +ELSE + + ALLOCATE( progs_cbl_vars_data%SoilTemp_CABLE(1, 1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SoilMoisture_CABLE(1, 1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%FrozenSoilFrac_CABLE(1, 1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowDepth_CABLE(1, 1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowMass_CABLE(1,1, 1),STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowTemp_CABLE(1, 1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowDensity_CABLE(1,1,1),STAT = ERROR) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%ThreeLayerSnowFlag_CABLE(1,1),STAT = ERROR) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%OneLyrSnowDensity_CABLE(1,1),STAT = ERROR) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%SnowAge_CABLE(1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + ALLOCATE( progs_cbl_vars_data%snowOsurft(1, 1), STAT = ERROR ) + error_sum = error_sum + ERROR + + !----------------------------------------------------------------------- + ! Write out an error if there was one + !----------------------------------------------------------------------- + IF ( error_sum /= 0 ) & + CALL ereport(RoutineName, errcode, & + "Error allocating CABLE prognostic array") + +END IF + +progs_cbl_vars_data%SoilTemp_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%SoilMoisture_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%FrozenSoilFrac_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%SnowDepth_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%SnowMass_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%SnowTemp_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%SnowDensity_CABLE(:,:,:) = 0.0 +progs_cbl_vars_data%SnowAge_CABLE(:,:) = 0.0 +progs_cbl_vars_data%snowOsurft(:,:) = 0.0 +progs_cbl_vars_data%ThreeLayerSnowFlag_CABLE(:,:) = 0.0 +progs_cbl_vars_data%OneLyrSnowDensity_CABLE(:,:) = 0.0 + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE progs_cbl_vars_alloc + +!=============================================================================== +SUBROUTINE progs_cbl_vars_dealloc(progs_cbl_vars_data ) + +! Description: +! Deallocate the CABLE prognostic data variables in the derived type structure + + !Common Non-science modules +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(progs_cbl_vars_data_type), INTENT(IN OUT) :: progs_cbl_vars_data + +!----------------------------------------------------------------------- +! Local variables +!----------------------------------------------------------------------- +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='PROGS_CBL_VARS_DEALLOC' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + + +! CABLE vars to be initialized via JULES i/o +DEALLOCATE( progs_cbl_vars_data%snowOsurft) +DEALLOCATE( progs_cbl_vars_data%SnowAge_CABLE) +DEALLOCATE( progs_cbl_vars_data%OneLyrSnowDensity_CABLE) +DEALLOCATE( progs_cbl_vars_data%ThreeLayerSnowFlag_CABLE) +DEALLOCATE( progs_cbl_vars_data%SnowDensity_CABLE) +DEALLOCATE( progs_cbl_vars_data%SnowTemp_CABLE) +DEALLOCATE( progs_cbl_vars_data%SnowMass_CABLE) +DEALLOCATE( progs_cbl_vars_data%SnowDepth_CABLE) +DEALLOCATE( progs_cbl_vars_data%FrozenSoilFrac_CABLE) +DEALLOCATE( progs_cbl_vars_data%SoilMoisture_CABLE) +DEALLOCATE( progs_cbl_vars_data%SoilTemp_CABLE) + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE progs_cbl_vars_dealloc + +!=============================================================================== +SUBROUTINE progs_cbl_vars_assoc(progs_cbl_vars, progs_cbl_vars_data ) + +! Description: +! Associate the CABLE prognostic pointers in the derived type structure + +!No USE statements other than Dr Hook +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(progs_cbl_vars_type), INTENT(IN OUT) :: progs_cbl_vars +TYPE(progs_cbl_vars_data_type), INTENT(IN OUT), TARGET :: progs_cbl_vars_data + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='PROGS_CBL_VARS_ASSOC' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL progs_cbl_vars_nullify(progs_cbl_vars) + +progs_cbl_vars%SoilTemp_CABLE => progs_cbl_vars_data%SoilTemp_CABLE +progs_cbl_vars%SoilMoisture_CABLE => & + progs_cbl_vars_data%SoilMoisture_CABLE +progs_cbl_vars%FrozenSoilFrac_CABLE => & + progs_cbl_vars_data%FrozenSoilFrac_CABLE +progs_cbl_vars%SnowDepth_CABLE => progs_cbl_vars_data%SnowDepth_CABLE +progs_cbl_vars%SnowMass_CABLE => progs_cbl_vars_data%SnowMass_CABLE +progs_cbl_vars%SnowTemp_CABLE => progs_cbl_vars_data%SnowTemp_CABLE +progs_cbl_vars%SnowDensity_CABLE => & + progs_cbl_vars_data%SnowDensity_CABLE +progs_cbl_vars%SnowAge_CABLE => progs_cbl_vars_data%SnowAge_CABLE +progs_cbl_vars%snowOsurft => progs_cbl_vars_data%snowOsurft +progs_cbl_vars%ThreeLayerSnowFlag_CABLE => & + progs_cbl_vars_data%ThreeLayerSnowFlag_CABLE +progs_cbl_vars%OneLyrSnowDensity_CABLE => & + progs_cbl_vars_data%OneLyrSnowDensity_CABLE + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE progs_cbl_vars_assoc + +!=============================================================================== +SUBROUTINE progs_cbl_vars_nullify(progs_cbl_vars) + +! Description: +! Nullify the CABLE prognostic pointers in the derived type structure + + !No USE statements other than Dr Hook +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(progs_cbl_vars_type), INTENT(IN OUT) :: progs_cbl_vars + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='PROGS_CBL_VARS_NULLIFY' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +NULLIFY(progs_cbl_vars%SoilTemp_CABLE) +NULLIFY(progs_cbl_vars%SoilMoisture_CABLE) +NULLIFY(progs_cbl_vars%FrozenSoilFrac_CABLE) +NULLIFY(progs_cbl_vars%SnowDepth_CABLE) +NULLIFY(progs_cbl_vars%SnowMass_CABLE) +NULLIFY(progs_cbl_vars%SnowTemp_CABLE) +NULLIFY(progs_cbl_vars%SnowDensity_CABLE) +NULLIFY(progs_cbl_vars%SnowAge_CABLE) +NULLIFY(progs_cbl_vars%snowOsurft) +NULLIFY(progs_cbl_vars%ThreeLayerSnowFlag_CABLE) +NULLIFY(progs_cbl_vars%OneLyrSnowDensity_CABLE) + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN + +END SUBROUTINE progs_cbl_vars_nullify + +END MODULE progs_cbl_vars_mod + diff --git a/src/coupled/AM3/control/cable/shared/work_vars_mod_cbl.F90 b/src/coupled/AM3/control/cable/shared/work_vars_mod_cbl.F90 new file mode 100644 index 000000000..c342950ee --- /dev/null +++ b/src/coupled/AM3/control/cable/shared/work_vars_mod_cbl.F90 @@ -0,0 +1,361 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** +MODULE work_vars_mod_cbl + +!------------------------------------------------------------------------------ +! Description: +! Declares/(de)allocates/assigns CABLE "working" variables +! These are vars reqested to be kept across the surf_couple* pathways +! and/or timesteps. Some will be elevated to prognostics, others will be +! removed via rewriting of the algorithm where requested +! +! This MODULE is USEd by: +! cable_fields_mod.F90, +! surf_couple_explicit_mod.F90, +! surf_couple_extra_mod.F90, +! surf_couple_implicit_mod.F90, +! control.F90, +! init_cable_working_vars.F90, +! init.F90 +! +! This MODULE contains 4 public Subroutines: +! alloc_work_vars_cbl, +! dealloc_work_vars_cbl, +! assoc_work_vars_cbl, +! nullify_assoc_work_vars_cbl +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!------------------------------------------------------------------------------ + +USE cable_canopy_type_mod, ONLY: canopy_type +USE cable_canopy_type_mod, ONLY: canopy_data_type +USE cable_air_type_mod, ONLY: air_type +USE cable_air_type_mod, ONLY: air_data_type +USE cable_met_type_mod, ONLY: met_type +USE cable_met_type_mod, ONLY: met_data_type +USE cable_balances_type_mod, ONLY: balances_type +USE cable_balances_type_mod, ONLY: balances_data_type +USE cable_soil_type_mod, ONLY: soil_type +USE cable_soil_type_mod, ONLY: soil_data_type +USE cable_veg_type_mod, ONLY: veg_type +USE cable_veg_type_mod, ONLY: veg_data_type +USE cable_soil_snow_type_mod, ONLY: soil_snow_type +USE cable_soil_snow_type_mod, ONLY: soil_snow_data_type +USE cable_radiation_type_mod, ONLY: radiation_type +USE cable_radiation_type_mod, ONLY: radiation_data_type +USE cable_roughness_type_mod, ONLY: roughness_type +USE cable_roughness_type_mod, ONLY: roughness_data_type +USE cable_climate_type_mod, ONLY: climate_type +USE cable_climate_type_mod, ONLY: climate_data_type +USE cable_bgc_pool_type_mod, ONLY: bgc_pool_type +USE cable_bgc_pool_type_mod, ONLY: bgc_pool_data_type +USE cable_sum_flux_type_mod, ONLY: sum_flux_type +USE cable_sum_flux_type_mod, ONLY: sum_flux_data_type + +IMPLICIT NONE + +PUBLIC :: alloc_work_vars_cbl +PUBLIC :: assoc_work_vars_cbl +PUBLIC :: work_vars_data_type +PUBLIC :: work_vars_type +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='WORK_VARS_MOD_CBL' + +TYPE :: work_vars_data_type + + !fields returned @ hydrology (surf_couple_extra) level of JULES + !computed in CABLE @ implicit (surf_couple_implicit) level + REAL, ALLOCATABLE, PUBLIC :: snow_surft(:,:) + REAL, ALLOCATABLE, PUBLIC :: lying_snow(:) + REAL, ALLOCATABLE, PUBLIC :: surf_roff(:) + REAL, ALLOCATABLE, PUBLIC :: sub_surf_roff(:) + REAL, ALLOCATABLE, PUBLIC :: tot_tfall(:) + REAL, ALLOCATABLE, PUBLIC :: sw_down_ij(:,:,:) + REAL, ALLOCATABLE, PUBLIC :: reducedLAIdue2snow(:) +!check dims +REAL, ALLOCATABLE, PUBLIC :: tot_wb_lake(:) + +END TYPE work_vars_data_type + +TYPE :: work_vars_type + + !fields returned @ hydrology (surf_couple_extra) level of JULES + !computed in CABLE @ implicit (surf_couple_implicit) level + REAL, POINTER, PUBLIC :: snow_surft(:,:) + REAL, POINTER, PUBLIC :: lying_snow(:) + REAL, POINTER, PUBLIC :: surf_roff(:) + REAL, POINTER, PUBLIC :: sub_surf_roff(:) + REAL, POINTER, PUBLIC :: tot_tfall(:) + REAL, POINTER, PUBLIC :: sw_down_ij(:,:,:) + REAL, POINTER, PUBLIC :: reducedLAIdue2snow(:) + + TYPE(canopy_type) :: canopy + TYPE(air_type) :: air + TYPE(met_type) :: met + TYPE(balances_type) :: bal + TYPE(soil_type) :: soil + TYPE(veg_type) :: veg + TYPE(soil_snow_type) :: ssnow + TYPE(radiation_type) :: rad + TYPE(roughness_type) :: rough + TYPE(climate_type) :: climate + TYPE(bgc_pool_type) :: bgc + TYPE(sum_flux_type) :: sum_flux + +END TYPE work_vars_type + +! data arrays need to be declared outside of the work% TYPE +TYPE(canopy_data_type), PUBLIC, TARGET :: canopy_data +TYPE(air_data_type), PUBLIC, TARGET :: air_data +TYPE(met_data_type), PUBLIC, TARGET :: met_data +TYPE(balances_data_type), PUBLIC, TARGET :: bal_data +TYPE(veg_data_type), PUBLIC, TARGET :: veg_data +TYPE(soil_data_type), PUBLIC, TARGET :: soil_data +TYPE(soil_snow_data_type), PUBLIC, TARGET :: soil_snow_data +TYPE(radiation_data_type), PUBLIC, TARGET :: rad_data +TYPE(roughness_data_type), PUBLIC, TARGET :: rough_data +TYPE(climate_data_type), PUBLIC, TARGET :: climate_data +TYPE(bgc_pool_data_type), PUBLIC, TARGET :: bgc_data +TYPE(sum_flux_data_type), PUBLIC, TARGET :: sum_flux_data + +CONTAINS + +!=============================================================================== +SUBROUTINE alloc_work_vars_cbl( row_length, rows, land_pts, nsurft, sm_levels, & + lsm_id, cable, work_data_cbl ) + +! Description: +! Allocate the CABLE work data variables in the derived type structure + +!Replacements for the argument list +USE grid_constants_mod_cbl, ONLY: nsnl + +!Common Non-science modules +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook +USE jules_print_mgr, ONLY: jules_message, jules_print, PrNorm +USE ereport_mod, ONLY: ereport + +IMPLICIT NONE + +!Arguments +INTEGER, INTENT(IN) :: row_length, rows +INTEGER, INTENT(IN) :: land_pts, nsurft,sm_levels +INTEGER, INTENT(IN) :: lsm_id, cable + +TYPE(work_vars_data_type), INTENT(IN OUT) :: work_data_cbl + +!----------------------------------------------------------------------- +! Local variables for error trapping +!----------------------------------------------------------------------- +INTEGER :: & + ERROR = 0, & + ! Variable for trapping the error from each + ! individual call to allocate + error_sum = 0, & + + ! Variable to track the sum of all errors + ! resulting from calls to allocate. Hence we + ! know that everything was successful if and + ! only if this is zero at the end + errcode + ! Variable to use in error report + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='ALLOC_WORK_VARS_CBL' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +! CABLE vars to be initialized +IF ( lsm_id == cable ) THEN + + ALLOCATE( work_data_cbl%snow_surft(land_pts, nsurft), STAT = ERROR ) + ALLOCATE( work_data_cbl%lying_snow(land_pts), STAT = ERROR ) + ALLOCATE( work_data_cbl%surf_roff(land_pts), STAT = ERROR ) + ALLOCATE( work_data_cbl%tot_tfall(land_pts), STAT = ERROR ) + ALLOCATE( work_data_cbl%sub_surf_roff(land_pts), STAT = ERROR ) + !CM3 + ALLOCATE( work_data_cbl%sw_down_ij(row_length, rows,4), STAT = ERROR ) + ALLOCATE( work_data_cbl%reducedLAIdue2snow(land_pts * nsurft), STAT = ERROR ) + !mp=sum(surft_pts) would do it + error_sum = error_sum + ERROR + + !----------------------------------------------------------------------- + ! Write out an error if there was one + !----------------------------------------------------------------------- + IF ( error_sum /= 0 ) & + CALL ereport(RoutineName, errcode, & + "Error allocating CABLE work type") + +ELSE + + ALLOCATE( work_data_cbl%snow_surft(1,1), STAT = ERROR ) + ALLOCATE( work_data_cbl%lying_snow(1), STAT = ERROR ) + ALLOCATE( work_data_cbl%surf_roff(1), STAT = ERROR ) + ALLOCATE( work_data_cbl%tot_tfall(1), STAT = ERROR ) + ALLOCATE( work_data_cbl%sub_surf_roff(1), STAT = ERROR ) + !CM3 + ALLOCATE( work_data_cbl%sw_down_ij(1,1,1), STAT = ERROR ) + error_sum = error_sum + ERROR + + !----------------------------------------------------------------------- + ! Write out an error if there was one + !----------------------------------------------------------------------- + IF ( error_sum /= 0 ) & + CALL ereport(RoutineName, errcode, & + "Error allocating CABLE work type") + +END IF + +work_data_cbl% snow_surft (:,:) = 0.0 +work_data_cbl% lying_snow (:) = 0.0 +work_data_cbl% surf_roff (:) = 0.0 +work_data_cbl% sub_surf_roff (:) = 0.0 +work_data_cbl% tot_tfall (:) = 0.0 +work_data_cbl% sw_down_ij(:,:,:) = 0.0 +work_data_cbl%reducedLAIdue2snow(:) = 0.0 + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE alloc_work_vars_cbl + +!=============================================================================== +SUBROUTINE dealloc_work_vars_cbl(work_data_cbl ) + +! Description: +! Deallocate the CABLE work data variables in the derived type structure + +!Common Non-science modules +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(work_vars_data_type), INTENT(IN OUT) :: work_data_cbl + +!----------------------------------------------------------------------- +! Local variables +!----------------------------------------------------------------------- +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='DEALLOC_WORK_VARS_CBL' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +! CABLE vars to be initialized via JULES i/o +DEALLOCATE( work_data_cbl %snow_surft ) +DEALLOCATE( work_data_cbl %lying_snow ) +DEALLOCATE( work_data_cbl %surf_roff ) +DEALLOCATE( work_data_cbl %sub_surf_roff ) +DEALLOCATE( work_data_cbl %tot_tfall ) +DEALLOCATE( work_data_cbl %sw_down_ij ) + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE dealloc_work_vars_cbl + +!=============================================================================== +SUBROUTINE assoc_work_vars_cbl(work_cbl, work_data_cbl ) + +! Description: +! Associate the CABLE work pointers in the derived type structure + +!No USE statements other than Dr Hook +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(work_vars_type), INTENT(IN OUT) :: work_cbl +TYPE(work_vars_data_type), INTENT(IN OUT), TARGET :: work_data_cbl + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='ASSOC_WORK_VARS_CBL' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +CALL nullify_assoc_work_vars_cbl(work_cbl) + +work_cbl% snow_surft => work_data_cbl% snow_surft +work_cbl% lying_snow => work_data_cbl% lying_snow +work_cbl% surf_roff => work_data_cbl% surf_roff +work_cbl% sub_surf_roff => work_data_cbl% sub_surf_roff +work_cbl% tot_tfall => work_data_cbl% tot_tfall +work_cbl% sw_down_ij => work_data_cbl% sw_down_ij +work_cbl% reducedLAIdue2snow => work_data_cbl% reducedLAIdue2snow + + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN +END SUBROUTINE assoc_work_vars_cbl + +!=============================================================================== +SUBROUTINE nullify_assoc_work_vars_cbl(work_cbl) + +! Description: +! Nullify the CABLE work pointers in the derived type structure + + !No USE statements other than Dr Hook +USE parkind1, ONLY: jprb, jpim +USE yomhook, ONLY: lhook, dr_hook + +IMPLICIT NONE + +!Arguments +TYPE(work_vars_type), INTENT(IN OUT) :: work_cbl + +INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0 +INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1 +REAL(KIND=jprb) :: zhook_handle + +CHARACTER(LEN=*), PARAMETER :: RoutineName='NULLIFY_ASSOC_WORK_VARS_CBL' + +!End of header + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_in,zhook_handle) + +NULLIFY( work_cbl% snow_surft ) +NULLIFY( work_cbl% lying_snow ) +NULLIFY( work_cbl% surf_roff ) +NULLIFY( work_cbl% sub_surf_roff ) +NULLIFY( work_cbl% tot_tfall ) +NULLIFY( work_cbl% sw_down_ij ) +NULLIFY( work_cbl% reducedLAIdue2snow ) + +IF (lhook) CALL dr_hook(ModuleName//':'//RoutineName,zhook_out,zhook_handle) +RETURN + +END SUBROUTINE nullify_assoc_work_vars_cbl + +END MODULE work_vars_mod_cbl + diff --git a/src/coupled/AM3/control/cable/util/activeTile_mask_cbl.F90 b/src/coupled/AM3/control/cable/util/activeTile_mask_cbl.F90 new file mode 100644 index 000000000..f294bf6a0 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/activeTile_mask_cbl.F90 @@ -0,0 +1,100 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE init_active_tile_mask_mod + +!------------------------------------------------------------------------------ +! Description: +! Initialises the JULES/CABLE grid array, which aligns JULES grid points +! with CABLE land points +! +! This MODULE is USEd by: +! cable_land_albedo_mod.F90 +! +! This MODULE contains 1 public Subroutine: +! init_active_tile_mask_cbl +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!------------------------------------------------------------------------------ + +IMPLICIT NONE +PUBLIC :: cable_mp +PUBLIC :: init_active_tile_mask_cbl +PRIVATE + +CONTAINS + +SUBROUTINE cable_mp(mp, land_pts, nsurft, tile_frac ) + +! Description: +! Nothing further to add to module description. + +IMPLICIT NONE + +INTEGER, INTENT(OUT) :: mp +INTEGER, INTENT(IN) :: land_pts, nsurft +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) !fraction of each surf type + +!Local vars: +INTEGER :: i, j, k + +k=0 +DO j = 1, nsurft + DO i = 1, land_pts + IF ( tile_frac(i,j) > 0.0 ) THEN + k = k + 1 + END IF + END DO +END DO +mp = k + +RETURN + +END SUBROUTINE cable_mp + + +SUBROUTINE init_active_tile_mask_cbl(l_tile_pts, land_pts, nsurft, tile_frac ) + +! Description: +! Nothing further to add to module description. + +IMPLICIT NONE + +LOGICAL, INTENT(OUT), ALLOCATABLE :: L_tile_pts(:,:) +INTEGER, INTENT(IN) :: land_pts, nsurft +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) !fraction of each surf type + +!Local vars: +INTEGER :: i, j + +! Determine active tiles map +IF ( .NOT. ALLOCATED(l_tile_pts)) ALLOCATE( l_tile_pts(land_pts, nsurft) ) + +l_tile_pts(:,:) = .FALSE. + +DO j = 1, nsurft + DO i = 1, land_pts + IF ( tile_frac(i,j) > 0.0 ) THEN + l_tile_pts(i,j) = .TRUE. + END IF + END DO +END DO + +RETURN + +END SUBROUTINE init_active_tile_mask_cbl + +END MODULE init_active_tile_mask_mod diff --git a/src/coupled/AM3/control/cable/util/cable_jules_links_mod.F90 b/src/coupled/AM3/control/cable/util/cable_jules_links_mod.F90 new file mode 100644 index 000000000..d45b9fd67 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/cable_jules_links_mod.F90 @@ -0,0 +1,196 @@ +!============================================================================== +! This source code is part of the +! Australian Community Atmosphere Biosphere Land Exchange (CABLE) model. +! This work is licensed under the CSIRO Open Source Software License +! Agreement (variation of the BSD / MIT License). +! +! You may not use this file except in compliance with this License. +! A copy of the License (CSIRO_BSD_MIT_License_v2.0_CABLE.txt) is located +! in each directory containing CABLE code. +! +! ============================================================================== +! Purpose: Reorders JULES and Unified Model tiled parameters to an order +! appropriate for CABLE and ACCESS-CM2 +! +! assumes input from JULES/UM is on 17 tiles with order: +! (1) dec broadlf, (2) evgn broadlf tropics, (3) evgn broadlf temp, +! (4) dec needlelf, (5) evgn needlelf, (6) grass c3, (7)crop c3, +! (8) pasture c3, (9) grass c4, (10) crop c4, (11) pasture c4, +! (12) dec shrub, (13) evgn shrub, (14) urban, (15) lakes, +! (16) baresoil, (17) permanent ice +! +! mapping at time of writing is: +! +! CABLE egnneedle tile 1 -> ndl_leaf_eg tile 5 JULES +! egnbroad 2 -> brd_leaf_evg_ 0.5*(2+3) [special case] +! decneedle 3 -> ndl_leaf_dec 4 +! decbroad 4 -> brd_leaf_dec 1 +! shrub 5 -> shrub_dec/evg 12 or 13 +! grass c3 6 -> c3_grass 6 +! grass c4 7 -> c4_grass 9 +! tundra 8 -> c3_grass 6 or evg shrub 13 +! crop c3 9 -> c3_crop 7 +! crop_c4 10 -> c4_crop 10 +! wetland 11 -> lake 15 or c3 grass 6 or c4 grass 9 +! empty 12 -> c3_grass 6 +! empty 13 -> c3_grass 6 +! bare soil 14 -> soil 16 +! urban 15 -> urban 14 +! lakes 16 -> lakes 15 +! ice 17 -> ice 17 +! +! CABLE shrub map largely coincides with JULES tile 12 map +! CABLE tundra map largely conincides with JULES tile 13 map +! +! integer switch shrub permits CABLE shrub to take another value +! +! integer switch tundra permits CABLE tundra to take another value +! +! integer switch wetland13/17 permits CABLE wetlands to take another value e.g. +! lake (15), c3 grass (6) or c4 grass (9) (ideally it depends on the process) +! note cannot take a lake value if only veg pfts are available. +! +! Future development needed to permit external/namelist prescription of the +! integer switches for shrub, tundra, wetland13/17 +! +! Called from: ukca routines surfddr, ddepaer & ddepaer_inc_sedi +! +! 2024-04-22 Edits for 27 tile configuration of CABLE +! As of coding - we will assume the current 17 tile ordering applies for tiles +! 1:13 of the 27 tile configuration, with the 4 non-veg tiles appended into +! tiles 24:27. The additional tiles are filled with bare soil values. +! +! The current hard-wired ordering is retained in all other aspects. +! +! =============================================================================== + +MODULE cable_jules_links_mod + + IMPLICIT NONE + + PUBLIC tile_resort_1D, tile_resort_2D + PRIVATE tile_order + +CONTAINS + SUBROUTINE tile_order(ntiles,t_sort) + !sets new order of tiles + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ntiles !number of tiles - should be 4, 13 or 17 + INTEGER, DIMENSION(ntiles), INTENT(OUT) :: t_sort + + INTEGER :: shrub !switch to specify shrub tile values + INTEGER :: tundra !switch to specify tundra tile values + INTEGER :: wetland13 !switch to specify wetland tile values + INTEGER :: wetland17 !switch to specify wetland tile values + + !edit shrub, tundra and wetland mapping - other tile mapping is hard-wired + shrub = 12 !to be 12 (default) or 13 + tundra = 13 !to be 6, 12 or 13 (default) + wetland13 = 6 !to be 6 (default for 13 tiles) or 9 + wetland17 = 15 !to be 6, 9 or 15 (default for 13 tiles) + + !set the tile order ----------------------------------------------------- + IF (ntiles == 27) THEN !all tiles 27 tile version (CM3) + t_sort = (/5,2,4,1,shrub,6,9,tundra,7,10,wetland17,6,6, & + 16,16,16,16,16,16,16,16,16,16, 16,14,15,17/) + + ELSEIF (ntiles == 17) THEN !all tiles 17 tile version (CM2) + t_sort = (/5,2,4,1,shrub,6,9,tundra,7,10,wetland17,6,6,16,14,15,17/) + + ELSEIF (ntiles == 13) THEN !veg tiles only (17 or 27 tiles) + t_sort = (/5,2,4,1,shrub,6,9,tundra,7,10,wetland13,6,6/) + + ELSEIF (ntiles == 4) THEN !non-veg tiles only + t_sort = (/3,1,2,4/) + + ELSE + !error message + t_sort(:) = MAX(1,MIN(ntiles-1,6)) !catch all as c3 grass, bare soil + ENDIF + + RETURN + END SUBROUTINE + + SUBROUTINE tile_resort_2D(ntiles, nvar, t_params) + !2D array case + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ntiles !number of tiles - should be 13 or 17 + INTEGER, INTENT(IN) :: nvar !number of variables in array to sort + + REAL, DIMENSION(ntiles,nvar), INTENT (INOUT) :: t_params + !variable array to resort + + INTEGER :: i !looping variable + INTEGER, DIMENSION(:), ALLOCATABLE :: t_sort + !ordering of tiles + REAL, DIMENSION(:,:), ALLOCATABLE :: t_params_new + !resorted variable array + !END header + ALLOCATE(t_sort(ntiles)) + ALLOCATE(t_params_new(ntiles,nvar)) + + !set the tile order ----------------------------------------------------- + CALL tile_order(ntiles, t_sort) + + !reorder ---------------------------------------------------------------- + + DO i = 1,ntiles + t_params_new(i,:) = t_params(t_sort(i),:) + !special cases + IF ((ntiles==13) .or. (ntiles==17) .or. (ntiles==27)) THEN + t_params_new(2,:) = 0.5*(t_params(2,:)+t_params(3,:)) + END IF + END DO + t_params(:,:) = t_params_new(:,:) + + DEALLOCATE(t_sort,t_params_new) + + RETURN + + END SUBROUTINE tile_resort_2D + + SUBROUTINE tile_resort_1D(ntiles, t_params) + !1D array case + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: ntiles !number of tiles - should be 13 or 17 + + REAL, DIMENSION(ntiles), INTENT (INOUT) :: t_params + !variable array to resort + + !working variables + INTEGER :: i !looping variable + INTEGER, DIMENSION(:), ALLOCATABLE :: t_sort + !ordering of tiles + REAL, DIMENSION(:), ALLOCATABLE :: t_params_new + !resorted variable array + !END header + ALLOCATE(t_sort(ntiles)) + ALLOCATE(t_params_new(ntiles)) + + !set the tile order ----------------------------------------------------- + CALL tile_order(ntiles, t_sort) + + !reordering ------------------------------------------------------------- + DO i = 1,ntiles + t_params_new(i) = t_params(t_sort(i)) + !special cases + IF ((ntiles==13) .or. (ntiles==17) .or. (ntiles==27)) THEN + t_params_new(2) = 0.5*(t_params(2)+t_params(3)) + END IF + END DO + t_params(:) = t_params_new(:) + + DEALLOCATE(t_sort,t_params_new) + + RETURN + + END SUBROUTINE tile_resort_1D +END MODULE + + \ No newline at end of file diff --git a/src/coupled/AM3/control/cable/util/cable_model_env_opts.F90 b/src/coupled/AM3/control/cable/util/cable_model_env_opts.F90 new file mode 100644 index 000000000..64eb45b96 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/cable_model_env_opts.F90 @@ -0,0 +1,12 @@ +MODULE cable_model_env_opts_mod + +USE missing_data_mod, ONLY: imdi + +IMPLICIT NONE + +INTEGER :: icycle = imdi +LOGICAL :: l_casacnp = .FALSE. + +END MODULE cable_model_env_opts_mod + + diff --git a/src/coupled/AM3/control/cable/util/init/cable_um_init_bgc.F90 b/src/coupled/AM3/control/cable/util/init/cable_um_init_bgc.F90 new file mode 100644 index 000000000..88256659c --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cable_um_init_bgc.F90 @@ -0,0 +1,35 @@ +MODULE cable_um_init_bgc_mod + +IMPLICIT NONE +PUBLIC init_bgc_vars + +CONTAINS + +SUBROUTINE init_bgc_vars( pars, bgc, veg ) +USE cable_def_types_mod, ONLY : ncs, ncp +USE cable_def_types_mod, ONLY: bgc_pool_type, veg_parameter_type +USE params_io_mod_cbl, ONLY: params_io_data_type +IMPLICIT NONE +TYPE(params_io_data_type), INTENT(IN) :: pars +TYPE(veg_parameter_type), INTENT(IN) :: veg ! vegetation parameters +TYPE(bgc_pool_type), INTENT(OUT) :: bgc + +INTEGER :: k + +! note that ratecp and ratecs are the same for all veg at the moment. (BP) +DO k=1,ncp + bgc%cplant(:,k) = pars%vegin_cplant(k,veg%iveg) + bgc%ratecp(k) = pars%vegin_ratecp(k,1) +ENDDO +DO k=1,ncs + bgc%csoil(:,k) = pars%vegin_csoil(k,veg%iveg) + bgc%ratecs(k) = pars%vegin_ratecs(k,1) +ENDDO + +END SUBROUTINE init_bgc_vars + +END MODULE cable_um_init_bgc_mod + + + + diff --git a/src/coupled/AM3/control/cable/util/init/cable_um_init_respiration.F90 b/src/coupled/AM3/control/cable/util/init/cable_um_init_respiration.F90 new file mode 100644 index 000000000..78b2f843c --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cable_um_init_respiration.F90 @@ -0,0 +1,44 @@ +MODULE cable_um_init_respiration_mod + +IMPLICIT NONE +PUBLIC init_respiration + +CONTAINS + +SUBROUTINE init_respiration( land_pts, ntiles, npft, l_tilepts, & + npp_pft_acc, resp_w_pft_acc, canopy ) +USE cable_def_types_mod, ONLY: canopy_type + +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: ntiles ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +LOGICAL, INTENT(IN) :: L_tilepts(land_pts, ntiles) ! TRUE if active tile +TYPE(canopy_type), INTENT(OUT) :: canopy +REAL, INTENT(IN) :: npp_pft_acc(land_pts, npft) +REAL, INTENT(IN) :: resp_w_pft_acc(land_pts, npft) + +REAL :: fnpp_pft_acc(land_pts, ntiles) +REAL :: fresp_w_pft_acc(land_pts, ntiles) + +! make ntile versions of npp_pft_acc/resp_w_pft_acc +fnpp_pft_acc(:,1:ntiles) = 0.0 +fresp_w_pft_acc(:,1:ntiles) = 0.0 +fnpp_pft_acc(:,1:npft) = npp_pft_acc(:,1:npft) +fresp_w_pft_acc(:,1:npft) = resp_w_pft_acc(:,1:npft) + +!---set soil & plant respiration (now in dim(land_pts,ntiles)) +canopy%frs = PACK(fnpp_pft_acc , l_tilepts) +canopy%frp = PACK(fresp_w_pft_acc, l_tilepts) + +!---convert units to g C m-2 s-1 +canopy%frs = canopy%frs * 1000. +canopy%frp = canopy%frp * 1000. + +RETURN +END SUBROUTINE init_respiration + +END MODULE cable_um_init_respiration_mod + + + + diff --git a/src/coupled/AM3/control/cable/util/init/cable_um_init_sumflux.F90 b/src/coupled/AM3/control/cable/util/init/cable_um_init_sumflux.F90 new file mode 100644 index 000000000..3eb1f681f --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cable_um_init_sumflux.F90 @@ -0,0 +1,35 @@ +MODULE cable_um_init_sumflux_mod + +IMPLICIT NONE +PUBLIC init_sumflux_zero + +CONTAINS + +SUBROUTINE init_sumflux_zero( sum_flux ) + +USE cable_def_types_mod, ONLY: sum_flux_type + +IMPLICIT NONE + +TYPE(sum_flux_type), INTENT(OUT) :: sum_flux + +sum_flux%sumpn = 0.0 +sum_flux%sumrp = 0.0 +sum_flux%sumrpw = 0.0 +sum_flux%sumrpr = 0.0 +sum_flux%sumrs = 0.0 +sum_flux%sumrd = 0.0 +sum_flux%dsumpn = 0.0 +sum_flux%dsumrp = 0.0 +sum_flux%dsumrs = 0.0 +sum_flux%dsumrd = 0.0 +sum_flux%sumxrp = 0.0 +sum_flux%sumxrs = 0.0 +RETURN +END SUBROUTINE init_sumflux_zero + +END MODULE cable_um_init_sumflux_mod + + + + diff --git a/src/coupled/AM3/control/cable/util/init/cbl_um_init.F90 b/src/coupled/AM3/control/cable/util/init/cbl_um_init.F90 new file mode 100644 index 000000000..be07a734c --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cbl_um_init.F90 @@ -0,0 +1,134 @@ +MODULE cbl_um_init_mod + +IMPLICIT NONE +PUBLIC :: init_data +PRIVATE + +CONTAINS + +SUBROUTINE init_data( row_length, rows, land_pts, nsurft, npft, ms, msn, & + soil_zse, mp, nrb, CO2_MMR, tfrz, ICE_SurfaceType, & + ICE_SoilType, land_index, surft_pts, surft_index, & + tile_frac, L_tile_pts, albsoil, bexp, hcon, satcon, & + sathh, smvcst, smvcwt, smvccl, pars, tl_1, snow_tile, & + SoilTemp, SoilMoisture, FrozenSoilFrac, & + OneLyrSnowDensity, SnowAge, ThreeLayerSnowFlag, & + SnowDensity, SnowDepth, SnowTemp, SnowMass, rad_trad, & + met_tk, veg, soil, canopy, ssnow, bgc, sum_flux, & + SurfaceType, SoilType, npp_pft_acc, resp_w_pft_acc ) +! subrs +USE cbl_um_init_veg_mod, ONLY: initialize_veg +USE cbl_um_init_soil_mod, ONLY: initialize_soil +USE cbl_um_init_soilsnow_mod, ONLY: initialize_soilsnow +USE cable_um_init_respiration_mod, ONLY: init_respiration +USE cable_um_init_bgc_mod, ONLY: init_bgc_vars +USE cable_um_init_sumflux_mod, ONLY: init_sumflux_zero +USE cable_pack_mod, ONLY: cable_pack_rr + +! data +USE cable_other_constants_mod, ONLY: LAI_THRESH +USE grid_constants_mod_cbl, ONLY: nsnl, nsoil_max +USE cable_def_types_mod, ONLY: veg_parameter_type, canopy_type, & + soil_parameter_type, soil_snow_type, & + bgc_pool_type, sum_flux_type +USE params_io_mod_cbl, ONLY: params_io_data_type + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +INTEGER, INTENT(IN) :: ms ! # soil layers +INTEGER, INTENT(IN) :: msn ! # snow layers +REAL, INTENT(IN) :: soil_zse(ms) ! soil layer thicknesses +REAL, INTENT(IN) :: tfrz +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nrb +INTEGER, INTENT(IN) :: ICE_SoilType +REAL, INTENT(IN) :: co2_mmr +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER, INTENT(IN) :: land_index(land_pts) ! cell index of land_pt +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) +REAL, INTENT(IN) :: bexp (land_pts, ms) ! b in Campbell equation +REAL, INTENT(IN) :: satcon(land_pts, ms) + ! hydraulic conductivity @ saturation [mm/s] +REAL, INTENT(IN) :: sathh(land_pts, ms) +REAL, INTENT(IN) :: smvcst(land_pts, ms) +REAL, INTENT(IN) :: smvcwt(land_pts, ms) +REAL, INTENT(IN) :: smvccl(land_pts, ms) +REAL, INTENT(IN) :: hcon(land_pts) ! Soil thermal conductivity (W/m/K). +REAL, INTENT(IN) :: albsoil(land_pts) +REAL, INTENT(IN) :: tl_1(row_length,rows) +REAL, INTENT(IN) :: snow_tile(land_pts, nsurft) +REAL, INTENT(IN) :: SoilTemp(land_pts, nsurft, ms) +REAL, INTENT(IN) :: SoilMoisture(land_pts, nsurft, ms) +REAL, INTENT(IN) :: FrozenSoilFrac(land_pts, nsurft, ms) +REAL, INTENT(IN) :: SnowDepth(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: SnowTemp(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: SnowMass(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: SnowDensity(land_pts, nsurft,nsnl) +REAL, INTENT(IN) :: OneLyrSnowDensity(land_pts, nsurft) +REAL, INTENT(IN) :: SnowAge(land_pts, nsurft) +REAL, INTENT(IN) :: npp_pft_acc(land_pts,npft) +REAL, INTENT(IN) :: resp_w_pft_acc(land_pts,npft) +INTEGER, INTENT(IN) :: ThreeLayerSnowFlag(land_pts, nsurft) +INTEGER, INTENT(IN) :: ICE_SurfaceType !CABLE surface tile PFT/nveg +INTEGER, INTENT(IN) :: SurfaceType(mp) ! surface tile PFT/nveg +INTEGER, INTENT(IN) :: SoilType(mp) ! soil type per tile +REAL, INTENT(OUT) :: rad_trad(mp) +REAL, INTENT(OUT) :: met_tk(mp) + +TYPE(canopy_type), INTENT(OUT) :: canopy +TYPE(veg_parameter_type), INTENT(OUT) :: veg ! vegetation parameters +TYPE(soil_parameter_type), INTENT(OUT) :: soil ! soil parameters +TYPE(soil_snow_type), INTENT(OUT) :: ssnow ! +TYPE(params_io_data_type), INTENT(IN) :: pars +TYPE(bgc_pool_type), INTENT(OUT) :: bgc +TYPE(sum_flux_type), INTENT(OUT) :: sum_flux + +! only needed to set rad%otrad on the first timestep. +canopy%ga = 0.0 +canopy%fes_cor = 0.0 +canopy%fhs_cor = 0.0 +canopy%us = 0.01 +canopy%fwsoil = 1.0 + +CALL initialize_veg( SurfaceType, SoilType, mp, ms, & + nrb, npft, nsurft, land_pts, l_tile_pts, ICE_SurfaceType, & + ICE_SoilType, LAI_thresh, soil_zse, surft_pts, & + surft_index, tile_frac, & + veg, soil, pars ) + + +CALL initialize_soil( nsurft, land_pts, ms, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, soiltype, & + bexp, hcon, satcon, sathh, smvcst, smvcwt, & + smvccl, albsoil, soil_zse, pars, soil ) + +! def met_tk on first call as is needed in wetfac calc ( which should be +! replaced with tss) approximating surface temp of lake and to init trad below +CALL cable_pack_rr( met_tk, tl_1, mp, l_tile_pts, row_length, rows, nsurft, & + land_pts, land_index, surft_pts, surft_index ) + +CALL initialize_soilsnow( mp, msn, ms, TFRZ, land_pts, nsurft, row_length, & + rows, ICE_SoilType, l_tile_pts, surft_pts, & + surft_index, smvcst, SoilTemp, FrozenSoilFrac, & + SoilMoisture, snow_tile, OneLyrSnowDensity, SnowAge, & + ThreeLayerSnowFlag, SnowDensity, SnowDepth, & + SnowMass, SnowTemp, soil, ssnow, veg%iveg, met_tk ) + +CALL init_bgc_vars( pars, bgc, veg ) +CALL init_sumflux_zero( sum_flux ) +CALL init_respiration( land_pts, nsurft, npft, L_tile_pts, & + npp_pft_acc, resp_w_pft_acc, canopy ) + +rad_trad = met_tk + +RETURN +END SUBROUTINE init_data + +END MODULE cbl_um_init_mod diff --git a/src/coupled/AM3/control/cable/util/init/cbl_um_init_soil.F90 b/src/coupled/AM3/control/cable/util/init/cbl_um_init_soil.F90 new file mode 100644 index 000000000..78d5ea2b5 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cbl_um_init_soil.F90 @@ -0,0 +1,236 @@ +MODULE cbl_um_init_soil_mod + +IMPLICIT NONE +PUBLIC initialize_soil + +CONTAINS + +SUBROUTINE initialize_soil( nsurft, land_pts, ms, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, soiltype, & + bexp, hcon, satcon, sathh, smvcst, smvcwt, & + smvccl, albsoil, dzsoil, pars, soil ) + +! subrs +USE cable_pack_mod, ONLY: pack_landpts2mp_ICE, pack_landpts2mp + +! data +USE cable_def_types_mod, ONLY: soil_parameter_type, r_2 +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_common_module, ONLY : cable_user, gw_params +IMPLICIT NONE + +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: ms +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nsoil_max +REAL, INTENT(IN) :: dzsoil(ms) ! soil layer thicknesses +INTEGER, INTENT(IN) :: ICE_soiltype +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points on each tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! index of tile points +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) +INTEGER, INTENT(IN) :: SoilType(mp) !CABLE soil type per tile +REAL, INTENT(IN) :: bexp(land_pts) +REAL, INTENT(IN) :: hcon(land_pts) +REAL, INTENT(IN) :: satcon(land_pts) +REAL, INTENT(IN) :: sathh(land_pts) +REAL, INTENT(IN) :: smvcst(land_pts) +REAL, INTENT(IN) :: smvcwt(land_pts) +REAL, INTENT(IN) :: smvccl(land_pts) +REAL, INTENT(IN) :: albsoil(land_pts) + +TYPE(soil_parameter_type), INTENT(INOUT) :: soil ! soil parameters +TYPE(params_io_data_type), INTENT(IN) :: pars + +!__ local vars +INTEGER :: i,j,k +REAL :: hcon_ICE(nsoil_max) +REAL :: soilCnsd_real(mp) +REAL :: sucs_sign_factor, hyds_unit_factor, sucs_min_magnitude +REAL, PARAMETER :: ssat_lo = 0.15 +REAL, PARAMETER :: ssat_hi = 0.65 +REAL, PARAMETER :: rhob_lo = 810.0 +REAL, PARAMETER :: rhob_hi = 2300.0 +REAL, ALLOCATABLE :: znode(:), ssat_bounded(:,:),rho_soil_bulk(:,:) + +! defined in namelist in UM + +soil%zse_vec = spread(dzsoil,1,mp) +soil%watr(:,:) = 0.05 +soil%GWwatr(:) = 0.05 + +! distance between consecutive layer midpoints +soil%zshh(1) = 0.5 * soil%zse(1) +soil%zshh(ms+1) = 0.5 * soil%zse(ms) +soil%zshh(2:ms) = 0.5 * (soil%zse(1:ms-1) + soil%zse(2:ms)) + +! albsoil -> soil%albsoil +CALL pack_landpts2mp( nsurft, land_pts, mp, surft_pts, surft_index, & + L_tile_pts, albsoil, soil%albsoil(:,1) ) + +! bexp -> soil%bch: parameter b in Campbell equation +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, BEXP, SoilType, & + pars%soilin_bch, soil%bch ) + +hcon_ICE(:) = ( pars%soilin_sand(ICE_SoilType) * 0.3 ) & + + ( pars%soilin_clay(ICE_SoilType) * 0.25 ) & + + ( pars%soilin_silt(ICE_SoilType) * 0.265 ) + +! hcon -> soil%cnsd +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, hcon, soiltype, & + hcon_ICE, soilCnsd_real ) + +soil%cnsd = REAL( soilCnsd_real, r_2 ) + +! CABLE soil parameters are in general PACKed from UM spatial fields +! *EXCEPT* for permanent ice points where we overwrite with parametrs read from +! cable_soil_params (pars%) + +! soil%hyds = hydraulic conductivity @saturation is PACKed from satcon[mm/s] +! *EXCEPT* at permanent ice points where we overwrite with parametrs read from +! pars%soilin_hyds[m/s] which are already in correct units. Dividing by 1000 +! soil%hyds is correct for tiles 1:8. Would be 1000* too small, hence *1000 first +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, satcon, soiltype,& + pars%soilin_hyds * 1000.0, soil%hyds ) +soil%hyds = soil%hyds / 1000.0 + +! sathh -> soil%sucs +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, sathh, soiltype, & + pars%soilin_sucs, soil%sucs ) + +! smvcst -> soil%ssat +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, smvcst, soiltype,& + pars%soilin_ssat, soil%ssat ) + +! smvcwt -> soil%swilt +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, smvcwt, soiltype,& + pars%soilin_swilt, soil%swilt ) + +! smvccl -> soil%sfc +CALL pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + surft_pts, surft_index, L_tile_pts, smvccl, soiltype,& + pars%soilin_sfc, soil%sfc ) + +!--- (re)set values for CABLE +soil%ibp2 = NINT(soil%bch) + 2 +soil%i2bp3 = 2 * NINT(soil%bch) + 3 + +soil%ssat = MAX( soil%ssat, soil%sfc + 0.01 ) +soil%sucs = ABS( soil%sucs ) +WHERE( soil%ssat > 0. ) + soil%pwb_min = (soil%swilt / soil%ssat )**soil%ibp2 +END WHERE +sucs_min_magnitude = 106.0/1000.0 +soil%sucs = MAX(sucs_min_magnitude,soil%sucs) +soil%hsbh = soil%hyds * ABS(soil%sucs) * soil%bch + +!from CM2 - BUT i don't think even necessary here. CM2 has a LOT of GW +!stuff here and cable_user%soil_thermal_fix stuff +DO k=1,ms + soil%ssat_vec(:,k) = real(soil%ssat(:) ,r_2) + soil%sucs_vec(:,k) = real(soil%sucs(:) ,r_2) + soil%hyds_vec(:,k) = real(soil%hyds(:) ,r_2) + soil%swilt_vec(:,k) = real(soil%swilt(:) ,r_2) + soil%bch_vec(:,k) = real(soil%bch(:) ,r_2) + soil%sfc_vec(:,k) = real(soil%sfc(:) ,r_2) + soil%rhosoil_vec(:,k) = real(soil%rhosoil(:),r_2) + soil%cnsd_vec(:,k) = real(soil%cnsd ,r_2) + soil%css_vec(:,k) = real(soil%css ,r_2) + soil%watr(:,k) = 0.001_r_2 +END DO + +WHERE (soil%ssat_vec .LE. 0.0 .AND. soil%sfc_vec .GT. 0.0) + soil%ssat_vec = soil%sfc_vec + 0.05 +END WHERE + +! review:: good chance we want some of this is CM3 +!jhan!IF (cable_user%soil_thermal_fix) THEN +!jhan! +!jhan!if (allocated(ssat_bounded)) deallocate(ssat_bounded) +!jhan!if (allocated(rho_soil_bulk)) deallocate(rho_soil_bulk) +!jhan! +!jhan!allocate(ssat_bounded(size(soil%ssat_vec,dim=1),& +!jhan! size(soil%ssat_vec,dim=2) ) ) +!jhan! +!jhan!ssat_bounded(:,:) = min( ssat_hi, max(ssat_lo, & +!jhan! soil%ssat_vec(:,:) ) ) +!jhan! +!jhan!allocate(rho_soil_bulk(size(soil%rhosoil_vec,dim=1),& +!jhan! size(soil%rhosoil_vec,dim=2) ) ) +!jhan! +!jhan!rho_soil_bulk(:,:) = min(rhob_hi, max(rhob_lo , & +!jhan! (2700.0*(1.0 - ssat_bounded(:,:)) ) ) ) +!jhan! +!jhan! +!jhan!do k=1,ms +!jhan! do i=1,mp +!jhan! +!jhan! +!jhan! if (soil%isoilm(i) .ne. 9) then +!jhan! +!jhan! soil%rhosoil_vec(i,k) = 2700.0 +!jhan! +!jhan! soil%cnsd_vec(i,k) = ( (0.135*(1.0-ssat_bounded(i,k))) +& +!jhan! (64.7/rho_soil_bulk(i,k)) ) / & +!jhan! (1.0 - 0.947*(1.0-ssat_bounded(i,k))) +!jhan! +!jhan! end if +!jhan! +!jhan! end do +!jhan!end do +!jhan! +!jhan!k=1 +!jhan!do i=1,mp +!jhan! if (soil%isoilm(i) .ne. 9) then +!jhan! soil%rhosoil(i) = soil%rhosoil_vec(i,1) +!jhan! soil%cnsd(i) = soil%cnsd_vec(i,1) +!jhan! end if +!jhan!end do +!jhan! +!jhan! if (allocated(ssat_bounded)) deallocate(ssat_bounded) +!jhan! if (allocated(rho_soil_bulk)) deallocate(rho_soil_bulk) +!jhan! +!jhan!END IF +!jhan! +!jhan!!node depths +!jhan!IF (allocated(znode)) deallocate(znode) +!jhan!allocate(znode(ms)) +!jhan! +!jhan!znode(1) = soil%zshh(1) +!jhan!do k=2,ms +!jhan! znode(k) = znode(k-1) * 0.5*(soil%zse(k-1)+soil%zse(k)) +!jhan!end do +!jhan! +!jhan!IF (cable_user%gw_model) THEN +!jhan! +!jhan! DO k=1,ms +!jhan! +!jhan! do i=1,mp !from reversing pedotransfer functions +!jhan! !,ay cause io issues because not passed into um +!jhan! +!jhan! if (soil%isoilm(i) .ne. 9) then +!jhan! +!jhan! soil%hyds_vec(i,k) = soil%hyds_vec(i,k) * & !change in hyds +!jhan! exp(-gw_params%hkrz*( znode(k)-gw_params%zdepth) ) +!jhan! +!jhan! end if +!jhan! +!jhan! +!jhan! end do +!jhan! end do +!jhan! +!jhan! k=1 +!jhan! soil%hyds(:) = soil%hyds_vec(:,k) +!jhan! +!jhan!END IF + +RETURN +END SUBROUTINE initialize_soil + +END MODULE cbl_um_init_soil_mod diff --git a/src/coupled/AM3/control/cable/util/init/cbl_um_init_soilsnow.F90 b/src/coupled/AM3/control/cable/util/init/cbl_um_init_soilsnow.F90 new file mode 100644 index 000000000..c199527ca --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cbl_um_init_soilsnow.F90 @@ -0,0 +1,157 @@ +MODULE cbl_um_init_soilsnow_mod + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE initialize_soilsnow( mp, msn, ms, TFRZ, land_pts, nsurft, & + row_length, rows, ICE_SoilType,l_surft_pts, & + surft_pts, surft_index, smvcst, tsoil_tile, & + sthf_tile, smcl_tile, snow_tile, snow_rho1l, & + snow_age, isnow_flg3l, snow_rho3l, & + snow_depth3l, snow_mass3l, snow_tmp3l, soil, & + ssnow, veg_iveg, met_tk ) + +! subrs +USE cable_init_wetfac_mod, ONLY: initialize_wetfac + +! data +USE cable_def_types_mod, ONLY : r_2 +USE cable_def_types_mod, ONLY: soil_parameter_type, veg_parameter_type +USE cable_def_types_mod, ONLY: met_type, soil_snow_type +USE cable_phys_constants_mod, ONLY: density_ice, density_liq + +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: ms ! # soil layers +INTEGER, INTENT(IN) :: msn ! # snow layers +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: ICE_SoilType ! ice soil type index +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +LOGICAL, INTENT(IN) :: l_surft_pts(land_pts, nsurft) +REAL, INTENT(IN) :: smvcst(land_pts) +REAL, INTENT(IN) :: sthf_tile(land_pts, nsurft, ms) +REAL, INTENT(IN) :: smcl_tile(land_pts, nsurft, ms) +REAL, INTENT(IN) :: tsoil_tile(land_pts, nsurft, ms) +REAL, INTENT(IN) :: snow_rho1l(land_pts, nsurft) +REAL, INTENT(IN) :: snow_tile(land_pts, nsurft) +REAL, INTENT(IN) :: snow_age(land_pts, nsurft) +REAL, INTENT(IN) :: snow_rho3l(land_pts, nsurft, msn) +REAL, INTENT(IN) :: snow_depth3l(land_pts, nsurft, msn) +REAL, INTENT(IN) :: snow_mass3l(land_pts, nsurft, msn) +REAL, INTENT(IN) :: snow_tmp3l(land_pts, nsurft, msn) +INTEGER, INTENT(IN) :: isnow_flg3l(land_pts, nsurft) +REAL, INTENT(IN) :: TFRZ +INTEGER, INTENT(IN) :: veg_iveg(mp) +REAL, INTENT(IN) :: met_tk(mp) + +TYPE(soil_parameter_type), INTENT(IN) :: soil ! soil parameters +TYPE(soil_snow_type), INTENT(OUT) :: ssnow ! + +!local vars +INTEGER :: i,j,k,L,n +REAL :: zsetot +REAL :: ice_vol_tmp(land_pts, nsurft, ms) +REAL :: wbtot_mp(mp, ms) +REAL :: wbice_mp(mp, ms) + +ssnow%pudsto = 0.0 +ssnow%pudsmx = 0.0 +ssnow%wbtot = 0.0 +ssnow%totwblake = 0.0 ! wb_lake integrated over river timestep +ssnow%tggav = 0.0 +ssnow%qhz = 0.0 +ssnow%qhlev = 0.0 +ssnow%qrecharge = 0.0 +ssnow%rtevap_sat = 0.0 +ssnow%rtevap_unsat = 0.0 + +! identify module parameters here and recast (NOT ssnow% state variables) +ssnow%t_snwlr = 0.05 +ssnow%rtsoil = 50.0 +ssnow%satfrac = 0.5 +ssnow%wtd = 1.0 + +ssnow%snowd = PACK( snow_tile, l_surft_pts ) +ssnow%snage = PACK( snow_age, l_surft_pts ) +ssnow%ssdnn = PACK( snow_rho1l, l_surft_pts ) +ssnow%isflag = PACK( isnow_flg3L, l_surft_pts ) +ssnow%ssdnn = PACK( snow_rho1l, l_surft_pts ) +ssnow%isflag = PACK( isnow_flg3l, l_surft_pts ) + +! over snow layers +DO j=1, msn + ssnow%sdepth(:,j)= PACK( snow_depth3l(:,:,j), l_surft_pts ) + ssnow%smass(:,j) = PACK( snow_mass3l(:,:,j), l_surft_pts ) + ssnow%ssdn(:,j) = PACK( snow_rho3l(:,:,j), l_surft_pts ) + ssnow%tggsn(:,j) = PACK( snow_tmp3l(:,:,j), l_surft_pts ) +ENDDO + +! over soil layers +DO j=1, ms + ssnow%tgg(:,j) = PACK( tsoil_tile(:,:,j), l_surft_pts ) +ENDDO + +ssnow%osnowd = ssnow%snowd + +zsetot = sum(soil%zse) +DO k = 1, ms + ssnow%tggav = ssnow%tggav + soil%zse(k)*ssnow%tgg(:,k)/zsetot +END DO + +ice_vol_tmp(:,:,:) = 0.0 +DO n=1,nsurft + DO k=1,surft_pts(n) + i = surft_index(k,n) + DO j = 1, ms + ice_vol_tmp(i,n,j) = sthf_tile(i,n,j) * smvcst(i) + ENDDO ! J + ENDDO +ENDDO + +DO j = 1, ms + !liq volume from (tot_mass - ice_mass) / (dz*rho_liq) + wbtot_mp(:,j) = PACK( smcl_tile(:,:,j), l_surft_pts ) + + ssnow%wbice(:,J) = PACK( ice_vol_tmp(:,:,j), l_surft_pts ) + ssnow%wbice(:,J) = MAX ( 0.0 , ssnow%wbice(:,j) ) + wbice_mp(:,j) = ssnow%wbice(:,j) * ( soil%zse(j) * density_ice ) + + ssnow%wbliq(:,j) = ( wbtot_mp(:,j) - wbice_mp(:,j) ) / ( soil%zse(j) * density_liq ) + ssnow%wb(:,j) = ssnow%wbice(:,j) + ssnow%wbliq(:,j) +END DO + +! wetfac initialized here as used to init owetfac on firstimestep in cbm +! add to startdump? includes Temporay fix for accounting for reduction of +! soil evaporation due to freezing. Also includes specific lakes case +! Prevents divide by zero at glaciated points where both wb and wbice=0. +CALL initialize_wetfac( mp, ssnow%wetfac, soil%swilt, soil%sfc, & + ssnow%wb(:,1), ssnow%wbice(:,1), ssnow%snowd, & + veg_iveg, met_tk, tfrz ) + +! initialized here on first call +ssnow%tss=(1-ssnow%isflag)*ssnow%tgg(:,1) + ssnow%isflag*ssnow%tggsn(:,1) + +!jhan: do we want to do this before %owetfac is set +DO J = 1, ms + !should be removed!!!!!!!! This cannot conserve if there are any + !dynamics + WHERE( soil%isoilm == ICE_SoilType) + ssnow%wb(:,j) = 0.95 * soil%ssat + ssnow%wbice(:,j) = 0.85 * ssnow%wb(:,j) + ENDWHERE + + !no not force rho_water==rho_ice==1000.0 + ssnow%wbtot = ssnow%wbtot + soil%zse(j) * & + ( ssnow%wbliq(:,j) * density_liq + & + ssnow%wbice(:,j) * density_ice ) +ENDDO + +RETURN +END SUBROUTINE initialize_soilsnow + +END MODULE cbl_um_init_soilsnow_mod + diff --git a/src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90 b/src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90 new file mode 100644 index 000000000..fe1fe67b9 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90 @@ -0,0 +1,71 @@ +MODULE cbl_um_init_veg_mod + +IMPLICIT NONE + +PUBLIC initialize_veg + +CONTAINS + +SUBROUTINE initialize_veg( SurfaceType, SoilType, mp,& + ms, nrb, npft, nsurft, land_pts, l_tile_pts, & + ICE_SurfaceType, ICE_SoilType, LAI_thresh, & + soil_zse, surft_pts, surft_index, tile_frac, & + veg, soil, pars ) + +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_def_types_mod, ONLY: veg_parameter_type +USE cable_def_types_mod, ONLY: soil_parameter_type, r_2 + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: ms +INTEGER, INTENT(IN) :: nrb +INTEGER, INTENT(IN) :: nsurft +INTEGER, INTENT(IN) :: npft +INTEGER, INTENT(IN) :: land_pts +INTEGER, INTENT(IN) :: ICE_SurfaceType ! index ICE surface type +INTEGER, INTENT(IN) :: ICE_SoilType ! index soil type +REAL, INTENT(IN) :: lai_thresh +REAL, INTENT(IN) :: soil_zse(ms) ! soil depth per layer +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) + +INTEGER, INTENT(IN) :: SurfaceType(mp) ! surface tile PFT/nveg +INTEGER, INTENT(IN) :: SoilType(mp) ! soil type per tile + +TYPE(veg_parameter_type), INTENT(OUT) :: veg ! vegetation parameters +TYPE(soil_parameter_type), INTENT(OUT) :: soil ! soil parameters +TYPE(params_io_data_type), INTENT(IN) :: pars + +! local vars +INTEGER :: i +REAL :: totdepth + +veg%meth = 1 ! review !should be namelist config if even used +veg%ejmax = 2.0 * veg%vcmax +veg%gamma = 3.e-2 ! for Haverd2013 switch ! offline init _parameters +veg%F10 = 0.85 ! offline set init _parameters + +! calculate veg%froot from using rootbeta and soil depth +! (Jackson et al. 1996, Oceologica, 108:389-411) +totdepth = 0.0 +DO i = 1, ms-1 + totdepth = totdepth + soil_zse(i) * 100.0 ! unit in centimetres + veg%froot(:, i) = MIN( 1.0_r_2, 1.0-veg%rootbeta(:)**totdepth ) +END DO +veg%froot(:, ms) = 1.0 - veg%froot(:, ms-1) +DO i = ms-1, 2, -1 + veg%froot(:, i) = veg%froot(:, i)-veg%froot(:,i-1) +END DO + +RETURN +END SUBROUTINE initialize_veg + +END MODULE cbl_um_init_veg_mod + + + + diff --git a/src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90.manual b/src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90.manual new file mode 100644 index 000000000..b1548b0d8 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/init/cbl_um_init_veg.F90.manual @@ -0,0 +1,77 @@ +MODULE cbl_um_init_veg_mod + +IMPLICIT NONE + +PUBLIC initialize_veg + +CONTAINS + +SUBROUTINE initialize_veg( SurfaceType, SoilType, mp,& + ms, nrb, npft, nsurft, land_pts, l_tile_pts, & + ICE_SurfaceType, ICE_SoilType, LAI_thresh, & + soil_zse, surft_pts, surft_index, tile_frac, & + veg, soil, pars ) + +USE init_cable_parms_mod, ONLY: init_cable_parms_expl +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_def_types_mod, ONLY: veg_parameter_type +USE cable_def_types_mod, ONLY: soil_parameter_type, r_2 + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: ms +INTEGER, INTENT(IN) :: nrb +INTEGER, INTENT(IN) :: nsurft +INTEGER, INTENT(IN) :: npft +INTEGER, INTENT(IN) :: land_pts +INTEGER, INTENT(IN) :: ICE_SurfaceType ! index ICE surface type +INTEGER, INTENT(IN) :: ICE_SoilType ! index soil type +REAL, INTENT(IN) :: lai_thresh +REAL, INTENT(IN) :: soil_zse(ms) ! soil depth per layer +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) + +INTEGER, INTENT(OUT) :: SurfaceType(mp) ! surface tile PFT/nveg +INTEGER, INTENT(OUT) :: SoilType(mp) ! soil type per tile + +TYPE(veg_parameter_type), INTENT(OUT) :: veg ! vegetation parameters +TYPE(soil_parameter_type), INTENT(OUT) :: soil ! soil parameters +TYPE(params_io_data_type), INTENT(IN) :: pars + +! local vars +INTEGER :: i +REAL :: totdepth + +CALL init_cable_parms_expl( SurfaceType, SoilType, mp, ms, nrb, land_pts, & + nsurft, l_tile_pts, ICE_SurfaceType, & + ICE_SoilType, soil_zse, veg, soil, pars, tile_frac ) + +veg%meth = 1 ! review !should be namelist config if even used +veg%ejmax = 2.*veg%vcmax +veg%gamma = 3.e-2 ! for Haverd2013 switch ! offline set init _parameters +veg%F10 = 0.85 ! offline set init _parameters + +! calculate veg%froot from using rootbeta and soil depth +! (Jackson et al. 1996, Oceologica, 108:389-411) +totdepth = 0.0 +DO i = 1, ms-1 + totdepth = totdepth + soil_zse(i) * 100.0 ! unit in centimetres + veg%froot(:, i) = MIN( 1.0_r_2, 1.0-veg%rootbeta(:)**totdepth ) +END DO +veg%froot(:, ms) = 1.0 - veg%froot(:, ms-1) +DO i = ms-1, 2, -1 + veg%froot(:, i) = veg%froot(:, i)-veg%froot(:,i-1) +END DO + + +RETURN +END SUBROUTINE initialize_veg + +END MODULE cbl_um_init_veg_mod + + + + diff --git a/src/coupled/AM3/control/cable/util/map_paramaters_cbl.F90 b/src/coupled/AM3/control/cable/util/map_paramaters_cbl.F90 new file mode 100644 index 000000000..2f7219516 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/map_paramaters_cbl.F90 @@ -0,0 +1,230 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE map_cable_parms_mod + +!------------------------------------------------------------------------------ +! Description: +! Initialises CABLE parameter variables from values read in namelist +! +! This MODULE is USEd in: +! cable_land_albedo_mod_cbl.F90 +! +! This MODULE contains 1 public Subroutine: +! map_cable_parms_rad +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +!------------------------------------------------------------------------------ + +IMPLICIT NONE + +PUBLIC map_cable_parms + +CONTAINS + +SUBROUTINE map_cable_parms( mp, ms, nrb, land_pts, nsurft, l_tile_pts, & + ICE_SurfaceType, ICE_SoilType, soil_zse, veg, & + soil, pars, tile_frac ) + +! Description: +! Nothing further to add to the module description. + +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_def_types_mod, ONLY: veg_parameter_type +USE cable_def_types_mod, ONLY: soil_parameter_type + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: ms +INTEGER, INTENT(IN) :: nrb +INTEGER, INTENT(IN) :: nsurft +INTEGER, INTENT(IN) :: land_pts +INTEGER, INTENT(IN) :: ICE_SurfaceType !index ICE surface type +INTEGER, INTENT(IN) :: ICE_SoilType !index soil type +LOGICAL, INTENT(IN) :: l_tile_pts(land_pts,nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: soil_zse(ms) ! soil depth per layer +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) + +TYPE(veg_parameter_type), INTENT(OUT) :: veg ! vegetation parameters +TYPE(soil_parameter_type), INTENT(OUT) :: soil ! soil parameters +TYPE(params_io_data_type), INTENT(IN) :: pars + + +!local vars +INTEGER :: JSurfaceTypeID(land_pts,nsurft) +INTEGER :: i, j, h + +CALL DefinePatchType( veg%iveg, soil%isoilm, mp, land_pts, nsurft, & + ICE_SurfaceType, ICE_SoilType, tile_frac, L_tile_pts ) + +CALL init_ALLveg( veg%iveg, mp, ms, nrb, veg, pars ) + +CALL init_ALLsoil( soil%isoilm, mp, ms, soil_zse, soil, pars ) + +RETURN +END SUBROUTINE map_cable_parms + +SUBROUTINE DefinePatchType( SurfaceType, SoilType, mp, land_pts, nsurft, & + ICE_SurfaceType, ICE_SoilType, tile_frac, L_tile_pts) + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(OUT) :: SurfaceType(mp) !CABLE surface tile PFT/nveg +INTEGER, INTENT(OUT) :: SoilType(mp) !CABLE soil type per tile + +INTEGER, INTENT(IN) :: nsurft +INTEGER, INTENT(IN) :: land_pts +INTEGER, INTENT(IN) :: ICE_SurfaceType ! index ICE surface type +INTEGER, INTENT(IN) :: ICE_SoilType ! index soil type +LOGICAL, INTENT(IN) :: l_tile_pts(land_pts,nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: tile_frac(land_pts,nsurft) + +!local vars +INTEGER :: JSurfaceTypeID(land_pts,nsurft) +INTEGER :: i, j + +!local var to pack surface type: +JSurfaceTypeID = 0 +DO j = 1, land_pts + DO i = 1, nsurft + IF ( tile_frac(j,i) > 0 ) JSurfaceTypeID(j,i) = i + END DO +END DO + +SurfaceType = 0 +SurfaceType = PACK( JSurfaceTypeID, L_tile_pts) + +SoilType(:)=2 +DO j=1,mp + IF (SurfaceType(j) == ICE_SurfaceType) THEN + SoilType(j)= ICE_SoilType + END IF +END DO + +END SUBROUTINE DefinePatchType + +SUBROUTINE init_ALLveg( SurfaceType, mp, ms, nrb, veg, pars ) + +! Description: Map per PFT parameters onto CABLE vectors of length mp +! Note: Canopy height (%hc) & LAI (%vlai) are clobbered by +! range limited UM/JULES spatial fields in limit_HGT_LAI() + +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_def_types_mod, ONLY: veg_parameter_type, r_2 + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: SurfaceType(mp) ! CABLE surface tile PFT/nveg +INTEGER, INTENT(IN) :: ms +INTEGER, INTENT(IN) :: nrb + +TYPE(veg_parameter_type), INTENT(OUT) :: veg ! vegetation parameters +TYPE(params_io_data_type), INTENT(IN) :: pars + +!local vars +INTEGER :: i, h + +DO h = 1, mp ! over each patch in current grid + + veg%frac4(h) = pars%vegin_frac4(SurfaceType(h)) + veg%taul(h,1) = pars%vegin_taul(1,SurfaceType(h)) + veg%taul(h,2) = pars%vegin_taul(2,SurfaceType(h)) + veg%refl(h,1) = pars%vegin_refl(1,SurfaceType(h)) + veg%refl(h,2) = pars%vegin_refl(2,SurfaceType(h)) + veg%canst1(h) = pars%vegin_canst1(SurfaceType(h)) + veg%dleaf(h) = pars%vegin_dleaf(SurfaceType(h)) + veg%vcmax(h) = pars%vegin_vcmax(SurfaceType(h)) + veg%ejmax(h) = pars%vegin_ejmax(SurfaceType(h)) + veg%hc(h) = pars%vegin_hc(SurfaceType(h)) + veg%xfang(h) = pars%vegin_xfang(SurfaceType(h)) + veg%vbeta(h) = pars%vegin_vbeta(SurfaceType(h)) + veg%xalbnir(h) = pars%vegin_xalbnir(SurfaceType(h)) + veg%rp20(h) = pars%vegin_rp20(SurfaceType(h)) + veg%rpcoef(h) = pars%vegin_rpcoef(SurfaceType(h)) + veg%rs20(h) = pars%vegin_rs20(SurfaceType(h)) + veg%shelrb(h) = pars%vegin_shelrb(SurfaceType(h)) + veg%wai(h) = pars%vegin_wai(SurfaceType(h)) + veg%a1gs(h) = pars%vegin_a1gs(SurfaceType(h)) + veg%d0gs(h) = pars%vegin_d0gs(SurfaceType(h)) + veg%vegcf(h) = pars%vegin_vegcf(SurfaceType(h)) + veg%extkn(h) = pars%vegin_extkn(SurfaceType(h)) + veg%tminvj(h) = pars%vegin_tminvj(SurfaceType(h)) + veg%tmaxvj(h) = pars%vegin_tmaxvj(SurfaceType(h)) + veg%g0(h) = pars%vegin_g0(SurfaceType(h)) ! Ticket #56 + veg%g1(h) = pars%vegin_g1(SurfaceType(h)) ! Ticket #56 + veg%a1gs(h) = pars%vegin_a1gs(SurfaceType(h)) + veg%d0gs(h) = pars%vegin_d0gs(SurfaceType(h)) + veg%alpha(h) = pars%vegin_alpha(SurfaceType(h)) + veg%convex(h) = pars%vegin_convex(SurfaceType(h)) + veg%cfrd(h) = pars%vegin_cfrd(SurfaceType(h)) + veg%gswmin(h) = pars%vegin_gswmin(SurfaceType(h)) + veg%conkc0(h) = pars%vegin_conkc0(SurfaceType(h)) + veg%conko0(h) = pars%vegin_conko0(SurfaceType(h)) + veg%ekc(h) = pars%vegin_ekc(SurfaceType(h)) + veg%eko(h) = pars%vegin_eko(SurfaceType(h)) + veg%rootbeta(h) = pars%vegin_rootbeta(SurfaceType(h)) + veg%zr(h) = pars%vegin_zr(SurfaceType(h)) + veg%clitt(h) = pars%vegin_clitt(SurfaceType(h)) + +END DO ! over each veg patch in land point + +RETURN +END SUBROUTINE init_ALLveg + +SUBROUTINE init_ALLsoil( SoilType, mp, ms, soil_zse, soil, pars ) + +! Description: UM/JULES spatial fields are used later in initialize_soil() to +! define soil properties. However note these are per landpoint as +! JULES doesn't have soil per tile. We use PFT=ICE to define +! Soil=ICE and use values from here. Also, there is no soil density +! field in the UM, we effectively use density @ soil%isoilm=2 + +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_def_types_mod, ONLY: soil_parameter_type + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: ms +INTEGER, INTENT(IN) :: SoilType(mp) !CABLE soil type per tile +REAL, INTENT(IN) :: soil_zse(ms) ! soil depth per layer + +TYPE(soil_parameter_type), INTENT(OUT) :: soil ! vegetation parameters +TYPE(params_io_data_type), INTENT(IN) :: pars + +!local vars +INTEGER :: h + +soil%zse(:) = soil_zse(:) + +DO h = 1, mp ! over each patch in current grid + + soil%swilt(h) = pars%soilin_swilt(SoilType(h)) + soil%sfc(h) = pars%soilin_sfc(SoilType(h)) + soil%ssat(h) = pars%soilin_ssat(SoilType(h)) + soil%bch(h) = pars%soilin_bch(SoilType(h)) + soil%hyds(h) = pars%soilin_hyds(SoilType(h)) + soil%sucs(h) = pars%soilin_sucs(SoilType(h)) + soil%rhosoil(h) = pars%soilin_rhosoil(SoilType(h)) + soil%css(h) = pars%soilin_css(SoilType(h)) + soil%silt(h) = pars%soilin_silt(SoilType(h)) + soil%clay(h) = pars%soilin_clay(SoilType(h)) + soil%sand(h) = pars%soilin_sand(SoilType(h)) + +END DO + +END SUBROUTINE init_ALLsoil + +END MODULE map_cable_parms_mod diff --git a/src/coupled/AM3/control/cable/util/pack_mod_cbl.F90 b/src/coupled/AM3/control/cable/util/pack_mod_cbl.F90 new file mode 100644 index 000000000..eec8c407f --- /dev/null +++ b/src/coupled/AM3/control/cable/util/pack_mod_cbl.F90 @@ -0,0 +1,164 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE cable_pack_mod + +!----------------------------------------------------------------------------- +! Description: +! JULES met forcing vars needed by CABLE commonly have JULES dimensions +! (row_length,rows), which are no good for CABLE. These have to be +! re-packed in a single vector of active tiles. Hence we use +! conditional "mask" l_tile_pts(land_pts,ntiles) which is .true. +! if the land point is/has an active tile. A packing routine for +! land_point dimensioned JULES fields is to be included as required on the +! subsequent (e.g. explicit) CALLs to CABLE +! +! This MODULE is USEd by: +! cable_land_albedo_mod.F90 +! +! This MODULE contains 1 public Subroutine: +! cable_pack_rr, +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +IMPLICIT NONE +PUBLIC :: cable_pack_rr, pack_landpts2mp_ICE, pack_landpts2mp +PRIVATE + +CONTAINS + +SUBROUTINE cable_pack_rr( cable_var, jules_var, mp, l_tile_pts, row_length, & + rows, ntype, land_pts, land_index, surft_pts, & + surft_index ) + +! Description: +! Nothing further to add to module description. + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp, row_length, rows, ntype, land_pts +REAL, INTENT(OUT) :: cable_var(mp) +LOGICAL, INTENT(IN) :: l_tile_pts(land_pts, ntype) +INTEGER, INTENT(IN) :: land_index(land_pts) !Index in (x,y) array +INTEGER, INTENT(IN) :: surft_pts(ntype) !# land points per PFT +INTEGER, INTENT(IN) :: surft_index(land_pts,ntype) !Index in land_pts array +REAL, INTENT(IN) :: jules_var(row_length, rows) +!local vars +REAL :: fvar(land_pts, ntype) +INTEGER :: n, k, l, j, i + +fvar(:, :) = 0.0 +DO n = 1, ntype + ! loop over number of points per tile + DO k = 1, surft_pts(n) + l = surft_index(k, n) + j = (land_index(l) - 1) / row_length + 1 + i = land_index(l) - (j-1) * row_length + fvar(l, n) = jules_var(i, j) + END DO +END DO +cable_var = PACK(fvar, l_tile_pts) + +RETURN +END SUBROUTINE cable_pack_rr + +!--- UM met forcing vars needed by CABLE which have UM dimensions +!---(land_points)[_lp], which is no good to cable. These have to be +!--- re-packed in a single vector of active tiles. Hence we use +!--- conditional "mask" l_tile_pts(land_pts,ntiles) which is .true. +!--- if the land point is/has an active tile +SUBROUTINE pack_landpts2mp_ICE( nsurft, land_pts, mp, nsoil_max, ICE_soiltype, & + tile_pts, tile_index, L_tile_pts, umvar, & + soiltype, ICE_value, cablevar ) + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: nsurft +INTEGER, INTENT(IN) :: land_pts +INTEGER, INTENT(IN) :: mp +INTEGER, INTENT(IN) :: nsoil_max +INTEGER, INTENT(IN) :: ICE_soiltype +INTEGER, INTENT(IN) :: soiltype(mp) +INTEGER, INTENT(IN) :: tile_pts(nsurft) +INTEGER, INTENT(IN) :: tile_index(land_pts, nsurft) +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) +REAL, INTENT(IN) :: umvar(land_pts) +REAL, INTENT(IN) :: ICE_value(nsoil_max) +REAL, INTENT(INOUT) :: cablevar(mp) +!local vars +REAL :: fvar(land_pts, nsurft) +INTEGER :: n,k,l,i + +fvar(:,:) = 0.0 +DO n=1, nsurft + + ! loop over number of points per nth tile + DO k=1,tile_pts(n) + ! land pt index of point + L = tile_index(k,n) + ! at this point fvar=umvar, ELSE=0.0 + fvar(l,n) = umvar(l) + ENDDO + +ENDDO + +cablevar = PACK(fvar,L_tile_pts) + +DO i=1,mp + + IF(soiltype(i)==ICE_soiltype) THEN + cablevar(i) = ICE_value(ICE_soiltype) + END IF + +ENDDO + +END SUBROUTINE pack_landpts2mp_ICE + +SUBROUTINE pack_landpts2mp( nsurft, land_pts, mp, tile_pts, tile_index, & + L_tile_pts, umvar, cablevar ) + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: nsurft +INTEGER, INTENT(IN) :: land_pts +INTEGER, INTENT(IN) :: mp +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) +INTEGER, INTENT(IN) :: tile_pts(nsurft) +INTEGER, INTENT(IN) :: tile_index(land_pts, nsurft) +REAL, INTENT(IN) :: umvar(land_pts) +REAL, INTENT(INOUT) :: cablevar(mp) +!local vars +REAL :: fvar(land_pts, nsurft) +INTEGER :: n,k,l + +fvar(:,:) = 0.0 +DO n=1, nsurft + ! loop over number of points per nth tile + DO k=1,tile_pts(n) + ! land pt index of point + l = tile_index(k,n) + ! at this point fvar=umvar, ELSE=0.0 + fvar(l,n) = umvar(l) + ENDDO +ENDDO + +cablevar = PACK(fvar,L_tile_pts) + +END SUBROUTINE pack_landpts2mp + + +END MODULE cable_pack_mod diff --git a/src/coupled/AM3/control/cable/util/update/cbl_um_update.F90 b/src/coupled/AM3/control/cable/util/update/cbl_um_update.F90 new file mode 100644 index 000000000..a290eed7d --- /dev/null +++ b/src/coupled/AM3/control/cable/util/update/cbl_um_update.F90 @@ -0,0 +1,117 @@ +MODULE cbl_um_update_mod + +IMPLICIT NONE +PUBLIC :: update_data +PRIVATE + +CONTAINS + +SUBROUTINE update_data( row_length, rows, land_pts, nsurft, npft, ms, msn, & + timestep, timestep_number, mp, nrb, CO2_MMR, & + HGT_pft_um, lai_pft_um, land_index, surft_pts, & + surft_index, tile_frac, L_tile_pts, cos_zenith_angle, & + latitude, longitude, sw_down_VIS, sw_down_NIR, & + beamFrac_VIS, beamFrac_NIR, beamFrac_TOT, lw_down, & + ls_rain, ls_snow, tl_1, qw_1, vshr_land, pstar, z1_tq, & + z1_uv, canopy_tile, rad, met, veg, soil, rough,canopy, & + ssnow, HGT_pft_cbl, LAI_pft_cbl, reducedLAIdue2snow ) + +USE cbl_um_update_met_mod, ONLY: update_met +USE cbl_um_update_radiation_mod, ONLY: update_radiation +USE cbl_um_update_roughness_mod, ONLY: update_roughness +USE cbl_um_update_canopy_mod, ONLY: update_canopy +USE cbl_um_update_soilsnow_mod, ONLY: update_soilsnow +USE cbl_LAI_canopy_height_mod, ONLY: limit_HGT_LAI +USE params_io_mod_cbl, ONLY: params_io_data_type +USE cable_other_constants_mod, ONLY: LAI_THRESH +USE cable_def_types_mod, ONLY: radiation_type, met_type, & + veg_parameter_type, & + soil_parameter_type, roughness_type, & + canopy_type, soil_snow_type + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft ! # plant functional types +INTEGER, INTENT(IN) :: ms ! # soil layers +INTEGER, INTENT(IN) :: msn ! # snow layers +REAL, INTENT(IN) :: timestep +INTEGER, INTENT(IN) :: timestep_number +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nrb +REAL, INTENT(IN) :: co2_mmr +REAL, INTENT(IN) :: HGT_pft_um(land_pts, npft) +REAL, INTENT(IN) :: lai_pft_um(land_pts, npft) +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER, INTENT(IN) :: land_index(land_pts) ! tangled cell index of land_pt +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: tile_frac(land_pts, nsurft) +REAL, INTENT(IN) :: cos_zenith_angle(row_length,rows) +REAL, INTENT(IN) :: latitude(row_length,rows) +REAL, INTENT(IN) :: longitude(row_length,rows) +REAL, INTENT(IN) :: lw_down(row_length,rows) +REAL, INTENT(IN) :: ls_rain(row_length,rows) +REAL, INTENT(IN) :: ls_snow(row_length,rows) +REAL, INTENT(IN) :: tl_1(row_length,rows) +REAL, INTENT(IN) :: qw_1(row_length,rows) +REAL, INTENT(IN) :: vshr_land(row_length,rows) +REAL, INTENT(IN) :: pstar(row_length,rows) +REAL, INTENT(IN) :: z1_tq(row_length,rows) +REAL, INTENT(IN) :: z1_uv(row_length,rows) +REAL, INTENT(IN) :: sw_down_VIS(row_length,rows) +REAL, INTENT(IN) :: sw_down_NIR(row_length,rows) +REAL, INTENT(IN) :: beamFrac_VIS(row_length,rows) +REAL, INTENT(IN) :: beamFrac_NIR(row_length,rows) +REAL, INTENT(IN) :: beamFrac_TOT(row_length,rows) +REAL, INTENT(IN) :: canopy_tile(land_pts, nsurft) +REAL, INTENT(IN) :: reducedLAIdue2snow(mp) +REAL, INTENT(OUT) :: HGT_pft_cbl(mp) +REAL, INTENT(OUT) :: LAI_pft_cbl(mp) + +TYPE(soil_parameter_type), INTENT(IN) :: soil ! soil parameters +TYPE(radiation_type), INTENT(OUT) :: rad +TYPE(met_type), INTENT(OUT) :: met +TYPE(roughness_type), INTENT(OUT) :: rough +TYPE(canopy_type), INTENT(OUT) :: canopy +TYPE(soil_snow_type), INTENT(INOUT) :: ssnow ! +TYPE(veg_parameter_type), INTENT(INOUT) :: veg ! vegetation parameters + +! Even when prescribed LAI, canopy height are seasonal so this cant be done ONLY +! on first call limit IN height, LAI and initialize veg% equivalents +CALL limit_HGT_LAI( LAI_pft_cbl, HGT_pft_cbl, mp, land_pts, nsurft, npft, & + surft_pts, surft_index, tile_frac, l_tile_pts, LAI_pft_um, & + HGT_pft_um, LAI_thresh ) + +! def veg% as they are what is USEd used in core science code +veg%vlai = LAI_pft_cbl +veg%hc = HGT_pft_cbl + +!--- Met. forcing +CALL update_met( mp, row_length, rows, timestep, land_pts, nsurft, & + surft_pts, surft_index,land_index,L_tile_pts, co2_mmr, & + ls_rain, ls_snow, tl_1, qw_1, vshr_land, pstar, met ) + +CALL update_radiation( mp, row_length, rows, timestep, land_pts, nsurft, & + surft_pts, surft_index,land_index, L_tile_pts, & + latitude, longitude, cos_zenith_angle, sw_down_VIS, & + sw_down_NIR, beamFrac_VIS, beamFrac_NIR, & + beamFrac_TOT, lw_down, rad, met ) + +CALL update_roughness( row_length, rows, mp, land_pts, nsurft, npft, & + lai_thresh, surft_pts, surft_index, land_index, & + L_tile_pts, z1_tq, z1_uv, HGT_pft_um, HGT_pft_cbl, & + rough, veg ) + +CALL update_canopy( mp, land_pts, nsurft, L_tile_pts, canopy_tile, & + reducedLAIdue2snow, canopy ) + +CALL update_soilsnow( mp, soil, ssnow, veg%iveg ) + +RETURN +END SUBROUTINE update_data + +END MODULE cbl_um_update_mod diff --git a/src/coupled/AM3/control/cable/util/update/cbl_um_update_canopy.F90 b/src/coupled/AM3/control/cable/util/update/cbl_um_update_canopy.F90 new file mode 100644 index 000000000..dc5de2c3d --- /dev/null +++ b/src/coupled/AM3/control/cable/util/update/cbl_um_update_canopy.F90 @@ -0,0 +1,36 @@ +MODULE cbl_um_update_canopy_mod + +IMPLICIT NONE + +PUBLIC update_canopy + +CONTAINS + +SUBROUTINE update_canopy( mp, land_pts, nsurft, L_tile_pts, canopy_tile, & + reducedLAIdue2snow, canopy ) + +USE cable_def_types_mod, ONLY: canopy_type + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: land_pts ! # land points +INTEGER, INTENT(IN) :: nsurft ! # tiles +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) +REAL, INTENT(IN) :: canopy_tile(land_pts, nsurft) +REAL, INTENT(IN) :: reducedLAIdue2snow(mp) +TYPE(canopy_type), INTENT(OUT) :: canopy + +!---set canopy storage (already in dim(land_pts,ntiles) ) +canopy%cansto = PACK(CANOPY_TILE, l_tile_pts) +canopy%oldcansto = canopy%cansto +canopy%vlaiw = reducedLAIdue2snow + +RETURN +END SUBROUTINE update_canopy + +END MODULE cbl_um_update_canopy_mod + + + + diff --git a/src/coupled/AM3/control/cable/util/update/cbl_um_update_met.F90 b/src/coupled/AM3/control/cable/util/update/cbl_um_update_met.F90 new file mode 100644 index 000000000..39576370c --- /dev/null +++ b/src/coupled/AM3/control/cable/util/update/cbl_um_update_met.F90 @@ -0,0 +1,111 @@ +MODULE cbl_um_update_met_mod + + IMPLICIT NONE + +CONTAINS + +SUBROUTINE update_met( mp, row_length, rows, timestep, land_pts, nsurft, & + surft_pts, surft_index, land_index, L_tile_pts, co2_mmr,& + ls_rain, ls_snow, tl_1, qw_1, vshr_land, pstar, met ) + !block!CO2_MMR,CO2_3D,CO2_DIM_LEN,CO2_DIM_ROW, + !block!L_CO2_INTERACTIVE ) + +USE cable_pack_mod, ONLY: cable_pack_rr +USE cable_phys_constants_mod, ONLY: UMIN +USE cable_def_types_mod, ONLY: met_type + +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles +REAL, INTENT(IN) :: timestep +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # points on each tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! index of tile points +INTEGER, INTENT(IN) :: land_index(land_pts) ! index of land points +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) + +! "forcing" +REAL, INTENT(IN) :: co2_mmr +REAL, INTENT(IN) :: ls_rain(row_length,rows) +REAL, INTENT(IN) :: ls_snow(row_length,rows) +REAL, INTENT(IN) :: tl_1(row_length,rows) +REAL, INTENT(IN) :: qw_1(row_length,rows) +REAL, INTENT(IN) :: vshr_land(row_length,rows) +REAL, INTENT(IN) :: pstar(row_length,rows) + +TYPE(met_type), INTENT(OUT) :: met + +!local decs +REAL :: ls_rain_dt(row_length,rows) +REAL :: ls_snow_dt(row_length,rows) +REAL :: precip_dt(row_length,rows) +REAL :: CO2_3D(row_length,rows) ! co2 mass mixing ratio +LOGICAL :: L_CO2_INTERACTIVE = .FALSE. ! namelist? + +!block!! rml 2/7/13 Extra atmospheric co2 variables +!block! LOGICAL, INTENT(IN) :: L_CO2_INTERACTIVE +!block! INTEGER, INTENT(IN) :: CO2_DIM_LEN, CO2_DIM_ROW +!block! REAL, INTENT(IN) :: CO2_3D(:,:) ! co2 mass mixing ratio + +met%DoY = 1.0 !jhan: fudged initialization to prevent dangling arg to init_rad + +!jhan:implies precip is given as per second +ls_rain_dt = ls_rain * timestep +ls_snow_dt = ls_snow * timestep +precip_dt = ls_rain_dt + ls_snow_dt +CALL cable_pack_rr( met%precip, precip_dt, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%precip_sn, ls_snow_dt, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%tk, tl_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%qv, qw_1, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%ua, vshr_land, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +met%ua = MAX( UMIN, met%ua ) !---this is necessary cloberring at present + +CALL cable_pack_rr( met%pmb, pstar, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +met%pmb = 0.01 * met%pmb ! what is this .01? Units conversion? + +!block!IF( .NOT. ALLOCATED( conv_rain_prevstep(mp) ) ) THEN +!block! ALLOCATE( conv_rain_prevstep(mp ) +!block! ALLOCATE( conv_snow_prevstep(mp) ) +!block! conv_rain_prevstep = 0. +!block! conv_snow_prevstep = 0. +!block!ENDIF +!block!we would need to get conv_*_from prev step for a start +!block!met%precip = (met%precip + conv_rain_prevstep) & +!block! + (met%precip_sn + conv_snow_prevstep) +!block! + (met%precip_sn + conv_rain_prevstep) + +!jhan:This might be peculiar to the UM? and if so presents a problem +met%tvair = met%tk +met%tvrad = met%tk + +!******************clobbered by a hard-wired number ********************! +! rml 24/2/11 Set atmospheric CO2 seen by cable to CO2_MMR (value seen +! by radiation scheme). Option in future to have cable see interactive +! (3d) CO2 field Convert CO2 from kg/kg to mol/mol ( m_air, +! 28.966 taken from include/constant/ccarbon.h file ) +! r935 rml 2/7/13 Add in co2_interactive option +IF (L_CO2_INTERACTIVE) THEN + CALL cable_pack_rr( met%ca, CO2_3D, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) +ELSE + met%ca = CO2_MMR +ENDIF +!jhan:WTF +met%ca = met%ca * 28.966/44. + +END SUBROUTINE update_met + +END MODULE cbl_um_update_met_mod diff --git a/src/coupled/AM3/control/cable/util/update/cbl_um_update_radiation.F90 b/src/coupled/AM3/control/cable/util/update/cbl_um_update_radiation.F90 new file mode 100644 index 000000000..5d4e0af80 --- /dev/null +++ b/src/coupled/AM3/control/cable/util/update/cbl_um_update_radiation.F90 @@ -0,0 +1,88 @@ +MODULE cbl_um_update_radiation_mod + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE update_radiation( mp, row_length, rows, timestep, land_pts, nsurft, & + surft_pts, surft_index, land_index, L_tile_pts, & + latitude, longitude, cos_zenith_angle, & + sw_down_VIS, sw_down_NIR, beamFrac_VIS, & + beamFrac_NIR, beamFrac_TOT, lw_down, rad, met ) + +USE cable_pack_mod, ONLY: cable_pack_rr +USE cable_other_constants_mod, ONLY: RAD_THRESH +USE cable_def_types_mod, ONLY: radiation_type, met_type +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: row_length ! # columns in spatial grid +INTEGER, INTENT(IN) :: rows ! # rows in spatial grid +REAL, INTENT(IN) :: timestep +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +INTEGER, INTENT(IN) :: nsurft ! # tiles + +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER, INTENT(IN) :: land_index(land_pts) ! tangled cell index of land_pt +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: cos_zenith_angle(row_length,rows) +REAL, INTENT(IN) :: latitude(row_length,rows) +REAL, INTENT(IN) :: longitude(row_length,rows) + +! radiation streams +REAL, INTENT(IN) :: sw_down_VIS(row_length,rows) +REAL, INTENT(IN) :: sw_down_NIR(row_length,rows) +REAL, INTENT(IN) :: beamFrac_VIS(row_length,rows) +REAL, INTENT(IN) :: beamFrac_NIR(row_length,rows) +REAL, INTENT(IN) :: beamFrac_TOT(row_length,rows) +REAL, INTENT(IN) :: lw_down(row_length,rows) + +TYPE(radiation_type), INTENT(OUT) :: rad +TYPE(met_type), INTENT(OUT) :: met + +!local vars +INTEGER :: i + +rad%otrad = rad%trad + +CALL cable_pack_rr( met%coszen, cos_zenith_angle, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +met%coszen = max(met%coszen,1e-8) ! is this really required now + +CALL cable_pack_rr( met%fsd(:,1), sw_down_VIS, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( met%fsd(:,2), sw_down_NIR, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( rad%fbeam(:,1), beamFrac_VIS, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( rad%fbeam(:,2), beamFrac_NIR, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( rad%fbeam(:,3), beamFrac_TOT, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) +DO i=1,mp + IF( met%coszen(i) < RAD_THRESH ) THEN + rad%fbeam(i,1) = REAL(0) + rad%fbeam(i,2) = REAL(0) + rad%fbeam(i,3) = REAL(0) + END IF +END DO + +CALL cable_pack_rr( met%fld, lw_down, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( rad%latitude, latitude, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( rad%longitude, longitude, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +RETURN +END SUBROUTINE update_radiation + +END MODULE cbl_um_update_radiation_mod diff --git a/src/coupled/AM3/control/cable/util/update/cbl_um_update_roughness.F90 b/src/coupled/AM3/control/cable/util/update/cbl_um_update_roughness.F90 new file mode 100644 index 000000000..d8ef7221f --- /dev/null +++ b/src/coupled/AM3/control/cable/util/update/cbl_um_update_roughness.F90 @@ -0,0 +1,73 @@ +MODULE cbl_um_update_roughness_mod + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE update_roughness( row_length, rows, mp, land_pts, nsurft, npft, & + lai_thresh, surft_pts, surft_index, land_index, & + L_tile_pts, z1_tq, z1_uv, HGT_pft_um, HGT_pft_cbl,& + rough, veg ) + +USE cable_pack_mod, ONLY: cable_pack_rr +USE cable_def_types_mod, ONLY: roughness_type, veg_parameter_type + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: row_length +INTEGER, INTENT(IN) :: rows +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: nsurft ! # tiles +INTEGER, INTENT(IN) :: npft +INTEGER, INTENT(IN) :: land_pts ! # land points being processed +REAL, INTENT(IN) :: lai_thresh +INTEGER, INTENT(IN) :: surft_pts(nsurft) ! # land points per tile +INTEGER, INTENT(IN) :: surft_index(land_pts, nsurft) ! land_pt index of point +INTEGER, INTENT(IN) :: land_index(land_pts) ! tangled cell index of land_pt +LOGICAL, INTENT(IN) :: L_tile_pts(land_pts, nsurft) ! TRUE if active tile +REAL, INTENT(IN) :: z1_tq(row_length, rows) +REAL, INTENT(IN) :: z1_uv(row_length, rows) +REAL, INTENT(IN) :: HGT_pft_um(land_pts,nsurft) +REAL, INTENT(IN) :: HGT_pft_cbl(mp) + +TYPE(roughness_type), INTENT(OUT) :: rough +TYPE(veg_parameter_type), INTENT(IN) :: veg ! vegetation parameters + +!local vars +INTEGER :: i,j,k,L,n +REAL :: jhruff(land_pts,nsurft) +REAL :: jhwork(land_pts,nsurft) + +!--- CABLE roughness type forcings +CALL cable_pack_rr( rough%za_tq, z1_tq, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +CALL cable_pack_rr( rough%za_uv, z1_uv, mp, l_tile_pts, row_length, & + rows, nsurft, land_pts, land_index, surft_pts, surft_index ) + +!Veg height changes seasonally in MOSES hence no updates here due to snow +jhwork = 0. +DO n=1,nsurft + DO k=1,surft_pts(n) + l = surft_index(k,n) + jhwork(l,n) = MAX( .01, HGT_pft_um(L,N) ) + ENDDO +ENDDO + +jhruff= 0.01 +DO l=1,land_pts + DO n=1,nsurft + IF( jhruff(L,N) .lt. jhwork(l,n)) THEN + jhruff(L,:) = jhwork(l,n) + END IF + ENDDO +ENDDO + +! CM2 set hruff from veg%hc - will require review with POP implementation +rough%hruff= MAX( 0.01, HGT_pft_cbl ) +rough%hruff_grmx = PACK(jhruff, l_tile_pts) + +RETURN +END SUBROUTINE update_roughness + +END MODULE cbl_um_update_roughness_mod diff --git a/src/coupled/AM3/control/cable/util/update/cbl_um_update_soilsnow.F90 b/src/coupled/AM3/control/cable/util/update/cbl_um_update_soilsnow.F90 new file mode 100644 index 000000000..fb3c5872f --- /dev/null +++ b/src/coupled/AM3/control/cable/util/update/cbl_um_update_soilsnow.F90 @@ -0,0 +1,48 @@ +MODULE cbl_um_update_soilsnow_mod + +IMPLICIT NONE + +CONTAINS + +SUBROUTINE update_soilsnow( mp, soil, ssnow, veg_iveg ) + + +USE cable_def_types_mod, ONLY: soil_parameter_type +USE cable_def_types_mod, ONLY: soil_snow_type +USE cable_phys_constants_mod, ONLY: density_ice, density_liq +USE cable_surface_types_mod, ONLY: lakes_cable +IMPLICIT NONE + +INTEGER, INTENT(IN) :: mp ! # active land points +INTEGER, INTENT(IN) :: veg_iveg(mp) +!jhan:build fudge inOUT +TYPE(soil_snow_type), INTENT(inOUT) :: ssnow ! +TYPE(soil_parameter_type), INTENT(IN) :: soil ! soil parameters + +INTEGER :: j + +ssnow%wb_lake = 0.0 +ssnow%wbtot1 = 0.0 +ssnow%wbtot2 = 0.0 + +ssnow%wbliq = ssnow%wb - ssnow%wbice + +!jhan:this was in a do loop from 1:1 +! lakes: remove hard-wired number in future version +WHERE( veg_iveg == lakes_cable .AND. ssnow%wb(:,1) < soil%sfc ) + + ssnow%wbtot1 = ssnow%wbtot1 + REAL( ssnow%wb(:,1) ) * 1000.0 * & + soil%zse(1) + ssnow%wb(:,1) = soil%sfc + ssnow%wbtot2 = ssnow%wbtot2 + REAL( ssnow%wb(:,1) ) * 1000.0 * & + soil%zse(1) +ENDWHERE + +ssnow%wb_lake = MAX( ssnow%wbtot2 - ssnow%wbtot1, 0.) + +RETURN +END SUBROUTINE update_soilsnow + +END MODULE cbl_um_update_soilsnow_mod + + diff --git a/src/coupled/AM3/control/casa/shared/cnp_fields_mod.F90 b/src/coupled/AM3/control/casa/shared/cnp_fields_mod.F90 new file mode 100644 index 000000000..122a7aebe --- /dev/null +++ b/src/coupled/AM3/control/casa/shared/cnp_fields_mod.F90 @@ -0,0 +1,19 @@ +MODULE cnp_fields_mod + +! TYPE definitions +USE progs_cnp_vars_mod, ONLY: progs_cnp_vars_type, & + progs_cnp_vars_data_type + +USE work_vars_mod_cnp, ONLY: work_vars_type + +PUBLIC + +! instantiated TYPES to hold the data +TYPE(progs_cnp_vars_data_type), TARGET :: progs_cnp_vars_data + +! instantiated TYPES we pass around. These happen to be pointers to the data +! types above but this should be transparent +TYPE(progs_cnp_vars_type) :: progs_cnp_vars +TYPE(work_vars_type) :: work_vars_cnp + +END MODULE cnp_fields_mod diff --git a/src/coupled/AM3/control/casa/shared/progs_cnp_vars_mod.F90 b/src/coupled/AM3/control/casa/shared/progs_cnp_vars_mod.F90 new file mode 100644 index 000000000..419990e3d --- /dev/null +++ b/src/coupled/AM3/control/casa/shared/progs_cnp_vars_mod.F90 @@ -0,0 +1,182 @@ +MODULE progs_cnp_vars_mod + +IMPLICIT NONE + +PUBLIC :: progs_cnp_vars_alloc +PUBLIC :: progs_cnp_vars_assoc +PUBLIC :: progs_cnp_vars_data_type +PUBLIC :: progs_cnp_vars_type +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='PROGS_CNP_VARS_MOD' +! Prognostic Fields for CASA-CNP to be initialized from IO +TYPE :: progs_cnp_vars_data_type + + REAL, ALLOCATABLE :: C_pool_casa(:,:,:) + REAL, ALLOCATABLE :: N_pool_casa(:,:,:) + REAL, ALLOCATABLE :: P_pool_casa(:,:,:) + REAL, ALLOCATABLE :: soil_order_casa(:) + REAL, ALLOCATABLE :: N_dep_casa(:) + REAL, ALLOCATABLE :: N_fix_casa(:) + REAL, ALLOCATABLE :: P_dust_casa(:) + REAL, ALLOCATABLE :: P_weath_casa(:) + REAL, ALLOCATABLE :: LAI_casa(:,:) + REAL, ALLOCATABLE :: phenphase_casa(:,:) + REAL, ALLOCATABLE :: wood_hvest_C(:,:,:) + REAL, ALLOCATABLE :: wood_hvest_N(:,:,:) + REAL, ALLOCATABLE :: wood_hvest_P(:,:,:) + REAL, ALLOCATABLE :: thinning(:,:) + REAL, ALLOCATABLE :: prev_yr_sfrac(:,:) + +END TYPE progs_cnp_vars_data_type + +TYPE :: progs_cnp_vars_type + + REAL, POINTER, PUBLIC :: C_pool_casa(:,:,:) + REAL, POINTER, PUBLIC :: N_pool_casa(:,:,:) + REAL, POINTER, PUBLIC :: P_pool_casa(:,:,:) + REAL, POINTER, PUBLIC :: soil_order_casa(:) + REAL, POINTER, PUBLIC :: N_dep_casa(:) + REAL, POINTER, PUBLIC :: N_fix_casa(:) + REAL, POINTER, PUBLIC :: P_dust_casa(:) + REAL, POINTER, PUBLIC :: P_weath_casa(:) + REAL, POINTER, PUBLIC :: LAI_casa(:,:) + REAL, POINTER, PUBLIC :: phenphase_casa(:,:) + REAL, POINTER, PUBLIC :: wood_hvest_C(:,:,:) + REAL, POINTER, PUBLIC :: wood_hvest_N(:,:,:) + REAL, POINTER, PUBLIC :: wood_hvest_P(:,:,:) + REAL, POINTER, PUBLIC :: thinning(:,:) + REAL, POINTER, PUBLIC :: prev_yr_sfrac(:,:) + +END TYPE progs_cnp_vars_type + +CONTAINS + +SUBROUTINE progs_cnp_vars_alloc(land_pts, nsurft, progs_cnp_vars_data ) + +USE grid_constants_mod_cbl, ONLY : nCpool_casa, nNpool_casa, nPpool_casa +USE casadimension, ONLY: mwood + +IMPLICIT NONE + +!Arguments +INTEGER, INTENT(IN) :: land_pts, nsurft + +TYPE(progs_cnp_vars_data_type), INTENT(OUT) :: progs_cnp_vars_data + +ALLOCATE ( progs_cnp_vars_data % C_pool_casa ( land_pts, nsurft, nCpool_casa ) ) +ALLOCATE ( progs_cnp_vars_data % N_pool_casa ( land_pts, nsurft, nNpool_casa ) ) +ALLOCATE ( progs_cnp_vars_data % P_pool_casa ( land_pts, nsurft, nPpool_casa ) ) +ALLOCATE ( progs_cnp_vars_data % soil_order_casa ( land_pts ) ) +ALLOCATE ( progs_cnp_vars_data % N_dep_casa ( land_pts ) ) +ALLOCATE ( progs_cnp_vars_data % N_fix_casa ( land_pts ) ) +ALLOCATE ( progs_cnp_vars_data % P_dust_casa ( land_pts ) ) +ALLOCATE ( progs_cnp_vars_data % P_weath_casa ( land_pts ) ) +ALLOCATE ( progs_cnp_vars_data % LAI_casa ( land_pts, nsurft ) ) +ALLOCATE ( progs_cnp_vars_data % phenphase_casa ( land_pts, nsurft ) ) +ALLOCATE ( progs_cnp_vars_data % wood_hvest_C ( land_pts, nsurft, mwood ) ) +ALLOCATE ( progs_cnp_vars_data % wood_hvest_N ( land_pts, nsurft, mwood ) ) +ALLOCATE ( progs_cnp_vars_data % wood_hvest_P ( land_pts, nsurft, mwood ) ) +ALLOCATE ( progs_cnp_vars_data % thinning ( land_pts, nsurft ) ) +ALLOCATE ( progs_cnp_vars_data % prev_yr_sfrac ( land_pts, nsurft ) ) + +progs_cnp_vars_data % C_pool_casa(:,:,:) = 0.0 +progs_cnp_vars_data % N_pool_casa(:,:,:) = 0.0 +progs_cnp_vars_data % P_pool_casa(:,:,:) = 0.0 +progs_cnp_vars_data % soil_order_casa(:) = 0.0 +progs_cnp_vars_data % N_dep_casa(:) = 0.0 +progs_cnp_vars_data % N_fix_casa(:) = 0.0 +progs_cnp_vars_data % P_dust_casa(:) = 0.0 +progs_cnp_vars_data % P_weath_casa(:) = 0.0 +progs_cnp_vars_data % LAI_casa(:,:) = 0.0 +progs_cnp_vars_data % phenphase_casa(:,:) = 0.0 +progs_cnp_vars_data % wood_hvest_C(:,:,:) = 0.0 +progs_cnp_vars_data % wood_hvest_N(:,:,:) = 0.0 +progs_cnp_vars_data % wood_hvest_P(:,:,:) = 0.0 +progs_cnp_vars_data % thinning(:,:) = 0.0 +progs_cnp_vars_data % prev_yr_sfrac(:,:) = 0.0 + +RETURN +END SUBROUTINE progs_cnp_vars_alloc + +SUBROUTINE progs_cnp_vars_dealloc(progs_cnp_vars_data ) + +IMPLICIT NONE + +!Arguments +TYPE(progs_cnp_vars_data_type) :: progs_cnp_vars_data + +DEALLOCATE ( progs_cnp_vars_data % C_pool_casa ) +DEALLOCATE ( progs_cnp_vars_data % N_pool_casa ) +DEALLOCATE ( progs_cnp_vars_data % P_pool_casa ) +DEALLOCATE ( progs_cnp_vars_data % soil_order_casa ) +DEALLOCATE ( progs_cnp_vars_data % N_dep_casa ) +DEALLOCATE ( progs_cnp_vars_data % N_fix_casa ) +DEALLOCATE ( progs_cnp_vars_data % P_dust_casa ) +DEALLOCATE ( progs_cnp_vars_data % P_weath_casa ) +DEALLOCATE ( progs_cnp_vars_data % LAI_casa ) +DEALLOCATE ( progs_cnp_vars_data % phenphase_casa ) +DEALLOCATE ( progs_cnp_vars_data % wood_hvest_C ) +DEALLOCATE ( progs_cnp_vars_data % wood_hvest_N ) +DEALLOCATE ( progs_cnp_vars_data % wood_hvest_P ) +DEALLOCATE ( progs_cnp_vars_data % thinning ) +DEALLOCATE ( progs_cnp_vars_data % prev_yr_sfrac ) + +RETURN +END SUBROUTINE progs_cnp_vars_dealloc + +SUBROUTINE progs_cnp_vars_assoc(progs_cnp_vars, progs_cnp_vars_data ) + +IMPLICIT NONE + +!Arguments +TYPE(progs_cnp_vars_type), INTENT(IN OUT) :: progs_cnp_vars +TYPE(progs_cnp_vars_data_type), INTENT(IN OUT), TARGET :: progs_cnp_vars_data + +progs_cnp_vars % C_pool_casa => progs_cnp_vars_data % C_pool_casa +progs_cnp_vars % N_pool_casa => progs_cnp_vars_data % N_pool_casa +progs_cnp_vars % P_pool_casa => progs_cnp_vars_data % P_pool_casa +progs_cnp_vars % soil_order_casa => progs_cnp_vars_data % soil_order_casa +progs_cnp_vars % N_dep_casa => progs_cnp_vars_data % N_dep_casa +progs_cnp_vars % N_fix_casa => progs_cnp_vars_data % N_fix_casa +progs_cnp_vars % P_dust_casa => progs_cnp_vars_data % P_dust_casa +progs_cnp_vars % P_weath_casa => progs_cnp_vars_data % P_weath_casa +progs_cnp_vars % LAI_casa => progs_cnp_vars_data % LAI_casa +progs_cnp_vars % phenphase_casa => progs_cnp_vars_data % phenphase_casa +progs_cnp_vars % wood_hvest_C => progs_cnp_vars_data % wood_hvest_C +progs_cnp_vars % wood_hvest_N => progs_cnp_vars_data % wood_hvest_N +progs_cnp_vars % wood_hvest_P => progs_cnp_vars_data % wood_hvest_P +progs_cnp_vars % thinning => progs_cnp_vars_data % thinning +progs_cnp_vars % prev_yr_sfrac => progs_cnp_vars_data % prev_yr_sfrac + +RETURN +END SUBROUTINE progs_cnp_vars_assoc + +SUBROUTINE progs_cnp_vars_nullify(progs_cnp_vars) + +IMPLICIT NONE + +!Arguments +TYPE(progs_cnp_vars_type) :: progs_cnp_vars + +NULLIFY ( progs_cnp_vars % C_pool_casa ) +NULLIFY ( progs_cnp_vars % N_pool_casa ) +NULLIFY ( progs_cnp_vars % P_pool_casa ) +NULLIFY ( progs_cnp_vars % soil_order_casa ) +NULLIFY ( progs_cnp_vars % N_dep_casa ) +NULLIFY ( progs_cnp_vars % N_fix_casa ) +NULLIFY ( progs_cnp_vars % P_dust_casa ) +NULLIFY ( progs_cnp_vars % P_weath_casa ) +NULLIFY ( progs_cnp_vars % LAI_casa ) +NULLIFY ( progs_cnp_vars % phenphase_casa ) +NULLIFY ( progs_cnp_vars % wood_hvest_C ) +NULLIFY ( progs_cnp_vars % wood_hvest_N ) +NULLIFY ( progs_cnp_vars % wood_hvest_P ) +NULLIFY ( progs_cnp_vars % thinning ) +NULLIFY ( progs_cnp_vars % prev_yr_sfrac ) + +RETURN + +END SUBROUTINE progs_cnp_vars_nullify + +END MODULE progs_cnp_vars_mod diff --git a/src/coupled/AM3/control/casa/shared/work_vars_mod_cnp.F90 b/src/coupled/AM3/control/casa/shared/work_vars_mod_cnp.F90 new file mode 100644 index 000000000..360ba2777 --- /dev/null +++ b/src/coupled/AM3/control/casa/shared/work_vars_mod_cnp.F90 @@ -0,0 +1,52 @@ +MODULE work_vars_mod_cnp + +!!USE cable_bgc_pool_type_mod, ONLY: bgc_pool_type +!!USE cable_bgc_pool_type_mod, ONLY: bgc_pool_data_type +!!USE cable_sum_flux_type_mod, ONLY: sum_flux_type +!!USE cable_sum_flux_type_mod, ONLY: sum_flux_data_type + +USE casa_biome_type_mod, ONLY: casa_biome_data_type +USE casa_biome_type_mod, ONLY: casa_biome_type +USE casa_pool_type_mod, ONLY: casa_pool_data_type +USE casa_pool_type_mod, ONLY: casa_pool_type +USE casa_flux_type_mod, ONLY: casa_flux_data_type +USE casa_flux_type_mod, ONLY: casa_flux_type +USE casa_met_type_mod, ONLY: casa_met_data_type +USE casa_met_type_mod, ONLY: casa_met_type +USE casa_balance_type_mod, ONLY: casa_bal_data_type +USE casa_balance_type_mod, ONLY: casa_bal_type +USE phenology_type_mod, ONLY: phenology_data_type +USE phenology_type_mod, ONLY: phenology_type + +IMPLICIT NONE + +PUBLIC :: work_vars_type +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='WORK_VARS_MOD_CNP' + +TYPE :: work_vars_type + + TYPE( casa_biome_type ) :: casabiome + TYPE( casa_pool_type ) :: casapool + TYPE( casa_pool_type ) :: sum_casapool + TYPE( casa_flux_type ) :: casaflux + TYPE( casa_flux_type ) :: sum_casaflux + TYPE( casa_met_type ) :: casamet + TYPE( casa_bal_type ) :: casabal + TYPE( phenology_type ) :: phen + +END TYPE work_vars_type + +! data arrays need to be declared outside of the work% TYPE +TYPE( casa_biome_data_type ), PUBLIC, TARGET :: casabiome_data +TYPE( casa_pool_data_type ), PUBLIC, TARGET :: casapool_data +TYPE( casa_pool_data_type ), PUBLIC, TARGET :: sum_casapool_data +TYPE( casa_flux_data_type ), PUBLIC, TARGET :: casaflux_data +TYPE( casa_flux_data_type ), PUBLIC, TARGET :: sum_casaflux_data +TYPE( casa_met_data_type ), PUBLIC, TARGET :: casamet_data +TYPE( casa_bal_data_type ), PUBLIC, TARGET :: casabal_data +TYPE( phenology_data_type ), PUBLIC, TARGET :: phen_data + +END MODULE work_vars_mod_cnp + diff --git a/src/coupled/AM3/initialisation/cable_pft_params.F90 b/src/coupled/AM3/initialisation/cable_pft_params.F90 new file mode 100644 index 000000000..81cb6fa8e --- /dev/null +++ b/src/coupled/AM3/initialisation/cable_pft_params.F90 @@ -0,0 +1,1033 @@ +MODULE cable_pft_params_mod + + IMPLICIT NONE + +CONTAINS + +subroutine cable_pft_params(pars_io_data_cbl) + + ! Gets parameter values for each vegetation type +USE grid_constants_mod_cbl, ONLY : ms => nsl, nrb +USE grid_constants_mod_cbl, ONLY : ncs => nsCs, ncp => nvCs +USE params_io_mod_cbl, ONLY: params_io_data_type + + IMPLICIT NONE + + TYPE(params_io_data_type), TARGET :: pars_io_data_cbl + + INTEGER :: a, jveg ! do loop counter + + !PFT parameters: description and corresponding variable name in code. + !PFT parameters are assigned as TYPE pars_io_data_cbl%vegin_ but later used as veg% + + !PFT: evergreen_needleleaf + !========================================================= + + pars_io_data_cbl%vegin_canst1(1) = 0.100000 + pars_io_data_cbl%vegin_length(1) = 0.055000 + pars_io_data_cbl%vegin_width(1) = 0.001000 + pars_io_data_cbl%vegin_vcmax(1) = 0.000040 + pars_io_data_cbl%vegin_ejmax(1) = 0.000000 + pars_io_data_cbl%vegin_hc(1) = 17.000000 + pars_io_data_cbl%vegin_xfang(1) = 0.010000 + pars_io_data_cbl%vegin_rp20(1) = 3.000000 + pars_io_data_cbl%vegin_rpcoef(1) = 0.083200 + pars_io_data_cbl%vegin_rs20(1) = 1.000000 + pars_io_data_cbl%vegin_wai(1) = 1.000000 + pars_io_data_cbl%vegin_rootbeta(1) = 0.943000 + pars_io_data_cbl%vegin_shelrb(1) = 2.000000 + pars_io_data_cbl%vegin_vegcf(1) = 9.000000 + pars_io_data_cbl%vegin_frac4(1) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(1) = 1.000000 + pars_io_data_cbl%vegin_extkn(1) = 0.001000 + pars_io_data_cbl%vegin_tminvj(1) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(1) = -10.000000 + pars_io_data_cbl%vegin_vbeta(1) = 2.000000 + pars_io_data_cbl%vegin_froot(1,1) = 0.050000 + pars_io_data_cbl%vegin_froot(2,1) = 0.050000 + pars_io_data_cbl%vegin_froot(3,1) = 0.050000 + pars_io_data_cbl%vegin_froot(4,1) = 0.050000 + pars_io_data_cbl%vegin_froot(5,1) = 0.050000 + pars_io_data_cbl%vegin_froot(6,1) = 0.050000 + pars_io_data_cbl%vegin_refl(1,1) = 0.090000 + pars_io_data_cbl%vegin_taul(1,1) = 0.090000 + pars_io_data_cbl%vegin_refl(2,1) = 0.300000 + pars_io_data_cbl%vegin_taul(2,1) = 0.300000 + pars_io_data_cbl%vegin_refl(3,1) = 0.010000 + pars_io_data_cbl%vegin_taul(3,1) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,1) = 184.000000 + pars_io_data_cbl%vegin_ratecs(1,1) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,1) = 367.000000 + pars_io_data_cbl%vegin_ratecs(2,1) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,1) = 200.000000 + pars_io_data_cbl%vegin_ratecp(1,1) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,1) = 10217.000000 + pars_io_data_cbl%vegin_ratecp(2,1) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,1) = 876.000000 + pars_io_data_cbl%vegin_ratecp(3,1) = 0.140000 + pars_io_data_cbl%vegin_a1gs(1) = 9.000000 + pars_io_data_cbl%vegin_d0gs(1) = 1500.000000 + pars_io_data_cbl%vegin_alpha(1) = 0.200000 + pars_io_data_cbl%vegin_convex(1) = 0.700000 + pars_io_data_cbl%vegin_cfrd(1) = 0.015000 + pars_io_data_cbl%vegin_gswmin(1) = 0.010000 + pars_io_data_cbl%vegin_conkc0(1) = 0.000302 + pars_io_data_cbl%vegin_conko0(1) = 0.256000 + pars_io_data_cbl%vegin_ekc(1) = 59430.000000 + pars_io_data_cbl%vegin_eko(1) = 36000.000000 + pars_io_data_cbl%vegin_g0(1) = 0.000000 + pars_io_data_cbl%vegin_g1(1) = 2.346064 + pars_io_data_cbl%vegin_zr(1) = 1.800000 + pars_io_data_cbl%vegin_clitt(1) = 20.000000 + + !PFT: evergreen_broadleaf + !========================================================= + pars_io_data_cbl%vegin_canst1(2) = 0.100000 + pars_io_data_cbl%vegin_length(2) = 0.100000 + pars_io_data_cbl%vegin_width(2) = 0.050000 + pars_io_data_cbl%vegin_vcmax(2) = 0.000055 + pars_io_data_cbl%vegin_ejmax(2) = 0.000000 + pars_io_data_cbl%vegin_hc(2) = 35.000000 + pars_io_data_cbl%vegin_xfang(2) = 0.100000 + pars_io_data_cbl%vegin_rp20(2) = 0.600000 + pars_io_data_cbl%vegin_rpcoef(2) = 0.083200 + pars_io_data_cbl%vegin_rs20(2) = 1.000000 + pars_io_data_cbl%vegin_wai(2) = 1.000000 + pars_io_data_cbl%vegin_rootbeta(2) = 0.962000 + pars_io_data_cbl%vegin_shelrb(2) = 2.000000 + pars_io_data_cbl%vegin_vegcf(2) = 14.000000 + pars_io_data_cbl%vegin_frac4(2) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(2) = 1.000000 + pars_io_data_cbl%vegin_extkn(2) = 0.001000 + pars_io_data_cbl%vegin_tminvj(2) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(2) = -10.000000 + pars_io_data_cbl%vegin_vbeta(2) = 2.000000 + pars_io_data_cbl%vegin_froot(1,2) = 0.200000 + pars_io_data_cbl%vegin_froot(2,2) = 0.200000 + pars_io_data_cbl%vegin_froot(3,2) = 0.200000 + pars_io_data_cbl%vegin_froot(4,2) = 0.200000 + pars_io_data_cbl%vegin_froot(5,2) = 0.200000 + pars_io_data_cbl%vegin_froot(6,2) = 0.200000 + pars_io_data_cbl%vegin_refl(1,2) = 0.090000 + pars_io_data_cbl%vegin_taul(1,2) = 0.090000 + pars_io_data_cbl%vegin_refl(2,2) = 0.290000 + pars_io_data_cbl%vegin_taul(2,2) = 0.290000 + pars_io_data_cbl%vegin_refl(3,2) = 0.010000 + pars_io_data_cbl%vegin_taul(3,2) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,2) = 303.000000 + pars_io_data_cbl%vegin_ratecs(1,2) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,2) = 606.000000 + pars_io_data_cbl%vegin_ratecs(2,2) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,2) = 300.000000 + pars_io_data_cbl%vegin_ratecp(1,2) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,2) = 16833.000000 + pars_io_data_cbl%vegin_ratecp(2,2) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,2) = 1443.000000 + pars_io_data_cbl%vegin_ratecp(3,2) = 0.140000 + pars_io_data_cbl%vegin_a1gs(2) = 9.000000 + pars_io_data_cbl%vegin_d0gs(2) = 1500.000000 + pars_io_data_cbl%vegin_alpha(2) = 0.200000 + pars_io_data_cbl%vegin_convex(2) = 0.700000 + pars_io_data_cbl%vegin_cfrd(2) = 0.015000 + pars_io_data_cbl%vegin_gswmin(2) = 0.010000 + pars_io_data_cbl%vegin_conkc0(2) = 0.000302 + pars_io_data_cbl%vegin_conko0(2) = 0.256000 + pars_io_data_cbl%vegin_ekc(2) = 59430.000000 + pars_io_data_cbl%vegin_eko(2) = 36000.000000 + pars_io_data_cbl%vegin_g0(2) = 0.000000 + pars_io_data_cbl%vegin_g1(2) = 4.114762 + pars_io_data_cbl%vegin_zr(2) = 3.000000 + pars_io_data_cbl%vegin_clitt(2) = 6.000000 + + !PFT: deciduous_needleleaf + !========================================================= + pars_io_data_cbl%vegin_canst1(3) = 0.100000 + pars_io_data_cbl%vegin_length(3) = 0.040000 + pars_io_data_cbl%vegin_width(3) = 0.001000 + pars_io_data_cbl%vegin_vcmax(3) = 0.000040 + pars_io_data_cbl%vegin_ejmax(3) = 0.000000 + pars_io_data_cbl%vegin_hc(3) = 15.500000 + pars_io_data_cbl%vegin_xfang(3) = 0.010000 + pars_io_data_cbl%vegin_rp20(3) = 3.000000 + pars_io_data_cbl%vegin_rpcoef(3) = 0.083200 + pars_io_data_cbl%vegin_rs20(3) = 1.000000 + pars_io_data_cbl%vegin_wai(3) = 1.000000 + pars_io_data_cbl%vegin_rootbeta(3) = 0.966000 + pars_io_data_cbl%vegin_shelrb(3) = 2.000000 + pars_io_data_cbl%vegin_vegcf(3) = 9.000000 + pars_io_data_cbl%vegin_frac4(3) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(3) = 1.000000 + pars_io_data_cbl%vegin_extkn(3) = 0.001000 + pars_io_data_cbl%vegin_tminvj(3) = 5.000000 + pars_io_data_cbl%vegin_tmaxvj(3) = 10.000000 + pars_io_data_cbl%vegin_vbeta(3) = 2.000000 + pars_io_data_cbl%vegin_froot(1,3) = 0.200000 + pars_io_data_cbl%vegin_froot(2,3) = 0.200000 + pars_io_data_cbl%vegin_froot(3,3) = 0.200000 + pars_io_data_cbl%vegin_froot(4,3) = 0.200000 + pars_io_data_cbl%vegin_froot(5,3) = 0.200000 + pars_io_data_cbl%vegin_froot(6,3) = 0.200000 + pars_io_data_cbl%vegin_refl(1,3) = 0.075000 + pars_io_data_cbl%vegin_taul(1,3) = 0.075000 + pars_io_data_cbl%vegin_refl(2,3) = 0.300000 + pars_io_data_cbl%vegin_taul(2,3) = 0.300000 + pars_io_data_cbl%vegin_refl(3,3) = 0.010000 + pars_io_data_cbl%vegin_taul(3,3) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,3) = 107.000000 + pars_io_data_cbl%vegin_ratecs(1,3) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,3) = 214.000000 + pars_io_data_cbl%vegin_ratecs(2,3) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,3) = 200.000000 + pars_io_data_cbl%vegin_ratecp(1,3) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,3) = 5967.000000 + pars_io_data_cbl%vegin_ratecp(2,3) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,3) = 511.000000 + pars_io_data_cbl%vegin_ratecp(3,3) = 0.140000 + pars_io_data_cbl%vegin_a1gs(3) = 9.000000 + pars_io_data_cbl%vegin_d0gs(3) = 1500.000000 + pars_io_data_cbl%vegin_alpha(3) = 0.200000 + pars_io_data_cbl%vegin_convex(3) = 0.700000 + pars_io_data_cbl%vegin_cfrd(3) = 0.015000 + pars_io_data_cbl%vegin_gswmin(3) = 0.010000 + pars_io_data_cbl%vegin_conkc0(3) = 0.000302 + pars_io_data_cbl%vegin_conko0(3) = 0.256000 + pars_io_data_cbl%vegin_ekc(3) = 59430.000000 + pars_io_data_cbl%vegin_eko(3) = 36000.000000 + pars_io_data_cbl%vegin_g0(3) = 0.000000 + pars_io_data_cbl%vegin_g1(3) = 2.346064 + pars_io_data_cbl%vegin_zr(3) = 2.000000 + pars_io_data_cbl%vegin_clitt(3) = 10.000000 + + !PFT: deciduous_broadleaf + !========================================================= + pars_io_data_cbl%vegin_canst1(4) = 0.100000 + pars_io_data_cbl%vegin_length(4) = 0.150000 + pars_io_data_cbl%vegin_width(4) = 0.080000 + pars_io_data_cbl%vegin_vcmax(4) = 0.000060 + pars_io_data_cbl%vegin_ejmax(4) = 0.000000 + pars_io_data_cbl%vegin_hc(4) = 20.000000 + pars_io_data_cbl%vegin_xfang(4) = 0.250000 + pars_io_data_cbl%vegin_rp20(4) = 2.200000 + pars_io_data_cbl%vegin_rpcoef(4) = 0.083200 + pars_io_data_cbl%vegin_rs20(4) = 1.000000 + pars_io_data_cbl%vegin_wai(4) = 1.000000 + pars_io_data_cbl%vegin_rootbeta(4) = 0.961000 + pars_io_data_cbl%vegin_shelrb(4) = 2.000000 + pars_io_data_cbl%vegin_vegcf(4) = 8.000000 + pars_io_data_cbl%vegin_frac4(4) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(4) = 1.000000 + pars_io_data_cbl%vegin_extkn(4) = 0.001000 + pars_io_data_cbl%vegin_tminvj(4) = 5.000000 + pars_io_data_cbl%vegin_tmaxvj(4) = 15.000000 + pars_io_data_cbl%vegin_vbeta(4) = 2.000000 + pars_io_data_cbl%vegin_froot(1,4) = 0.200000 + pars_io_data_cbl%vegin_froot(2,4) = 0.200000 + pars_io_data_cbl%vegin_froot(3,4) = 0.200000 + pars_io_data_cbl%vegin_froot(4,4) = 0.200000 + pars_io_data_cbl%vegin_froot(5,4) = 0.200000 + pars_io_data_cbl%vegin_froot(6,4) = 0.200000 + pars_io_data_cbl%vegin_refl(1,4) = 0.090000 + pars_io_data_cbl%vegin_taul(1,4) = 0.090000 + pars_io_data_cbl%vegin_refl(2,4) = 0.290000 + pars_io_data_cbl%vegin_taul(2,4) = 0.290000 + pars_io_data_cbl%vegin_refl(3,4) = 0.010000 + pars_io_data_cbl%vegin_taul(3,4) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,4) = 216.000000 + pars_io_data_cbl%vegin_ratecs(1,4) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,4) = 432.000000 + pars_io_data_cbl%vegin_ratecs(2,4) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,4) = 300.000000 + pars_io_data_cbl%vegin_ratecp(1,4) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,4) = 12000.000000 + pars_io_data_cbl%vegin_ratecp(2,4) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,4) = 1029.000000 + pars_io_data_cbl%vegin_ratecp(3,4) = 0.140000 + pars_io_data_cbl%vegin_a1gs(4) = 9.000000 + pars_io_data_cbl%vegin_d0gs(4) = 1500.000000 + pars_io_data_cbl%vegin_alpha(4) = 0.200000 + pars_io_data_cbl%vegin_convex(4) = 0.700000 + pars_io_data_cbl%vegin_cfrd(4) = 0.015000 + pars_io_data_cbl%vegin_gswmin(4) = 0.010000 + pars_io_data_cbl%vegin_conkc0(4) = 0.000302 + pars_io_data_cbl%vegin_conko0(4) = 0.256000 + pars_io_data_cbl%vegin_ekc(4) = 59430.000000 + pars_io_data_cbl%vegin_eko(4) = 36000.000000 + pars_io_data_cbl%vegin_g0(4) = 0.000000 + pars_io_data_cbl%vegin_g1(4) = 4.447321 + pars_io_data_cbl%vegin_zr(4) = 2.000000 + pars_io_data_cbl%vegin_clitt(4) = 13.000000 + + !PFT: shrub + !========================================================= + pars_io_data_cbl%vegin_canst1(5) = 0.100000 + pars_io_data_cbl%vegin_length(5) = 0.100000 + pars_io_data_cbl%vegin_width(5) = 0.005000 + pars_io_data_cbl%vegin_vcmax(5) = 0.000040 + pars_io_data_cbl%vegin_ejmax(5) = 0.000000 + pars_io_data_cbl%vegin_hc(5) = 0.600000 + pars_io_data_cbl%vegin_xfang(5) = 0.010000 + pars_io_data_cbl%vegin_rp20(5) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(5) = 0.083200 + pars_io_data_cbl%vegin_rs20(5) = 1.000000 + pars_io_data_cbl%vegin_wai(5) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(5) = 0.964000 + pars_io_data_cbl%vegin_shelrb(5) = 2.000000 + pars_io_data_cbl%vegin_vegcf(5) = 5.000000 + pars_io_data_cbl%vegin_frac4(5) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(5) = 1.000000 + pars_io_data_cbl%vegin_extkn(5) = 0.001000 + pars_io_data_cbl%vegin_tminvj(5) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(5) = -10.000000 + pars_io_data_cbl%vegin_vbeta(5) = 4.000000 + pars_io_data_cbl%vegin_froot(1,5) = 0.200000 + pars_io_data_cbl%vegin_froot(2,5) = 0.200000 + pars_io_data_cbl%vegin_froot(3,5) = 0.200000 + pars_io_data_cbl%vegin_froot(4,5) = 0.200000 + pars_io_data_cbl%vegin_froot(5,5) = 0.200000 + pars_io_data_cbl%vegin_froot(6,5) = 0.200000 + pars_io_data_cbl%vegin_refl(1,5) = 0.090000 + pars_io_data_cbl%vegin_taul(1,5) = 0.090000 + pars_io_data_cbl%vegin_refl(2,5) = 0.300000 + pars_io_data_cbl%vegin_taul(2,5) = 0.300000 + pars_io_data_cbl%vegin_refl(3,5) = 0.010000 + pars_io_data_cbl%vegin_taul(3,5) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,5) = 100.000000 + pars_io_data_cbl%vegin_ratecs(1,5) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,5) = 250.000000 + pars_io_data_cbl%vegin_ratecs(2,5) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,5) = 159.000000 + pars_io_data_cbl%vegin_ratecp(1,5) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,5) = 5000.000000 + pars_io_data_cbl%vegin_ratecp(2,5) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,5) = 500.000000 + pars_io_data_cbl%vegin_ratecp(3,5) = 0.140000 + pars_io_data_cbl%vegin_a1gs(5) = 9.000000 + pars_io_data_cbl%vegin_d0gs(5) = 1500.000000 + pars_io_data_cbl%vegin_alpha(5) = 0.200000 + pars_io_data_cbl%vegin_convex(5) = 0.700000 + pars_io_data_cbl%vegin_cfrd(5) = 0.015000 + pars_io_data_cbl%vegin_gswmin(5) = 0.010000 + pars_io_data_cbl%vegin_conkc0(5) = 0.000302 + pars_io_data_cbl%vegin_conko0(5) = 0.256000 + pars_io_data_cbl%vegin_ekc(5) = 59430.000000 + pars_io_data_cbl%vegin_eko(5) = 36000.000000 + pars_io_data_cbl%vegin_g0(5) = 0.000000 + pars_io_data_cbl%vegin_g1(5) = 4.694803 + pars_io_data_cbl%vegin_zr(5) = 2.500000 + pars_io_data_cbl%vegin_clitt(5) = 2.000000 + + !PFT: C3 + !========================================================= + pars_io_data_cbl%vegin_canst1(6) = 0.100000 + pars_io_data_cbl%vegin_length(6) = 0.300000 + pars_io_data_cbl%vegin_width(6) = 0.010000 + pars_io_data_cbl%vegin_vcmax(6) = 0.000060 + pars_io_data_cbl%vegin_ejmax(6) = 0.000000 + pars_io_data_cbl%vegin_hc(6) = 0.567000 + pars_io_data_cbl%vegin_xfang(6) = -0.300000 + pars_io_data_cbl%vegin_rp20(6) = 1.500000 + pars_io_data_cbl%vegin_rpcoef(6) = 0.083200 + pars_io_data_cbl%vegin_rs20(6) = 1.000000 + pars_io_data_cbl%vegin_wai(6) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(6) = 0.943000 + pars_io_data_cbl%vegin_shelrb(6) = 2.000000 + pars_io_data_cbl%vegin_vegcf(6) = 7.000000 + pars_io_data_cbl%vegin_frac4(6) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(6) = 1.000000 + pars_io_data_cbl%vegin_extkn(6) = 0.001000 + pars_io_data_cbl%vegin_tminvj(6) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(6) = -10.000000 + pars_io_data_cbl%vegin_vbeta(6) = 4.000000 + pars_io_data_cbl%vegin_froot(1,6) = 0.150000 + pars_io_data_cbl%vegin_froot(2,6) = 0.150000 + pars_io_data_cbl%vegin_froot(3,6) = 0.150000 + pars_io_data_cbl%vegin_froot(4,6) = 0.150000 + pars_io_data_cbl%vegin_froot(5,6) = 0.150000 + pars_io_data_cbl%vegin_froot(6,6) = 0.150000 + pars_io_data_cbl%vegin_refl(1,6) = 0.110000 + pars_io_data_cbl%vegin_taul(1,6) = 0.110000 + pars_io_data_cbl%vegin_refl(2,6) = 0.340000 + pars_io_data_cbl%vegin_taul(2,6) = 0.340000 + pars_io_data_cbl%vegin_refl(3,6) = 0.010000 + pars_io_data_cbl%vegin_taul(3,6) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,6) = 275.000000 + pars_io_data_cbl%vegin_ratecs(1,6) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,6) = 314.000000 + pars_io_data_cbl%vegin_ratecs(2,6) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,6) = 250.000000 + pars_io_data_cbl%vegin_ratecp(1,6) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,6) = 0.000000 + pars_io_data_cbl%vegin_ratecp(2,6) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,6) = 500.000000 + pars_io_data_cbl%vegin_ratecp(3,6) = 0.140000 + pars_io_data_cbl%vegin_a1gs(6) = 9.000000 + pars_io_data_cbl%vegin_d0gs(6) = 1500.000000 + pars_io_data_cbl%vegin_alpha(6) = 0.200000 + pars_io_data_cbl%vegin_convex(6) = 0.700000 + pars_io_data_cbl%vegin_cfrd(6) = 0.015000 + pars_io_data_cbl%vegin_gswmin(6) = 0.010000 + pars_io_data_cbl%vegin_conkc0(6) = 0.000302 + pars_io_data_cbl%vegin_conko0(6) = 0.256000 + pars_io_data_cbl%vegin_ekc(6) = 59430.000000 + pars_io_data_cbl%vegin_eko(6) = 36000.000000 + pars_io_data_cbl%vegin_g0(6) = 0.000000 + pars_io_data_cbl%vegin_g1(6) = 5.248500 + pars_io_data_cbl%vegin_zr(6) = 0.500000 !1.5 in Haverd et al. (2016) + pars_io_data_cbl%vegin_clitt(6) = 2.000000 + + !PFT: C4 + !========================================================= + pars_io_data_cbl%vegin_canst1(7) = 0.100000 + pars_io_data_cbl%vegin_length(7) = 0.300000 + pars_io_data_cbl%vegin_width(7) = 0.010000 + pars_io_data_cbl%vegin_vcmax(7) = 0.000010 + pars_io_data_cbl%vegin_ejmax(7) = 0.000000 + pars_io_data_cbl%vegin_hc(7) = 0.567000 + pars_io_data_cbl%vegin_xfang(7) = -0.300000 + pars_io_data_cbl%vegin_rp20(7) = 2.800000 + pars_io_data_cbl%vegin_rpcoef(7) = 0.083200 + pars_io_data_cbl%vegin_rs20(7) = 1.000000 + pars_io_data_cbl%vegin_wai(7) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(7) = 0.943000 + pars_io_data_cbl%vegin_shelrb(7) = 2.000000 + pars_io_data_cbl%vegin_vegcf(7) = 7.000000 + pars_io_data_cbl%vegin_frac4(7) = 1.000000 + pars_io_data_cbl%vegin_xalbnir(7) = 1.000000 + pars_io_data_cbl%vegin_extkn(7) = 0.001000 + pars_io_data_cbl%vegin_tminvj(7) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(7) = -10.000000 + pars_io_data_cbl%vegin_vbeta(7) = 4.000000 + pars_io_data_cbl%vegin_froot(1,7) = 0.000000 + pars_io_data_cbl%vegin_froot(2,7) = 0.000000 + pars_io_data_cbl%vegin_froot(3,7) = 0.000000 + pars_io_data_cbl%vegin_froot(4,7) = 0.000000 + pars_io_data_cbl%vegin_froot(5,7) = 0.000000 + pars_io_data_cbl%vegin_froot(6,7) = 0.000000 + pars_io_data_cbl%vegin_refl(1,7) = 0.110000 + pars_io_data_cbl%vegin_taul(1,7) = 0.110000 + pars_io_data_cbl%vegin_refl(2,7) = 0.340000 + pars_io_data_cbl%vegin_taul(2,7) = 0.340000 + pars_io_data_cbl%vegin_refl(3,7) = 0.010000 + pars_io_data_cbl%vegin_taul(3,7) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,7) = 275.000000 + pars_io_data_cbl%vegin_ratecs(1,7) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,7) = 314.000000 + pars_io_data_cbl%vegin_ratecs(2,7) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,7) = 250.000000 + pars_io_data_cbl%vegin_ratecp(1,7) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,7) = 0.000000 + pars_io_data_cbl%vegin_ratecp(2,7) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,7) = 500.000000 + pars_io_data_cbl%vegin_ratecp(3,7) = 0.140000 + pars_io_data_cbl%vegin_a1gs(7) = 4.000000 + pars_io_data_cbl%vegin_d0gs(7) = 1500.000000 + pars_io_data_cbl%vegin_alpha(7) = 0.050000 + pars_io_data_cbl%vegin_convex(7) = 0.800000 + pars_io_data_cbl%vegin_cfrd(7) = 0.025000 + pars_io_data_cbl%vegin_gswmin(7) = 0.040000 + pars_io_data_cbl%vegin_conkc0(7) = 0.000302 + pars_io_data_cbl%vegin_conko0(7) = 0.256000 + pars_io_data_cbl%vegin_ekc(7) = 59430.000000 + pars_io_data_cbl%vegin_eko(7) = 36000.000000 + pars_io_data_cbl%vegin_g0(7) = 0.000000 + pars_io_data_cbl%vegin_g1(7) = 1.616178 + pars_io_data_cbl%vegin_zr(7) = 0.500000 !2.4 in Haverd et al. (2016) + pars_io_data_cbl%vegin_clitt(7) = 0.300000 + + !PFT: Tundra + !========================================================= + pars_io_data_cbl%vegin_canst1(8) = 0.100000 + pars_io_data_cbl%vegin_length(8) = 0.300000 + pars_io_data_cbl%vegin_width(8) = 0.010000 + pars_io_data_cbl%vegin_vcmax(8) = 0.000040 + pars_io_data_cbl%vegin_ejmax(8) = 0.000000 + pars_io_data_cbl%vegin_hc(8) = 0.567000 + pars_io_data_cbl%vegin_xfang(8) = -0.300000 + pars_io_data_cbl%vegin_rp20(8) = 2.500000 + pars_io_data_cbl%vegin_rpcoef(8) = 0.083200 + pars_io_data_cbl%vegin_rs20(8) = 1.000000 + pars_io_data_cbl%vegin_wai(8) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(8) = 0.943000 + pars_io_data_cbl%vegin_shelrb(8) = 2.000000 + pars_io_data_cbl%vegin_vegcf(8) = 5.000000 + pars_io_data_cbl%vegin_frac4(8) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(8) = 1.000000 + pars_io_data_cbl%vegin_extkn(8) = 0.001000 + pars_io_data_cbl%vegin_tminvj(8) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(8) = -10.000000 + pars_io_data_cbl%vegin_vbeta(8) = 4.000000 + pars_io_data_cbl%vegin_froot(1,8) = 0.000000 + pars_io_data_cbl%vegin_froot(2,8) = 0.000000 + pars_io_data_cbl%vegin_froot(3,8) = 0.000000 + pars_io_data_cbl%vegin_froot(4,8) = 0.000000 + pars_io_data_cbl%vegin_froot(5,8) = 0.000000 + pars_io_data_cbl%vegin_froot(6,8) = 0.000000 + pars_io_data_cbl%vegin_refl(1,8) = 0.075000 + pars_io_data_cbl%vegin_taul(1,8) = 0.075000 + pars_io_data_cbl%vegin_refl(2,8) = 0.320000 + pars_io_data_cbl%vegin_taul(2,8) = 0.320000 + pars_io_data_cbl%vegin_refl(3,8) = 0.010000 + pars_io_data_cbl%vegin_taul(3,8) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,8) = 275.000000 + pars_io_data_cbl%vegin_ratecs(1,8) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,8) = 314.000000 + pars_io_data_cbl%vegin_ratecs(2,8) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,8) = 250.000000 + pars_io_data_cbl%vegin_ratecp(1,8) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,8) = 0.000000 + pars_io_data_cbl%vegin_ratecp(2,8) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,8) = 500.000000 + pars_io_data_cbl%vegin_ratecp(3,8) = 0.140000 + pars_io_data_cbl%vegin_a1gs(8) = 9.000000 + pars_io_data_cbl%vegin_d0gs(8) = 1500.000000 + pars_io_data_cbl%vegin_alpha(8) = 0.200000 + pars_io_data_cbl%vegin_convex(8) = 0.700000 + pars_io_data_cbl%vegin_cfrd(8) = 0.015000 + pars_io_data_cbl%vegin_gswmin(8) = 0.010000 + pars_io_data_cbl%vegin_conkc0(8) = 0.000302 + pars_io_data_cbl%vegin_conko0(8) = 0.256000 + pars_io_data_cbl%vegin_ekc(8) = 59430.000000 + pars_io_data_cbl%vegin_eko(8) = 36000.000000 + pars_io_data_cbl%vegin_g0(8) = 0.000000 + pars_io_data_cbl%vegin_g1(8) = 2.222156 + pars_io_data_cbl%vegin_zr(8) = 0.500000 + pars_io_data_cbl%vegin_clitt(8) = 0.300000 + + !PFT: C3 + !========================================================= + pars_io_data_cbl%vegin_canst1(9) = 0.100000 + pars_io_data_cbl%vegin_length(9) = 0.300000 + pars_io_data_cbl%vegin_width(9) = 0.010000 + pars_io_data_cbl%vegin_vcmax(9) = 0.000080 + pars_io_data_cbl%vegin_ejmax(9) = 0.000000 + pars_io_data_cbl%vegin_hc(9) = 0.550000 + pars_io_data_cbl%vegin_xfang(9) = -0.300000 + pars_io_data_cbl%vegin_rp20(9) = 1.500000 + pars_io_data_cbl%vegin_rpcoef(9) = 0.083200 + pars_io_data_cbl%vegin_rs20(9) = 1.000000 + pars_io_data_cbl%vegin_wai(9) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(9) = 0.961000 + pars_io_data_cbl%vegin_shelrb(9) = 2.000000 + pars_io_data_cbl%vegin_vegcf(9) = 7.000000 + pars_io_data_cbl%vegin_frac4(9) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(9) = 1.000000 + pars_io_data_cbl%vegin_extkn(9) = 0.001000 + pars_io_data_cbl%vegin_tminvj(9) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(9) = -10.000000 + pars_io_data_cbl%vegin_vbeta(9) = 2.000000 + pars_io_data_cbl%vegin_froot(1,9) = 0.000000 + pars_io_data_cbl%vegin_froot(2,9) = 0.000000 + pars_io_data_cbl%vegin_froot(3,9) = 0.000000 + pars_io_data_cbl%vegin_froot(4,9) = 0.000000 + pars_io_data_cbl%vegin_froot(5,9) = 0.000000 + pars_io_data_cbl%vegin_froot(6,9) = 0.000000 + pars_io_data_cbl%vegin_refl(1,9) = 0.110000 + pars_io_data_cbl%vegin_taul(1,9) = 0.110000 + pars_io_data_cbl%vegin_refl(2,9) = 0.340000 + pars_io_data_cbl%vegin_taul(2,9) = 0.340000 + pars_io_data_cbl%vegin_refl(3,9) = 0.010000 + pars_io_data_cbl%vegin_taul(3,9) = 0.010000 + pars_io_data_cbl%vegin_csoil(1,9) = 149.000000 + pars_io_data_cbl%vegin_ratecs(1,9) = 2.000000 + pars_io_data_cbl%vegin_csoil(2,9) = 300.000000 + pars_io_data_cbl%vegin_ratecs(2,9) = 0.500000 + pars_io_data_cbl%vegin_cplant(1,9) = 150.000000 + pars_io_data_cbl%vegin_ratecp(1,9) = 1.000000 + pars_io_data_cbl%vegin_cplant(2,9) = 0.000000 + pars_io_data_cbl%vegin_ratecp(2,9) = 0.030000 + pars_io_data_cbl%vegin_cplant(3,9) = 607.000000 + pars_io_data_cbl%vegin_ratecp(3,9) = 0.140000 + pars_io_data_cbl%vegin_a1gs(9) = 9.000000 + pars_io_data_cbl%vegin_d0gs(9) = 1500.000000 + pars_io_data_cbl%vegin_alpha(9) = 0.200000 + pars_io_data_cbl%vegin_convex(9) = 0.700000 + pars_io_data_cbl%vegin_cfrd(9) = 0.015000 + pars_io_data_cbl%vegin_gswmin(9) = 0.010000 + pars_io_data_cbl%vegin_conkc0(9) = 0.000302 + pars_io_data_cbl%vegin_conko0(9) = 0.256000 + pars_io_data_cbl%vegin_ekc(9) = 59430.000000 + pars_io_data_cbl%vegin_eko(9) = 36000.000000 + pars_io_data_cbl%vegin_g0(9) = 0.000000 + pars_io_data_cbl%vegin_g1(9) = 5.789377 + pars_io_data_cbl%vegin_zr(9) = 0.500000 !1.5 in Haverd et al. (2016) + pars_io_data_cbl%vegin_clitt(9) = 0.000000 + + !PFT: C4 + !========================================================= + pars_io_data_cbl%vegin_canst1(10) = 0.100000 + pars_io_data_cbl%vegin_length(10) = 0.300000 + pars_io_data_cbl%vegin_width(10) = 0.010000 + pars_io_data_cbl%vegin_vcmax(10) = 0.000080 + pars_io_data_cbl%vegin_ejmax(10) = 0.000000 + pars_io_data_cbl%vegin_hc(10) = 0.550000 + pars_io_data_cbl%vegin_xfang(10) = -0.300000 + pars_io_data_cbl%vegin_rp20(10) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(10) = 0.083200 + pars_io_data_cbl%vegin_rs20(10) = 1.000000 + pars_io_data_cbl%vegin_wai(10) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(10) = 0.961000 + pars_io_data_cbl%vegin_shelrb(10) = 2.000000 + pars_io_data_cbl%vegin_vegcf(10) = 1.000000 + pars_io_data_cbl%vegin_frac4(10) = 1.000000 + pars_io_data_cbl%vegin_xalbnir(10) = 1.000000 + pars_io_data_cbl%vegin_extkn(10) = 0.001000 + pars_io_data_cbl%vegin_tminvj(10) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(10) = -10.000000 + pars_io_data_cbl%vegin_vbeta(10) = 2.000000 + pars_io_data_cbl%vegin_froot( 1,10) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,10) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,10) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,10) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,10) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,10) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,10) = 0.110000 + pars_io_data_cbl%vegin_taul( 1,10) = 0.110000 + pars_io_data_cbl%vegin_refl( 2,10) = 0.340000 + pars_io_data_cbl%vegin_taul( 2,10) = 0.340000 + pars_io_data_cbl%vegin_refl( 3,10) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,10) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,10) = 149.000000 + pars_io_data_cbl%vegin_ratecs( 1,10) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,10) = 300.000000 + pars_io_data_cbl%vegin_ratecs( 2,10) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,10) = 150.000000 + pars_io_data_cbl%vegin_ratecp( 1,10) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,10) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,10) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,10) = 607.000000 + pars_io_data_cbl%vegin_ratecp( 3,10) = 0.140000 + pars_io_data_cbl%vegin_a1gs(10) = 4.000000 + pars_io_data_cbl%vegin_d0gs(10) = 1500.000000 + pars_io_data_cbl%vegin_alpha(10) = 0.050000 + pars_io_data_cbl%vegin_convex(10) = 0.800000 + pars_io_data_cbl%vegin_cfrd(10) = 0.025000 + pars_io_data_cbl%vegin_gswmin(10) = 0.040000 + pars_io_data_cbl%vegin_conkc0(10) = 0.000302 + pars_io_data_cbl%vegin_conko0(10) = 0.256000 + pars_io_data_cbl%vegin_ekc(10) = 59430.000000 + pars_io_data_cbl%vegin_eko(10) = 36000.000000 + pars_io_data_cbl%vegin_g0(10) = 0.000000 + pars_io_data_cbl%vegin_g1(10) = 1.616178 + pars_io_data_cbl%vegin_zr(10) = 0.500000 !1.5 in Haverd et al. (2016) + pars_io_data_cbl%vegin_clitt(10) = 0.000000 + + !PFT: wetland + !========================================================= + pars_io_data_cbl%vegin_canst1(11) = 0.100000 + pars_io_data_cbl%vegin_length(11) = 0.300000 + pars_io_data_cbl%vegin_width(11) = 0.010000 + pars_io_data_cbl%vegin_vcmax(11) = 0.000060 + pars_io_data_cbl%vegin_ejmax(11) = 0.000000 + pars_io_data_cbl%vegin_hc(11) = 0.567000 + pars_io_data_cbl%vegin_xfang(11) = -0.300000 + pars_io_data_cbl%vegin_rp20(11) = 1.500000 + pars_io_data_cbl%vegin_rpcoef(11) = 0.083200 + pars_io_data_cbl%vegin_rs20(11) = 1.000000 + pars_io_data_cbl%vegin_wai(11) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(11) = 0.943000 + pars_io_data_cbl%vegin_shelrb(11) = 2.000000 + pars_io_data_cbl%vegin_vegcf(11) = 7.000000 + pars_io_data_cbl%vegin_frac4(11) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(11) = 1.000000 + pars_io_data_cbl%vegin_extkn(11) = 0.001000 + pars_io_data_cbl%vegin_tminvj(11) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(11) = -10.000000 + pars_io_data_cbl%vegin_vbeta(11) = 4.000000 + pars_io_data_cbl%vegin_froot( 1,11) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,11) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,11) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,11) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,11) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,11) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,11) = 0.108000 + pars_io_data_cbl%vegin_taul( 1,11) = 0.075000 + pars_io_data_cbl%vegin_refl( 2,11) = 0.343000 + pars_io_data_cbl%vegin_taul( 2,11) = 0.146000 + pars_io_data_cbl%vegin_refl( 3,11) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,11) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,11) = 275.000000 + pars_io_data_cbl%vegin_ratecs( 1,11) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,11) = 314.000000 + pars_io_data_cbl%vegin_ratecs( 2,11) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,11) = 250.000000 + pars_io_data_cbl%vegin_ratecp( 1,11) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,11) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,11) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,11) = 500.000000 + pars_io_data_cbl%vegin_ratecp( 3,11) = 0.140000 + pars_io_data_cbl%vegin_a1gs(11) = 9.000000 + pars_io_data_cbl%vegin_d0gs(11) = 1500.000000 + pars_io_data_cbl%vegin_alpha(11) = 0.200000 + pars_io_data_cbl%vegin_convex(11) = 0.700000 + pars_io_data_cbl%vegin_cfrd(11) = 0.015000 + pars_io_data_cbl%vegin_gswmin(11) = 0.010000 + pars_io_data_cbl%vegin_conkc0(11) = 0.000302 + pars_io_data_cbl%vegin_conko0(11) = 0.256000 + pars_io_data_cbl%vegin_ekc(11) = 59430.000000 + pars_io_data_cbl%vegin_eko(11) = 36000.000000 + pars_io_data_cbl%vegin_g0(11) = 0.000000 + pars_io_data_cbl%vegin_g1(11) = 5.248500 + pars_io_data_cbl%vegin_zr(11) = 1.800000 + pars_io_data_cbl%vegin_clitt(11) = 2.000000 + + !PFT: empty + !========================================================= + pars_io_data_cbl%vegin_canst1(12) = 0.100000 + pars_io_data_cbl%vegin_length(12) = 0.030000 + pars_io_data_cbl%vegin_width(12) = 0.003000 + pars_io_data_cbl%vegin_vcmax(12) = 0.000017 + pars_io_data_cbl%vegin_ejmax(12) = 0.000000 + pars_io_data_cbl%vegin_hc(12) = 0.200000 + pars_io_data_cbl%vegin_xfang(12) = 0.100000 + pars_io_data_cbl%vegin_rp20(12) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(12) = 0.083200 + pars_io_data_cbl%vegin_rs20(12) = 0.000000 + pars_io_data_cbl%vegin_wai(12) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(12) = 0.975000 + pars_io_data_cbl%vegin_shelrb(12) = 2.000000 + pars_io_data_cbl%vegin_vegcf(12) = 1.000000 + pars_io_data_cbl%vegin_frac4(12) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(12) = 1.000000 + pars_io_data_cbl%vegin_extkn(12) = 0.001000 + pars_io_data_cbl%vegin_tminvj(12) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(12) = -10.000000 + pars_io_data_cbl%vegin_vbeta(12) = 4.000000 + pars_io_data_cbl%vegin_froot( 1,12) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,12) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,12) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,12) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,12) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,12) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,12) = 0.055000 + pars_io_data_cbl%vegin_taul( 1,12) = 0.023000 + pars_io_data_cbl%vegin_refl( 2,12) = 0.190000 + pars_io_data_cbl%vegin_taul( 2,12) = 0.198000 + pars_io_data_cbl%vegin_refl( 3,12) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,12) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,12) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 1,12) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,12) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 2,12) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,12) = 1.000000 + pars_io_data_cbl%vegin_ratecp( 1,12) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,12) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,12) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,12) = 1.000000 + pars_io_data_cbl%vegin_ratecp( 3,12) = 0.140000 + pars_io_data_cbl%vegin_a1gs(12) = 9.000000 + pars_io_data_cbl%vegin_d0gs(12) = 1500.000000 + pars_io_data_cbl%vegin_alpha(12) = 0.200000 + pars_io_data_cbl%vegin_convex(12) = 0.700000 + pars_io_data_cbl%vegin_cfrd(12) = 0.015000 + pars_io_data_cbl%vegin_gswmin(12) = 0.010000 + pars_io_data_cbl%vegin_conkc0(12) = 0.000302 + pars_io_data_cbl%vegin_conko0(12) = 0.256000 + pars_io_data_cbl%vegin_ekc(12) = 59430.000000 + pars_io_data_cbl%vegin_eko(12) = 36000.000000 + pars_io_data_cbl%vegin_g0(12) = 0.000000 + pars_io_data_cbl%vegin_g1(12) = 5.248500 + pars_io_data_cbl%vegin_zr(12) = 3.100000 + pars_io_data_cbl%vegin_clitt(12) = 2.000000 + + !PFT: empty + !========================================================= + pars_io_data_cbl%vegin_canst1(13) = 0.100000 + pars_io_data_cbl%vegin_length(13) = 0.242000 + pars_io_data_cbl%vegin_width(13) = 0.015000 + pars_io_data_cbl%vegin_vcmax(13) = 0.000001 + pars_io_data_cbl%vegin_ejmax(13) = 0.000000 + pars_io_data_cbl%vegin_hc(13) = 6.017000 + pars_io_data_cbl%vegin_xfang(13) = 0.000000 + pars_io_data_cbl%vegin_rp20(13) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(13) = 0.083200 + pars_io_data_cbl%vegin_rs20(13) = 1.000000 + pars_io_data_cbl%vegin_wai(13) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(13) = 0.961000 + pars_io_data_cbl%vegin_shelrb(13) = 2.000000 + pars_io_data_cbl%vegin_vegcf(13) = 1.000000 + pars_io_data_cbl%vegin_frac4(13) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(13) = 1.000000 + pars_io_data_cbl%vegin_extkn(13) = 0.001000 + pars_io_data_cbl%vegin_tminvj(13) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(13) = -10.000000 + pars_io_data_cbl%vegin_vbeta(13) = 2.000000 + pars_io_data_cbl%vegin_froot( 1,13) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,13) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,13) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,13) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,13) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,13) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,13) = 0.091000 + pars_io_data_cbl%vegin_taul( 1,13) = 0.059000 + pars_io_data_cbl%vegin_refl( 2,13) = 0.310000 + pars_io_data_cbl%vegin_taul( 2,13) = 0.163000 + pars_io_data_cbl%vegin_refl( 3,13) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,13) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,13) = 0.100000 + pars_io_data_cbl%vegin_ratecs( 1,13) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,13) = 0.100000 + pars_io_data_cbl%vegin_ratecs( 2,13) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,13) = 0.100000 + pars_io_data_cbl%vegin_ratecp( 1,13) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,13) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,13) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,13) = 0.100000 + pars_io_data_cbl%vegin_ratecp( 3,13) = 0.140000 + pars_io_data_cbl%vegin_a1gs(13) = 9.000000 + pars_io_data_cbl%vegin_d0gs(13) = 1500.000000 + pars_io_data_cbl%vegin_alpha(13) = 0.200000 + pars_io_data_cbl%vegin_convex(13) = 0.700000 + pars_io_data_cbl%vegin_cfrd(13) = 0.015000 + pars_io_data_cbl%vegin_gswmin(13) = 0.010000 + pars_io_data_cbl%vegin_conkc0(13) = 0.000302 + pars_io_data_cbl%vegin_conko0(13) = 0.256000 + pars_io_data_cbl%vegin_ekc(13) = 59430.000000 + pars_io_data_cbl%vegin_eko(13) = 36000.000000 + pars_io_data_cbl%vegin_g0(13) = 0.000000 + pars_io_data_cbl%vegin_g1(13) = 0.000000 + pars_io_data_cbl%vegin_zr(13) = 3.000000 + pars_io_data_cbl%vegin_clitt(13) = 0.000000 + + !PFT: barren + !========================================================= + pars_io_data_cbl%vegin_canst1(14) = 0.100000 + pars_io_data_cbl%vegin_length(14) = 0.030000 + pars_io_data_cbl%vegin_width(14) = 0.001000 + pars_io_data_cbl%vegin_vcmax(14) = 0.000017 + pars_io_data_cbl%vegin_ejmax(14) = 0.000000 + pars_io_data_cbl%vegin_hc(14) = 0.200000 + pars_io_data_cbl%vegin_xfang(14) = 0.000000 + pars_io_data_cbl%vegin_rp20(14) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(14) = 0.083200 + pars_io_data_cbl%vegin_rs20(14) = 0.000000 + pars_io_data_cbl%vegin_wai(14) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(14) = 0.961000 + pars_io_data_cbl%vegin_shelrb(14) = 2.000000 + pars_io_data_cbl%vegin_vegcf(14) = 1.000000 + pars_io_data_cbl%vegin_frac4(14) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(14) = 1.000000 + pars_io_data_cbl%vegin_extkn(14) = 0.001000 + pars_io_data_cbl%vegin_tminvj(14) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(14) = -10.000000 + pars_io_data_cbl%vegin_vbeta(14) = 4.000000 + pars_io_data_cbl%vegin_froot( 1,14) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,14) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,14) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,14) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,14) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,14) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,14) = 0.238000 + pars_io_data_cbl%vegin_taul( 1,14) = 0.039000 + pars_io_data_cbl%vegin_refl( 2,14) = 0.457000 + pars_io_data_cbl%vegin_taul( 2,14) = 0.189000 + pars_io_data_cbl%vegin_refl( 3,14) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,14) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,14) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 1,14) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,14) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 2,14) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,14) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 1,14) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,14) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,14) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,14) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 3,14) = 0.140000 + pars_io_data_cbl%vegin_a1gs(14) = 9.000000 + pars_io_data_cbl%vegin_d0gs(14) = 1500.000000 + pars_io_data_cbl%vegin_alpha(14) = 0.200000 + pars_io_data_cbl%vegin_convex(14) = 0.700000 + pars_io_data_cbl%vegin_cfrd(14) = 0.015000 + pars_io_data_cbl%vegin_gswmin(14) = 0.010000 + pars_io_data_cbl%vegin_conkc0(14) = 0.000302 + pars_io_data_cbl%vegin_conko0(14) = 0.256000 + pars_io_data_cbl%vegin_ekc(14) = 59430.000000 + pars_io_data_cbl%vegin_eko(14) = 36000.000000 + pars_io_data_cbl%vegin_g0(14) = 0.000000 + pars_io_data_cbl%vegin_g1(14) = 5.248500 + pars_io_data_cbl%vegin_zr(14) = 1.000000 + pars_io_data_cbl%vegin_clitt(14) = 0.000000 + + !PFT: urban + !========================================================= + pars_io_data_cbl%vegin_canst1(15) = 0.100000 + pars_io_data_cbl%vegin_length(15) = 0.030000 + pars_io_data_cbl%vegin_width(15) = 0.001000 + pars_io_data_cbl%vegin_vcmax(15) = 0.000017 + pars_io_data_cbl%vegin_ejmax(15) = 0.000000 + pars_io_data_cbl%vegin_hc(15) = 0.200000 + pars_io_data_cbl%vegin_xfang(15) = 0.000000 + pars_io_data_cbl%vegin_rp20(15) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(15) = 0.083200 + pars_io_data_cbl%vegin_rs20(15) = 0.000000 + pars_io_data_cbl%vegin_wai(15) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(15) = 0.961000 + pars_io_data_cbl%vegin_shelrb(15) = 2.000000 + pars_io_data_cbl%vegin_vegcf(15) = 1.000000 + pars_io_data_cbl%vegin_frac4(15) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(15) = 1.000000 + pars_io_data_cbl%vegin_extkn(15) = 0.001000 + pars_io_data_cbl%vegin_tminvj(15) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(15) = -10.000000 + pars_io_data_cbl%vegin_vbeta(15) = 4.000000 + pars_io_data_cbl%vegin_froot( 1,15) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,15) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,15) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,15) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,15) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,15) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,15) = 0.143000 + pars_io_data_cbl%vegin_taul( 1,15) = 0.023000 + pars_io_data_cbl%vegin_refl( 2,15) = 0.275000 + pars_io_data_cbl%vegin_taul( 2,15) = 0.113000 + pars_io_data_cbl%vegin_refl( 3,15) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,15) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,15) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 1,15) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,15) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 2,15) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,15) = 1.000000 + pars_io_data_cbl%vegin_ratecp( 1,15) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,15) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,15) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,15) = 1.000000 + pars_io_data_cbl%vegin_ratecp( 3,15) = 0.140000 + pars_io_data_cbl%vegin_a1gs(15) = 9.000000 + pars_io_data_cbl%vegin_d0gs(15) = 1500.000000 + pars_io_data_cbl%vegin_alpha(15) = 0.200000 + pars_io_data_cbl%vegin_convex(15) = 0.700000 + pars_io_data_cbl%vegin_cfrd(15) = 0.015000 + pars_io_data_cbl%vegin_gswmin(15) = 0.010000 + pars_io_data_cbl%vegin_conkc0(15) = 0.000302 + pars_io_data_cbl%vegin_conko0(15) = 0.256000 + pars_io_data_cbl%vegin_ekc(15) = 59430.000000 + pars_io_data_cbl%vegin_eko(15) = 36000.000000 + pars_io_data_cbl%vegin_g0(15) = 0.000000 + pars_io_data_cbl%vegin_g1(15) = 5.248500 + pars_io_data_cbl%vegin_zr(15) = 1.000000 + pars_io_data_cbl%vegin_clitt(15) = 0.000000 + + !PFT: lakes + !========================================================= + pars_io_data_cbl%vegin_canst1(16) = 0.100000 + pars_io_data_cbl%vegin_length(16) = 0.030000 + pars_io_data_cbl%vegin_width(16) = 0.001000 + pars_io_data_cbl%vegin_vcmax(16) = 0.000017 + pars_io_data_cbl%vegin_ejmax(16) = 0.000000 + pars_io_data_cbl%vegin_hc(16) = 0.200000 + pars_io_data_cbl%vegin_xfang(16) = 0.000000 + pars_io_data_cbl%vegin_rp20(16) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(16) = 0.083200 + pars_io_data_cbl%vegin_rs20(16) = 0.000000 + pars_io_data_cbl%vegin_wai(16) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(16) = 0.961000 + pars_io_data_cbl%vegin_shelrb(16) = 2.000000 + pars_io_data_cbl%vegin_vegcf(16) = 1.000000 + pars_io_data_cbl%vegin_frac4(16) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(16) = 1.000000 + pars_io_data_cbl%vegin_extkn(16) = 0.001000 + pars_io_data_cbl%vegin_tminvj(16) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(16) = -10.000000 + pars_io_data_cbl%vegin_vbeta(16) = 4.000000 + pars_io_data_cbl%vegin_froot( 1,16) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,16) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,16) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,16) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,16) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,16) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,16) = 0.143000 + pars_io_data_cbl%vegin_taul( 1,16) = 0.023000 + pars_io_data_cbl%vegin_refl( 2,16) = 0.275000 + pars_io_data_cbl%vegin_taul( 2,16) = 0.113000 + pars_io_data_cbl%vegin_refl( 3,16) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,16) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,16) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 1,16) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,16) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 2,16) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,16) = 1.000000 + pars_io_data_cbl%vegin_ratecp( 1,16) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,16) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,16) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,16) = 1.000000 + pars_io_data_cbl%vegin_ratecp( 3,16) = 0.140000 + pars_io_data_cbl%vegin_a1gs(16) = 9.000000 + pars_io_data_cbl%vegin_d0gs(16) = 1500.000000 + pars_io_data_cbl%vegin_alpha(16) = 0.200000 + pars_io_data_cbl%vegin_convex(16) = 0.700000 + pars_io_data_cbl%vegin_cfrd(16) = 0.015000 + pars_io_data_cbl%vegin_gswmin(16) = 0.010000 + pars_io_data_cbl%vegin_conkc0(16) = 0.000302 + pars_io_data_cbl%vegin_conko0(16) = 0.256000 + pars_io_data_cbl%vegin_ekc(16) = 59430.000000 + pars_io_data_cbl%vegin_eko(16) = 36000.000000 + pars_io_data_cbl%vegin_g0(16) = 0.000000 + pars_io_data_cbl%vegin_g1(16) = 5.248500 + pars_io_data_cbl%vegin_zr(16) = 1.000000 + pars_io_data_cbl%vegin_clitt(16) = 0.000000 + + !PFT: ice + !========================================================= + pars_io_data_cbl%vegin_canst1(17) = 0.100000 + pars_io_data_cbl%vegin_length(17) = 0.030000 + pars_io_data_cbl%vegin_width(17) = 0.001000 + pars_io_data_cbl%vegin_vcmax(17) = 0.000017 + pars_io_data_cbl%vegin_ejmax(17) = 0.000000 + pars_io_data_cbl%vegin_hc(17) = 0.200000 + pars_io_data_cbl%vegin_xfang(17) = 0.000000 + pars_io_data_cbl%vegin_rp20(17) = 1.000000 + pars_io_data_cbl%vegin_rpcoef(17) = 0.083200 + pars_io_data_cbl%vegin_rs20(17) = 0.000000 + pars_io_data_cbl%vegin_wai(17) = 0.000000 + pars_io_data_cbl%vegin_rootbeta(17) = 0.961000 + pars_io_data_cbl%vegin_shelrb(17) = 2.000000 + pars_io_data_cbl%vegin_vegcf(17) = 1.000000 + pars_io_data_cbl%vegin_frac4(17) = 0.000000 + pars_io_data_cbl%vegin_xalbnir(17) = 1.000000 + pars_io_data_cbl%vegin_extkn(17) = 0.001000 + pars_io_data_cbl%vegin_tminvj(17) = -15.000000 + pars_io_data_cbl%vegin_tmaxvj(17) = -10.000000 + pars_io_data_cbl%vegin_vbeta(17) = 4.000000 + pars_io_data_cbl%vegin_froot( 1,17) = 0.000000 + pars_io_data_cbl%vegin_froot( 2,17) = 0.000000 + pars_io_data_cbl%vegin_froot( 3,17) = 0.000000 + pars_io_data_cbl%vegin_froot( 4,17) = 0.000000 + pars_io_data_cbl%vegin_froot( 5,17) = 0.000000 + pars_io_data_cbl%vegin_froot( 6,17) = 0.000000 + pars_io_data_cbl%vegin_refl( 1,17) = 0.159000 + pars_io_data_cbl%vegin_taul( 1,17) = 0.026000 + pars_io_data_cbl%vegin_refl( 2,17) = 0.305000 + pars_io_data_cbl%vegin_taul( 2,17) = 0.113000 + pars_io_data_cbl%vegin_refl( 3,17) = 0.010000 + pars_io_data_cbl%vegin_taul( 3,17) = 0.010000 + pars_io_data_cbl%vegin_csoil( 1,17) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 1,17) = 2.000000 + pars_io_data_cbl%vegin_csoil( 2,17) = 1.000000 + pars_io_data_cbl%vegin_ratecs( 2,17) = 0.500000 + pars_io_data_cbl%vegin_cplant( 1,17) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 1,17) = 1.000000 + pars_io_data_cbl%vegin_cplant( 2,17) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 2,17) = 0.030000 + pars_io_data_cbl%vegin_cplant( 3,17) = 0.000000 + pars_io_data_cbl%vegin_ratecp( 3,17) = 0.140000 + pars_io_data_cbl%vegin_a1gs(17) = 9.000000 + pars_io_data_cbl%vegin_d0gs(17) = 1500.000000 + pars_io_data_cbl%vegin_alpha(17) = 0.200000 + pars_io_data_cbl%vegin_convex(17) = 0.700000 + pars_io_data_cbl%vegin_cfrd(17) = 0.015000 + pars_io_data_cbl%vegin_gswmin(17) = 0.010000 + pars_io_data_cbl%vegin_conkc0(17) = 0.000302 + pars_io_data_cbl%vegin_conko0(17) = 0.256000 + pars_io_data_cbl%vegin_ekc(17) = 59430.000000 + pars_io_data_cbl%vegin_eko(17) = 36000.000000 + pars_io_data_cbl%vegin_g0(17) = 0.000000 + pars_io_data_cbl%vegin_g1(17) = 5.248500 + pars_io_data_cbl%vegin_zr(17) = 1.000000 + pars_io_data_cbl%vegin_clitt(17) = 0.000000 + + ! new calculation dleaf since April 2012 (cable v1.8 did not use width) + pars_io_data_cbl%vegin_dleaf = SQRT(pars_io_data_cbl%vegin_width * pars_io_data_cbl%vegin_length) + +End subroutine cable_pft_params + +END MODULE cable_pft_params_mod + diff --git a/src/coupled/AM3/initialisation/cable_soil_params.F90 b/src/coupled/AM3/initialisation/cable_soil_params.F90 new file mode 100644 index 000000000..9372e1f92 --- /dev/null +++ b/src/coupled/AM3/initialisation/cable_soil_params.F90 @@ -0,0 +1,150 @@ +MODULE cable_soil_params_mod + + IMPLICIT NONE + +CONTAINS + +subroutine cable_soil_params(pars_io_cbl) + + ! Gets parameter values for each vegetation type and soil type. + +USE params_io_mod_cbl, ONLY: params_io_data_type + + IMPLICIT NONE + + TYPE(params_io_data_type), TARGET :: pars_io_cbl + + + !SOIL parameters: description and corresponding variable name in code. + !SOIL parameters are assigned as TYPE pars_io_cbl%soilin_ but later used as soil% + +!SOIL: Coarse sand/Loamy sand +! ========================================================= + pars_io_cbl%soilin_silt( 1) = 0.080000 + pars_io_cbl%soilin_clay( 1) = 0.090000 + pars_io_cbl%soilin_sand( 1) = 0.830000 + pars_io_cbl%soilin_swilt( 1) = 0.072000 + pars_io_cbl%soilin_sfc( 1) = 0.143000 + pars_io_cbl%soilin_ssat( 1) = 0.398000 + pars_io_cbl%soilin_bch( 1) = 4.200000 + pars_io_cbl%soilin_hyds( 1) = 0.000166 + pars_io_cbl%soilin_sucs( 1) = -0.106000 + pars_io_cbl%soilin_rhosoil( 1) = 1600.000000 + pars_io_cbl%soilin_css( 1) = 850.000000 + + !SOIL: Medium clay loam/silty clay loam/silt loam + !========================================================= + pars_io_cbl%soilin_silt( 2) = 0.330000 + pars_io_cbl%soilin_clay( 2) = 0.300000 + pars_io_cbl%soilin_sand( 2) = 0.370000 + pars_io_cbl%soilin_swilt( 2) = 0.216000 + pars_io_cbl%soilin_sfc( 2) = 0.301000 + pars_io_cbl%soilin_ssat( 2) = 0.479000 + pars_io_cbl%soilin_bch( 2) = 7.100000 + pars_io_cbl%soilin_hyds( 2) = 0.000004 + pars_io_cbl%soilin_sucs( 2) = -0.591000 + pars_io_cbl%soilin_rhosoil( 2) = 1600.000000 + pars_io_cbl%soilin_css( 2) = 850.000000 + + !SOIL: Fine clay + !========================================================= + pars_io_cbl%soilin_silt( 3) = 0.170000 + pars_io_cbl%soilin_clay( 3) = 0.670000 + pars_io_cbl%soilin_sand( 3) = 0.160000 + pars_io_cbl%soilin_swilt( 3) = 0.286000 + pars_io_cbl%soilin_sfc( 3) = 0.367000 + pars_io_cbl%soilin_ssat( 3) = 0.482000 + pars_io_cbl%soilin_bch( 3) = 11.400000 + pars_io_cbl%soilin_hyds( 3) = 0.000001 + pars_io_cbl%soilin_sucs( 3) = -0.405000 + pars_io_cbl%soilin_rhosoil( 3) = 1381.000000 + pars_io_cbl%soilin_css( 3) = 850.000000 + + !SOIL: Coarse-medium sandy loam/loam + !========================================================= + pars_io_cbl%soilin_silt( 4) = 0.200000 + pars_io_cbl%soilin_clay( 4) = 0.200000 + pars_io_cbl%soilin_sand( 4) = 0.600000 + pars_io_cbl%soilin_swilt( 4) = 0.135000 + pars_io_cbl%soilin_sfc( 4) = 0.218000 + pars_io_cbl%soilin_ssat( 4) = 0.443000 + pars_io_cbl%soilin_bch( 4) = 5.150000 + pars_io_cbl%soilin_hyds( 4) = 0.000021 + pars_io_cbl%soilin_sucs( 4) = -0.348000 + pars_io_cbl%soilin_rhosoil( 4) = 1373.000000 + pars_io_cbl%soilin_css( 4) = 850.000000 + + !SOIL: Coarse-fine sandy clay + !========================================================= + pars_io_cbl%soilin_silt( 5) = 0.060000 + pars_io_cbl%soilin_clay( 5) = 0.420000 + pars_io_cbl%soilin_sand( 5) = 0.520000 + pars_io_cbl%soilin_swilt( 5) = 0.219000 + pars_io_cbl%soilin_sfc( 5) = 0.310000 + pars_io_cbl%soilin_ssat( 5) = 0.426000 + pars_io_cbl%soilin_bch( 5) = 10.400000 + pars_io_cbl%soilin_hyds( 5) = 0.000002 + pars_io_cbl%soilin_sucs( 5) = -0.153000 + pars_io_cbl%soilin_rhosoil( 5) = 1476.000000 + pars_io_cbl%soilin_css( 5) = 850.000000 + + !SOIL: Medium-fine silty clay + !========================================================= + pars_io_cbl%soilin_silt( 6) = 0.250000 + pars_io_cbl%soilin_clay( 6) = 0.480000 + pars_io_cbl%soilin_sand( 6) = 0.270000 + pars_io_cbl%soilin_swilt( 6) = 0.283000 + pars_io_cbl%soilin_sfc( 6) = 0.370000 + pars_io_cbl%soilin_ssat( 6) = 0.482000 + pars_io_cbl%soilin_bch( 6) = 10.400000 + pars_io_cbl%soilin_hyds( 6) = 0.000001 + pars_io_cbl%soilin_sucs( 6) = -0.490000 + pars_io_cbl%soilin_rhosoil( 6) = 1521.000000 + pars_io_cbl%soilin_css( 6) = 850.000000 + + !SOIL: Coarse-medium-fine sandy clay loam + !========================================================= + pars_io_cbl%soilin_silt( 7) = 0.150000 + pars_io_cbl%soilin_clay( 7) = 0.270000 + pars_io_cbl%soilin_sand( 7) = 0.580000 + pars_io_cbl%soilin_swilt( 7) = 0.175000 + pars_io_cbl%soilin_sfc( 7) = 0.255000 + pars_io_cbl%soilin_ssat( 7) = 0.420000 + pars_io_cbl%soilin_bch( 7) = 7.120000 + pars_io_cbl%soilin_hyds( 7) = 0.000006 + pars_io_cbl%soilin_sucs( 7) = -0.299000 + pars_io_cbl%soilin_rhosoil( 7) = 1373.000000 + pars_io_cbl%soilin_css( 7) = 850.000000 + + !SOIL: Organic peat + !========================================================= + pars_io_cbl%soilin_silt( 8) = 0.700000 + pars_io_cbl%soilin_clay( 8) = 0.170000 + pars_io_cbl%soilin_sand( 8) = 0.130000 + pars_io_cbl%soilin_swilt( 8) = 0.395000 + pars_io_cbl%soilin_sfc( 8) = 0.450000 + pars_io_cbl%soilin_ssat( 8) = 0.451000 + pars_io_cbl%soilin_bch( 8) = 5.830000 + pars_io_cbl%soilin_hyds( 8) = 0.000800 + pars_io_cbl%soilin_sucs( 8) = -0.356000 + pars_io_cbl%soilin_rhosoil( 8) = 1537.000000 + pars_io_cbl%soilin_css( 8) = 1920.000000 + + !SOIL: Permanent ice + !========================================================= + pars_io_cbl%soilin_silt( 9) = 0.330000 + pars_io_cbl%soilin_clay( 9) = 0.300000 + pars_io_cbl%soilin_sand( 9) = 0.370000 + pars_io_cbl%soilin_swilt( 9) = 0.216000 + pars_io_cbl%soilin_sfc( 9) = 0.301000 + pars_io_cbl%soilin_ssat( 9) = 0.479000 + pars_io_cbl%soilin_bch( 9) = 7.100000 + pars_io_cbl%soilin_hyds( 9) = 0.000001 + pars_io_cbl%soilin_sucs( 9) = -0.153000 + pars_io_cbl%soilin_rhosoil( 9) = 917.000000 + pars_io_cbl%soilin_css( 9) = 2100.000000 + +End subroutine cable_soil_params + +END MODULE cable_soil_params_mod + diff --git a/src/coupled/AM3/initialisation/init_cable_working_vars.F90 b/src/coupled/AM3/initialisation/init_cable_working_vars.F90 new file mode 100644 index 000000000..5053cbba4 --- /dev/null +++ b/src/coupled/AM3/initialisation/init_cable_working_vars.F90 @@ -0,0 +1,63 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE init_cable_work_mod + +!------------------------------------------------------------------------------ +! Description: +! Main driver to dec/alloc/initialize CABLE prognostic variables +! +! This MODULE is USEd in: +! init.F90 +! +! This MODULE contains 1 public Subroutine: +! init_cable_work +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +!------------------------------------------------------------------------------ + +IMPLICIT NONE + +PUBLIC :: init_cable_work +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='INIT_CABLE_WORK_MOD' + +CONTAINS + +SUBROUTINE init_cable_work(row_length, rows, land_pts, nsurft, sm_levels, lsm_id, cable, & + work_cbl, work_cbl_data ) + +! Description: +! Nothing further to add to the module description. + +USE work_vars_mod_cbl, ONLY: work_vars_type, & + work_vars_data_type, & + alloc_work_vars_cbl, & + assoc_work_vars_cbl + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: row_length, rows, land_pts, nsurft,sm_levels +INTEGER, INTENT(IN) :: lsm_id, cable +TYPE(work_vars_data_type), INTENT(IN OUT) :: work_cbl_data +TYPE(work_vars_type), INTENT(IN OUT) :: work_cbl + +CALL alloc_work_vars_cbl(row_length, rows, land_pts, nsurft, sm_levels, & + lsm_id, cable, work_cbl_data ) +CALL assoc_work_vars_cbl(work_cbl, work_cbl_data ) + +RETURN + +END SUBROUTINE init_cable_work + +END MODULE init_cable_work_mod diff --git a/src/coupled/AM3/initialisation/init_soilin_cbl.inc b/src/coupled/AM3/initialisation/init_soilin_cbl.inc new file mode 100644 index 000000000..13b2efbc3 --- /dev/null +++ b/src/coupled/AM3/initialisation/init_soilin_cbl.inc @@ -0,0 +1,187 @@ +! *****************************COPYRIGHT************************************** +! (C) Crown copyright Met Office. All rights reserved. +! For further details please refer to the file COPYRIGHT.txt +! which you should have received as part of this distribution. +! *****************************COPYRIGHT************************************** + +SUBROUTINE init_soilin_cbl(nml_dir) + +!----------------------------------------------------------------------------- +! Description: +! Initialises the non-vegetation parameters +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in TECHNICAL +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +USE missing_data_mod, ONLY: & +! imported scalar parameters + rmdi + +USE io_constants, ONLY: namelist_unit + +USE string_utils_mod, ONLY: to_string +USE errormessagelength_mod, ONLY: errormessagelength + +USE grid_constants_mod_cbl, ONLY: nsoil_max ! # of soil types [9] +USE cable_fields_mod, ONLY: pars_io_data_cbl + +IMPLICIT NONE + +! Arguments +CHARACTER(LEN=*), INTENT(IN) :: nml_dir ! The directory containing the + ! namelists +! Work variables +INTEGER :: ERROR ! Error indicator +CHARACTER(LEN=errormessagelength) :: iomessage + +CHARACTER(LEN=*), PARAMETER :: routinename='INIT_SOILIN_CABLE' + +!----------------------------------------------------------------------------- + +REAL :: & + silt_io(nsoil_max), & + clay_io(nsoil_max), & + sand_io(nsoil_max), & + swilt_io(nsoil_max), & + sfc_io(nsoil_max), & + ssat_io(nsoil_max), & + bch_io(nsoil_max), & + hyds_io(nsoil_max), & + sucs_io(nsoil_max), & + rhosoil_io(nsoil_max), & + css_io(nsoil_max) + +!----------------------------------------------------------------------------- +! Namelist definition +!----------------------------------------------------------------------------- +NAMELIST / cable_soilparm/ silt_io, clay_io, sand_io, swilt_io, & + sfc_io, ssat_io, bch_io, hyds_io, sucs_io, rhosoil_io, css_io + +!----------------------------------------------------------------------------- +! Initialise namelist values before reading them +!----------------------------------------------------------------------------- +silt_io(:nsoil_max) = rmdi +clay_io(:nsoil_max) = rmdi +sand_io(:nsoil_max) = rmdi +swilt_io(:nsoil_max) = rmdi +sfc_io(:nsoil_max) = rmdi +ssat_io(:nsoil_max) = rmdi +bch_io(:nsoil_max) = rmdi +hyds_io(:nsoil_max) = rmdi +sucs_io(:nsoil_max) = rmdi +rhosoil_io(:nsoil_max) = rmdi +css_io(:nsoil_max) = rmdi + +!----------------------------------------------------------------------------- +! Read namelist +!----------------------------------------------------------------------------- +CALL log_info(routinename, "Reading CABLE_SOILPARM namelist...") + +! Open the CABLE soil parameters namelist file +OPEN(namelist_unit, FILE=(TRIM(nml_dir) // '/' // & + 'cable_soilparm.nml'), & + STATUS='old', POSITION='rewind', ACTION='read', IOSTAT = ERROR, & + IOMSG = iomessage) +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Error opening namelist file cable_soilparm.nml " // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + +READ(namelist_unit, NML = cable_soilparm, IOSTAT = ERROR, & + IOMSG = iomessage) +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Error reading namelist CABLE_SOILPARM " // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + +! Close the namelist file +CLOSE(namelist_unit, IOSTAT = ERROR, IOMSG = iomessage) +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Error closing namelist file cable_soilparm.nml " // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + + +!----------------------------------------------------------------------------- +! Process the namelist values +!----------------------------------------------------------------------------- +! Copy values from dedicated I/O arrays into the soil parameter data type +pars_io_data_cbl%soilin_silt(1:nsoil_max) = silt_io(1:nsoil_max) +pars_io_data_cbl%soilin_clay(1:nsoil_max) = clay_io(1:nsoil_max) +pars_io_data_cbl%soilin_sand(1:nsoil_max) = sand_io(1:nsoil_max) +pars_io_data_cbl%soilin_swilt(1:nsoil_max) = swilt_io(1:nsoil_max) +pars_io_data_cbl%soilin_sfc(1:nsoil_max) = sfc_io(1:nsoil_max) +pars_io_data_cbl%soilin_ssat(1:nsoil_max) = ssat_io(1:nsoil_max) +pars_io_data_cbl%soilin_bch(1:nsoil_max) = bch_io(1:nsoil_max) +pars_io_data_cbl%soilin_hyds(1:nsoil_max) = hyds_io(1:nsoil_max) +pars_io_data_cbl%soilin_sucs(1:nsoil_max) = sucs_io(1:nsoil_max) +pars_io_data_cbl%soilin_rhosoil(1:nsoil_max) = rhosoil_io(1:nsoil_max) +pars_io_data_cbl%soilin_css(1:nsoil_max) = css_io(1:nsoil_max) + +!----------------------------------------------------------------------------- +! Check that all variables were present in the namelist. +! The namelist variables were initialised to rmdi. +!----------------------------------------------------------------------------- +ERROR = 0 +IF ( ANY( ABS( pars_io_data_cbl%soilin_silt(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for silt") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_clay(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for clay") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_sand(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for sand") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_swilt(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for swilt") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_sfc(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for sfc") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_ssat(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for ssat") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_bch(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for bch") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_hyds(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for hyds") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_sucs(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for sucs") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_rhosoil(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for rhosoil") +END IF +IF ( ANY( ABS( pars_io_data_cbl%soilin_css(1:nsoil_max) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for css") +END IF + +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Variable(s) missing from namelist - see earlier " // & + "error message(s)") + +RETURN + +END SUBROUTINE init_soilin_cbl + diff --git a/src/coupled/AM3/initialisation/init_vegin_cbl.inc b/src/coupled/AM3/initialisation/init_vegin_cbl.inc new file mode 100644 index 000000000..4ab1b9a7e --- /dev/null +++ b/src/coupled/AM3/initialisation/init_vegin_cbl.inc @@ -0,0 +1,479 @@ + +SUBROUTINE init_vegin_cbl(nml_dir,progs) + +!----------------------------------------------------------------------------- +! Description: +! Reads the JULES_PFT_PARAMS_CABLE namelist for standalone runs +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in TECHNICAL +! +! Code Description: +! Language: Fortran 90. +! This code is written to JULES coding standards v1. +!----------------------------------------------------------------------------- + +USE missing_data_mod, ONLY: & +! imported scalar parameters + rmdi +USE io_constants, ONLY: namelist_unit + +USE string_utils_mod, ONLY: to_string + +USE errormessagelength_mod, ONLY: errormessagelength + +USE logging_mod, ONLY: log_info, log_fatal + +USE jules_surface_types_mod, ONLY: ntype, npft + +USE ancil_info, ONLY: land_pts + +USE grid_constants_mod_cbl, ONLY: nsl, nscs, nvcs, nrb + +USE max_dimensions, ONLY: ntype_max + +USE prognostics, ONLY: progs_type +USE cable_fields_mod, ONLY: pars_io_data_cbl, pars_io_cbl + +USE params_io_mod_cbl, ONLY: params_io_assoc_cbl + +IMPLICIT NONE + +! Arguments +CHARACTER(LEN=*), INTENT(IN) :: nml_dir ! The directory containing the + ! namelists +!TYPES containing the data +TYPE(progs_type), INTENT(IN OUT) :: progs + +! Work variables +INTEGER :: ERROR ! Error indicator +CHARACTER(LEN=errormessagelength) :: iomessage + +CHARACTER(LEN=*), PARAMETER :: routinename='INIT_VEGIN_CABLE' + +! With some compilers, namelists cannot contain multidimensional arrays. +! Therefore, an input type without multidimensional arrays is used to read +! in the the values from the namelist, and these values will then be +! transferred to the desired data type which does contain multidimensional +! arrays + +! Whereas in JULES PFT parameters are only used for veg types, in CABLE they +! are used for both. Therefore CABLE PFT arrays need to be allocated ntype_max, +! which equals (npft_max + nvg_max). + +REAL :: & + canst1_io(ntype_max), & + length_io(ntype_max), & + width_io(ntype_max), & + vcmax_io(ntype_max), & + ejmax_io(ntype_max), & + hc_io(ntype_max), & + xfang_io(ntype_max), & + rp20_io(ntype_max), & + rpcoef_io(ntype_max), & + rs20_io(ntype_max), & + wai_io(ntype_max), & + rootbeta_io(ntype_max), & + shelrb_io(ntype_max), & + vegcf_io(ntype_max), & + frac4_io(ntype_max), & + xalbnir_io(ntype_max), & + extkn_io(ntype_max), & + tminvj_io(ntype_max), & + tmaxvj_io(ntype_max), & + vbeta_io(ntype_max), & + a1gs_io(ntype_max), & + d0gs_io(ntype_max), & + alpha_io(ntype_max), & + convex_io(ntype_max), & + cfrd_io(ntype_max), & + gswmin_io(ntype_max), & + conkc0_io(ntype_max), & + conko0_io(ntype_max), & + ekc_io(ntype_max), & + eko_io(ntype_max), & + g0_io(ntype_max), & + g1_io(ntype_max), & + zr_io(ntype_max), & + clitt_io(ntype_max), & + froot1_io(ntype_max), & + froot2_io(ntype_max), & + froot3_io(ntype_max), & + froot4_io(ntype_max), & + froot5_io(ntype_max), & + froot6_io(ntype_max), & + csoil1_io(ntype_max), & + csoil2_io(ntype_max), & + ratecs1_io(ntype_max), & + ratecs2_io(ntype_max), & + cplant1_io(ntype_max), & + cplant2_io(ntype_max), & + cplant3_io(ntype_max), & + ratecp1_io(ntype_max), & + ratecp2_io(ntype_max), & + ratecp3_io(ntype_max), & + refl1_io(ntype_max), & + refl2_io(ntype_max), & + refl3_io(ntype_max), & + taul1_io(ntype_max), & + taul2_io(ntype_max), & + taul3_io(ntype_max), & + lai_io(ntype_max) + +!----------------------------------------------------------------------------- +! Namelist definition +!----------------------------------------------------------------------------- +NAMELIST / cable_pftparm/ canst1_io, length_io, width_io, vcmax_io, & + ejmax_io, hc_io, xfang_io, rp20_io, rpcoef_io, rs20_io, wai_io, & + rootbeta_io, shelrb_io, vegcf_io, frac4_io, xalbnir_io, extkn_io, & + tminvj_io, tmaxvj_io, vbeta_io, a1gs_io, d0gs_io, alpha_io, & + convex_io, cfrd_io, gswmin_io, conkc0_io, conko0_io, ekc_io, & + eko_io, g0_io, g1_io, zr_io, clitt_io, froot1_io, froot2_io, & + froot3_io, froot4_io, froot5_io, froot6_io, cplant1_io, & + cplant2_io, cplant3_io, csoil1_io, csoil2_io, ratecp1_io, & + ratecp2_io, ratecp3_io, ratecs1_io, ratecs2_io, refl1_io, & + refl2_io, refl3_io, taul1_io, taul2_io, taul3_io, lai_io + +!----------------------------------------------------------------------------- +! Initialise namelist values before reading them +!----------------------------------------------------------------------------- +canst1_io(:ntype) = rmdi +length_io(:ntype) = rmdi +width_io(:ntype) = rmdi +vcmax_io(:ntype) = rmdi +ejmax_io(:ntype) = rmdi +hc_io(:ntype) = rmdi +xfang_io(:ntype) = rmdi +rp20_io(:ntype) = rmdi +rpcoef_io(:ntype) = rmdi +rs20_io(:ntype) = rmdi +wai_io(:ntype) = rmdi +rootbeta_io(:ntype) = rmdi +shelrb_io(:ntype) = rmdi +vegcf_io(:ntype) = rmdi +frac4_io(:ntype) = rmdi +xalbnir_io(:ntype) = rmdi +extkn_io(:ntype) = rmdi +tminvj_io(:ntype) = rmdi +tmaxvj_io(:ntype) = rmdi +vbeta_io(:ntype) = rmdi +a1gs_io(:ntype) = rmdi +d0gs_io(:ntype) = rmdi +alpha_io(:ntype) = rmdi +convex_io(:ntype) = rmdi +cfrd_io(:ntype) = rmdi +gswmin_io(:ntype) = rmdi +conkc0_io(:ntype) = rmdi +conko0_io(:ntype) = rmdi +ekc_io(:ntype) = rmdi +eko_io(:ntype) = rmdi +g0_io(:ntype) = rmdi +g1_io(:ntype) = rmdi +zr_io(:ntype) = rmdi +clitt_io(:ntype) = rmdi +froot1_io(:ntype) = rmdi +froot2_io(:ntype) = rmdi +froot3_io(:ntype) = rmdi +froot4_io(:ntype) = rmdi +froot5_io(:ntype) = rmdi +froot6_io(:ntype) = rmdi +cplant1_io(:ntype) = rmdi +cplant2_io(:ntype) = rmdi +cplant3_io(:ntype) = rmdi +csoil1_io(:ntype) = rmdi +csoil2_io(:ntype) = rmdi +ratecp1_io(:ntype) = rmdi +ratecp2_io(:ntype) = rmdi +ratecp3_io(:ntype) = rmdi +ratecs1_io(:ntype) = rmdi +ratecs2_io(:ntype) = rmdi +refl1_io(:ntype) = rmdi +refl2_io(:ntype) = rmdi +refl3_io(:ntype) = rmdi +taul1_io(:ntype) = rmdi +taul2_io(:ntype) = rmdi +taul3_io(:ntype) = rmdi +lai_io(:ntype) = rmdi + +!----------------------------------------------------------------------------- +! Read namelist +!----------------------------------------------------------------------------- +CALL log_info(routinename, "Reading CABLE_PFTPARM namelist...") + +OPEN(namelist_unit, FILE=(TRIM(nml_dir) // '/' // 'pft_params.nml'), & + STATUS='old', POSITION='rewind', ACTION='read', IOSTAT = ERROR,& + IOMSG = iomessage) +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Error opening namelist file pft_params.nml " // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + +READ(namelist_unit, NML = cable_pftparm, IOSTAT = ERROR, IOMSG = iomessage) +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Error reading namelist CABLE_PFTPARM " // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + +CLOSE(namelist_unit, IOSTAT = ERROR, IOMSG = iomessage) +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Error closing namelist file pft_params.nml " // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + +!----------------------------------------------------------------------------- +! Transfer values from io values to vegin +!----------------------------------------------------------------------------- + +pars_io_data_cbl%vegin_canst1(:ntype) = canst1_io(:ntype) +pars_io_data_cbl%vegin_length(:ntype) = length_io(:ntype) +pars_io_data_cbl%vegin_width(:ntype) = width_io(:ntype) +pars_io_data_cbl%vegin_vcmax(:ntype) = vcmax_io(:ntype) +pars_io_data_cbl%vegin_ejmax(:ntype) = ejmax_io(:ntype) +pars_io_data_cbl%vegin_hc(:ntype) = hc_io(:ntype) +pars_io_data_cbl%vegin_xfang(:ntype) = xfang_io(:ntype) +pars_io_data_cbl%vegin_rp20(:ntype) = rp20_io(:ntype) +pars_io_data_cbl%vegin_rpcoef(:ntype) = rpcoef_io(:ntype) +pars_io_data_cbl%vegin_rs20(:ntype) = rs20_io(:ntype) +pars_io_data_cbl%vegin_wai(:ntype) = wai_io(:ntype) +pars_io_data_cbl%vegin_rootbeta(:ntype) = rootbeta_io(:ntype) +pars_io_data_cbl%vegin_shelrb(:ntype) = shelrb_io(:ntype) +pars_io_data_cbl%vegin_vegcf(:ntype) = vegcf_io(:ntype) +pars_io_data_cbl%vegin_frac4(:ntype) = frac4_io(:ntype) +pars_io_data_cbl%vegin_xalbnir(:ntype) = xalbnir_io(:ntype) +pars_io_data_cbl%vegin_extkn(:ntype) = extkn_io(:ntype) +pars_io_data_cbl%vegin_tminvj(:ntype) = tminvj_io(:ntype) +pars_io_data_cbl%vegin_tmaxvj(:ntype) = tmaxvj_io(:ntype) +pars_io_data_cbl%vegin_vbeta(:ntype) = vbeta_io(:ntype) +pars_io_data_cbl%vegin_a1gs(:ntype) = a1gs_io(:ntype) +pars_io_data_cbl%vegin_d0gs(:ntype) = d0gs_io(:ntype) +pars_io_data_cbl%vegin_alpha(:ntype) = alpha_io(:ntype) +pars_io_data_cbl%vegin_convex(:ntype) = convex_io(:ntype) +pars_io_data_cbl%vegin_cfrd(:ntype) = cfrd_io(:ntype) +pars_io_data_cbl%vegin_gswmin(:ntype) = gswmin_io(:ntype) +pars_io_data_cbl%vegin_conkc0(:ntype) = conkc0_io(:ntype) +pars_io_data_cbl%vegin_conko0(:ntype) = conko0_io(:ntype) +pars_io_data_cbl%vegin_ekc(:ntype) = ekc_io(:ntype) +pars_io_data_cbl%vegin_eko(:ntype) = eko_io(:ntype) +pars_io_data_cbl%vegin_g0(:ntype) = g0_io(:ntype) +pars_io_data_cbl%vegin_g1(:ntype) = g1_io(:ntype) +pars_io_data_cbl%vegin_zr(:ntype) = zr_io(:ntype) +pars_io_data_cbl%vegin_clitt(:ntype) = clitt_io(:ntype) +pars_io_data_cbl%vegin_froot(1,:ntype) = froot1_io(:ntype) +pars_io_data_cbl%vegin_froot(2,:ntype) = froot2_io(:ntype) +pars_io_data_cbl%vegin_froot(3,:ntype) = froot3_io(:ntype) +pars_io_data_cbl%vegin_froot(4,:ntype) = froot4_io(:ntype) +pars_io_data_cbl%vegin_froot(5,:ntype) = froot5_io(:ntype) +pars_io_data_cbl%vegin_froot(6,:ntype) = froot6_io(:ntype) +pars_io_data_cbl%vegin_cplant(1,:ntype) = cplant1_io(:ntype) +pars_io_data_cbl%vegin_cplant(2,:ntype) = cplant2_io(:ntype) +pars_io_data_cbl%vegin_cplant(3,:ntype) = cplant3_io(:ntype) +pars_io_data_cbl%vegin_csoil(1,:ntype) = csoil1_io(:ntype) +pars_io_data_cbl%vegin_csoil(2,:ntype) = csoil2_io(:ntype) +pars_io_data_cbl%vegin_ratecp(1,:ntype) = ratecp1_io(:ntype) +pars_io_data_cbl%vegin_ratecp(2,:ntype) = ratecp2_io(:ntype) +pars_io_data_cbl%vegin_ratecp(3,:ntype) = ratecp3_io(:ntype) +pars_io_data_cbl%vegin_ratecs(1,:ntype) = ratecs1_io(:ntype) +pars_io_data_cbl%vegin_ratecs(2,:ntype) = ratecs2_io(:ntype) +pars_io_data_cbl%vegin_refl(1,:ntype) = refl1_io(:ntype) +pars_io_data_cbl%vegin_refl(2,:ntype) = refl2_io(:ntype) +pars_io_data_cbl%vegin_refl(3,:ntype) = refl3_io(:ntype) +pars_io_data_cbl%vegin_taul(1,:ntype) = taul1_io(:ntype) +pars_io_data_cbl%vegin_taul(2,:ntype) = taul2_io(:ntype) +pars_io_data_cbl%vegin_taul(3,:ntype) = taul3_io(:ntype) +progs%canht_pft(:,:npft) = SPREAD(hc_io(1:npft), 1, land_pts) +progs%lai_pft(:,:npft) = SPREAD(lai_io(1:npft), 1, land_pts) + +!----------------------------------------------------------------------------- +! Check that all required variables were present in the namelist. +! The namelist variables were initialised to rmdi. +! Some configurations don't need all parameters but for now we insist on +! getting all parameters (and that there are not rmdi!). +!----------------------------------------------------------------------------- +ERROR = 0 +IF ( ANY( ABS( pars_io_data_cbl%vegin_canst1(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for canst1") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_length(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for length") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_width(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for width") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_vcmax(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for vcmax") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_ejmax(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for ejmax") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_hc(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for hc") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_xfang(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for xfang") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_rp20(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for rp20") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_rpcoef(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for rpcoef") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_rs20(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for rs20") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_wai(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for wai") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_rootbeta(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for rootbeta") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_shelrb(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for shelrb") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_vegcf(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for vegcf") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_frac4(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for frac4") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_xalbnir(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for xalbnir") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_extkn(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for extkni") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_tminvj(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for tminvj") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_tmaxvj(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for tmaxvj") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_vbeta(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for vbeta") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_a1gs(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for a1hs") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_d0gs(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for d0gs") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_alpha(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for alpha") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_convex(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for convex") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_cfrd(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for cfrd") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_gswmin(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for gswmin") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_conkc0(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for conkc0") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_conko0(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for conko0") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_ekc(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for ekc") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_eko(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for eko") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_g0(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for g0") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_g1(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for g1") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_zr(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for zr") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_clitt(:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for clitt") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_froot(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for froot") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_cplant(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for cplant") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_csoil(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for csoil") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_ratecp(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for ratecp") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_ratecs(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for ratecs") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_refl(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for refl") +END IF +IF ( ANY( ABS( pars_io_data_cbl%vegin_taul(:,:ntype) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for taul") +END IF +IF ( ANY( ABS( progs%canht_pft(:,:) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for hc") +END IF +IF ( ANY( ABS( progs%lai_pft(:,:) - rmdi ) < EPSILON(1.0) ) ) THEN + ERROR = 1 + CALL log_error(routinename, "No value for lai") +END IF + +IF ( ERROR /= 0 ) & + CALL log_fatal(routinename, & + "Variable(s) missing from namelist - see earlier " // & + "error message(s)") + +pars_io_data_cbl%vegin_dleaf(:) = SQRT(pars_io_data_cbl%vegin_width(:) * pars_io_data_cbl%vegin_length(:)) + +CALL params_io_assoc_cbl(pars_io_cbl,pars_io_data_cbl) + +END SUBROUTINE init_vegin_cbl + diff --git a/src/coupled/AM3/initialisation/prognostics/init_cable_progs.F90 b/src/coupled/AM3/initialisation/prognostics/init_cable_progs.F90 new file mode 100644 index 000000000..d06626097 --- /dev/null +++ b/src/coupled/AM3/initialisation/prognostics/init_cable_progs.F90 @@ -0,0 +1,65 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE init_cable_progs_mod + +!------------------------------------------------------------------------------ +! Description: +! Main driver to dec/alloc/initialize CABLE prognostic variables +! +! This MODULE is USEd: +! init.F90 +! +! This MODULE contains 1 public Subroutine: +! init_cable_progs +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +!------------------------------------------------------------------------------ + +IMPLICIT NONE + +PUBLIC :: init_cable_progs +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='INIT_CABLE_PROGS_MOD' + +CONTAINS + +SUBROUTINE init_cable_progs( land_pts, nsurft, sm_levels, lsm_id, cable, & + progs_cbl_vars, progs_cbl_vars_data ) + +! Description: +! Nothing further to add to the module description + +!USE read_cable_progs_mod, ONLY: read_cable_progs +USE progs_cbl_vars_mod, ONLY: progs_cbl_vars_type, & + progs_cbl_vars_data_type, & + progs_cbl_vars_alloc, & + progs_cbl_vars_assoc + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: land_pts, nsurft,sm_levels +INTEGER, INTENT(IN) :: lsm_id, cable +TYPE(progs_cbl_vars_data_type), INTENT(IN OUT) :: progs_cbl_vars_data +TYPE(progs_cbl_vars_type), INTENT(IN OUT) :: progs_cbl_vars + +CALL progs_cbl_vars_alloc(land_pts, nsurft, sm_levels, lsm_id, cable, & + progs_cbl_vars_data ) +CALL progs_cbl_vars_assoc(progs_cbl_vars, progs_cbl_vars_data ) +!CALL read_cable_progs() + +RETURN + +END SUBROUTINE init_cable_progs + +END MODULE init_cable_progs_mod diff --git a/src/coupled/AM3/initialisation/prognostics/init_cnp_progs.F90 b/src/coupled/AM3/initialisation/prognostics/init_cnp_progs.F90 new file mode 100644 index 000000000..773df3779 --- /dev/null +++ b/src/coupled/AM3/initialisation/prognostics/init_cnp_progs.F90 @@ -0,0 +1,33 @@ +MODULE init_cnp_progs_mod + +IMPLICIT NONE + +PUBLIC :: init_cnp_progs +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='INIT_CNP_PROGS_MOD' + +CONTAINS + +SUBROUTINE init_cnp_progs( land_pts, nsurft, progs_cnp_vars, & + progs_cnp_vars_data ) + +USE progs_cnp_vars_mod, ONLY: progs_cnp_vars_type, & + progs_cnp_vars_data_type, & + progs_cnp_vars_alloc, & + progs_cnp_vars_assoc + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: land_pts, nsurft +TYPE(progs_cnp_vars_data_type), INTENT(OUT) :: progs_cnp_vars_data +TYPE(progs_cnp_vars_type), INTENT(OUT) :: progs_cnp_vars + +CALL progs_cnp_vars_alloc(land_pts, nsurft, progs_cnp_vars_data ) +CALL progs_cnp_vars_assoc(progs_cnp_vars, progs_cnp_vars_data ) + +RETURN + +END SUBROUTINE init_cnp_progs + +END MODULE init_cnp_progs_mod diff --git a/src/coupled/AM3/initialisation/prognostics/read_cable_progs.F90 b/src/coupled/AM3/initialisation/prognostics/read_cable_progs.F90 new file mode 100644 index 000000000..ad06b4cc1 --- /dev/null +++ b/src/coupled/AM3/initialisation/prognostics/read_cable_progs.F90 @@ -0,0 +1,276 @@ +!******************************COPYRIGHT******************************************** +! (c) CSIRO 2022. +! All rights reserved. +! +! This routine has been licensed to the other JULES partners for use and +! distribution under the JULES collaboration agreement, subject to the terms and +! conditions set out therein. +! +! [Met Office Ref SC0237] +!******************************COPYRIGHT******************************************** + +MODULE read_cable_progs_mod + +!------------------------------------------------------------------------------ +! Description: +! Reads in information about CABLE prognostic variables for their +! initialisation +! +! This MODULE is USEd in: +! init_cable_progs.F90 +! +! This MODULE contains 1 public Subroutine: +! read_cable_progs +! +! Code Owner: Please refer to ModuleLeaders.txt +! This file belongs in CABLE SCIENCE +!------------------------------------------------------------------------------ + +IMPLICIT NONE + +PUBLIC :: read_cable_progs +PRIVATE + +CHARACTER(LEN=*), PARAMETER, PRIVATE :: ModuleName='INIT_CABLE_PROGS_MOD' + +CONTAINS + +SUBROUTINE read_cable_progs() + +! Description: +! Nothing further to add to the module description + +USE errormessagelength_mod, ONLY: errormessagelength + +USE fill_variables_from_file_mod, ONLY: fill_variables_from_file + +USE io_constants, ONLY: max_sdf_name_len, max_file_name_len, namelist_unit + +USE string_utils_mod, ONLY: to_string + +USE templating_mod, ONLY: tpl_has_var_name, tpl_substitute_var + +USE model_interface_mod, ONLY: identifier_len, populate_var, get_var_id + +USE ancil_info, ONLY: land_pts + +USE missing_data_mod, ONLY: rmdi + +USE logging_mod, ONLY: log_info, log_warn, log_fatal + +IMPLICIT NONE + +! Work variables +INTEGER, PARAMETER :: max_cable_vars = 10 + ! The maximum number of CABLE model variables that can be given + +INTEGER :: nvars_required ! The number of prognostic variables that are + ! required in this configuration + +CHARACTER(LEN=identifier_len) :: required_vars(max_cable_vars) + ! The variable identifiers of the required + ! variables + +INTEGER :: nvars_file ! The number of variables that will be set + ! from the given file (template?) + +INTEGER :: i,l ! Index variables + +INTEGER :: ERROR ! Error indicator + +!! Variables passed to fill_variables_from_file +!CHARACTER(LEN=identifier_len) :: file_var(max_cable_vars) +! ! The variable identifiers of the variables to set +! ! from file +!CHARACTER(LEN=max_sdf_name_len) :: file_var_name(max_cable_vars) +! ! The name of each variable in the file +! +!CHARACTER(LEN=max_sdf_name_len) :: file_tpl_name(max_cable_vars) +! ! The name to substitute in a template for each +! ! variable + + +!----------------------------------------------------------------------------- +! Definition of the cable_progs namelist +!----------------------------------------------------------------------------- +CHARACTER(LEN=max_file_name_len) :: FILE + ! The name of the file (or variable name template) to + ! use for variables that need to be filled from file + +INTEGER :: nvars ! The number of variables in this section + +CHARACTER(LEN=identifier_len) :: var(max_cable_vars) + ! The variable identifiers of the variables +CHARACTER(LEN=max_sdf_name_len) :: var_name(max_cable_vars) + ! The name of each variable in the file +CHARACTER(LEN=max_sdf_name_len) :: tpl_name(max_cable_vars) + ! The name to substitute in a template for each + ! variable +LOGICAL :: use_file(max_cable_vars) + ! T - the variable uses the file + ! F - the variable is set using a constant value +CHARACTER(LEN=errormessagelength) :: iomessage + ! I/O error message string +REAL :: const_val(max_cable_vars) +!INTEGER:: iconst_val(max_cable_vars) + ! The constant value to use for each variable if + ! use_file = F for that variable +NAMELIST / cable_progs/ FILE, nvars, var, var_name, use_file, tpl_name, & + const_val + +!----------------------------------------------------------------------------- + + +!----------------------------------------------------------------------------- +! Initialise +!----------------------------------------------------------------------------- +nvars_required = 0 +nvars_file = 0 +nvars = 0 +use_file(:) = .TRUE. ! Default is for every variable to be read from file +FILE(:) = '' ! Empty file names +var_name(:) = '' ! Empty variable names +tpl_name(:) = '' ! Empty template string +const_val(:) = rmdi + +!----------------------------------------------------------------------------- +! Read namelist +!----------------------------------------------------------------------------- +CALL log_info("init_cable_progs", "Reading CABLE_PROGS namelist...") +OPEN(namelist_unit, FILE=('cable_prognostics.nml'), & + STATUS='old', POSITION='rewind', ACTION='read', IOSTAT = ERROR, & + IOMSG = iomessage) + + +! First, we read the cable_progs namelist +READ(namelist_unit, NML = cable_progs, IOSTAT = ERROR) + +IF ( ERROR /= 0 ) & + CALL log_fatal("init_cable_progs", & + "Error reading namelist CABLE_PROGS" // & + "(IOSTAT=" // TRIM(to_string(ERROR)) // " IOMSG=" // & + TRIM(iomessage) // ")") + +!----------------------------------------------------------------------------- +! Set up CABLE prognostics using namelist values +!----------------------------------------------------------------------------- +! Set up the required variables +! All the CABLE variables are always required for CABLE runs +nvars_required = max_cable_vars +required_vars(:) = [ & + 'ThreeLayerSnowFlag_CABLE', & + 'OneLyrSnowDensity_CABLE ', & + 'SnowAge_CABLE ', & + 'SnowDensity_CABLE ', & + 'SnowMass_CABLE ', & + 'SnowDepth_CABLE ', & + 'SnowTemp_CABLE ', & + 'FrozenSoilFrac_CABLE ', & + 'SoilMoisture_CABLE ', & + 'SoilTemp_CABLE ' & + ] +!------------------------------------------------------------------------- +! Check that variable identifiers are not empty. +! Although we might later decide that the identifier is not required, for +! clarity we check here whether the claimed amount of information was +! provided. +!------------------------------------------------------------------------- +DO i = 1,nvars + IF ( LEN_TRIM(var(i)) == 0 ) & + CALL log_fatal("init_cable_progs", & + "Insufficient values for var. " // & + "No name provided for var at position #" // & + TRIM(to_string(i)) ) +END DO + +!----------------------------------------------------------------------------- +! Check that all the required variables are there +!----------------------------------------------------------------------------- + +DO i = 1,nvars_required + IF ( .NOT. ANY(var(1:nvars) == TRIM(required_vars(i))) ) & + CALL log_fatal("init_cable_progs", & + "No value given for required variable '" // & + TRIM(required_vars(i)) // "'") +END DO + + +!----------------------------------------------------------------------------- +! Check which variables we will be using and partition them into variables +! set to constant values and variables set from file +!----------------------------------------------------------------------------- +DO i = 1,nvars + !----------------------------------------------------------------------------- + ! If the variable is one of the required vars, then we will be using it + !----------------------------------------------------------------------------- + IF ( ANY(required_vars(1:nvars_required) == var(i)) ) THEN + IF ( use_file(i) ) THEN + CALL log_info("init_cable_progs", & + "'" // TRIM(var(i)) // "' will be read from file") + + ! If the variable will be filled from file, register it here + nvars_file = nvars_file + 1 + var(nvars_file) = var(i) + var_name(nvars_file) = var_name(i) + tpl_name(nvars_file) = tpl_name(i) + ELSE + ! If the variable is being set as a constant, just populate it here + ! First check that a value has been provided. + IF ( ABS( const_val(i) - rmdi ) < EPSILON(1.0) ) & + CALL log_fatal("init_cable_progs", & + "No constant value provided for variable '" & + // TRIM(var(i)) // "'" ) + + CALL log_info("init_cable_progs", & + "'" // TRIM(var(i)) // "' will be set to a " // & + "constant = " // to_string(const_val(i))) + + CALL populate_var(get_var_id(var(i)), const_val = const_val(i)) + END IF + ELSE + ! If the variable is not a required variable, warn about not using it + CALL log_warn("init_cable_progs", & + "Provided variable '" // TRIM(var(i)) // & + "' is not required, so will be ignored") + END IF +END DO + +!----------------------------------------------------------------------------- +! Set variables from file +!----------------------------------------------------------------------------- +IF ( nvars_file > 0 ) THEN + ! Check that a file name was provided. + IF ( LEN_TRIM(FILE) == 0 ) & + CALL log_fatal("init_cable_progs", "No file name provided") + + IF ( tpl_has_var_name(FILE) ) THEN + ! We are using a file name template, so loop through the variables setting + ! one from each file + DO i = 1,nvars_file + ! If using a variable name template, check that a template string was + !provided for the current variable + IF ( LEN_TRIM(tpl_name(i)) == 0 ) & + CALL log_fatal("init_cable_progs", & + "No variable name template substitution " // & + "(tpl_name) provided for " // TRIM(var(i))) + + + CALL fill_variables_from_file( & + tpl_substitute_var(FILE, tpl_name(i)), & + [ var(i) ], [ var_name(i) ] & + ) + END DO + ELSE + ! We are not using a file name template, so set all variables from the same + ! file + + CALL fill_variables_from_file( & + FILE,var(1:nvars_file), var_name(1:nvars_file) & + ) + END IF +END IF + +RETURN + +END SUBROUTINE read_cable_progs +END MODULE read_cable_progs_mod From 042cc34f9a6d85778d769068f744d5765663296c Mon Sep 17 00:00:00 2001 From: "Srbinovsky, Jhan (O&A, Aspendale)" Date: Wed, 14 Aug 2024 15:46:52 +1000 Subject: [PATCH 2/3] manually merge changes from AM3 --- src/params/cable_other_constants_mod.F90 | 16 +++++----------- src/params/grid_constants_cbl.F90 | 13 ++++++++++--- src/util/cable_runtime_opts_mod.F90 | 2 +- 3 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/params/cable_other_constants_mod.F90 b/src/params/cable_other_constants_mod.F90 index 77d0efb15..b91797355 100644 --- a/src/params/cable_other_constants_mod.F90 +++ b/src/params/cable_other_constants_mod.F90 @@ -18,6 +18,10 @@ MODULE cable_other_constants_mod !----------------------------------------------------------------------------- !CABLE science not yet in JAC uses msn to describe number of snow layers USE grid_constants_mod_cbl, ONLY: nrb, nsl, nsCs, nvCs, msn => nsnl +USE grid_constants_mod_cbl, ONLY: n_soiltypes => nsoil_max ! # of soil types [9] +USE grid_constants_mod_cbl, ONLY: niter ! # iterations za/L +USE grid_constants_mod_cbl, ONLY: mf !sunlit/shaded leaves +USE grid_constants_mod_cbl, ONLY: swb ! 2 shortwave bands (VIS,NIR) IMPLICIT NONE @@ -28,17 +32,7 @@ MODULE cable_other_constants_mod REAL, PARAMETER :: rad_thresh = 0.001 ! min. zenithal angle for downward SW REAL, PARAMETER :: lai_thresh = 0.001 ! min. LAI to be considered as vegetated -INTEGER, PARAMETER :: & - swb = 2, & ! 2 shortwave bands (initial division - visible / - ! near infrared) - n_sw_bands = 4, & ! total number of shortwave radiation bands - ! (above divided into direct / diffuse) - mf = 2, & ! types of leaves (sunlit / shaded) - r_2 = SELECTED_REAL_KIND(12, 50), &!this will be removed - ! double precision real dimension - niter = 4, & ! number of iterations for za/L - n_assim_rates = 3, & ! Rubisco, RuBP and Sink-limited rates of photosynthesis - n_soiltypes = 9 ! number of soil types +INTEGER, PARAMETER :: r_2 = KIND(1.d0) ! SELECTED_REAL_KIND(12, 50) REAL, PARAMETER :: & max_snow_depth = 50000.0, & ! maximum depth of lying snow on tiles (kg/m2) diff --git a/src/params/grid_constants_cbl.F90 b/src/params/grid_constants_cbl.F90 index 2ae2aa6eb..cede548bf 100644 --- a/src/params/grid_constants_cbl.F90 +++ b/src/params/grid_constants_cbl.F90 @@ -1,3 +1,4 @@ +!#define UM_CBL YES !****************************************************************************** ! This source code is part of the Community Atmosphere Biosphere Land Exchange ! (CABLE) model. This work is licensed under the CSIRO Open Source Software @@ -45,10 +46,16 @@ MODULE grid_constants_mod_cbl INTEGER, PARAMETER :: nsCs = 2 ! # soil carbon stores INTEGER, PARAMETER :: nvCs = 3 ! # vegetation carbon stores INTEGER, PARAMETER :: ICE_SoilType = 9 ! SoilType Index (soilparm_cable.nml JAC) +#ifndef UM_CBL INTEGER, PARAMETER :: lakes_cable = 16! SoilType Index (soilparm_cable.nml JAC) - -INTEGER, PARAMETER :: mf = 2 ! # leaves (sunlit, shaded) -INTEGER, PARAMETER :: niter = 4 ! number of iterations for za/L + ! CM3 gets this from cable_surface_types namelist +#endif +INTEGER, PARAMETER :: mf = 2 ! # leaves (sunlit, shaded) +INTEGER, PARAMETER :: niter = 4 ! number of iterations for za/L +INTEGER, PARAMETER :: swb = 2 ! # SW bands (VIS+NIR) - CM3 alloc TYPEs +INTEGER, PARAMETER :: nCpool_casa = 10 +INTEGER, PARAMETER :: nNpool_casa = 10 +INTEGER, PARAMETER :: nPPool_casa = 12 ! Strictly NOT a constant. # of active tiles, length of CABLE working vectors INTEGER :: mp diff --git a/src/util/cable_runtime_opts_mod.F90 b/src/util/cable_runtime_opts_mod.F90 index 46b2da7b3..c2aa4dd3c 100644 --- a/src/util/cable_runtime_opts_mod.F90 +++ b/src/util/cable_runtime_opts_mod.F90 @@ -12,7 +12,7 @@ MODULE cable_runtime_opts_mod !jhan:make this logical CHARACTER(LEN=3) :: diag_soil_resp='' - CHARACTER(LEN=20) :: fwsoil_switch='' + CHARACTER(LEN=20) :: fwsoil_switch='standard' ! Ticket #56 !jhan:options? From b5bf0637e21722b9c93259e2cf39217c48857e0d Mon Sep 17 00:00:00 2001 From: "Srbinovsky, Jhan (O&A, Aspendale)" Date: Wed, 14 Aug 2024 18:21:05 +1000 Subject: [PATCH 3/3] add ice_cable index to grid_constants --- src/params/grid_constants_cbl.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/params/grid_constants_cbl.F90 b/src/params/grid_constants_cbl.F90 index cede548bf..dc3e38187 100644 --- a/src/params/grid_constants_cbl.F90 +++ b/src/params/grid_constants_cbl.F90 @@ -47,8 +47,8 @@ MODULE grid_constants_mod_cbl INTEGER, PARAMETER :: nvCs = 3 ! # vegetation carbon stores INTEGER, PARAMETER :: ICE_SoilType = 9 ! SoilType Index (soilparm_cable.nml JAC) #ifndef UM_CBL -INTEGER, PARAMETER :: lakes_cable = 16! SoilType Index (soilparm_cable.nml JAC) - ! CM3 gets this from cable_surface_types namelist +INTEGER, PARAMETER :: lakes_cable = 16 ! cable_surface_type (nml) Index +INTEGER, PARAMETER :: ice_cable = 17 ! cable_surface_type (nml) Index #endif INTEGER, PARAMETER :: mf = 2 ! # leaves (sunlit, shaded) INTEGER, PARAMETER :: niter = 4 ! number of iterations for za/L