diff --git a/.gitmodules b/.gitmodules index 5e5f8d2215..97014cd97c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,15 +1,15 @@ [submodule "fv3/atmos_cubed_sphere"] path = fv3/atmos_cubed_sphere - url = https://github.com/NOAA-GFDL/GFDL_atmos_cubed_sphere - branch = dev/emc + url = https://github.com/hafs-community/GFDL_atmos_cubed_sphere + branch = feature/hafsv2_sync [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NCAR/ccpp-framework branch = develop [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/ufs-community/ccpp-physics - branch = ufs/dev + url = https://github.com/hafs-community/ccpp-physics + branch = feature/hafsv2_sync [submodule "upp"] path = upp url = https://github.com/NOAA-EMC/UPP diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index eface64dac..223dda270c 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -967,6 +967,10 @@ module GFS_typedefs logical :: top_at_1 !< Vertical ordering flag. integer :: iSFC !< Vertical index for surface integer :: iTOA !< Vertical index for TOA + logical :: is_init_lw_gas_optics = .false. + logical :: is_init_sw_gas_optics = .false. + logical :: is_init_lw_cloud_optics = .false. + logical :: is_init_sw_cloud_optics = .false. !--- microphysical switch logical :: convert_dry_rho = .true. !< flag for converting mass/number concentrations from moist to dry @@ -1083,6 +1087,8 @@ module GFS_typedefs real(kind=kind_phys) :: ssati_min !< minimum supersaturation over ice threshold for deposition nucleation real(kind=kind_phys) :: Nt_i_max !< maximum threshold number concentration of cloud ice water crystals in air real(kind=kind_phys) :: rr_min !< multiplicative tuning parameter for microphysical sedimentation minimum threshold + real(kind=kind_phys) :: fs_fac_rain !< adjustment for rain fall speed + real(kind=kind_phys) :: fs_fac_snow !< adjustment for snow fall speed !--- GFDL microphysical paramters @@ -1365,6 +1371,7 @@ module GFS_typedefs !< Nccn: CCN number concentration in cm^(-3) !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land + real(kind=kind_phys) :: cat_adj_deep !< Adjustment for convective advection time for deep convection !--- mass flux shallow convection real(kind=kind_phys) :: clam_shal !< c_e for shallow convection (Han and Pan, 2011, eq(6)) @@ -1379,6 +1386,7 @@ module GFS_typedefs !< Nccn: CCN number concentration in cm^(-3) !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land + real(kind=kind_phys) :: cat_adj_shal !< Adjustment for convective advection time for shallow convection !--- near surface temperature model logical :: nst_anl !< flag for NSSTM analysis in gcycle/sfcsub @@ -1696,6 +1704,8 @@ module GFS_typedefs real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours character(len=240) :: iau_inc_files(7)! list of increment files real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files + logical :: iau_regional !< doing IAU for the nested domain for regional model + real :: iau_inc_scale !< increase IAU weight for 3DIAU logical :: iau_filter_increments, iau_drymassfixer ! From physcons.F90, updated/set in control_initialize @@ -3714,6 +3724,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & real(kind=kind_phys) :: ssati_min = 0.15 !< minimum supersaturation over ice threshold for deposition nucleation real(kind=kind_phys) :: Nt_i_max = 4999.e3 !< maximum threshold number concentration of cloud ice water crystals in air real(kind=kind_phys) :: rr_min = 1000.0 !< multiplicative tuning parameter for microphysical sedimentation minimum threshold + real(kind=kind_phys) :: fs_fac_rain = 1.0 !< adjustment for rain fall speed + real(kind=kind_phys) :: fs_fac_snow = 1.0 !< adjustment for snow fall speed !--- GFDL microphysical parameters logical :: lgfdlmprad = .false. !< flag for GFDLMP radiation interaction @@ -3967,6 +3979,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & !< Nccn: CCN number concentration in cm^(-3) !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land + real(kind=kind_phys) :: cat_adj_deep = 1.0 !< Adjustment for convective advection time for deep convection !--- mass flux shallow convection real(kind=kind_phys) :: clam_shal = 0.3 !< c_e for shallow convection (Han and Pan, 2011, eq(6)) @@ -3981,6 +3994,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & !< Nccn: CCN number concentration in cm^(-3) !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land + real(kind=kind_phys) :: cat_adj_shal = 1.0 !< Adjustment for convective advection time for shallow convection !--- near surface sea temperature model logical :: nst_anl = .false. !< flag for NSSTM analysis in gcycle/sfcsub @@ -4071,6 +4085,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & real(kind=kind_phys) :: iau_delthrs = 0 !< iau time interval (to scale increments) character(len=240) :: iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: iaufhrs(7) = -1 !< forecast hours associated with increment files + logical :: iau_regional = .false. !< doing IAU for the nested domain for regional model + real :: iau_inc_scale = 1. !< increase IAU weight for 3DIAU logical :: iau_filter_increments = .false. !< filter IAU increments logical :: iau_drymassfixer = .false. !< IAU dry mass fixer @@ -4226,7 +4242,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & mg_alf, mg_qcmin, mg_do_ice_gmao, mg_do_liq_liu, & ltaerosol, lthailaware, lradar, nsfullradar_diag, lrefres, & ttendlim, ext_diag_thompson, nt_c_l, nt_c_o, av_i, xnc_max, & - ssati_min, Nt_i_max, rr_min, dt_inner, lgfdlmprad, & + ssati_min, Nt_i_max, rr_min, fs_fac_rain, fs_fac_snow, & + dt_inner, lgfdlmprad, & sedi_semi, decfl, & nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_alphar, nssl_ehw0, nssl_ehlw0, & @@ -4292,9 +4309,10 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & !--- mass flux deep convection clam_deep, c0s_deep, c1_deep, betal_deep, & betas_deep, evef, evfact_deep, evfactl_deep, pgcon_deep, & - asolfac_deep, & + asolfac_deep, cat_adj_deep, & !--- mass flux shallow convection clam_shal, c0s_shal, c1_shal, pgcon_shal, asolfac_shal, & + cat_adj_shal, & !--- near surface sea temperature model nst_anl, lsea, nstf_name, & frac_grid, min_lakeice, min_seaice, min_lake_height, & @@ -4319,7 +4337,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & increment_file_on_native_grid, & !--- IAU iau_delthrs,iaufhrs,iau_inc_files,iau_filter_increments, & - iau_drymassfixer, & + iau_drymassfixer,iau_regional,iau_inc_scale, & !--- debug options debug, pre_rad, print_diff_pgr, & !--- parameter range for critical relative humidity @@ -4970,6 +4988,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & Model%ssati_min = ssati_min Model%Nt_i_max = Nt_i_max Model%rr_min = rr_min + Model%fs_fac_rain = fs_fac_rain + Model%fs_fac_snow = fs_fac_snow !--- TEMPO MP parameters ! DJS to Anders: Maybe we put more of these nml options into the TEMPO configuration type? @@ -5315,6 +5335,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & Model%evfactl_deep = evfactl_deep Model%pgcon_deep = pgcon_deep Model%asolfac_deep = asolfac_deep + Model%cat_adj_deep = cat_adj_deep !--- mass flux shallow convection Model%clam_shal = clam_shal @@ -5322,6 +5343,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & Model%c1_shal = c1_shal Model%pgcon_shal = pgcon_shal Model%asolfac_shal = asolfac_shal + Model%cat_adj_shal = cat_adj_shal !--- near surface sea temperature model Model%nst_anl = nst_anl @@ -5441,6 +5463,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & Model%iaufhrs = iaufhrs Model%iau_inc_files = iau_inc_files Model%iau_delthrs = iau_delthrs + Model%iau_regional = iau_regional + Model%iau_inc_scale = iau_inc_scale Model%iau_filter_increments = iau_filter_increments Model%iau_drymassfixer = iau_drymassfixer if(Model%me==0) print *,' model init,iaufhrs=',Model%iaufhrs @@ -6436,6 +6460,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, & ' ssati_min',ssati_min, & ' Nt_i_max',Nt_i_max, & ' rr_min',rr_min, & + ' fs_fac_rain',fs_fac_rain, & + ' fs_fac_snow',fs_fac_snow, & ' effr_in =',Model%effr_in, & ' lradar =',Model%lradar, & ' nsfullradar_diag =',Model%nsfullradar_diag, & @@ -7034,6 +7060,8 @@ subroutine control_print(Model) print *, ' ssati_min : ', Model%ssati_min print *, ' Nt_i_max : ', Model%Nt_i_max print *, ' rr_min : ', Model%rr_min + print *, ' fs_fac_rain : ', Model%fs_fac_rain + print *, ' fs_fac_snow : ', Model%fs_fac_snow print *, ' ' endif if (Model%imp_physics == Model%imp_physics_nssl) then @@ -7247,6 +7275,7 @@ subroutine control_print(Model) print *, ' evfactl_deep : ', Model%evfactl_deep print *, ' pgcon_deep : ', Model%pgcon_deep print *, ' asolfac_deep : ', Model%asolfac_deep + print *, ' cat_adj_deep : ', Model%cat_adj_deep print *, ' ' endif if (Model%imfshalcnv >= 0) then @@ -7256,6 +7285,7 @@ subroutine control_print(Model) print *, ' c1_shal : ', Model%c1_shal print *, ' pgcon_shal : ', Model%pgcon_shal print *, ' asolfac_shal : ', Model%asolfac_shal + print *, ' cat_adj_shal : ', Model%cat_adj_shal endif print *, ' ' print *, 'near surface sea temperature model' diff --git a/ccpp/data/GFS_typedefs.meta b/ccpp/data/GFS_typedefs.meta index f09fa74484..1614ce2a35 100644 --- a/ccpp/data/GFS_typedefs.meta +++ b/ccpp/data/GFS_typedefs.meta @@ -4504,6 +4504,30 @@ units = flag dimensions = () type = integer +[is_init_sw_gas_optics] + standard_name = flag_for_rrmtgp_sw_gas_optics_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical +[is_init_sw_cloud_optics] + standard_name = flag_for_rrmtgp_sw_cloud_optics_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical +[is_init_lw_gas_optics] + standard_name = flag_for_rrmtgp_lw_gas_optics_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical +[is_init_lw_cloud_optics] + standard_name = flag_for_rrmtgp_lw_cloud_optics_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical [convert_dry_rho] standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air long_name = flag for converting hydrometeors from moist to dry air @@ -5187,6 +5211,22 @@ dimensions = () type = real kind = kind_phys +[fs_fac_rain] + standard_name = multiplicative_tuning_parameter_for_rain_fall_speed + long_name = multiplicative tuning parameter for rain fall speed + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[fs_fac_snow] + standard_name = multiplicative_tuning_parameter_for_snow_fall_speed + long_name = multiplicative tuning parameter_for snow fall speed + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [gfs_phys_time_vary_is_init] standard_name = flag_for_gfs_phys_time_vary_interstitial_initialization long_name = flag carrying interstitial initialization status @@ -6199,6 +6239,14 @@ dimensions = () type = real kind = kind_phys +[cat_adj_deep] + standard_name = Adjustment_for_convective_advection_time_for_deep + long_name = Adjustment for convective advection time for deep + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [clam_shal] standard_name = entrainment_rate_coefficient_for_shallow_convection long_name = entrainment rate coefficient for shallow convection @@ -6234,6 +6282,14 @@ dimensions = () type = real kind = kind_phys +[cat_adj_shal] + standard_name = Adjustment_for_convective_advection_time_for_shallow + long_name = Adjustment for convective advection time for shallow + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [xkzm_m] standard_name = atmosphere_momentum_diffusivity_due_to_background long_name = background vertical diffusion for momentum diff --git a/ccpp/physics b/ccpp/physics index 55886ae3c2..fd734a03df 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 55886ae3c2c8c95d4e14a72a7115cfe88678178f +Subproject commit fd734a03df98e372083aebdc53bd6ff25a15c9b8 diff --git a/ccpp/suites_not_used/suite_FV3_HAFS_v1_thompson_noahmp.xml b/ccpp/suites/suite_FV3_HAFS_v2.xml similarity index 82% rename from ccpp/suites_not_used/suite_FV3_HAFS_v1_thompson_noahmp.xml rename to ccpp/suites/suite_FV3_HAFS_v2.xml index c8d7f7f6fa..40bdc9f5a2 100644 --- a/ccpp/suites_not_used/suite_FV3_HAFS_v1_thompson_noahmp.xml +++ b/ccpp/suites/suite_FV3_HAFS_v2.xml @@ -1,31 +1,30 @@ - + GFS_time_vary_pre - GFS_rrtmg_setup + GFS_rrtmgp_setup GFS_rad_time_vary GFS_phys_time_vary - GFS_suite_interstitial_rad_reset - GFS_rrtmg_pre + GFS_rrtmgp_pre GFS_radiation_surface - rad_sw_pre - rrtmg_sw - rrtmg_sw_post - rrtmg_lw - rrtmg_lw_post - GFS_rrtmg_post + GFS_rrtmgp_cloud_mp + GFS_rrtmgp_cloud_overlap + GFS_cloud_diagnostics + rrtmgp_aerosol_optics + rrtmgp_sw_main + rrtmgp_lw_main + GFS_radiation_post - + - GFS_suite_interstitial_phys_reset GFS_suite_stateout_reset get_prs_fv3 GFS_suite_interstitial_1 @@ -60,7 +59,11 @@ unified_ugwp_post GFS_GWD_generic_post GFS_suite_stateout_update - h2ophys + + + + + GFS_photochemistry get_phi_fv3 GFS_suite_interstitial_3 GFS_DCNV_generic_pre diff --git a/ccpp/suites_not_used/suite_FV3_HAFS_v1_thompson_noahmp_nonsst.xml b/ccpp/suites/suite_FV3_HAFS_v2_coupled.xml similarity index 81% rename from ccpp/suites_not_used/suite_FV3_HAFS_v1_thompson_noahmp_nonsst.xml rename to ccpp/suites/suite_FV3_HAFS_v2_coupled.xml index 2a1462136b..9da81a47ce 100644 --- a/ccpp/suites_not_used/suite_FV3_HAFS_v1_thompson_noahmp_nonsst.xml +++ b/ccpp/suites/suite_FV3_HAFS_v2_coupled.xml @@ -1,31 +1,30 @@ - + GFS_time_vary_pre - GFS_rrtmg_setup + GFS_rrtmgp_setup GFS_rad_time_vary GFS_phys_time_vary - GFS_suite_interstitial_rad_reset - GFS_rrtmg_pre + GFS_rrtmgp_pre GFS_radiation_surface - rad_sw_pre - rrtmg_sw - rrtmg_sw_post - rrtmg_lw - rrtmg_lw_post - GFS_rrtmg_post + GFS_rrtmgp_cloud_mp + GFS_rrtmgp_cloud_overlap + GFS_cloud_diagnostics + rrtmgp_aerosol_optics + rrtmgp_sw_main + rrtmgp_lw_main + GFS_radiation_post - + - GFS_suite_interstitial_phys_reset GFS_suite_stateout_reset get_prs_fv3 GFS_suite_interstitial_1 @@ -58,7 +57,11 @@ unified_ugwp_post GFS_GWD_generic_post GFS_suite_stateout_update - h2ophys + + + + + GFS_photochemistry get_phi_fv3 GFS_suite_interstitial_3 GFS_DCNV_generic_pre diff --git a/fv3/atmos_cubed_sphere b/fv3/atmos_cubed_sphere index 87936f8b0d..3f742540a1 160000 --- a/fv3/atmos_cubed_sphere +++ b/fv3/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 87936f8b0d57b541ebade64a33a926b583c70c6d +Subproject commit 3f742540a1beb0018dd4a54a603c3831e475a481 diff --git a/fv3/atmos_model.F90 b/fv3/atmos_model.F90 index 9d268be902..13ef73f628 100644 --- a/fv3/atmos_model.F90 +++ b/fv3/atmos_model.F90 @@ -2032,13 +2032,17 @@ subroutine assign_importdata(jdat, rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) im = GFS_control%chunk_begin(nb)+ix-1 - if (GFS_Sfcprop%oceanfrac(im) > zero .and. datar8(i,j) > zorlmin) then - tem = 100.0_GFS_kind_phys * min(0.1_GFS_kind_phys, datar8(i,j)) -! GFS_Coupling%zorlwav_cpl(im) = tem - GFS_Sfcprop%zorlwav(im) = tem - GFS_Sfcprop%zorlw(im) = tem - else - GFS_Sfcprop%zorlwav(im) = -999.0_GFS_kind_phys +! if (GFS_Sfcprop%oceanfrac(im) > zero .and. datar8(i,j) > zorlmin) then + if (GFS_Sfcprop%oceanfrac(im) > zero) then + if (mergeflg(i,j)) datar8(i,j)=GFS_Sfcprop%zorlw(im) ! use initial value + if (datar8(i,j) > zorlmin) then + tem = 100.0_GFS_kind_phys * min(0.1_GFS_kind_phys, datar8(i,j)) +! GFS_Coupling%zorlwav_cpl(im) = tem + GFS_Sfcprop%zorlwav(im) = tem + GFS_Sfcprop%zorlw(im) = tem + else + GFS_Sfcprop%zorlwav(im) = -999.0_GFS_kind_phys + endif endif enddo enddo diff --git a/fv3/moving_nest/fv_moving_nest.F90 b/fv3/moving_nest/fv_moving_nest.F90 index 91c80165bd..9c639cf3c3 100644 --- a/fv3/moving_nest/fv_moving_nest.F90 +++ b/fv3/moving_nest/fv_moving_nest.F90 @@ -62,14 +62,11 @@ module fv_moving_nest_mod use mpp_domains_mod, only : NORTH, SOUTH, EAST, WEST, CORNER, CENTER use mpp_domains_mod, only : NUPDATE, SUPDATE, EUPDATE, WUPDATE, DGRID_NE -!#ifdef GFS_TYPES -! use GFS_typedefs, only: IPD_data_type => GFS_data_type, & -! IPD_control_type => GFS_control_type, kind_phys -!#else -! use IPD_typedefs, only: IPD_data_type, IPD_control_type, kind_phys => IPD_kind_phys -!#endif -! use GFS_init, only: GFS_grid_populate - +#ifdef GFS_TYPES + use GFS_typedefs, only: kind_phys +#else + use IPD_typedefs, only: kind_phys => IPD_kind_phys +#endif use boundary_mod, only: update_coarse_grid, update_coarse_grid_mpp use bounding_box_mod, only: bbox, bbox_get_C2F_index, fill_bbox #ifdef OVERLOAD_R4 @@ -87,7 +84,7 @@ module fv_moving_nest_mod use fv_nwp_nudge_mod, only: do_adiabatic_init use init_hydro_mod, only: p_var use tracer_manager_mod, only: get_tracer_index, get_tracer_names - use fv_moving_nest_types_mod, only: fv_moving_nest_prog_type, fv_moving_nest_physics_type, Moving_nest + use fv_moving_nest_types_mod, only: fv_moving_nest_prog_type, fv_moving_nest_physics_type, Moving_nest, mn_land_mask_grids, mn_fix_grids, alloc_set_facwf use fv_moving_nest_utils_mod, only: alloc_halo_buffer, load_nest_latlons_from_nc, grid_geometry, output_grid_to_nc use fv_moving_nest_utils_mod, only: fill_nest_from_buffer, fill_nest_from_buffer_cell_center, fill_nest_from_buffer_nearest_neighbor use fv_moving_nest_utils_mod, only: fill_nest_halos_from_parent, fill_grid_from_supergrid, fill_weight_grid @@ -130,11 +127,13 @@ module fv_moving_nest_mod !! Step 6 interface mn_var_shift_data module procedure mn_var_shift_data_r4_2d - module procedure mn_var_shift_data_r4_3d + module procedure mn_var_shift_data_r4_3d_highz + module procedure mn_var_shift_data_r4_3d_lowhighz module procedure mn_var_shift_data_r4_4d module procedure mn_var_shift_data_r8_2d - module procedure mn_var_shift_data_r8_3d + module procedure mn_var_shift_data_r8_3d_highz + module procedure mn_var_shift_data_r8_3d_lowhighz module procedure mn_var_shift_data_r8_4d end interface mn_var_shift_data @@ -614,10 +613,10 @@ subroutine mn_latlon_load_parent(surface_dir, Atm, n, parent_tile, delta_i_c, de parent_geo%nxp = Atm(1)%npx parent_geo%nyp = Atm(1)%npy - + parent_geo%nx = parent_geo%nxp - 1 parent_geo%ny = parent_geo%nyp - 1 - + call mn_static_filename(surface_dir, parent_tile, 'grid', 1, grid_filename) call load_nest_latlons_from_nc(grid_filename, parent_geo%nxp, parent_geo%nyp, 1, pelist, & parent_geo, p_istart_fine, p_iend_fine, p_jstart_fine, p_jend_fine) @@ -764,7 +763,10 @@ subroutine mn_static_filename(surface_dir, tile_num, tag, refine, grid_filename) write(parent_str, '(I0)'), tile_num - if (refine .eq. 1 .and. (tag .eq. 'grid' .or. tag .eq. 'oro_data')) then + if (refine .eq. 1 .and. tag .eq. 'sfc_data') then + ! + grid_filename = trim(trim(surface_dir) // '/../' // trim(tag) // '.nc') + elseif (refine .eq. 1 .and. (tag .eq. 'grid' .or. tag .eq. 'oro_data')) then ! For 1x files in INPUT directory; go at the symbolic link grid_filename = trim(trim(surface_dir) // '/' // trim(tag) // '.tile' // trim(parent_str) // '.nc') else @@ -803,6 +805,7 @@ subroutine mn_latlon_read_hires_parent(npx, npy, refine, pelist, fp_super_tile_g call load_nest_latlons_from_nc(trim(grid_filename), npx, npy, refine, pelist, & fp_super_tile_geo, fp_super_istart_fine, fp_super_iend_fine, fp_super_jstart_fine, fp_super_jend_fine) + end subroutine mn_latlon_read_hires_parent !>@brief The subroutine 'mn_orog_read_hires_parent' loads parent orography data from netCDF @@ -815,7 +818,7 @@ subroutine mn_orog_read_hires_parent(npx, npy, refine, pelist, surface_dir, filt real, allocatable, intent(out) :: orog_grid(:,:) !< Output orography grid real, allocatable, intent(out) :: orog_std_grid(:,:) !< Output orography standard deviation grid real, allocatable, intent(out) :: ls_mask_grid(:,:) !< Output land sea mask grid - real, allocatable, intent(out) :: land_frac_grid(:,:)!< Output land fraction grid + real(kind=kind_phys), allocatable, intent(out) :: land_frac_grid(:,:)!< Output land fraction grid integer, intent(in) :: parent_tile !< Parent tile number integer :: nx_cubic, nx, ny, fp_nx, fp_ny, mid_nx, mid_ny @@ -857,6 +860,119 @@ subroutine mn_orog_read_hires_parent(npx, npy, refine, pelist, surface_dir, filt end subroutine mn_orog_read_hires_parent + !>@brief The subroutine 'mn_replace_low_values' replaces low values with a default value. + subroutine mn_replace_low_values(data_grid, low_value, new_value) + real, _ALLOCATABLE, intent(inout) :: data_grid(:,:) !< 2D grid of data + real, intent(in) :: low_value !< Low value to check for; e.g. negative or fill value + real, intent(in) :: new_value !< Value to replace low value with + + integer :: i, j + + do i=lbound(data_grid,1),ubound(data_grid,1) + do j=lbound(data_grid,2),ubound(data_grid,2) + if (data_grid(i,j) .le. low_value) data_grid(i,j) = new_value + enddo + enddo + end subroutine mn_replace_low_values + + subroutine mn_static_read_ls(static_ls, npx, npy, refine, pelist, surface_dir, tile_num, terrain_smoother, filtered_terrain) + type(mn_land_mask_grids), intent(inout) :: static_ls + integer, intent(in) :: npx, npy, refine, tile_num !< Number of x,y points and nest refinement, (parent) tile number + integer, allocatable, intent(in) :: pelist(:) !< PE list for fms2_io + character(len=*), intent(in) :: surface_dir !< Surface directory + integer, intent(in) :: terrain_smoother + logical, intent(in) :: filtered_terrain + + ! If terrain_smoother method 1 is chosen, we need the parent coarse terrain + if (terrain_smoother .eq. 1) then + if (filtered_terrain) then + call mn_static_read_hires(npx, npy, refine, pelist, surface_dir, "oro_data", "orog_filt", static_ls%orog_grid, tile_num) + else + call mn_static_read_hires(npx, npy, refine, pelist, surface_dir, "oro_data", "orog_raw", static_ls%orog_grid, tile_num) + endif + endif + + ! Read in coarse resolution land sea mask to use for masked interpolations; factor in lakes as well + + if (refine .eq. 1 .and. tile_num .eq. 1) then + ! Read in coarse parent slmask from sfc_data.nc -- this will have land/sea/sea ice mask + print '("[INFO] WDR STATIC_READ_LS parent sfc_data npe=",I0)', mpp_pe() + call mn_static_read_hires(npx, npy, refine, pelist, surface_dir, "sfc_data", "slmsk", static_ls%ls_mask_grid, tile_num) + else + print '("[INFO] WDR STATIC_READ_LS other oro_data npe=",I0)', mpp_pe() + call mn_static_read_hires(npx, npy, refine, pelist, surface_dir, "oro_data", "slmsk", static_ls%ls_mask_grid, tile_num) + endif + + call mn_static_read_hires(npx, npy, refine, pelist, surface_dir, "oro_data", "land_frac", static_ls%land_frac_grid, tile_num) + + !! Lat lons for debugging + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "oro_data", "geolat", static_ls%geolat_grid, tile_num) + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "oro_data", "geolon", static_ls%geolon_grid, tile_num) + + ! Need parent soil type to determine lakes + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "soil_type", "soil_type", static_ls%soil_type_grid, tile_num) + ! To match initialization behavior, set any -999s to 0 in soil_type + call mn_replace_low_values(static_ls%soil_type_grid, -100.0, 0.0) + + end subroutine mn_static_read_ls + + subroutine mn_static_read_fix(static_fix, npx, npy, refine, pelist, surface_dir, tile_num, month) + type(mn_fix_grids), intent(inout) :: static_fix + integer, allocatable, intent(in) :: pelist(:) !< PE list for fms2_io + character(len=*), intent(in) :: surface_dir !< Surface directory + integer, intent(in) :: npx, npy, refine, tile_num, month !< Number of x,y points and nest refinement, (parent) tile number + + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "substrate_temperature", "substrate_temperature", static_fix%deep_soil_temp_grid, tile_num) + ! set any -999s to +4C + call mn_replace_low_values(static_fix%deep_soil_temp_grid, -100.0, 277.0) + + + !! TODO investigate reading high-resolution veg_frac and veg_greenness + !call mn_static_read_hires(npx, npy, refine, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "", mn_static%veg_frac_grid) + + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "vegetation_type", "vegetation_type", static_fix%veg_type_grid, tile_num) + ! To match initialization behavior, set any -999s to 0 in veg_type + call mn_replace_low_values(static_fix%veg_type_grid, -100.0, 0.0) + + + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "slope_type", "slope_type", static_fix%slope_type_grid, tile_num) + ! To match initialization behavior, set any -999s to 0 in slope_type + call mn_replace_low_values(static_fix%slope_type_grid, -100.0, 0.0) + + + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "maximum_snow_albedo", "maximum_snow_albedo", static_fix%max_snow_alb_grid, tile_num) + ! Set any -999s to 0.5 + call mn_replace_low_values(static_fix%max_snow_alb_grid, -100.0, 0.5) + + ! Albedo fraction -- read and calculate + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "facsf", "facsf", static_fix%facsf_grid, tile_num) + + call alloc_set_facwf(static_fix) + + ! Additional albedo variables + ! black sky = strong cosz -- direct sunlight + ! white sky = weak cosz -- diffuse light + + ! alvsf = visible strong cosz = visible_black_sky_albedo + ! alvwf = visible weak cosz = visible_white_sky_albedo + ! alnsf = near IR strong cosz = near_IR_black_sky_albedo + ! alnwf = near IR weak cosz = near_IR_white_sky_albedo + + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "snowfree_albedo", "visible_black_sky_albedo", static_fix%alvsf_grid, tile_num, time=month) + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "snowfree_albedo", "visible_white_sky_albedo", static_fix%alvwf_grid, tile_num, time=month) + + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "snowfree_albedo", "near_IR_black_sky_albedo", static_fix%alnsf_grid, tile_num, time=month) + call mn_static_read_hires(npx, npy, refine, pelist, trim(surface_dir), "snowfree_albedo", "near_IR_white_sky_albedo", static_fix%alnwf_grid, tile_num, time=month) + + ! Set the -999s to small value of 0.06, matching initialization code in chgres + + call mn_replace_low_values(static_fix%alvsf_grid, -100.0, 0.06) + call mn_replace_low_values(static_fix%alvwf_grid, -100.0, 0.06) + call mn_replace_low_values(static_fix%alnsf_grid, -100.0, 0.06) + call mn_replace_low_values(static_fix%alnwf_grid, -100.0, 0.06) + + end subroutine mn_static_read_fix + !>@brief The subroutine 'mn_static_read_hires_r4' loads high resolution data from netCDF !>@details Gathers a single variable from the netCDF file subroutine mn_static_read_hires_r4(npx, npy, refine, pelist, surface_dir, file_prefix, var_name, data_grid, parent_tile, time) @@ -1252,9 +1368,9 @@ subroutine mn_var_shift_data_r8_2d(data_var, interp_type, wt, ind, delta_i_c, de end subroutine mn_var_shift_data_r8_2d - !>@brief The subroutine 'mn_prog_shift_data_r4_3d' shifts the data for a variable on each nest PE + !>@brief The subroutine 'mn_prog_shift_data_r4_3d_highz' shifts the data for a variable on each nest PE !>@details For one single precision 3D variable - subroutine mn_var_shift_data_r4_3d(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) + subroutine mn_var_shift_data_r4_3d_highz(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) real*4, allocatable, intent(inout) :: data_var(:,:,:) !< Data variable integer, intent(in) :: interp_type !< Interpolation stagger type @@ -1265,6 +1381,22 @@ subroutine mn_var_shift_data_r4_3d(data_var, interp_type, wt, ind, delta_i_c, de type(nest_domain_type), intent(inout) :: nest_domain !< Nest domain structure integer, intent(in) :: position, nz !< Grid offset, number of vertical levels + call mn_var_shift_data_r4_3d_lowhighz(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, 1, nz) + + end subroutine mn_var_shift_data_r4_3d_highz + !>@brief The subroutine 'mn_prog_shift_data_r4_3d_lowhighz' shifts the data for a variable on each nest PE + !>@details For one single precision 3D variable + subroutine mn_var_shift_data_r4_3d_lowhighz(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, z_low, z_high) + + real*4, allocatable, intent(inout) :: data_var(:,:,:) !< Data variable + integer, intent(in) :: interp_type !< Interpolation stagger type + real, allocatable, intent(in) :: wt(:,:,:) !< Interpolation weight array + integer, allocatable, intent(in) :: ind(:,:,:) !< Fine to coarse index array + integer, intent(in) :: delta_i_c, delta_j_c, x_refine, y_refine !< delta i,j for nest move. Nest refinement. + logical, intent(in) :: is_fine_pe !< Is nest PE? + type(nest_domain_type), intent(inout) :: nest_domain !< Nest domain structure + integer, intent(in) :: position, z_low, z_high !< Grid offset, number of vertical levels + real*4, dimension(:,:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer type(bbox) :: north_fine, north_coarse ! step 4 type(bbox) :: south_fine, south_coarse @@ -1278,10 +1410,10 @@ subroutine mn_var_shift_data_r4_3d(data_var, interp_type, wt, ind, delta_i_c, de !! !!=========================================================== - call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, nz) - call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, nz) - call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, nz) - call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, nz) + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, z_low, z_high) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, z_low, z_high) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, z_low, z_high) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, z_low, z_high) !==================================================== @@ -1310,10 +1442,10 @@ subroutine mn_var_shift_data_r4_3d(data_var, interp_type, wt, ind, delta_i_c, de !! !!=========================================================== - call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, nz, NORTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, nz, SOUTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, nz, EAST, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, nz, WEST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, z_low, z_high, NORTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, z_low, z_high, SOUTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, z_low, z_high, EAST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, z_low, z_high, WEST, x_refine, y_refine, wt, ind) endif deallocate(nbuffer) @@ -1321,12 +1453,12 @@ subroutine mn_var_shift_data_r4_3d(data_var, interp_type, wt, ind, delta_i_c, de deallocate(ebuffer) deallocate(wbuffer) - end subroutine mn_var_shift_data_r4_3d + end subroutine mn_var_shift_data_r4_3d_lowhighz - !>@brief The subroutine 'mn_prog_shift_data_r8_3d' shifts the data for a variable on each nest PE + !>@brief The subroutine 'mn_prog_shift_data_r8_3d_highz' shifts the data for a variable on each nest PE !>@details For one double precision 3D variable - subroutine mn_var_shift_data_r8_3d(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) + subroutine mn_var_shift_data_r8_3d_highz(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) real*8, allocatable, intent(inout) :: data_var(:,:,:) !< Data variable integer, intent(in) :: interp_type !< Interpolation stagger type @@ -1337,6 +1469,23 @@ subroutine mn_var_shift_data_r8_3d(data_var, interp_type, wt, ind, delta_i_c, de type(nest_domain_type), intent(inout) :: nest_domain !< Nest domain structure integer, intent(in) :: position, nz !< Grid offset, number vertical levels + call mn_var_shift_data_r8_3d_lowhighz(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, 1, nz) + + end subroutine mn_var_shift_data_r8_3d_highz + + !>@brief The subroutine 'mn_prog_shift_data_r8_3d' shifts the data for a variable on each nest PE + !>@details For one double precision 3D variable + subroutine mn_var_shift_data_r8_3d_lowhighz(data_var, interp_type, wt, ind, delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, z_low, z_high) + + real*8, allocatable, intent(inout) :: data_var(:,:,:) !< Data variable + integer, intent(in) :: interp_type !< Interpolation stagger type + real, allocatable, intent(in) :: wt(:,:,:) !< Interpolation weight array + integer, allocatable, intent(in) :: ind(:,:,:) !< Fine to coarse index array + integer, intent(in) :: delta_i_c, delta_j_c, x_refine, y_refine !< delta i,j for nest move. Nest refinement. + logical, intent(in) :: is_fine_pe !< Is nest PE? + type(nest_domain_type), intent(inout) :: nest_domain !< Nest domain structure + integer, intent(in) :: position, z_low, z_high !< Grid offset, number vertical levels + real*8, dimension(:,:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer type(bbox) :: north_fine, north_coarse ! step 4 type(bbox) :: south_fine, south_coarse @@ -1350,10 +1499,10 @@ subroutine mn_var_shift_data_r8_3d(data_var, interp_type, wt, ind, delta_i_c, de !! !!=========================================================== - call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, nz) - call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, nz) - call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, nz) - call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, nz) + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, z_low, z_high) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, z_low, z_high) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, z_low, z_high) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, z_low, z_high) !==================================================== ! Passes data from coarse grid to fine grid's halo buffers; requires nest_domain to be intent(inout) @@ -1380,10 +1529,10 @@ subroutine mn_var_shift_data_r8_3d(data_var, interp_type, wt, ind, delta_i_c, de !! !!=========================================================== - call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, nz, NORTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, nz, SOUTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, nz, EAST, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, nz, WEST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, z_low, z_high, NORTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, z_low, z_high, SOUTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, z_low, z_high, EAST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, z_low, z_high, WEST, x_refine, y_refine, wt, ind) endif deallocate(nbuffer) @@ -1391,7 +1540,7 @@ subroutine mn_var_shift_data_r8_3d(data_var, interp_type, wt, ind, delta_i_c, de deallocate(ebuffer) deallocate(wbuffer) - end subroutine mn_var_shift_data_r8_3d + end subroutine mn_var_shift_data_r8_3d_lowhighz !>@brief The subroutine 'mn_prog_shift_data_r4_4d' shifts the data for a variable on each nest PE @@ -2121,14 +2270,14 @@ subroutine mn_var_dump_3d_to_netcdf( data_var, is_fine_pe, domain_coarse, domain call output_grid_to_nc("GH", isd_fine, ied_fine, jsd_fine, jed_fine, nz, data_var, prefix_fine, var_name, time_step, domain_fine, position) else - if (this_tile == 6) then + !if (this_tile == 6) then !call mpp_get_compute_domain(domain_coarse, isc_coarse, iec_coarse, jsc_coarse, jec_coarse, position=position) call mpp_get_data_domain(domain_coarse, isd_coarse, ied_coarse, jsd_coarse, jed_coarse, position=position) !call mpp_get_memory_domain(domain_coarse, ism_coarse, iem_coarse, jsm_coarse, jem_coarse, position=position) call output_grid_to_nc("GH", isd_coarse, ied_coarse, jsd_coarse, jed_coarse, nz, data_var, prefix_coarse, var_name, time_step, domain_coarse, position) - endif + !endif endif end subroutine mn_var_dump_3d_to_netcdf @@ -2172,14 +2321,14 @@ subroutine mn_var_dump_2d_to_netcdf( data_var, is_fine_pe, domain_coarse, domain call output_grid_to_nc("GH", isd_fine, ied_fine, jsd_fine, jed_fine, data_var, prefix_fine, var_name, time_step, domain_fine, position) else - if (this_tile == 6) then + !if (this_tile == 6) then !call mpp_get_compute_domain(domain_coarse, isc_coarse, iec_coarse, jsc_coarse, jec_coarse, position=position) call mpp_get_data_domain(domain_coarse, isd_coarse, ied_coarse, jsd_coarse, jed_coarse, position=position) !call mpp_get_memory_domain(domain_coarse, ism_coarse, iem_coarse, jsm_coarse, jem_coarse, position=position) call output_grid_to_nc("GH", isd_coarse, ied_coarse, jsd_coarse, jed_coarse, data_var, prefix_coarse, var_name, time_step, domain_coarse, position) - endif + !endif endif end subroutine mn_var_dump_2d_to_netcdf @@ -2439,7 +2588,7 @@ subroutine assign_p_grids(parent_geo, p_grid, position) do i = 1, ubound(p_grid,1) ! centered grid version p_grid(i, j, :) = 0.0 - + if (2*i .gt. ubound(parent_geo%lons,1)) then print '("[ERROR] WDR PG_CLONi npe=",I0," 2*i=",I0," ubound=",I0)', mpp_pe(), 2*i, ubound(parent_geo%lons,1) elseif (2*j .gt. ubound(parent_geo%lons,2)) then @@ -2450,7 +2599,7 @@ subroutine assign_p_grids(parent_geo, p_grid, position) endif enddo enddo - + do i = 1, ubound(p_grid,1) do j = 1, ubound(p_grid,2) @@ -2465,7 +2614,7 @@ subroutine assign_p_grids(parent_geo, p_grid, position) if (p_grid(i,j,1) .ne. 0.0) num_vals = num_vals + 1 enddo enddo - + if (num_zeros .gt. 0) print '("[INFO] WDR set p_grid npe=",I0," num_zeros=",I0," full_zeros=",I0," num_vals=",I0" nxp=",I0," nyp=",I0," parent_geo%lats(",I0,",",I0,")"," p_grid(",I0,",",I0,",2)")', mpp_pe(), num_zeros, full_zeros, num_vals, parent_geo%nxp, parent_geo%nyp, ubound(parent_geo%lats,1), ubound(parent_geo%lats,2), ubound(p_grid,1), ubound(p_grid,2) @@ -2480,15 +2629,15 @@ subroutine assign_p_grids(parent_geo, p_grid, position) elseif (2*j-1 .gt. ubound(parent_geo%lons,2)) then print '("[ERROR] WDR PG_ULONj npe=",I0," 2*j-1=",I0," ubound=",I0)', mpp_pe(), 2*j-1, ubound(parent_geo%lons,2) else - + ! This seems correct p_grid(i, j, 1) = parent_geo%lons(2*i, 2*j-1) p_grid(i, j, 2) = parent_geo%lats(2*i, 2*j-1) endif enddo enddo - - + + do i = 1, ubound(p_grid,1) do j = 1, ubound(p_grid,2) @@ -2516,18 +2665,18 @@ subroutine assign_p_grids(parent_geo, p_grid, position) print '("[ERROR] WDR PG_VLONi npe=",I0," 2*i-1=",I0," ubound=",I0)', mpp_pe(), 2*i-1, ubound(parent_geo%lons,1) elseif (2*j .gt. ubound(parent_geo%lons,2)) then print '("[ERROR] WDR PG_VLONj npe=",I0," 2*j=",I0," ubound=",I0)', mpp_pe(), 2*j, ubound(parent_geo%lons,2) - else + else ! This seems correct p_grid(i, j, 1) = parent_geo%lons(2*i-1, 2*j) p_grid(i, j, 2) = parent_geo%lats(2*i-1, 2*j) endif enddo enddo - + do i = 1, ubound(p_grid,1) do j = 1, ubound(p_grid,2) - + if (p_grid(i,j,1) .eq. 0.0) then num_zeros = num_zeros + 1 if (p_grid(i,j,2) .eq. 0.0) then @@ -2538,13 +2687,13 @@ subroutine assign_p_grids(parent_geo, p_grid, position) if (p_grid(i,j,1) .ne. 0.0) num_vals = num_vals + 1 enddo enddo - + if (num_zeros .gt. 0) print '("[INFO] WDR set p_grid_v npe=",I0," num_zeros=",I0," full_zeros=",I0," num_vals=",I0" nxp=",I0," nyp=",I0," parent_geo%lats(",I0,",",I0,")"," p_grid(",I0,",",I0,",2)")', mpp_pe(), num_zeros, full_zeros, num_vals, parent_geo%nxp, parent_geo%nyp, ubound(parent_geo%lats,1), ubound(parent_geo%lats,2), ubound(p_grid,1), ubound(p_grid,2) - - - + + + endif - + end subroutine assign_p_grids @@ -2596,9 +2745,9 @@ subroutine calc_inside(p_grid, ic, jc, n_grid1, n_grid2, istag, jstag, is_inside real(kind=R_GRID), intent(in) :: n_grid1, n_grid2 integer, intent(in) :: ic, jc, istag, jstag logical, intent(out) :: is_inside - logical, intent(in) :: verbose + logical, intent(in) :: verbose + - real(kind=R_GRID) :: max1, max2, min1, min2, eps max1 = max(p_grid(ic,jc,1), p_grid(ic,jc+1,1), p_grid(ic,jc+1,1), p_grid(ic+1,jc+1,1), p_grid(ic+1,jc+1,1), p_grid(ic+1,jc,1)) @@ -2606,21 +2755,21 @@ subroutine calc_inside(p_grid, ic, jc, n_grid1, n_grid2, istag, jstag, is_inside min1 = min(p_grid(ic,jc,1), p_grid(ic,jc+1,1), p_grid(ic,jc+1,1), p_grid(ic+1,jc+1,1), p_grid(ic+1,jc+1,1), p_grid(ic+1,jc,1)) min2 = min(p_grid(ic,jc,2), p_grid(ic,jc+1,2), p_grid(ic,jc+1,2), p_grid(ic+1,jc+1,2), p_grid(ic+1,jc+1,2), p_grid(ic+1,jc,2)) - + is_inside = .False. - + eps = 0.00001 !eps = 0.000001 if (n_grid1 .le. max1+eps .and. n_grid1 .ge. min1-eps) then if (n_grid2 .le. max2+eps .and. n_grid2 .ge. min2-eps) then is_inside = .True. - !if (verbose) print '("[INFO] WDR is_inside TRUE npe=",I0," ic=",I0," jc=",I0," n_grid1=",F12.8," min1=",F12.8," max1=",F12.8," n_grid2=",F12.8," min2=",F12.8," max2=", F12.8," p_grid(",I0,",",I0,",2) istag=",I0," jstag=",I0)', mpp_pe(), ic, jc, n_grid1, min1, max1, n_grid2, min2, max2, ubound(p_grid,1), ubound(p_grid,2), istag, jstag +! if (verbose) print '("[INFO] WDR is_inside TRUE npe=",I0," ic=",I0," jc=",I0," n_grid1=",F12.8," min1=",F12.8," max1=",F12.8," n_grid2=",F12.8," min2=",F12.8," max2=", F12.8," p_grid(",I0,",",I0,",2) istag=",I0," jstag=",I0)', mpp_pe(), ic, jc, n_grid1, min1, max1, n_grid2, min2, max2, ubound(p_grid,1), ubound(p_grid,2), istag, jstag endif endif if (verbose .and. .not. is_inside) then - print '("[INFO] WDR is_inside FALSE npe=",I0," ic=",I0," jc=",I0," n_grid1=",F12.8," min1=",F12.8," max1=",F12.8," n_grid2=",F12.8," min2=",F12.8," max2=", F10.4," p_grid(",I0,",",I0,",2) istag=",I0," jstag=",I0)', mpp_pe(), ic, jc, n_grid1, min1, max1, n_grid2, min2, max2, ubound(p_grid,1), ubound(p_grid,2), istag, jstag + print '("[WARN] WDR is_inside FALSE npe=",I0," ic=",I0," jc=",I0," n_grid1=",F12.8," min1=",F12.8," max1=",F12.8," n_grid2=",F12.8," min2=",F12.8," max2=", F10.4," p_grid(",I0,",",I0,",2) istag=",I0," jstag=",I0)', mpp_pe(), ic, jc, n_grid1, min1, max1, n_grid2, min2, max2, ubound(p_grid,1), ubound(p_grid,2), istag, jstag endif @@ -2672,7 +2821,7 @@ subroutine calc_nest_halo_weights(bbox_fine, bbox_coarse, p_grid, n_grid, wt, is ic = ind(i,j,1) if (ic+1 .gt. ubound(p_grid, 1)) print '("[ERROR] WDR CALCWT off end of p_grid i npe=",I0," ic+1=",I0," bound=",I0)', mpp_pe(), ic+1, ubound(p_grid,1) if (jc+1 .gt. ubound(p_grid, 2)) print '("[ERROR] WDR CALCWT off end of p_grid j npe=",I0," jc+1=",I0," bound=",I0)', mpp_pe(), jc+1, ubound(p_grid,2) - + ! dist2side_latlon takes points in longitude-latitude coordinates. dist1 = dist2side_latlon(p_grid(ic,jc,:), p_grid(ic,jc+1,:), n_grid(i,j,:)) dist2 = dist2side_latlon(p_grid(ic,jc+1,:), p_grid(ic+1,jc+1,:), n_grid(i,j,:)) @@ -2681,33 +2830,33 @@ subroutine calc_nest_halo_weights(bbox_fine, bbox_coarse, p_grid, n_grid, wt, is call calc_inside(p_grid, ic, jc, n_grid(i,j,1), n_grid(i,j,2), istag, jstag, is_inside, .True.) -! if (.not. is_inside) then -! adjusted = .False. -! -! do di = -2,2 -! do dj = -2,1 -! if (.not. adjusted) then -! call calc_inside(p_grid, ic+di, jc+dj, n_grid(i,j,1), n_grid(i,j,2), istag, jstag, is_inside, .False.) -! if (is_inside) then -! ic = ic + di -! jc = jc + dj -! -! print '("[INFO] WDR is_inside UPDATED npe=",I0," ic=",I0," jc=",I0," istart_coarse=",I0," jstart_coarse=",I0," i=",I0," j=",I0," di=",I0," dj=",I0," n_grid1=",F12.8," n_grid2=",F12.8," istag=",I0," jstag=",I0)', mpp_pe(), ic, jc, istart_coarse, jstart_coarse, i, j, di, dj, n_grid(i,j,1), n_grid(i,j,2), istag, jstag - -! dist1 = dist2side_latlon(p_grid(ic,jc,:), p_grid(ic,jc+1,:), n_grid(i,j,:)) -! dist2 = dist2side_latlon(p_grid(ic,jc+1,:), p_grid(ic+1,jc+1,:), n_grid(i,j,:)) -! dist3 = dist2side_latlon(p_grid(ic+1,jc+1,:), p_grid(ic+1,jc,:), n_grid(i,j,:)) -! dist4 = dist2side_latlon(p_grid(ic,jc,:), p_grid(ic+1,jc,:), n_grid(i,j,:)) -! -! adjusted = .True. -! endif -! endif -! enddo -! enddo -! if (.not. adjusted) print '("[ERROR] WDR is_inside UPDATE FAILED npe=",I0," i=",I0," j=",I0," ic=",I0," jc=",I0," n_grid1=",F12.8," n_grid2=",F12.8," istag=",I0," jstag=",I0)', mpp_pe(), i, j, ic, jc, n_grid(i,j,1), n_grid(i,j,2), istag, jstag -! -! endif - + if (.not. is_inside) then + adjusted = .False. + + do di = -2,2 + do dj = -2,1 + if (.not. adjusted) then + call calc_inside(p_grid, ic+di, jc+dj, n_grid(i,j,1), n_grid(i,j,2), istag, jstag, is_inside, .False.) + if (is_inside) then + ic = ic + di + jc = jc + dj + + print '("[INFO] WDR is_inside UPDATED npe=",I0," ic=",I0," jc=",I0," istart_coarse=",I0," jstart_coarse=",I0," i=",I0," j=",I0," di=",I0," dj=",I0," n_grid1=",F12.8," n_grid2=",F12.8," istag=",I0," jstag=",I0)', mpp_pe(), ic, jc, istart_coarse, jstart_coarse, i, j, di, dj, n_grid(i,j,1), n_grid(i,j,2), istag, jstag + + dist1 = dist2side_latlon(p_grid(ic,jc,:), p_grid(ic,jc+1,:), n_grid(i,j,:)) + dist2 = dist2side_latlon(p_grid(ic,jc+1,:), p_grid(ic+1,jc+1,:), n_grid(i,j,:)) + dist3 = dist2side_latlon(p_grid(ic+1,jc+1,:), p_grid(ic+1,jc,:), n_grid(i,j,:)) + dist4 = dist2side_latlon(p_grid(ic,jc,:), p_grid(ic+1,jc,:), n_grid(i,j,:)) + + adjusted = .True. + endif + endif + enddo + enddo + if (.not. adjusted) print '("[ERROR] WDR is_inside UPDATE FAILED npe=",I0," i=",I0," j=",I0," ic=",I0," jc=",I0," n_grid1=",F12.8," n_grid2=",F12.8," istag=",I0," jstag=",I0)', mpp_pe(), i, j, ic, jc, n_grid(i,j,1), n_grid(i,j,2), istag, jstag + + endif + old_weight = wt(i,j,:) wt(i,j,1)=dist2*dist3 ! ic, jc weight @@ -2723,9 +2872,9 @@ subroutine calc_nest_halo_weights(bbox_fine, bbox_coarse, p_grid, n_grid, wt, is call mpp_error(WARNING, "WARNING: calc_nest_halo_weights sum of weights is zero.") wt(i,j,:) = 0.25 - + else - wt(i,j,:)=wt(i,j,:)/sum + wt(i,j,:)=wt(i,j,:)/sum endif diff_weight = old_weight - wt(i,j,:) @@ -2733,7 +2882,7 @@ subroutine calc_nest_halo_weights(bbox_fine, bbox_coarse, p_grid, n_grid, wt, is if (abs(diff_weight(k)) .ge. 0.01) then print '("[WARN] WDR DIFFWT npe=",I0," old_wt=",F10.6," wt(",I0,",",I0,",",I0,")=",F10.6," diff=",F10.6," istag=",I0," jstag=",I0)', & mpp_pe(), old_weight(k), i, j, k, wt(i,j,k), diff_weight(k), istag, jstag - + endif enddo enddo @@ -2743,4 +2892,3 @@ subroutine calc_nest_halo_weights(bbox_fine, bbox_coarse, p_grid, n_grid, wt, is end subroutine calc_nest_halo_weights end module fv_moving_nest_mod - diff --git a/fv3/moving_nest/fv_moving_nest_main.F90 b/fv3/moving_nest/fv_moving_nest_main.F90 index b26b720c79..fceabff990 100644 --- a/fv3/moving_nest/fv_moving_nest_main.F90 +++ b/fv3/moving_nest/fv_moving_nest_main.F90 @@ -99,15 +99,19 @@ module fv_moving_nest_main_mod !------------------------------------ use fv_moving_nest_types_mod, only: allocate_fv_moving_nest_prog_type, allocate_fv_moving_nest_physics_type - use fv_moving_nest_types_mod, only: deallocate_fv_moving_nests + use fv_moving_nest_types_mod, only: deallocate_fv_moving_nests, mn_set_leading_edge use fv_moving_nest_types_mod, only: Moving_nest + use fv_moving_nest_types_mod, only: mn_apply_lakes, mn_overwrite_with_nest_init_values, alloc_set_facwf + use fv_moving_nest_types_mod, only: mn_static_overwrite_ls_from_nest, mn_static_overwrite_fix_from_nest + use fv_moving_nest_types_mod, only: deallocate_land_mask_grids, deallocate_fix_grids ! Prognostic variable routines use fv_moving_nest_mod, only: mn_prog_fill_intern_nest_halos, mn_prog_fill_nest_halos_from_parent, & mn_prog_dump_to_netcdf, mn_prog_shift_data + use fv_moving_nest_mod, only: mn_static_read_ls, mn_static_read_fix ! Physics variable routines use fv_moving_nest_physics_mod, only: mn_phys_fill_intern_nest_halos, mn_phys_fill_nest_halos_from_parent, & - mn_phys_dump_to_netcdf, mn_phys_shift_data, mn_phys_reset_sfc_props, move_nsst + mn_phys_dump_to_netcdf, mn_phys_shift_data, mn_phys_reset_sfc_props, move_nsst, mn_phys_set_slmsk ! Metadata routines use fv_moving_nest_mod, only: mn_meta_move_nest, mn_meta_recalc, mn_meta_reset_gridstruct, mn_shift_index @@ -160,6 +164,9 @@ module fv_moving_nest_main_mod integer :: id_movnestTot integer, save :: output_step = 0 + type(mn_surface_grids), save :: mn_static + + contains !>@brief The subroutine 'update_moving_nest' decides whether the nest should be moved, and if so, performs the move. @@ -247,6 +254,235 @@ end subroutine nest_tracker_end + + subroutine log_landsea_mask(Atm_block, GFS_control, GFS_sfcprop, time_step, parent_grid_num, child_grid_num) + type(block_control_type), intent(in) :: Atm_block !< Physics block layout + type(GFS_control_type), intent(in) :: GFS_control !< Physics metadata + type(GFS_sfcprop_type), intent(in) :: GFS_sfcprop !< Physics variable data + type(time_type), intent(in) :: time_step !< Current timestep + integer, intent(in) :: parent_grid_num, child_grid_num + + + character(len=160) :: line + character(len=1) :: mask_char + character(len=1) :: num_char + integer :: i,j + integer :: nb, blen, ix, i_pe, j_pe, i_idx, j_idx, refine, im + integer :: ioffset, joffset + real :: local_slmsk(Atm(2)%bd%isd:Atm(2)%bd%ied, Atm(2)%bd%jsd:Atm(2)%bd%jed) + integer :: nz, this_pe, n + integer :: num_land, num_water + + this_pe = mpp_pe() + n = mygrid + + refine = Atm(child_grid_num)%neststruct%refinement + ioffset = Atm(child_grid_num)%neststruct%ioffset + joffset = Atm(child_grid_num)%neststruct%joffset + + do i=lbound(Atm(n)%oro,1), ubound(Atm(n)%oro,1) + line = "" + do j=lbound(Atm(n)%oro,2), ubound(Atm(n)%oro,2) + !print '("[INFO] WDR oro size npe=",I0," is_allocated=",L1)', this_pe, allocated(Atm(n)%oro) + !print '("[INFO] WDR oro size npe=",I0," i=",I0,"-",I0," j=",I0,"-",I0)', this_pe, lbound(Atm(n)%oro,1), ubound(Atm(n)%oro,1), lbound(Atm(n)%oro,2), ubound(Atm(n)%oro,2) + if (Atm(n)%oro(i,j) .eq. 1) then + ! land + line = trim(line) // "+" + elseif (Atm(n)%oro(i,j) .eq. 2) then + ! Water + line = trim(line) // "." + else + ! Unknown + line = trim(line) // "X" + endif + enddo + !print '("[INFO] WDR oro npe=",I0," time=",I0," i=",I0," ",A80)',this_pe,a_step,i,trim(line) + + enddo + + + local_slmsk = 8 + !print '("[INFO] WDR local_slmsk size npe=",I0," i=",I0,"-",I0," j=",I0,"-",I0," n=",I0)', this_pe, lbound(local_slmsk,1), ubound(local_slmsk,1), lbound(local_slmsk,2), ubound(local_slmsk,2), n + im = 0 + do nb = 1,Atm_block%nblks + blen = Atm_block%blksz(nb) + do ix = 1, blen + i_pe = Atm_block%index(nb)%ii(ix) + j_pe = Atm_block%index(nb)%jj(ix) + im = im + 1 + + !print '("[INFO] WDR local_slmsk npe=",I0," i_pe=",I0," j_pe=",I0)', this_pe, i_pe, j_pe + + local_slmsk(i_pe, j_pe) = GFS_sfcprop%slmsk(im) + + if (allocated(Moving_nest)) then + if (allocated(Moving_nest(n)%mn_phys%slmsk)) then + if (int(local_slmsk(i_pe,j_pe)) .ne. 8) then + if (int(local_slmsk(i_pe,j_pe)) .ne. int(Moving_nest(n)%mn_phys%slmsk(i_pe,j_pe))) then + print '("[INFO] WDR mismatch local_slmsk_lake npe=",I0," time=",I3," i_pe=",I3," j_pe=",I3," slmsk=",I0," phys%slmsk=",I0," soil_type_grid=",I0," phys%soil_type=",I0," GFS_sfcprop%landfrac=",F10.5," land_frac_grid=",F12.5," GFS_sfcprop%lakefrac=",F10.5," GFS_sfcprop%oceanfrac=",F10.5)', & + this_pe,a_step,i_pe,j_pe, int(local_slmsk(i_pe,j_pe)), & + int(Moving_nest(n)%mn_phys%slmsk(i_pe,j_pe)), & + int(GFS_sfcprop%stype(im)), & + int(mn_static%fp_ls%soil_type_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + GFS_sfcprop%landfrac(im), & + int(mn_static%fp_ls%land_frac_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + GFS_sfcprop%lakefrac(im), & + GFS_sfcprop%oceanfrac(im) + endif + endif + endif + endif + enddo + enddo + + print '("[INFO] WDR local_slmsk size npe=",I0," i=",I0,"-",I0," j=",I0,"-",I0)', this_pe, lbound(local_slmsk,1), ubound(local_slmsk,1), lbound(local_slmsk,2), ubound(local_slmsk,2) + + line = "" + do j=lbound(local_slmsk,2), ubound(local_slmsk,2) + write(num_char, "(I1)"), mod(j,10) + line = trim(line) // trim(num_char) + enddo + print '("[INFO] WDR local_slmsk_lake npe=",I0," time=",I3," i=",I3," ",A60)',this_pe,a_step,-99,trim(line) + + do i=lbound(local_slmsk,1), ubound(local_slmsk,1) + line = "" + num_land = 0 + num_water = 0 + + do j=lbound(local_slmsk,2), ubound(local_slmsk,2) + + if (local_slmsk(i,j) .eq. 1) then + ! land + line = trim(line) // "+" + num_land = num_land + 1 + elseif (local_slmsk(i,j) .eq. 2) then + ! Water + line = trim(line) // "T" + elseif (local_slmsk(i,j) .eq. 0) then + ! Zero == lake? + line = trim(line) // "." + num_water = num_water + 1 + elseif (local_slmsk(i,j) .eq. 8) then + ! Missing/edge + line = trim(line) // "M" + else + ! Unknown + print '("[INFO] WDR local_slmsk_lake npe=",I0," time=",I3," i=",I3," j=",I3," slmsk=",E12.5)',this_pe,a_step,i,j, local_slmsk(i,j) + write (mask_char, "(I1)") int(local_slmsk(i,j)) + line = trim(line) // mask_char + endif + enddo + print '("[INFO] WDR local_slmsk_lake npe=",I0," time=",I3," i=",I3," ",A60," ",I2," ",I2)',this_pe,a_step,i,trim(line), num_land, num_water + enddo + end subroutine log_landsea_mask + + + subroutine validate_geo_coords(tag, geo_grid, nest_geo_grid, refine, ioffset, joffset) + character(len=*) :: tag + real(kind=kind_phys), allocatable, intent(in) :: geo_grid(:,:) + real(kind=kind_phys), allocatable, intent(in) :: nest_geo_grid(:,:) + integer, intent(in) :: refine, ioffset, joffset + + integer :: i,j, this_pe + real(kind=kind_phys) :: diff + + this_pe = mpp_pe() + + do i = lbound(nest_geo_grid,1), ubound(nest_geo_grid,1) + do j = lbound(nest_geo_grid,2), ubound(nest_geo_grid,2) + + diff = nest_geo_grid(i,j) - geo_grid((ioffset-1)*refine+i, (joffset-1)*refine+j) + print '("[INFO] WDR VALIDATEGEO tag=",A3," npe=",I0," i=",I0," j=",I0," diff=",F20.12," nest_val=",F16.12)', tag, this_pe, i, j, diff, nest_geo_grid(i,j) + + enddo + enddo + + end subroutine validate_geo_coords + + + + subroutine validate_navigation_fields(tag, Atm_block, GFS_control, GFS_sfcprop, parent_grid_num, child_grid_num) + character(len=*) :: tag + type(block_control_type), intent(in) :: Atm_block !< Physics block layout + type(GFS_control_type), intent(in) :: GFS_control !< Physics metadata + type(GFS_sfcprop_type), intent(in) :: GFS_sfcprop !< Physics variable data + integer, intent(in) :: parent_grid_num, child_grid_num + + + character(len=160) :: line + character(len=1) :: mask_char + character(len=1) :: num_char + integer :: i,j + integer :: nb, blen, ix, i_pe, j_pe, i_idx, j_idx, refine, im + integer :: ioffset, joffset + real :: local_slmsk(Atm(2)%bd%isd:Atm(2)%bd%ied, Atm(2)%bd%jsd:Atm(2)%bd%jed) + integer :: nz, this_pe, n + integer :: num_land, num_water + + this_pe = mpp_pe() + n = mygrid + + refine = Atm(child_grid_num)%neststruct%refinement + ioffset = Atm(child_grid_num)%neststruct%ioffset + joffset = Atm(child_grid_num)%neststruct%joffset + + local_slmsk = 8 + print '("[INFO] WDR VALIDATE local_slmsk size npe=",I0," i=",I0,"-",I0," j=",I0,"-",I0," n=",I0)', this_pe, lbound(local_slmsk,1), ubound(local_slmsk,1), lbound(local_slmsk,2), ubound(local_slmsk,2), n + + im = 0 + do nb = 1,Atm_block%nblks + blen = Atm_block%blksz(nb) + do ix = 1, blen + i_pe = Atm_block%index(nb)%ii(ix) + j_pe = Atm_block%index(nb)%jj(ix) + im = im + 1 + + !print '("[INFO] WDR local_slmsk npe=",I0," i_pe=",I0," j_pe=",I0)', this_pe, i_pe, j_pe + + local_slmsk(i_pe, j_pe) = GFS_sfcprop%slmsk(im) + + if (allocated(Moving_nest)) then + if (allocated(Moving_nest(n)%mn_phys%slmsk)) then + !print '("[INFO] WDR VALIDATE local_slmsk npe=",I0," i_pe=",I0," j_pe=",I0)', this_pe, i_pe, j_pe + + if (int(local_slmsk(i_pe,j_pe)) .ne. 8) then + if (int(local_slmsk(i_pe,j_pe)) .ne. int(Moving_nest(n)%mn_phys%slmsk(i_pe,j_pe))) then + print '("[INFO] WDR mismatch VALIDATE A tag=",A4," npe=",I0," time=",I3," i_pe=",I3," j_pe=",I3," GFS%slmsk=",I0," phys%slmsk=",I0," fp_slmsk=",I0," soil_type_grid=",I0," phys%soil_type=",I0," GFS_sfcprop%landfrac=",F10.5," land_frac_grid=",F12.5," GFS_sfcprop%lakefrac=",F10.5," GFS_sfcprop%oceanfrac=",F10.5)', & + tag, this_pe,a_step,i_pe,j_pe, int(local_slmsk(i_pe,j_pe)), & + int(Moving_nest(n)%mn_phys%slmsk(i_pe,j_pe)), & + int(mn_static%fp_ls%ls_mask_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + int(GFS_sfcprop%stype(im)), & + int(mn_static%fp_ls%soil_type_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + GFS_sfcprop%landfrac(im), & + int(mn_static%fp_ls%land_frac_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + GFS_sfcprop%lakefrac(im), & + GFS_sfcprop%oceanfrac(im) + endif + + +! if ((i_pe .eq. 149 .and. j_pe .eq. 169) .or.(i_pe .eq. 152 .and. j_pe .eq. 169) .or. int(local_slmsk(i_pe,j_pe)) .ne. int(mn_static%ls_mask_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe))) then + if (int(local_slmsk(i_pe,j_pe)) .ne. int(mn_static%fp_ls%ls_mask_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe))) then + print '("[INFO] WDR mismatch VALIDATE B tag=",A4," npe=",I0," time=",I3," i_pe=",I3," j_pe=",I3," GFS%slmsk=",I0," phys%slmsk=",I0," fp_slmsk=",I0," soil_type_grid=",I0," phys%soil_type=",I0," GFS_sfcprop%landfrac=",F10.5," land_frac_grid=",F12.5," GFS_sfcprop%lakefrac=",F10.5," GFS_sfcprop%oceanfrac=",F10.5)', & + tag, this_pe,a_step,i_pe,j_pe, int(local_slmsk(i_pe,j_pe)), & + int(Moving_nest(n)%mn_phys%slmsk(i_pe,j_pe)), & + int(mn_static%fp_ls%ls_mask_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + int(GFS_sfcprop%stype(im)), & + int(mn_static%fp_ls%soil_type_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + GFS_sfcprop%landfrac(im), & + int(mn_static%fp_ls%land_frac_grid((ioffset-1)*refine+i_pe, (joffset-1)*refine+j_pe)), & + GFS_sfcprop%lakefrac(im), & + GFS_sfcprop%oceanfrac(im) + endif + + endif + endif + endif + enddo + enddo + + end subroutine validate_navigation_fields + + !>@brief The subroutine 'dump_moving_nest' outputs native grid format data to netCDF files !>@details This subroutine exports model variables using FMS IO to netCDF files if tsvar_out is set to .True. subroutine dump_moving_nest(Atm_block, GFS_control, GFS_sfcprop, GFS_tbd, time_step) @@ -276,6 +512,18 @@ subroutine dump_moving_nest(Atm_block, GFS_control, GFS_sfcprop, GFS_tbd, time_s ! if (tsvar_out) call mn_prog_dump_to_netcdf(Atm(n), a_step, "tsavar", is_fine_pe, domain_coarse, domain_fine, nz) ! if (tsvar_out) call mn_phys_dump_to_netcdf(Atm(n), Atm_block, GFS_control, GFS_sfcprop, GFS_tbd, time_val, file_prefix, is_fine_pe, domain_coarse, domain_fine, nz) !endif + !if (a_step .ge. 310) then + !if (mod(a_step, 80) .eq. 0 ) then + ! if (tsvar_out) call mn_phys_dump_to_netcdf(Atm(n), Atm_block, GFS_control, GFS_sfcprop, a_step, "tsavar", is_fine_pe, domain_coarse, domain_fine, nz) + !endif + + ! if (is_fine_pe) then + ! call validate_navigation_fields("DUMP", Atm_block, GFS_control, GFS_sfcprop, parent_grid_num, child_grid_num) + ! endif + + !if (this_pe .eq. 88 .or. this_pe .eq. 89) then + ! call log_landsea_mask(Atm_block, GFS_control, GFS_sfcprop, time_step, parent_grid_num, child_grid_num) + !endif end subroutine dump_moving_nest @@ -505,7 +753,6 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd integer, pointer :: ioffset, joffset real, pointer, dimension(:,:,:) :: grid, agrid type(domain2d), pointer :: domain_coarse, domain_fine - real(kind=R_GRID), pointer, dimension(:,:,:,:) :: grid_global ! Constants for mpp calls integer :: position = CENTER @@ -515,23 +762,17 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd integer :: x_refine, y_refine ! Currently equal, but allows for future flexibility logical :: is_fine_pe - ! TODO read halo size from the namelist instead to allow nest refinement > 3 - integer :: ehalo = 3 - integer :: whalo = 3 - integer :: nhalo = 3 - integer :: shalo = 3 integer :: extra_halo = 0 ! Extra halo for moving nest routines integer :: istart_fine, iend_fine, jstart_fine, jend_fine integer :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse integer :: nx, ny, nz, nx_cubic, ny_cubic - integer :: p_istart_fine, p_iend_fine, p_jstart_fine, p_jend_fine ! Parent tile data, saved between timesteps logical, save :: first_nest_move = .true. type(grid_geometry), save :: parent_geo type(grid_geometry), save :: fp_super_tile_geo - type(mn_surface_grids), save :: mn_static +! type(mn_surface_grids), save :: mn_static real(kind=R_GRID), allocatable, save :: p_grid(:,:,:) real(kind=R_GRID), allocatable, save :: p_grid_u(:,:,:) real(kind=R_GRID), allocatable, save :: p_grid_v(:,:,:) @@ -547,9 +788,8 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd !real :: va(isd:ied,jsd:jed) logical :: filtered_terrain = .True. ! TODO set this from namelist - integer :: i, j, x, y, z, p, nn, n_moist + integer :: i, j integer :: parent_tile - logical :: found_nest_domain = .false. ! Variables to enable debugging use of mpp_sync logical :: debug_sync = .false. @@ -557,15 +797,12 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd integer :: pp, p1, p2 ! Variables for parent side of setup_aligned_nest() - integer :: isg, ieg, jsg, jeg, gid - integer :: isc_p, iec_p, jsc_p, jec_p - integer :: upoff, jind - integer :: ng, refinement integer :: npx, npy, npz, ncnst, pnats integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed integer :: nq ! number of transported tracers integer :: is, ie, js, je, k ! For recalculation of omga + integer :: i_idx, j_idx integer, save :: output_step = 0 integer, allocatable :: pelist(:) character(len=16) :: errstring @@ -573,13 +810,27 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd integer :: year, month, day, hour, minute, second real(kind=R_GRID) :: pi = 4 * atan(1.0d0) real :: rad2deg + logical :: move_noahmp + integer :: static_nest_num logical :: use_timers + real(kind=kind_phys):: maxSkinTempK + + !! For NOAHMP + ! (/0.0, 0.0, 0.0, 0.1,0.4,1.0,2.0/) -- 3 snow levels, 4 soil levels + real :: zsns_default(-2:4) + zsns_default = [0.0, 0.0, 0.0, -0.1,-0.4,-1.0,-2.0 ] rad2deg = 180.0 / pi - gid = mpp_pe() this_pe = mpp_pe() + ! Highest satellite observed skin temperatures on Earth are on the order of +70C/343K/+160F + ! Mildrexler, D. J., M. Zhao, and S. W. Running, 2011: Satellite Finds Highest Land Skin Temperatures on Earth. Bull. Amer. Meteor. Soc., 92, 855–860, + ! https://doi.org/10.1175/2011BAMS3067.1. + ! https://journals.ametsoc.org/view/journals/bams/92/7/2011bams3067_1.xml?tab_body=pdf + + maxSkinTempK = 273.15 + 80.0 + use_timers = Atm(n)%flagstruct%fv_timers allocate(pelist(mpp_npes())) @@ -614,9 +865,14 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd is_fine_pe = Atm(n)%neststruct%nested .and. ANY(Atm(n)%pelist(:) == this_pe) + if (GFS_control%lsm == GFS_control%lsm_noahmp) then + move_noahmp = .True. + else + move_noahmp = .False. + endif if (first_nest_move) then - + call fv_moving_nest_init_clocks(Atm(n)%flagstruct%fv_timers) ! If NSST is turned off, do not move the NSST variables. @@ -627,12 +883,14 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd move_nsst=.true. endif + ! This will only allocate the mn_prog and mn_phys for the active Atm(n), not all of them ! The others can safely remain unallocated. call allocate_fv_moving_nest_prog_type(isd, ied, jsd, jed, npz, Moving_nest(n)%mn_prog) - call allocate_fv_moving_nest_physics_type(isd, ied, jsd, jed, npz, move_physics, move_nsst, & - GFS_control%lsoil, GFS_control%nmtvr, GFS_control%levs, GFS_control%ntot2d, GFS_control%ntot3d, & + call allocate_fv_moving_nest_physics_type(isd, ied, jsd, jed, npz, move_physics, move_noahmp, move_nsst, & + GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound, GFS_control%lsoil, & + GFS_control%nmtvr, GFS_control%levs, GFS_control%ntot2d, GFS_control%ntot3d, & Moving_nest(n)%mn_phys) endif @@ -693,7 +951,7 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd allocate(wt_v(Atm(child_grid_num)%bd%isd:Atm(child_grid_num)%bd%ied+1, Atm(child_grid_num)%bd%jsd:Atm(child_grid_num)%bd%jed, 4)) wt_v = real_snan - ! Fill in the local weights with the ones from Atm just to be safe + ! Fill in the local weights with the ones from Atm just to be safe call fill_weight_grid(wt_h, Atm(n)%neststruct%wt_h) call fill_weight_grid(wt_u, Atm(n)%neststruct%wt_u) call fill_weight_grid(wt_v, Atm(n)%neststruct%wt_v) @@ -746,90 +1004,54 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd ! Also read in other static variables from the orography and surface files if (first_nest_move) then + ! TODO Compute this more flexibly for multiple moving nests + if (parent_tile .eq. 1) then + static_nest_num = 8 ! Regional + else + static_nest_num = 7 ! Global + endif + + !print '("[INFO] WDR NEST_NUM npe=",I0," is_regional=",L1," static_nest_num=",I0," parent_tile=",I0,", ntiles=",I0)', this_pe, Atm(n)%flagstruct%regional, static_nest_num, parent_tile, Atm(1)%flagstruct%ntiles ! TODO set pelist for the correct nest instead of hard-coded Atm(2)%pelist to allow multiple moving nests call mn_latlon_read_hires_parent(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, fp_super_tile_geo, & Moving_nest(child_grid_num)%mn_flag%surface_dir, parent_tile) - call mn_orog_read_hires_parent(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, & - Moving_nest(child_grid_num)%mn_flag%surface_dir, filtered_terrain, & - mn_static%orog_grid, mn_static%orog_std_grid, mn_static%ls_mask_grid, mn_static%land_frac_grid, parent_tile) - - ! If terrain_smoother method 1 is chosen, we need the parent coarse terrain - if (Moving_nest(n)%mn_flag%terrain_smoother .eq. 1) then - if (filtered_terrain) then - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, 1, Atm(2)%pelist, Moving_nest(child_grid_num)%mn_flag%surface_dir, "oro_data", "orog_filt", mn_static%parent_orog_grid, parent_tile) - else - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, 1, Atm(2)%pelist, Moving_nest(child_grid_num)%mn_flag%surface_dir, "oro_data", "orog_raw", mn_static%parent_orog_grid, parent_tile) - endif - endif - - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "substrate_temperature", "substrate_temperature", mn_static%deep_soil_temp_grid, parent_tile) - ! set any -999s to +4C - call mn_replace_low_values(mn_static%deep_soil_temp_grid, -100.0, 277.0) - - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "soil_type", "soil_type", mn_static%soil_type_grid, parent_tile) - ! To match initialization behavior, set any -999s to 0 in soil_type - call mn_replace_low_values(mn_static%soil_type_grid, -100.0, 0.0) - - - !! TODO investigate reading high-resolution veg_frac and veg_greenness - !call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "", mn_static%veg_frac_grid) - - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "vegetation_type", "vegetation_type", mn_static%veg_type_grid, parent_tile) - ! To match initialization behavior, set any -999s to 0 in veg_type - call mn_replace_low_values(mn_static%veg_type_grid, -100.0, 0.0) - + ! Read static parent land sea mask fields + call mn_static_read_ls(mn_static%parent_ls, Atm(1)%npx, Atm(1)%npy, 1, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), parent_tile, Moving_nest(n)%mn_flag%terrain_smoother, filtered_terrain) - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "slope_type", "slope_type", mn_static%slope_type_grid, parent_tile) - ! To match initialization behavior, set any -999s to 0 in slope_type - call mn_replace_low_values(mn_static%slope_type_grid, -100.0, 0.0) + ! Read full panel + call mn_static_read_ls(mn_static%fp_ls, Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), parent_tile, Moving_nest(n)%mn_flag%terrain_smoother, filtered_terrain) + ! Read static nest land sea mask fields + call mn_static_read_ls(mn_static%nest_ls, Atm(2)%npx, Atm(2)%npy, 1, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir) // "/..", static_nest_num, Moving_nest(n)%mn_flag%terrain_smoother, filtered_terrain) - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "maximum_snow_albedo", "maximum_snow_albedo", mn_static%max_snow_alb_grid, parent_tile) - ! Set any -999s to 0.5 - call mn_replace_low_values(mn_static%max_snow_alb_grid, -100.0, 0.5) + !call validate_geo_coords("LAT", mn_static%fp_ls%geolat_grid, mn_static%nest_ls%geolat_grid, x_refine, ioffset, joffset) + !call validate_geo_coords("LON", mn_static%fp_ls%geolon_grid, mn_static%nest_ls%geolon_grid, x_refine, ioffset, joffset) - ! Albedo fraction -- read and calculate - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "facsf", "facsf", mn_static%facsf_grid, parent_tile) + !! Apply lakes to land mask based on land_frac and soil_type + call mn_apply_lakes(mn_static%parent_ls) + call mn_apply_lakes(mn_static%fp_ls) + call mn_apply_lakes(mn_static%nest_ls) - allocate(mn_static%facwf_grid(lbound(mn_static%facsf_grid,1):ubound(mn_static%facsf_grid,1),lbound(mn_static%facsf_grid,2):ubound(mn_static%facsf_grid,2))) + call mn_static_overwrite_ls_from_nest(mn_static%fp_ls, mn_static%nest_ls, x_refine, ioffset, joffset) - ! For land points, set facwf = 1.0 - facsf - ! To match initialization behavior, set any -999s to 0 - do i=lbound(mn_static%facsf_grid,1),ubound(mn_static%facsf_grid,1) - do j=lbound(mn_static%facsf_grid,2),ubound(mn_static%facsf_grid,2) - if (mn_static%facsf_grid(i,j) .lt. -100) then - mn_static%facsf_grid(i,j) = 0 - mn_static%facwf_grid(i,j) = 0 - else - mn_static%facwf_grid(i,j) = 1.0 - mn_static%facsf_grid(i,j) - endif - enddo - enddo - - ! Additional albedo variables - ! black sky = strong cosz -- direct sunlight - ! white sky = weak cosz -- diffuse light - - ! alvsf = visible strong cosz = visible_black_sky_albedo - ! alvwf = visible weak cosz = visible_white_sky_albedo - ! alnsf = near IR strong cosz = near_IR_black_sky_albedo - ! alnwf = near IR weak cosz = near_IR_white_sky_albedo - - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "snowfree_albedo", "visible_black_sky_albedo", mn_static%alvsf_grid, parent_tile, time=month) - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "snowfree_albedo", "visible_white_sky_albedo", mn_static%alvwf_grid, parent_tile, time=month) + ! Initialize the land sea mask (slmsk) in the mn_phys structure + ! Important this is done after adjusting for lakes! + call mn_phys_set_slmsk(Atm, n, mn_static, ioffset, joffset, x_refine) - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "snowfree_albedo", "near_IR_black_sky_albedo", mn_static%alnsf_grid, parent_tile, time=month) - call mn_static_read_hires(Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), "snowfree_albedo", "near_IR_white_sky_albedo", mn_static%alnwf_grid, parent_tile, time=month) + ! Read in full panel fix data + call mn_static_read_fix(mn_static%fp_fix, Atm(1)%npx, Atm(1)%npy, x_refine, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir), parent_tile, month) + ! Read in nest fix data + call mn_static_read_fix(mn_static%nest_fix, Atm(2)%npx, Atm(2)%npy, 1, Atm(2)%pelist, trim(Moving_nest(child_grid_num)%mn_flag%surface_dir) // "/..", static_nest_num, month) - ! Set the -999s to small value of 0.06, matching initialization code in chgres + ! Overwrite fix data from nest initialization + call mn_static_overwrite_fix_from_nest(mn_static%fp_fix, mn_static%nest_fix, x_refine, ioffset, joffset) - call mn_replace_low_values(mn_static%alvsf_grid, -100.0, 0.06) - call mn_replace_low_values(mn_static%alvwf_grid, -100.0, 0.06) - call mn_replace_low_values(mn_static%alnsf_grid, -100.0, 0.06) - call mn_replace_low_values(mn_static%alnwf_grid, -100.0, 0.06) + ! The nest static grids are only used for this step; can safely deallocate them now. + call deallocate_land_mask_grids(mn_static%nest_ls) + call deallocate_fix_grids(mn_static%nest_fix) endif @@ -1013,21 +1235,21 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd select case(Moving_nest(n)%mn_flag%terrain_smoother) case (0) ! High-resolution terrain for entire nest - Atm(n)%phis(isd:ied, jsd:jed) = mn_static%orog_grid((ioffset-1)*x_refine+isd:(ioffset-1)*x_refine+ied, (joffset-1)*y_refine+jsd:(joffset-1)*y_refine+jed) * grav + Atm(n)%phis(isd:ied, jsd:jed) = mn_static%fp_ls%orog_grid((ioffset-1)*x_refine+isd:(ioffset-1)*x_refine+ied, (joffset-1)*y_refine+jsd:(joffset-1)*y_refine+jed) * grav case (1) ! Static nest smoothing algorithm - interpolation of coarse terrain in halo zone and 5 point blending zone of coarse and fine data - call set_blended_terrain(Atm(n), mn_static%parent_orog_grid, mn_static%orog_grid, x_refine, Atm(n)%bd%ng, 5, a_step) + call set_blended_terrain(Atm(n), mn_static%parent_ls%orog_grid, mn_static%fp_ls%orog_grid, x_refine, Atm(n)%bd%ng, 5, a_step) case (2) ! Static nest smoothing algorithm - interpolation of coarse terrain in halo zone and 5 point blending zone of coarse and fine data - call set_blended_terrain(Atm(n), mn_static%parent_orog_grid, mn_static%orog_grid, x_refine, Atm(n)%bd%ng, 10, a_step) + call set_blended_terrain(Atm(n), mn_static%parent_ls%orog_grid, mn_static%fp_ls%orog_grid, x_refine, Atm(n)%bd%ng, 10, a_step) case (4) ! Use coarse terrain; no-op here. ; case (5) ! 5 pt smoother. blend zone of 5 to match static nest - call set_smooth_nest_terrain(Atm(n), mn_static%orog_grid, x_refine, 5, Atm(n)%bd%ng, 5) + call set_smooth_nest_terrain(Atm(n), mn_static%fp_ls%orog_grid, x_refine, 5, Atm(n)%bd%ng, 5) case (9) ! 9 pt smoother. blend zone of 5 to match static nest - call set_smooth_nest_terrain(Atm(n), mn_static%orog_grid, x_refine, 9, Atm(n)%bd%ng, 5) + call set_smooth_nest_terrain(Atm(n), mn_static%fp_ls%orog_grid, x_refine, 9, Atm(n)%bd%ng, 5) case default write (errstring, "(I0)") Moving_nest(n)%mn_flag%terrain_smoother call mpp_error(FATAL,'Invalid terrain_smoother in fv_moving_nest_main '//errstring) @@ -1045,8 +1267,8 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd !real, _ALLOCATABLE :: oro(:,:) _NULL !< land fraction (1: all land; 0: all water) !real, _ALLOCATABLE :: sgh(:,:) _NULL !< Terrain standard deviation - Atm(n)%oro(isc:iec, jsc:jec) = mn_static%land_frac_grid((ioffset-1)*x_refine+isc:(ioffset-1)*x_refine+iec, (joffset-1)*y_refine+jsc:(joffset-1)*y_refine+jec) - Atm(n)%sgh(isc:iec, jsc:jec) = mn_static%orog_std_grid((ioffset-1)*x_refine+isc:(ioffset-1)*x_refine+iec, (joffset-1)*y_refine+jsc:(joffset-1)*y_refine+jec) + Atm(n)%oro(isc:iec, jsc:jec) = mn_static%fp_ls%land_frac_grid((ioffset-1)*x_refine+isc:(ioffset-1)*x_refine+iec, (joffset-1)*y_refine+jsc:(joffset-1)*y_refine+jec) + Atm(n)%sgh(isc:iec, jsc:jec) = mn_static%fp_ls%orog_std_grid((ioffset-1)*x_refine+isc:(ioffset-1)*x_refine+iec, (joffset-1)*y_refine+jsc:(joffset-1)*y_refine+jec) endif call mn_phys_reset_sfc_props(Atm, n, mn_static, Atm_block, GFS_sfcprop, ioffset, joffset, x_refine) @@ -1080,6 +1302,27 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd !!===================================================================================== if (use_timers) call mpp_clock_begin (id_movnest7_3) + if (is_fine_pe) then + do i=isc,iec + do j=jsc,jec + + ! EMIS PATCH - Force to positive at all locations. + if (Moving_nest(n)%mn_phys%emis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_lnd(i,j) = 0.5 + if (Moving_nest(n)%mn_phys%emis_ice(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_ice(i,j) = 0.5 + if (Moving_nest(n)%mn_phys%emis_wat(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_wat(i,j) = 0.5 + if (Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) = 0.5 + if (Moving_nest(n)%mn_phys%albdirnir_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) = 0.5 + if (Moving_nest(n)%mn_phys%albdifvis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdifvis_lnd(i,j) = 0.5 + if (Moving_nest(n)%mn_phys%albdifnir_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdifnir_lnd(i,j) = 0.5 + + enddo + enddo + endif + + if (is_fine_pe) then + call mn_set_leading_edge(Moving_nest(child_grid_num)%mn_phys, isd, ied, jsd, jed, delta_i_c, delta_j_c) + endif + call mn_prog_apply_temp_variables(Atm, n, child_grid_num, is_fine_pe, npz) call mn_phys_apply_temp_variables(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd, GFS_cldprop, GFS_intdiag, n, child_grid_num, is_fine_pe, npz) @@ -1090,32 +1333,6 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd !! Step 8 -- Dump to netCDF !!============================================================================ - - if (is_fine_pe) then - do i=isc,iec - do j=jsc,jec - ! EMIS PATCH - Force to positive at all locations matching the landmask - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 1 .and. Moving_nest(n)%mn_phys%emis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_lnd(i,j) = 0.5 - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 2 .and. Moving_nest(n)%mn_phys%emis_ice(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_ice(i,j) = 0.5 - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 0 .and. Moving_nest(n)%mn_phys%emis_wat(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_wat(i,j) = 0.5 - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 1 .and. Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) = 0.5 - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 1 .and. Moving_nest(n)%mn_phys%albdirnir_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) = 0.5 - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 1 .and. Moving_nest(n)%mn_phys%albdifvis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdifvis_lnd(i,j) = 0.5 - !if (Moving_nest(n)%mn_phys%slmsk(i,j) .eq. 1 .and. Moving_nest(n)%mn_phys%albdifnir_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdifnir_lnd(i,j) = 0.5 - - ! EMIS PATCH - Force to positive at all locations. - if (Moving_nest(n)%mn_phys%emis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_lnd(i,j) = 0.5 - if (Moving_nest(n)%mn_phys%emis_ice(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_ice(i,j) = 0.5 - if (Moving_nest(n)%mn_phys%emis_wat(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%emis_wat(i,j) = 0.5 - if (Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) = 0.5 - if (Moving_nest(n)%mn_phys%albdirnir_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdirvis_lnd(i,j) = 0.5 - if (Moving_nest(n)%mn_phys%albdifvis_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdifvis_lnd(i,j) = 0.5 - if (Moving_nest(n)%mn_phys%albdifnir_lnd(i,j) .lt. 0.0) Moving_nest(n)%mn_phys%albdifnir_lnd(i,j) = 0.5 - - enddo - enddo - endif - output_step = output_step + 1 if (debug_sync) call mpp_sync(full_pelist) ! Used to make debugging easier. Can be removed. @@ -1154,20 +1371,4 @@ subroutine fv_moving_nest_exec(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_tbd end subroutine fv_moving_nest_exec - !>@brief The subroutine 'mn_replace_low_values' replaces low values with a default value. - subroutine mn_replace_low_values(data_grid, low_value, new_value) - real, _ALLOCATABLE, intent(inout) :: data_grid(:,:) !< 2D grid of data - real, intent(in) :: low_value !< Low value to check for; e.g. negative or fill value - real, intent(in) :: new_value !< Value to replace low value with - - integer :: i, j - - do i=lbound(data_grid,1),ubound(data_grid,1) - do j=lbound(data_grid,2),ubound(data_grid,2) - if (data_grid(i,j) .le. low_value) data_grid(i,j) = new_value - enddo - enddo - end subroutine mn_replace_low_values - end module fv_moving_nest_main_mod - diff --git a/fv3/moving_nest/fv_moving_nest_physics.F90 b/fv3/moving_nest/fv_moving_nest_physics.F90 index db06d18022..c7ead53b4f 100644 --- a/fv3/moving_nest/fv_moving_nest_physics.F90 +++ b/fv3/moving_nest/fv_moving_nest_physics.F90 @@ -112,13 +112,121 @@ module fv_moving_nest_physics_mod !! Persistent variables to enable debug printing after range warnings. !type (fv_atmos_type), pointer :: save_Atm_n !type (block_control_type), pointer :: save_Atm_block - !type(IPD_control_type), pointer :: save_IPD_Control - !type(IPD_data_type), pointer :: save_IDP_Data + !type(GFS_control_type), pointer :: save_GFS_control + !type(GFS_sfcprop_type), pointer :: save_GFS_sfcprop #include contains + subroutine mn_phys_apply_coarse_seaice(Atm, n, mn_static, ioffset, joffset, refine) + type(fv_atmos_type), intent(inout),allocatable :: Atm(:) !< Array of atmospheric data + integer, intent(in) :: n !< Current grid number + type(mn_surface_grids), intent(in) :: mn_static !< Static surface data + integer, intent(in) :: ioffset, joffset !< Current nest offset in i,j direction + integer, intent(in) :: refine !< Nest refinement ratio + + integer :: i_pe, j_pe ! indices of the nest on this PE + integer :: i_idx, j_idx + integer :: i_parent, j_parent ! parent indices + integer :: this_pe, halo + + integer :: i,j, num_seaice + + integer, parameter :: M_WATER = 0, M_LAND = 1, M_SEAICE = 2 + + this_pe = mpp_pe() + ! Should only be run for a fine PE + + !print '("[INFO] MASK BEGIN inside mn_phys_apply_coarse_seaice npe=",I0," n=",I0," refine=",I0," ioffset=",I0," joffset=",I0)', this_pe, n, refine, ioffset, joffset + ! Setup local land sea mask grid for masked interpolations + ! These are grid centers, not corners + + halo = 3 + + num_seaice = 0 + + do i = lbound(mn_static%parent_ls%ls_mask_grid,1), ubound(mn_static%parent_ls%ls_mask_grid,1) + do j = lbound(mn_static%parent_ls%ls_mask_grid,2), ubound(mn_static%parent_ls%ls_mask_grid,2) + if (mn_static%parent_ls%ls_mask_grid(i, j) .eq. M_SEAICE) num_seaice = num_seaice + 1 + enddo + enddo + + !print '("[INFO] MASK ICE npe=",I0," parent_ls num_seaice=",I0)',this_pe, num_seaice + + num_seaice = 0 + + do i = lbound(mn_static%fp_ls%ls_mask_grid,1), ubound(mn_static%fp_ls%ls_mask_grid,1) + do j = lbound(mn_static%fp_ls%ls_mask_grid,2), ubound(mn_static%fp_ls%ls_mask_grid,2) + if (mn_static%fp_ls%ls_mask_grid(i, j) .eq. M_SEAICE) num_seaice = num_seaice + 1 + enddo + enddo + + !print '("[INFO] MASK ICE npe=",I0," fp_ls num_seaice=",I0)',this_pe, num_seaice + + do i_pe = Atm(n)%bd%isd, Atm(n)%bd%ied + do j_pe = Atm(n)%bd%jsd, Atm(n)%bd%jed + i_idx = (ioffset-1)*refine + i_pe + j_idx = (joffset-1)*refine + j_pe + + ! Fortran integer division truncates the fractional parts + i_parent = ioffset + (i_pe + 3)/refine + j_parent = joffset + (j_pe + 3)/refine + if (Moving_nest(n)%mn_phys%slmsk(i_pe, j_pe) .eq. M_WATER) then + if (mn_static%parent_ls%ls_mask_grid(i_parent, j_parent) .eq. M_SEAICE) then + !print '("[INFO] WDR COARSE_SEAICE AA npe=",I0," i_pe=",I0," j_pe=",I0)', this_pe, i_pe, j_pe + Moving_nest(n)%mn_phys%slmsk(i_pe, j_pe) = M_SEAICE + !print '("[INFO] WDR COARSE_SEAICE ZZ npe=",I0," i_pe=",I0," j_pe=",I0)', this_pe, i_pe, j_pe + + !print '("[INFO] WDR COARSE_SEAICE Z1 npe=",I0," parent geolat_grid(",I0,"-",I0,",",I0,"-",I0,") i_parent=",I0," j_parent=",I0)', this_pe, lbound(mn_static%parent_ls%geolat_grid,1), ubound(mn_static%parent_ls%geolat_grid,1), lbound(mn_static%parent_ls%geolat_grid,2), ubound(mn_static%parent_ls%geolat_grid,2), i_parent, j_parent + + !print '("[INFO] WDR COARSE_SEAICE Z1 npe=",I0," fp geolat_grid(",I0,",",I0,")")', this_pe, ubound(mn_static%fp_ls%geolat_grid,1), ubound(mn_static%fp_ls%geolat_grid,2) + + !print '("[INFO] WDR COARSE_SEAICE Z1 npe=",I0," nest geolat_grid(",I0,"-",I0,",",I0,"-",I0,") i_pe=",I0," j_pe=",I0)', this_pe, lbound(mn_static%nest_ls%geolat_grid,1), ubound(mn_static%nest_ls%geolat_grid,1), lbound(mn_static%nest_ls%geolat_grid,2), ubound(mn_static%nest_ls%geolat_grid,2), i_pe, j_pe + + !if (i_pe .ge. lbound(mn_static%nest_ls%geolat_grid,1) .and. i_pe .le. ubound(mn_static%nest_ls%geolat_grid,1) .and. j_pe .ge. lbound(mn_static%nest_ls%geolat_grid,2) .and. j_pe .le. ubound(mn_static%nest_ls%geolat_grid,2) ) then + !print '("[INFO] WDR COARSE_SEAICE INSIDE npe=",I0," i_pe=",I0," j_pe=",I0)', this_pe, i_pe, j_pe + !print '("[INFO] WDR COARSE_SEAICE npe=",I0," parent latlon ",F8.3,","F8.3," nest latlon ",F8.3,","F8.3)', this_pe, & + ! mn_static%parent_ls%geolat_grid(i_parent, j_parent), mn_static%parent_ls%geolon_grid(i_parent, j_parent), & + ! mn_static%nest_ls%geolat_grid(i_pe, j_pe), mn_static%nest_ls%geolon_grid(i_pe, j_pe) + !endif + + + !print '("[INFO] WDR COARSE_SEAICE npe=",I0," parent cell ",F8.3,","F8.3," nest cell ",F8.3,","F8.3)', this_pe, & + ! mn_static%parent_ls%geolat_grid(i_parent, j_parent), mn_static%parent_ls%geolon_grid(i_parent, j_parent), & + ! mn_static%nest_ls%geolat_grid(i_parent, j_parent), mn_static%nest_ls%geolon_grid(i_parent, j_parent) + endif + endif + enddo + enddo + + !print '("[INFO] MASK END inside mn_phys_apply_coarse_seaice npe=",I0)', this_pe + + end subroutine mn_phys_apply_coarse_seaice + + + subroutine mn_phys_set_slmsk(Atm, n, mn_static, ioffset, joffset, refine) + type(fv_atmos_type), intent(inout),allocatable :: Atm(:) !< Array of atmospheric data + integer, intent(in) :: n !< Current grid number + type(mn_surface_grids), intent(in) :: mn_static !< Static surface data + integer, intent(in) :: ioffset, joffset !< Current nest offset in i,j direction + integer, intent(in) :: refine !< Nest refinement ratio + + integer :: i_pe, j_pe, i_idx, j_idx + + !print '("[INFO] MASK inside mn_phys_set_slmsk npe=",I0)', mpp_pe() + ! Setup local land sea mask grid for masked interpolations + do i_pe = Atm(n)%bd%isd, Atm(n)%bd%ied + do j_pe = Atm(n)%bd%jsd, Atm(n)%bd%jed + i_idx = (ioffset-1)*refine + i_pe + j_idx = (joffset-1)*refine + j_pe + + Moving_nest(n)%mn_phys%slmsk(i_pe, j_pe) = mn_static%fp_ls%ls_mask_grid(i_idx, j_idx) + enddo + enddo + end subroutine mn_phys_set_slmsk + + !>@brief The subroutine 'mn_phys_reset_sfc_props' sets the static surface parameters from the high-resolution input file data !>@details This subroutine relies on earlier code reading the data from files into the mn_static data structure !! This subroutine does not yet handle ice points or frac_grid - fractional landfrac/oceanfrac values @@ -131,20 +239,20 @@ subroutine mn_phys_reset_sfc_props(Atm, n, mn_static, Atm_block, GFS_Sfcprop, io integer, intent(in) :: ioffset, joffset !< Current nest offset in i,j direction integer, intent(in) :: refine !< Nest refinement ratio + integer, parameter :: M_WATER = 0, M_LAND = 1, M_SEAICE = 2 + ! For iterating through physics/surface vector data integer :: nb, blen, ix, i_pe, j_pe, i_idx, j_idx, im real(kind=kind_phys) :: phys_oro + integer :: cell_slmsk + integer :: this_pe - ! Setup local land sea mask grid for masked interpolations - do i_pe = Atm(n)%bd%isd, Atm(n)%bd%ied - do j_pe = Atm(n)%bd%jsd, Atm(n)%bd%jed - i_idx = (ioffset-1)*refine + i_pe - j_idx = (joffset-1)*refine + j_pe + this_pe = mpp_pe() - Moving_nest(n)%mn_phys%slmsk(i_pe, j_pe) = mn_static%ls_mask_grid(i_idx, j_idx) - enddo - enddo + !print '("[INFO] MASK inside mn_phys_reset_sfc_props npe=",I0)', mpp_pe() + call mn_phys_set_slmsk(Atm, n, mn_static, ioffset, joffset, refine) + call mn_phys_apply_coarse_seaice(Atm, n, mn_static, ioffset, joffset, refine) ! Reset the variables from the fix_sfc files im = 0 do nb = 1,Atm_block%nblks @@ -159,56 +267,75 @@ subroutine mn_phys_reset_sfc_props(Atm, n, mn_static, Atm_block, GFS_Sfcprop, io im = im + 1 ! Reset the land sea mask from the hires parent data - GFS_Sfcprop%slmsk(im) = mn_static%ls_mask_grid(i_idx, j_idx) + !GFS_Sfcprop%slmsk(im) = mn_static%fp_ls%ls_mask_grid(i_idx, j_idx) + cell_slmsk = Moving_nest(n)%mn_phys%slmsk(i_pe, j_pe) + GFS_Sfcprop%slmsk(im) = cell_slmsk ! IFD values are 0 for land, and 1 for oceans/lakes -- reverse of the land sea mask ! Land Sea Mask has values of 0 for oceans/lakes, 1 for land, 2 for sea ice ! TODO figure out what ifd should be for sea ice - if (mn_static%ls_mask_grid(i_idx, j_idx) .eq. 1 ) then + + ! ICEFIX + ! ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F + ! sli .. land/sea/sea-ice mask. (1/0/2 respectively) + ! Seems to be slimsk + + ! Process land-sea-ice mask points + + !if (mn_static%fp_ls%ls_mask_grid(i_idx, j_idx) .eq. M_LAND ) then ! Land + if (cell_slmsk .eq. M_LAND ) then ! Land if (move_nsst) GFS_Sfcprop%ifd(im) = 0 ! Land GFS_Sfcprop%oceanfrac(im) = 0 ! Land -- TODO permit fractions GFS_Sfcprop%landfrac(im) = 1 ! Land -- TODO permit fractions - else + GFS_Sfcprop%fice(im) = 0 ! ice fraction over open water grid + !else if (mn_static%fp_ls%ls_mask_grid(i_idx, j_idx) .eq. M_WATER ) then ! Ocean + else if (cell_slmsk .eq. M_WATER ) then ! Ocean if (move_nsst) GFS_Sfcprop%ifd(im) = 1 ! Ocean GFS_Sfcprop%oceanfrac(im) = 1 ! Ocean -- TODO permit fractions GFS_Sfcprop%landfrac(im) = 0 ! Ocean -- TODO permit fractions + GFS_Sfcprop%fice(im) = 0 ! ice fraction over open water grid + !else if (mn_static%fp_ls%ls_mask_grid(i_idx, j_idx) .eq. M_SEAICE ) then ! Sea Ice + else if (cell_slmsk .eq. M_SEAICE ) then ! Sea Ice + if (move_nsst) GFS_Sfcprop%ifd(im) = 0 ! For Sea ice - ifd is set to Land 0, checked in sfc files + GFS_Sfcprop%oceanfrac(im) = 0 ! sea ice -- TODO permit fractions + GFS_Sfcprop%landfrac(im) = 0 ! sea ice -- TODO permit fractions + GFS_Sfcprop%fice(im) = 1 ! ice fraction over open water grid endif - GFS_Sfcprop%tg3(im) = mn_static%deep_soil_temp_grid(i_idx, j_idx) + GFS_Sfcprop%tg3(im) = mn_static%fp_fix%deep_soil_temp_grid(i_idx, j_idx) - ! Follow logic from FV3/io/fv3atm_sfc_io.F90 + ! Follow logic from FV3/io/FV3GFS_io.F90 line 1187 ! TODO this will need to be more complicated if we support frac_grid !if (nint(mn_static%soil_type_grid(i_idx, j_idx)) == 14 .or. int(mn_static%soil_type_grid(i_idx, j_idx)+0.5) <= 0) then !if (nint(mn_static%soil_type_grid(i_idx, j_idx)) == 14 .or. !if ( (mn_static%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. nint(mn_static%land_frac_grid(i_idx, j_idx)) == 0) .or. & ! mn_static%soil_type_grid(i_idx, j_idx) < 0.5) then - if (mn_static%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. nint(mn_static%land_frac_grid(i_idx, j_idx)) == 0 ) then + if (mn_static%fp_ls%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. nint(mn_static%fp_ls%land_frac_grid(i_idx, j_idx)) == 0 ) then ! Water soil type == lake, etc. -- override the other variables and make this water - !!print '("mn_phys_reset_sfc_props LAKE SOIL npe=",I0," x,y=",I0,",",I0," lat=",F10.3," lon=",F10.3)', mpp_pe(), i_idx, j_idx, IPD_data(nb)%Grid%xlat_d(ix), IPD_data(nb)%Grid%xlon_d(ix)-360.0 if (move_nsst) GFS_Sfcprop%ifd(im) = 1 ! Ocean GFS_Sfcprop%oceanfrac(im) = 1 ! Ocean -- TODO permit fractions GFS_Sfcprop%landfrac(im) = 0 ! Ocean -- TODO permit fractions - GFS_Sfcprop%stype(im) = 0 + GFS_Sfcprop%stype(im) = 14 ! change from 0 to 14 to avoid index conflict with porosity GFS_Sfcprop%slmsk(im) = 0 else - GFS_Sfcprop%stype(im) = nint(mn_static%soil_type_grid(i_idx, j_idx)) + GFS_Sfcprop%stype(im) = nint(mn_static%fp_ls%soil_type_grid(i_idx, j_idx)) endif !GFS_Sfcprop%vfrac(im) = mn_static%veg_frac_grid(i_idx, j_idx) - GFS_Sfcprop%vtype(im) = nint(mn_static%veg_type_grid(i_idx, j_idx)) - GFS_Sfcprop%slope(im) = nint(mn_static%slope_type_grid(i_idx, j_idx)) - GFS_Sfcprop%snoalb(im) = mn_static%max_snow_alb_grid(i_idx, j_idx) + GFS_Sfcprop%vtype(im) = nint(mn_static%fp_fix%veg_type_grid(i_idx, j_idx)) + GFS_Sfcprop%slope(im) = nint(mn_static%fp_fix%slope_type_grid(i_idx, j_idx)) + GFS_Sfcprop%snoalb(im) = mn_static%fp_fix%max_snow_alb_grid(i_idx, j_idx) - GFS_Sfcprop%facsf(im) = mn_static%facsf_grid(i_idx, j_idx) - GFS_Sfcprop%facwf(im) = mn_static%facwf_grid(i_idx, j_idx) + GFS_Sfcprop%facsf(im) = mn_static%fp_fix%facsf_grid(i_idx, j_idx) + GFS_Sfcprop%facwf(im) = mn_static%fp_fix%facwf_grid(i_idx, j_idx) - GFS_Sfcprop%alvsf(im) = mn_static%alvsf_grid(i_idx, j_idx) - GFS_Sfcprop%alvwf(im) = mn_static%alvwf_grid(i_idx, j_idx) - GFS_Sfcprop%alnsf(im) = mn_static%alnsf_grid(i_idx, j_idx) - GFS_Sfcprop%alnwf(im) = mn_static%alnwf_grid(i_idx, j_idx) + GFS_Sfcprop%alvsf(im) = mn_static%fp_fix%alvsf_grid(i_idx, j_idx) + GFS_Sfcprop%alvwf(im) = mn_static%fp_fix%alvwf_grid(i_idx, j_idx) + GFS_Sfcprop%alnsf(im) = mn_static%fp_fix%alnsf_grid(i_idx, j_idx) + GFS_Sfcprop%alnwf(im) = mn_static%fp_fix%alnwf_grid(i_idx, j_idx) ! Reset the orography in the physics arrays, using the smoothed values from above phys_oro = Atm(n)%phis(i_pe, j_pe) / grav @@ -315,13 +442,14 @@ subroutine mn_phys_fill_temp_variables(Atm, Atm_block, GFS_control, GFS_sfcprop, integer :: nb, blen, i, j, k, ix, nv, im type(fv_moving_nest_physics_type), pointer :: mn_phys + integer :: err_field = 0 this_pe = mpp_pe() !save_Atm_n => Atm(n) !save_Atm_block => Atm_block !save_GFS_control => GFS_control - !save_IPD_Data => IPD_Data + !save_GFS_sfcprop => GFS_sfcprop isd = Atm(n)%bd%isd ied = Atm(n)%bd%ied @@ -436,6 +564,70 @@ subroutine mn_phys_fill_temp_variables(Atm, Atm_block, GFS_control, GFS_sfcprop, mn_phys%dt_cool(i,j)= GFS_sfcprop%dt_cool(im) mn_phys%qrain(i,j) = GFS_sfcprop%qrain(im) endif + + if (GFS_control%lsm == GFS_control%lsm_noahmp) then + mn_phys%soilcolor(i,j) = GFS_sfcprop%scolor(im) + mn_phys%snowxy(i,j) = GFS_sfcprop%snowxy(im) + !if (i .eq. 149 .and. j .eq. 169) print '("[INFO] WDR SNOWXY MASK2D npe=",I0," i=",I0," j=",I0," snowxy=",E10.5)', this_pe, i, j, mn_phys%snowxy(i,j) + + + mn_phys%tvxy(i,j) = GFS_sfcprop%tvxy(im) + mn_phys%tgxy(i,j) = GFS_sfcprop%tgxy(im) + mn_phys%canicexy(i,j) = GFS_sfcprop%canicexy(im) + mn_phys%canliqxy(i,j) = GFS_sfcprop%canliqxy(im) + mn_phys%eahxy(i,j) = GFS_sfcprop%eahxy(im) + mn_phys%tahxy(i,j) = GFS_sfcprop%tahxy(im) + mn_phys%cmxy(i,j) = GFS_sfcprop%cmxy(im) + mn_phys%chxy(i,j) = GFS_sfcprop%chxy(im) + mn_phys%fwetxy(i,j) = GFS_sfcprop%fwetxy(im) + mn_phys%sneqvoxy(i,j) = GFS_sfcprop%sneqvoxy(im) + mn_phys%alboldxy(i,j) = GFS_sfcprop%alboldxy(im) + mn_phys%qsnowxy(i,j) = GFS_sfcprop%qsnowxy(im) + mn_phys%wslakexy(i,j) = GFS_sfcprop%wslakexy(im) + mn_phys%zwtxy(i,j) = GFS_sfcprop%zwtxy(im) + mn_phys%waxy(i,j) = GFS_sfcprop%waxy(im) + mn_phys%wtxy(i,j) = GFS_sfcprop%wtxy(im) + mn_phys%lfmassxy(i,j) = GFS_sfcprop%lfmassxy(im) + mn_phys%rtmassxy(i,j) = GFS_sfcprop%rtmassxy(im) + mn_phys%stmassxy(i,j) = GFS_sfcprop%stmassxy(im) + mn_phys%woodxy(i,j) = GFS_sfcprop%woodxy(im) + mn_phys%stblcpxy(i,j) = GFS_sfcprop%stblcpxy(im) + mn_phys%fastcpxy(i,j) = GFS_sfcprop%fastcpxy(im) + mn_phys%xsaixy(i,j) = GFS_sfcprop%xsaixy(im) + mn_phys%xlaixy(i,j) = GFS_sfcprop%xlaixy(im) + mn_phys%taussxy(i,j) = GFS_sfcprop%taussxy(im) + mn_phys%smcwtdxy(i,j) = GFS_sfcprop%smcwtdxy(im) + mn_phys%deeprechxy(i,j) = GFS_sfcprop%deeprechxy(im) + mn_phys%rechxy(i,j) = GFS_sfcprop%rechxy(im) + + do k = 1, GFS_control%lsoil + mn_phys%smoiseq(i,j,k) = GFS_sfcprop%smoiseq(im,k) + enddo + + ! lsnow_lsm_lbound is a negative value, lsnow_ubound is usually 0 + do k = GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound + mn_phys%snicexy(i,j,k) = GFS_sfcprop%snicexy(im,k) + mn_phys%snliqxy(i,j,k) = GFS_sfcprop%snliqxy(im,k) + mn_phys%tsnoxy(i,j,k) = GFS_sfcprop%tsnoxy(im,k) + enddo + + ! ICEFIX handle tiice + do k = 1, GFS_control%kice + mn_phys%tiice(i,j,k) = GFS_sfcprop%tiice(im,k) + enddo + mn_phys%tisfc(i,j) = GFS_sfcprop%tisfc(im) + mn_phys%sncovr(i,j) = GFS_sfcprop%sncovr(im) + + mn_phys%fice(i,j) = GFS_sfcprop%fice(im) + mn_phys%hice(i,j) = GFS_sfcprop%hice(im) + + mn_phys%snowd(i,j) = GFS_sfcprop%snowd(im) + mn_phys%weasd(i,j) = GFS_sfcprop%weasd(im) + + do k = GFS_control%lsnow_lsm_lbound, GFS_control%lsoil + mn_phys%zsnsoxy(i,j,k) = GFS_sfcprop%zsnsoxy(im,k) + enddo + endif enddo enddo @@ -459,10 +651,23 @@ subroutine mn_phys_apply_temp_variables(Atm, Atm_block, GFS_control, GFS_sfcprop integer :: is, ie, js, je integer :: this_pe integer :: nb, blen, i, j ,k, ix, nv, im + integer :: isnow !local for Noah MP + real(kind=kind_phys) :: dzs(1:4) !local for Noah MP + real(kind=kind_phys) :: dzsno(-2:0) !local for Noah MP + real(kind=kind_phys) :: dzsnso(-2:4) !local for Noah MP + real(kind=kind_phys) :: porosity(1:19) !local for Noah MP + real(kind=kind_phys) :: zsns_default(-2:4) !local for Noah MP type(fv_moving_nest_physics_type), pointer :: mn_phys this_pe = mpp_pe() mn_phys => Moving_nest(n)%mn_phys + dzs = (/0.1,0.3,0.6,1.0/) ! 4 layer soil thickness + dzsno = (/0.0,0.0,0.0/) ! 3 snow layer thichness + dzsnso = (/0.0,0.0,0.0,0.1,0.3,0.6,1.0/) ! dzs + dzsno + porosity = (/0.339,0.421,0.434,0.476,0.484,0.439,0.404,0.464, & + 0.465,0.406,0.468,0.468,0.439,1.000,0.200,0.421, & + 0.468,0.200,0.339/) + zsns_default = (/0.0, 0.0, 0.0, -0.1,-0.4,-1.0,-2.0 /) !depths from snow surface ! Needed to fill the local grids for parent and nest PEs in order to transmit/interpolate data from parent to nest ! But only the nest PE's have changed the values with nest motion, so they are the only ones that need to update the original arrays @@ -633,24 +838,180 @@ subroutine mn_phys_apply_temp_variables(Atm, Atm_block, GFS_control, GFS_sfcprop GFS_sfcprop%qrain(im) = mn_phys%qrain(i,j) endif - ! Check if stype and vtype are properly set for land points. Set to reasonable values if they have fill values. - if ( (int(GFS_sfcprop%slmsk(im)) .eq. 1) ) then + if (GFS_control%lsm == GFS_control%lsm_noahmp) then + + GFS_sfcprop%scolor(im) = mn_phys%soilcolor(i,j) + GFS_sfcprop%tvxy(im) = mn_phys%tvxy(i,j) + GFS_sfcprop%tgxy(im) = mn_phys%tgxy(i,j) + GFS_sfcprop%canicexy(im) = mn_phys%canicexy(i,j) + GFS_sfcprop%canliqxy(im) = mn_phys%canliqxy(i,j) + GFS_sfcprop%eahxy(im) = mn_phys%eahxy(i,j) + GFS_sfcprop%tahxy(im) = mn_phys%tahxy(i,j) + GFS_sfcprop%cmxy(im) = mn_phys%cmxy(i,j) + GFS_sfcprop%chxy(im) = mn_phys%chxy(i,j) + GFS_sfcprop%fwetxy(im) = mn_phys%fwetxy(i,j) + GFS_sfcprop%sneqvoxy(im) = mn_phys%sneqvoxy(i,j) + GFS_sfcprop%alboldxy(im) = mn_phys%alboldxy(i,j) + GFS_sfcprop%qsnowxy(im) = mn_phys%qsnowxy(i,j) + GFS_sfcprop%wslakexy(im) = mn_phys%wslakexy(i,j) + GFS_sfcprop%zwtxy(im) = mn_phys%zwtxy(i,j) + GFS_sfcprop%waxy(im) = mn_phys%waxy(i,j) + GFS_sfcprop%wtxy(im) = mn_phys%wtxy(i,j) + GFS_sfcprop%lfmassxy(im) = mn_phys%lfmassxy(i,j) + GFS_sfcprop%rtmassxy(im) = mn_phys%rtmassxy(i,j) + GFS_sfcprop%stmassxy(im) = mn_phys%stmassxy(i,j) + GFS_sfcprop%woodxy(im) = mn_phys%woodxy(i,j) + GFS_sfcprop%stblcpxy(im) = mn_phys%stblcpxy(i,j) + GFS_sfcprop%fastcpxy(im) = mn_phys%fastcpxy(i,j) + GFS_sfcprop%xsaixy(im) = mn_phys%xsaixy(i,j) + GFS_sfcprop%xlaixy(im) = mn_phys%xlaixy(i,j) + GFS_sfcprop%taussxy(im) = mn_phys%taussxy(i,j) + GFS_sfcprop%smcwtdxy(im) = mn_phys%smcwtdxy(i,j) + GFS_sfcprop%deeprechxy(im) = mn_phys%deeprechxy(i,j) + GFS_sfcprop%rechxy(im) = mn_phys%rechxy(i,j) + GFS_sfcprop%snowd(im) = mn_phys%snowd(i,j) + GFS_sfcprop%weasd(im) = mn_phys%weasd(i,j) + + if (GFS_sfcprop%snowd(im) == 0.0 .and. GFS_sfcprop%weasd(im) /= 0.0) then + GFS_sfcprop%snowd(im) = GFS_sfcprop%weasd(im)/10.0 + endif + + ! ICEFIX handle tiice + do k = 1, GFS_control%kice + GFS_sfcprop%tiice(im,k) = mn_phys%tiice(i,j,k) + enddo + if (mn_phys%tisfc(i,j) .lt. 240.0 .or. mn_phys%tisfc(i,j) .gt. 285.0 ) then + mn_phys%tisfc(i,j) = 273.15 - 5.0 + endif + GFS_sfcprop%tisfc(im) = mn_phys%tisfc(i,j) + GFS_sfcprop%sncovr(im) = mn_phys%sncovr(i,j) + GFS_sfcprop%fice(im) = mn_phys%fice(i,j) + GFS_sfcprop%hice(im) = mn_phys%hice(i,j) + + + + do k = 1, GFS_control%lsoil + GFS_sfcprop%smoiseq(im,k) = mn_phys%smoiseq(i,j,k) + enddo + + do k = 1, GFS_control%lsoil + GFS_sfcprop%smc(im,k) = min(GFS_sfcprop%smc(im,k),porosity(GFS_sfcprop%stype(im))-0.01) + GFS_sfcprop%slc(im,k) = min(GFS_sfcprop%slc(im,k),porosity(GFS_sfcprop%stype(im))-0.01) + enddo + + if (GFS_sfcprop%vtype(im) == 15) then ! glacier + do k = 1,GFS_control%lsoil + GFS_sfcprop%stc(im,k) = min(mn_phys%stc(i,j,k), min(GFS_Sfcprop%tg3(im), 263.15)) + GFS_sfcprop%smc(im,k) = 1.0 + GFS_sfcprop%slc(im,k) = 0.0 + enddo + GFS_sfcprop%weasd(im) = 600.0 ! 600mm SWE for glacier + GFS_sfcprop%snowd(im) = 2000.0 ! 2m snow depth for glacier, snowd/snwdph is in mm + endif + + if (mn_phys%leading_edge(i,j) == .True. .and. GFS_sfcprop%snowd(im) < 99999.0) then ! new land with snow + if (GFS_sfcprop%snowd(im)/1000.0 < 0.025) then + GFS_sfcprop%snowxy(im) = 0.0 + dzsno(-2:0) = 0.0 + elseif (GFS_sfcprop%snowd(im)/1000.0 >= 0.025 .and. GFS_sfcprop%snowd(im)/1000.0 <= 0.05) then + GFS_sfcprop%snowxy(im) = -1.0 + dzsno(0) = GFS_sfcprop%snowd(im)/1000.0 + elseif (GFS_sfcprop%snowd(im)/1000.0 > 0.05 .and. GFS_sfcprop%snowd(im)/1000.0 <= 0.10) then + GFS_sfcprop%snowxy(im) = -2.0 + dzsno(-1) = 0.5*GFS_sfcprop%snowd(im)/1000.0 + dzsno(0) = 0.5*GFS_sfcprop%snowd(im)/1000.0 + elseif (GFS_sfcprop%snowd(im)/1000.0> 0.10 .and. GFS_sfcprop%snowd(im)/1000.0 <= 0.25) then + GFS_sfcprop%snowxy(im) = -2.0 + dzsno(-1) = 0.05 + dzsno(0) = GFS_sfcprop%snowd(im)/1000.0 - 0.05 + elseif (GFS_sfcprop%snowd(im)/1000.0 > 0.25 .and. GFS_sfcprop%snowd(im)/1000.0 <= 0.45) then + GFS_sfcprop%snowxy(im) = -3.0 + dzsno(-2) = 0.05 + dzsno(-1) = 0.5*(GFS_sfcprop%snowd(im)/1000.0-0.05) + dzsno(0) = 0.5*(GFS_sfcprop%snowd(im)/1000.0-0.05) + elseif (GFS_sfcprop%snowd(im)/1000.0 > 0.45) then + GFS_sfcprop%snowxy(im) = -3.0 + dzsno(-2) = 0.05 + dzsno(-1) = 0.20 + dzsno(0) = GFS_sfcprop%snowd(im)/1000.0 - 0.05 - 0.20 + else + write(*,*) 'Error in fv_moving_nest_physics.F90 - Problem with the logic assigning snow layers' + stop + endif + isnow = nint(GFS_sfcprop%snowxy(im)) + 1 + do k = isnow, GFS_control%lsnow_lsm_ubound + GFS_sfcprop%tsnoxy(im,k) = GFS_sfcprop%tgxy(im) + ( (sum(dzsno(isnow:k))-0.5*dzsno(k)) / \ + GFS_sfcprop%snowd(im)/1000.0 ) * (GFS_sfcprop%stc(im,1)-GFS_sfcprop%tgxy(im)) + GFS_sfcprop%snliqxy(im,k) = 0.0 + GFS_sfcprop%snicexy(im,k) = 1.0 * dzsno(k) * GFS_sfcprop%weasd(im)/GFS_sfcprop%snowd(im) + enddo + do k = isnow,GFS_control%lsnow_lsm_ubound + dzsnso(k) = -dzsno(k) + enddo + do k = 1, GFS_control%lsoil + dzsnso(k) = -dzs(k) + enddo + GFS_sfcprop%zsnsoxy(im,isnow) = dzsnso(isnow) + + do k = isnow + 1, GFS_control%lsoil + GFS_sfcprop%zsnsoxy(im, k) = GFS_sfcprop%zsnsoxy(im,k-1) + dzsnso(k) + enddo + else ! internal moving land points + GFS_sfcprop%snowxy(im) = mn_phys%snowxy(i,j) + isnow = nint(GFS_sfcprop%snowxy(im)) + 1 + if (abs(isnow) < GFS_control%lsoil) then ! only isnow /= fill value + do k = GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound + GFS_sfcprop%snicexy(im,k) = mn_phys%snicexy(i,j,k) + GFS_sfcprop%snliqxy(im,k) = mn_phys%snliqxy(i,j,k) + GFS_sfcprop%tsnoxy(im,k) = mn_phys%tsnoxy(i,j,k) + enddo + do k = isnow, GFS_control%lsoil + GFS_sfcprop%zsnsoxy(im,k) = mn_phys%zsnsoxy(i,j,k) + enddo + endif + ! reset snow-related fields over the old glacier points to be consistent with the new glacier land points + ! for the next iteration + if (GFS_sfcprop%vtype(im) == 15) then + GFS_sfcprop%snowxy(im) = -3.0 + dzsno(-2) = 0.05 + dzsno(-1) = 0.20 + dzsno(0) = 2.0 - 0.05 - 0.20 + isnow = -2 + do k = isnow, GFS_control%lsnow_lsm_ubound + GFS_sfcprop%tsnoxy(im,k) = GFS_sfcprop%tgxy(im) + ( (sum(dzsno(isnow:k))-0.5*dzsno(k)) / \ + GFS_sfcprop%snowd(im)/1000.0 ) * (GFS_sfcprop%stc(im,1)-GFS_sfcprop%tgxy(im)) + GFS_sfcprop%snliqxy(im,k) = 0.0 + GFS_sfcprop%snicexy(im,k) = 1.0 * dzsno(k) * GFS_sfcprop%weasd(im)/GFS_sfcprop%snowd(im) + enddo + do k = isnow, GFS_control%lsnow_lsm_ubound + dzsnso(k) = -dzsno(k) + enddo + do k = 1, GFS_control%lsoil + dzsnso(k) = -dzs(k) + enddo + GFS_sfcprop%zsnsoxy(im,isnow) = dzsnso(isnow) + do k = isnow + 1, GFS_control%lsoil + GFS_sfcprop%zsnsoxy(im, k) = GFS_sfcprop%zsnsoxy(im,k-1) + dzsnso(k) + enddo + endif + endif + endif + + ! Check if stype and vtype are properly set for land points. Set to reasonable values if they have fill values. + if ( (int(GFS_sfcprop%slmsk(im)) .eq. 1) ) then if (GFS_sfcprop%vtype(im) .lt. 0.5) then GFS_sfcprop%vtype(im) = 7 ! Force to grassland endif - if (GFS_sfcprop%stype(im) .lt. 0.5) then GFS_sfcprop%stype(im) = 3 ! Force to sandy loam endif - if (GFS_sfcprop%vtype_save(im) .lt. 0.5) then GFS_sfcprop%vtype_save(im) = 7 ! Force to grassland endif if (GFS_sfcprop%stype_save(im) .lt. 0.5) then GFS_sfcprop%stype_save(im) = 3 ! Force to sandy loam endif - endif enddo enddo @@ -675,6 +1036,21 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c integer :: x_refine, y_refine type(fv_moving_nest_physics_type), pointer :: mn_phys + integer, parameter :: M_WATER = 0, M_LAND = 1, M_SEAICE = 2 + !! For NOAHMP + ! (/0.0, 0.0, 0.0, 0.1,0.4,1.0,2.0/) -- 3 snow levels, 4 soil levels + ! TODO make this more flexible for number of snow and soil levels + !do k = GFS_control%lsnow_lsm_lbound, GFS_control%lsoil + real(kind=kind_phys) :: zsns_default(-2:4) + + if (GFS_control%lsm == GFS_control%lsm_noahmp) then + zsns_default = [0.0, 0.0, 0.0, -0.1,-0.4,-1.0,-2.0 ] + else + ! Expect that zsns_default is not used in this case, but just to be safe, set to 0 + zsns_default = 0.0 + endif + + interp_type = 1 ! cell-centered A-grid interp_type_u = 4 ! D-grid interp_type_v = 4 ! D-grid @@ -697,18 +1073,21 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c is_fine_pe, nest_domain, position) if (move_physics) then - call fill_nest_halos_from_parent("smc", mn_phys%smc, interp_type, Atm(child_grid_num)%neststruct%wt_h, & + ! Default - Arbitrary value 0.3 + call fill_nest_halos_from_parent_masked("smc", mn_phys%smc, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, GFS_control%lsoil) - call fill_nest_halos_from_parent("stc", mn_phys%stc, interp_type, Atm(child_grid_num)%neststruct%wt_h, & + is_fine_pe, nest_domain, position, 1, GFS_Control%lsoil, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.3D0) + ! Defaults - use surface temperature to set soil temperature at each level + call fill_nest_halos_from_parent_masked("stc", mn_phys%stc, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, GFS_control%lsoil) - call fill_nest_halos_from_parent("slc", mn_phys%slc, interp_type, Atm(child_grid_num)%neststruct%wt_h, & + is_fine_pe, nest_domain, position, 1, GFS_Control%lsoil, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, mn_phys%ts) + ! Default - Arbitrary value 0.3 + call fill_nest_halos_from_parent_masked("slc", mn_phys%slc, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, GFS_control%lsoil) + is_fine_pe, nest_domain, position, 1, GFS_Control%lsoil, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.3D0) call fill_nest_halos_from_parent("phy_f2d", mn_phys%phy_f2d, interp_type, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & @@ -728,21 +1107,22 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c ! is_fine_pe, nest_domain, position) ! sea/land mask array (sea:0,land:1,sea-ice:2) + !integer, parameter :: M_WATER = 0, M_LAND = 1, M_SEAICE = 2 call fill_nest_halos_from_parent_masked("emis_lnd", mn_phys%emis_lnd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 1, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.5D0) call fill_nest_halos_from_parent_masked("emis_ice", mn_phys%emis_ice, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 2, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_SEAICE, 0.5D0) call fill_nest_halos_from_parent_masked("emis_wat", mn_phys%emis_wat, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 0, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_WATER, 0.5D0) !call fill_nest_halos_from_parent("sfalb_lnd_bck", mn_phys%sfalb_lnd_bck, interp_type, Atm(child_grid_num)%neststruct%wt_h, & ! Atm(child_grid_num)%neststruct%ind_h, & @@ -791,14 +1171,23 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c x_refine, y_refine, & is_fine_pe, nest_domain, position) - call fill_nest_halos_from_parent("canopy", mn_phys%canopy, interp_type, Atm(child_grid_num)%neststruct%wt_h, & - Atm(child_grid_num)%neststruct%ind_h, & - x_refine, y_refine, & - is_fine_pe, nest_domain, position) - call fill_nest_halos_from_parent("vegfrac", mn_phys%vegfrac, interp_type, Atm(child_grid_num)%neststruct%wt_h, & - Atm(child_grid_num)%neststruct%ind_h, & - x_refine, y_refine, & - is_fine_pe, nest_domain, position) +! call fill_nest_halos_from_parent("canopy", mn_phys%canopy, interp_type, Atm(child_grid_num)%neststruct%wt_h, & +! Atm(child_grid_num)%neststruct%ind_h, & +! x_refine, y_refine, & +! is_fine_pe, nest_domain, position) +! call fill_nest_halos_from_parent("vegfrac", mn_phys%vegfrac, interp_type, Atm(child_grid_num)%neststruct%wt_h, & +! Atm(child_grid_num)%neststruct%ind_h, & +! x_refine, y_refine, & +! is_fine_pe, nest_domain, position) + call fill_nest_halos_from_parent_masked("canopy", mn_phys%canopy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + call fill_nest_halos_from_parent_masked("vegfrac", mn_phys%vegfrac, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.50D0) + + + call fill_nest_halos_from_parent("uustar", mn_phys%uustar, interp_type, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & @@ -819,24 +1208,24 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c call fill_nest_halos_from_parent_masked("zorll", mn_phys%zorll, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 1, 86.0D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, 1, 86.0D0) call fill_nest_halos_from_parent_masked("zorlwav", mn_phys%zorlwav, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 0, 77.0D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, 0, 77.0D0) call fill_nest_halos_from_parent_masked("zorlw", mn_phys%zorlw, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 0, 78.0D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, 0, 78.0D0) call fill_nest_halos_from_parent_masked("usfco", mn_phys%usfco, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 0, 0.0D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, 0, 0.0D0) call fill_nest_halos_from_parent_masked("vsfco", mn_phys%vsfco, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 0, 0.0D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, 0, 0.0D0) call fill_nest_halos_from_parent("tsfco", mn_phys%tsfco, interp_type, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & @@ -854,19 +1243,19 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c call fill_nest_halos_from_parent_masked("albdirvis_lnd", mn_phys%albdirvis_lnd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 1, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.5D0) call fill_nest_halos_from_parent_masked("albdirnir_lnd", mn_phys%albdirnir_lnd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 1, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.5D0) call fill_nest_halos_from_parent_masked("albdifvis_lnd", mn_phys%albdifvis_lnd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 1, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.5D0) call fill_nest_halos_from_parent_masked("albdifnir_lnd", mn_phys%albdifnir_lnd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & Atm(child_grid_num)%neststruct%ind_h, & x_refine, y_refine, & - is_fine_pe, nest_domain, position, mn_phys%slmsk, 1, 0.5D0) + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.5D0) @@ -957,6 +1346,208 @@ subroutine mn_phys_fill_nest_halos_from_parent(Atm, GFS_control, mn_static, n, c endif + if (move_physics .and. GFS_control%lsm == GFS_control%lsm_noahmp) then + + !integer, parameter :: M_WATER = 0, M_LAND = 1, M_SEAICE = 2 + + ! Land Sea Mask has values of 0 for oceans/lakes, 1 for land, 2 for sea ice + + ! Soil color. Default is set to sandy soil/desert 1, which seems appropriate for isolated islands + ! Reference: https://www.jsg.utexas.edu/noah-mp/files/Users_Guide_v0.pdf + ! Default changed to 10 based on suggestion from Mike Barlage; more middle of the spectrum value. + call fill_nest_halos_from_parent_masked("soilcol", mn_phys%soilcolor, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 10.0D0) + + call fill_nest_halos_from_parent_masked("snowxy", mn_phys%snowxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + call fill_nest_halos_from_parent_masked("tvxy", mn_phys%tvxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, mn_phys%ts) + call fill_nest_halos_from_parent_masked("tgxy", mn_phys%tgxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, mn_phys%ts) + + call fill_nest_halos_from_parent_masked("canicexy", mn_phys%canicexy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + call fill_nest_halos_from_parent_masked("canliqxy", mn_phys%canliqxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + call fill_nest_halos_from_parent_masked("eahxy", mn_phys%eahxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 2000.0D0) + + call fill_nest_halos_from_parent_masked("tahxy", mn_phys%tahxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, mn_phys%ts) + + ! TODO get realistic default value here -- bulk momentum drag coefficient + call fill_nest_halos_from_parent_masked("cmxy", mn_phys%cmxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 2.4D-3) + + ! TODO get realistic default value here -- bulk sensible heat drag coefficient + call fill_nest_halos_from_parent_masked("chxy", mn_phys%chxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 2.4D-3) + + ! wetted or snowed fraction of the canopy + call fill_nest_halos_from_parent_masked("fwetxy", mn_phys%fwetxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! snow mass at last time step[mm h2o] + call fill_nest_halos_from_parent_masked("sneqvoxy", mn_phys%sneqvoxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! Albedo assuming deep snow on prev timestep - default to 0.65 + call fill_nest_halos_from_parent_masked("alboldxy", mn_phys%alboldxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.65D0) + + ! Liquid equivalent snow - default to 0 + call fill_nest_halos_from_parent_masked("qsnowxy", mn_phys%qsnowxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! Lake water storage [mm] -- TODO find better default + call fill_nest_halos_from_parent_masked("wslakexy", mn_phys%wslakexy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! Water table depth - set to 2.5, cold start value + call fill_nest_halos_from_parent_masked("zwtxy", mn_phys%zwtxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 2.5D0) + + ! Water storage in aquifer - set to 4900.0, cold start value + call fill_nest_halos_from_parent_masked("waxy", mn_phys%waxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 4900.0D0) + ! Water storage in aquifer and saturated soil - set to 4900.0, cold start value + call fill_nest_halos_from_parent_masked("wtxy", mn_phys%wtxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 4900.0D0) + + + ! Leaf mass [g/m2] -- TODO find better default + call fill_nest_halos_from_parent_masked("lfmassxy", mn_phys%lfmassxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + ! Fine root mass [g/m2] -- TODO find better default + call fill_nest_halos_from_parent_masked("rtmassxy", mn_phys%rtmassxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + ! Stem mass [g/m2] -- TODO find better default + call fill_nest_halos_from_parent_masked("stmassxy", mn_phys%stmassxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + ! Wood mass [g/m2] -- TODO find better default + call fill_nest_halos_from_parent_masked("woodxy", mn_phys%woodxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! stable carbon in deep soil [g/m2] -- TODO find a better default + call fill_nest_halos_from_parent_masked("stblcpxy", mn_phys%stblcpxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + ! short-lived carbon, shallow soil [g/m2] -- TODO find a better default + call fill_nest_halos_from_parent_masked("fastcpxy", mn_phys%fastcpxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! stem area index [m2/m2] -- TODO find a better default + call fill_nest_halos_from_parent_masked("xsaixy", mn_phys%xsaixy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + ! leaf area index [m2/m2] -- TODO find a better default + call fill_nest_halos_from_parent_masked("xlaixy", mn_phys%xlaixy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! snow age factor [-] -- TODO find a better default + call fill_nest_halos_from_parent_masked("taussxy", mn_phys%taussxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! soil moisture content in the layer to the water table when deep -- TODO find a better default + call fill_nest_halos_from_parent_masked("smcwtdxy", mn_phys%smcwtdxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! recharge to the water table when deep -- TODO find a better default + call fill_nest_halos_from_parent_masked("deeprechxy", mn_phys%deeprechxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + ! recharge to the water table -- TODO find a better default + call fill_nest_halos_from_parent_masked("rechxy", mn_phys%rechxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + call fill_nest_halos_from_parent_masked("snicexy", mn_phys%snicexy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound, & + mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + call fill_nest_halos_from_parent_masked("snliqxy", mn_phys%snliqxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound, & + mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! surface snow thickness water equivalent over land - - default to 0 + call fill_nest_halos_from_parent_masked("snowd", mn_phys%snowd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! Temperature in surface snow -- TODO notes say default to 0, but I will put 273.15K + call fill_nest_halos_from_parent_masked("tsnoxy", mn_phys%tsnoxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound, & + !mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 273.15D0) + mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + ! water equivalent accumulated snow depth over land - - default to 0 + call fill_nest_halos_from_parent_masked("weasd", mn_phys%weasd, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + call fill_nest_halos_from_parent_masked("smoiseq", mn_phys%smoiseq, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, & + x_refine, y_refine, & + is_fine_pe, nest_domain, position, 1, GFS_control%lsoil, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.3D0) + + + call fill_nest_halos_from_parent_masked("zsnsoxy", mn_phys%zsnsoxy, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsoil, & + mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, zsns_default) + + + ! ICEFIX tiice + call fill_nest_halos_from_parent_masked("tiice", mn_phys%tiice, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, 1, 2, & !! kice + mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_SEAICE, mn_phys%ts) + call fill_nest_halos_from_parent_masked("tisfc", mn_phys%tisfc, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_SEAICE, mn_phys%ts) + call fill_nest_halos_from_parent_masked("sncovr", mn_phys%sncovr, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_LAND, 0.0D0) + + call fill_nest_halos_from_parent_masked("fice", mn_phys%fice, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_SEAICE, 1.0D0) + call fill_nest_halos_from_parent_masked("hice", mn_phys%hice, interp_type_lmask, Atm(child_grid_num)%neststruct%wt_h, & + Atm(child_grid_num)%neststruct%ind_h, x_refine, y_refine, & + is_fine_pe, nest_domain, position, mn_phys%slmsk, mn_static%parent_ls%ls_mask_grid, M_SEAICE, 0.1D0) + + endif + end subroutine mn_phys_fill_nest_halos_from_parent !>@brief The subroutine 'mn_phys_fill_intern_nest_halos' fills the intenal nest halos for the physics variables @@ -1044,6 +1635,55 @@ subroutine mn_phys_fill_intern_nest_halos(moving_nest, GFS_control, domain_fine, call mn_var_fill_intern_nest_halos(mn_phys%qrain, domain_fine, is_fine_pe) endif + if (move_physics .and. GFS_control%lsm == GFS_control%lsm_noahmp) then + call mn_var_fill_intern_nest_halos(mn_phys%soilcolor, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%snowxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%tvxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%tgxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%canicexy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%canliqxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%eahxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%tahxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%cmxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%chxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%fwetxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%sneqvoxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%alboldxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%qsnowxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%wslakexy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%zwtxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%waxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%wtxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%lfmassxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%rtmassxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%stmassxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%woodxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%stblcpxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%fastcpxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%xsaixy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%xlaixy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%taussxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%smcwtdxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%deeprechxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%rechxy, domain_fine, is_fine_pe) + + call mn_var_fill_intern_nest_halos(mn_phys%snicexy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%snliqxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%snowd, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%tsnoxy, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%weasd, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%smoiseq, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%zsnsoxy, domain_fine, is_fine_pe) + + call mn_var_fill_intern_nest_halos(mn_phys%tiice, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%tisfc, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%sncovr, domain_fine, is_fine_pe) + + call mn_var_fill_intern_nest_halos(mn_phys%fice, domain_fine, is_fine_pe) + call mn_var_fill_intern_nest_halos(mn_phys%hice, domain_fine, is_fine_pe) + + endif + end subroutine mn_phys_fill_intern_nest_halos !>@brief The subroutine 'mn_phys_shift_data' shifts the variable in the nest, including interpolating at the leading edge @@ -1205,6 +1845,99 @@ subroutine mn_phys_shift_data(Atm, GFS_control, n, child_grid_num, wt_h, wt_u, w delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) endif + if (move_physics .and. GFS_control%lsm == GFS_control%lsm_noahmp) then + call mn_var_shift_data(mn_phys%soilcolor, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%snowxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%tvxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%tgxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%canicexy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%canliqxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%eahxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%tahxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%cmxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%chxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%fwetxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%sneqvoxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%alboldxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%qsnowxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%wslakexy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%zwtxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%waxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%wtxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%lfmassxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%rtmassxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%stmassxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%woodxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%stblcpxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%fastcpxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%xsaixy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%xlaixy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%taussxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%smcwtdxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%deeprechxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%rechxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%smoiseq, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, GFS_control%lsoil) + + + call mn_var_shift_data(mn_phys%snicexy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound) + call mn_var_shift_data(mn_phys%snliqxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound) + call mn_var_shift_data(mn_phys%snowd, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%tsnoxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsnow_lsm_ubound) + call mn_var_shift_data(mn_phys%weasd, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%zsnsoxy, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, GFS_control%lsnow_lsm_lbound, GFS_control%lsoil) + + ! ICEFIX + call mn_var_shift_data(mn_phys%tiice, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position, 1, GFS_control%kice) + call mn_var_shift_data(mn_phys%tisfc, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%sncovr, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%fice, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + call mn_var_shift_data(mn_phys%hice, interp_type, wt_h, Atm(child_grid_num)%neststruct%ind_h, & + delta_i_c, delta_j_c, x_refine, y_refine, is_fine_pe, nest_domain, position) + + endif + + end subroutine mn_phys_shift_data !>@brief The subroutine 'mn_phys_dump_to_netcdf' dumps physics variables to debugging netCDF files @@ -1247,6 +1980,10 @@ subroutine mn_phys_dump_to_netcdf(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_ real, allocatable :: lakefrac_pr_local (:,:) !< lake fraction real, allocatable :: landfrac_pr_local (:,:) !< land fraction real, allocatable :: emis_lnd_pr_local (:,:) !< emissivity land + real, allocatable :: snowxy_pr_local (:,:) !< number of snow layers + + logical :: move_noahmp + move_noahmp = .True. this_pe = mpp_pe() @@ -1313,6 +2050,10 @@ subroutine mn_phys_dump_to_netcdf(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_ allocate ( ifd_pr_local(is:ie, js:je) ) endif + if (move_noahmp) then + allocate ( snowxy_pr_local(is:ie, js:je) ) + endif + if (move_physics) then smc_pr_local = +99999.9 stc_pr_local = +99999.9 @@ -1340,6 +2081,9 @@ subroutine mn_phys_dump_to_netcdf(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_ xv_pr_local = +99999.9 ifd_pr_local = +99999.9 endif + if (move_nsst) then + snowxy_pr_local = +99999.9 + endif im = 0 do nb = 1,Atm_block%nblks @@ -1405,6 +2149,11 @@ subroutine mn_phys_dump_to_netcdf(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_ xv_pr_local(i,j) = GFS_sfcprop%xv(im) ifd_pr_local(i,j) = GFS_sfcprop%ifd(im) endif + + if (move_noahmp) then + snowxy_pr_local(i,j) = GFS_sfcprop%snowxy(im) + endif + enddo enddo @@ -1461,6 +2210,10 @@ subroutine mn_phys_dump_to_netcdf(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_ call mn_var_dump_to_netcdf(ifd_pr_local, is_fine_pe, domain_coarse, domain_fine, position, time_val, Atm%global_tile, file_prefix, "IFD") endif + if (move_noahmp) then + call mn_var_dump_to_netcdf(snowxy_pr_local, is_fine_pe, domain_coarse, domain_fine, position, time_val, Atm%global_tile, file_prefix, "SNOWXY") + endif + if (move_physics) then deallocate(smc_pr_local) deallocate(stc_pr_local) @@ -1480,6 +2233,9 @@ subroutine mn_phys_dump_to_netcdf(Atm, Atm_block, GFS_control, GFS_sfcprop, GFS_ if (move_nsst) deallocate(tref_pr_local, c_0_pr_local, xt_pr_local, xu_pr_local, xv_pr_local, ifd_pr_local) + if (move_noahmp) deallocate(snowxy_pr_local) + + end subroutine mn_phys_dump_to_netcdf end module fv_moving_nest_physics_mod diff --git a/fv3/moving_nest/fv_moving_nest_types.F90 b/fv3/moving_nest/fv_moving_nest_types.F90 index 299bf9c517..e40010cdd0 100644 --- a/fv3/moving_nest/fv_moving_nest_types.F90 +++ b/fv3/moving_nest/fv_moving_nest_types.F90 @@ -76,26 +76,30 @@ module fv_moving_nest_types_mod real, _ALLOCATABLE :: delz(:,:,:) _NULL !< layer thickness (meters) end type fv_moving_nest_prog_type - ! TODO deallocate these at end of model run. They are only allocated once, at first nest move, inside mn_static_read_hires(). - ! Note these are only 32 bits for now; matching the precision of the input netCDF files - ! though the model generally handles physics variables with 64 bit precision - type mn_surface_grids + + type mn_land_mask_grids real, allocatable :: orog_grid(:,:) _NULL ! orography -- raw or filtered depending on namelist option, in meters real, allocatable :: orog_std_grid(:,:) _NULL ! terrain standard deviation for gravity wave drag, in meters (?) - real, allocatable :: ls_mask_grid(:,:) _NULL ! land sea mask -- 0 for ocean/lakes, 1, for land. Perhaps 2 for sea ice. - real, allocatable :: land_frac_grid(:,:) _NULL ! Continuous land fraction - 0.0 ocean, 0.5 half of each, 1.0 all land + real, allocatable :: ls_mask_grid(:,:) _NULL ! land sea mask -- 0 for ocean/lakes, 1, for land. 2 for sea ice. + real, allocatable :: soil_type_grid(:,:) _NULL ! STATSGO soil type + ! Land frac needs to be kind_phys because CCPP defines it that way. Can have rounding mismatches around 0.5 if types don't match. + real(kind=kind_phys), allocatable :: land_frac_grid(:,:) _NULL ! Continuous land fraction - 0.0 ocean, 0.5 half of each, 1.0 all land - real, allocatable :: parent_orog_grid(:,:) _NULL ! parent orography -- only used for terrain_smoother=1. ! raw or filtered depending on namelist option,in meters + real(kind=kind_phys), allocatable :: geolat_grid(:,:) _NULL + real(kind=kind_phys), allocatable :: geolon_grid(:,:) _NULL + end type mn_land_mask_grids + + type mn_fix_grids ! Soil variables real, allocatable :: deep_soil_temp_grid(:,:) _NULL ! deep soil temperature at 5m, in degrees K - real, allocatable :: soil_type_grid(:,:) _NULL ! STATSGO soil type ! Vegetation variables real, allocatable :: veg_frac_grid(:,:) _NULL ! vegetation fraction real, allocatable :: veg_type_grid(:,:) _NULL ! IGBP vegetation type - real, allocatable :: veg_greenness_grid(:,:) _NULL ! NESDIS vegetation greenness; netCDF file has monthly values + ! TODO do we need veg_greenness? + !real, allocatable :: veg_greenness_grid(:,:) _NULL ! NESDIS vegetation greenness; netCDF file has monthly values ! Orography variables real, allocatable :: slope_type_grid(:,:) _NULL ! legacy 1 degree GFS slope type @@ -118,12 +122,31 @@ module fv_moving_nest_types_mod real, allocatable :: alvwf_grid(:,:) _NULL ! Visible white sky albedo; netCDF file has monthly values real, allocatable :: alnsf_grid(:,:) _NULL ! Near IR black sky albedo; netCDF file has monthly values real, allocatable :: alnwf_grid(:,:) _NULL ! Near IR white sky albedo; netCDF file has monthly values + end type mn_fix_grids + + + + ! TODO deallocate these at end of model run. They are only allocated once, at first nest move, inside mn_static_read_hires(). + ! Note these are only 32 bits for now; matching the precision of the input netCDF files + ! though the model generally handles physics variables with 64 bit precision + type mn_surface_grids + + type(mn_land_mask_grids) :: parent_ls + type(mn_land_mask_grids) :: fp_ls + type(mn_land_mask_grids) :: nest_ls + + ! type(mn_fix_grids) :: parent_fix ! Not needed at present + type(mn_fix_grids) :: fp_fix + type(mn_fix_grids) :: nest_fix end type mn_surface_grids type fv_moving_nest_physics_type real, _ALLOCATABLE :: ts(:,:) _NULL !< 2D skin temperature/SST real, _ALLOCATABLE :: slmsk(:,:) _NULL !< land sea mask -- 0 for ocean/lakes, 1, for land. Perhaps 2 for sea ice. + + logical, _ALLOCATABLE :: leading_edge(:,:) _NULL !< logical array -- at each nest move timestep, is this point getting interpolated values at the leading edge + real (kind=kind_phys), _ALLOCATABLE :: smc (:,:,:) _NULL !< soil moisture content real (kind=kind_phys), _ALLOCATABLE :: stc (:,:,:) _NULL !< soil temperature real (kind=kind_phys), _ALLOCATABLE :: slc (:,:,:) _NULL !< soil liquid water content @@ -209,6 +232,55 @@ module fv_moving_nest_types_mod real (kind=kind_phys), _ALLOCATABLE :: dt_cool (:,:) _NULL !< sub-layer cooling amount for NSSTM real (kind=kind_phys), _ALLOCATABLE :: qrain (:,:) _NULL !< sensible heat flux due to rainfall for NSSTM + ! NOAH MP LSM Variables + real (kind=kind_phys), _ALLOCATABLE :: soilcolor (:,:) _NULL !< soil color + real (kind=kind_phys), _ALLOCATABLE :: snowxy (:,:) _NULL !< number of snow layers + real (kind=kind_phys), _ALLOCATABLE :: tvxy (:,:) _NULL !< canopy temperature + real (kind=kind_phys), _ALLOCATABLE :: tgxy (:,:) _NULL !< ground temperature + real (kind=kind_phys), _ALLOCATABLE :: canicexy (:,:) _NULL !< canopy intercepted ice mass + real (kind=kind_phys), _ALLOCATABLE :: canliqxy (:,:) _NULL !< canopy intercepted liquid water + real (kind=kind_phys), _ALLOCATABLE :: eahxy (:,:) _NULL !< air vapor pressure in canopy + real (kind=kind_phys), _ALLOCATABLE :: tahxy (:,:) _NULL !< air temperature in canopy + real (kind=kind_phys), _ALLOCATABLE :: cmxy (:,:) _NULL !< bulk momentum drag coefficient [m/s] + real (kind=kind_phys), _ALLOCATABLE :: chxy (:,:) _NULL !< bulk sensible heat exchange coefficient [m/s] + real (kind=kind_phys), _ALLOCATABLE :: fwetxy (:,:) _NULL !< wetted or snowed fraction of the canopy + real (kind=kind_phys), _ALLOCATABLE :: sneqvoxy (:,:) _NULL !< snow mass at last time step[mm h2o] + real (kind=kind_phys), _ALLOCATABLE :: alboldxy (:,:) _NULL !< surface albedo assuming deep snow on previous timestep + real (kind=kind_phys), _ALLOCATABLE :: qsnowxy (:,:) _NULL !< liquid water equiv. snowfall rate + real (kind=kind_phys), _ALLOCATABLE :: wslakexy (:,:) _NULL !< lake water storage [mm] + real (kind=kind_phys), _ALLOCATABLE :: zwtxy (:,:) _NULL !< water table depth + real (kind=kind_phys), _ALLOCATABLE :: waxy (:,:) _NULL !< water storage in aquifer + real (kind=kind_phys), _ALLOCATABLE :: wtxy (:,:) _NULL !< water storage in aquifer and saturated soil + real (kind=kind_phys), _ALLOCATABLE :: lfmassxy (:,:) _NULL !< leaf mass [g/m2] + real (kind=kind_phys), _ALLOCATABLE :: rtmassxy (:,:) _NULL !< mass of fine roots [g/m2] + real (kind=kind_phys), _ALLOCATABLE :: stmassxy (:,:) _NULL !< stem mass [g/m2] + real (kind=kind_phys), _ALLOCATABLE :: woodxy (:,:) _NULL !< mass of wood (incl. woody roots) [g/m2] + real (kind=kind_phys), _ALLOCATABLE :: stblcpxy (:,:) _NULL !< stable carbon in deep soil [g/m2] + real (kind=kind_phys), _ALLOCATABLE :: fastcpxy (:,:) _NULL !< short-lived carbon, shallow soil [g/m2] + real (kind=kind_phys), _ALLOCATABLE :: xsaixy (:,:) _NULL !< stem area index [m2/m2] + real (kind=kind_phys), _ALLOCATABLE :: xlaixy (:,:) _NULL !< leaf area index [m2/m2] + real (kind=kind_phys), _ALLOCATABLE :: taussxy (:,:) _NULL !< snow age factor [-] + real (kind=kind_phys), _ALLOCATABLE :: smcwtdxy (:,:) _NULL !< soil moisture content in the layer to the water table when deep + real (kind=kind_phys), _ALLOCATABLE :: deeprechxy (:,:) _NULL !< recharge to the water table when deep + real (kind=kind_phys), _ALLOCATABLE :: rechxy (:,:) _NULL !< recharge to the water table + + real (kind=kind_phys), _ALLOCATABLE :: smoiseq (:,:,:) _NULL !< equvi. soil moisture + real (kind=kind_phys), _ALLOCATABLE :: snicexy (:,:,:) _NULL !< liq water equiv thickness of ice in surface snow + real (kind=kind_phys), _ALLOCATABLE :: snliqxy (:,:,:) _NULL !< liq water equiv thickness of liquid water in surface snow + real (kind=kind_phys), _ALLOCATABLE :: snowd (:,:) _NULL !< surface snow thickness water equivalent over land + real (kind=kind_phys), _ALLOCATABLE :: tsnoxy (:,:,:) _NULL !< temperature in surface snow + real (kind=kind_phys), _ALLOCATABLE :: weasd (:,:) _NULL !< water equivalent accumulated snow depth over land + real (kind=kind_phys), _ALLOCATABLE :: zsnsoxy (:,:,:) _NULL !< depth from snow surface at bottom interface + + ! ICEFIX Additional cryosphere variables Sept 2025 + real (kind=kind_phys), _ALLOCATABLE :: tiice (:,:,:) _NULL !< sea ice internal temperature, 2 layers [K] + real (kind=kind_phys), _ALLOCATABLE :: tisfc (:,:) _NULL !< surface skin temperature over ice [K] + real (kind=kind_phys), _ALLOCATABLE :: sncovr (:,:) _NULL !< snow cover in fraction over land + + real (kind=kind_phys), _ALLOCATABLE :: fice (:,:) _NULL !< sea ice fraction + real (kind=kind_phys), _ALLOCATABLE :: hice (:,:) _NULL !< sea ice thickness + + end type fv_moving_nest_physics_type type fv_moving_nest_type @@ -246,8 +318,44 @@ module fv_moving_nest_types_mod type(fv_moving_nest_type), _ALLOCATABLE, target :: Moving_nest(:) + interface mn_overwrite_with_nest_init_values + module procedure mn_overwrite_with_nest_init_values_r4 + module procedure mn_overwrite_with_nest_init_values_r8 + end interface mn_overwrite_with_nest_init_values + + contains + subroutine mn_set_leading_edge(mn_phys, isd, ied, jsd, jed, ioffset, joffset) + type(fv_moving_nest_physics_type), intent(inout) :: mn_phys + integer, intent(in) :: isd, ied, jsd, jed + integer, intent(in) :: ioffset, joffset + + mn_phys%leading_edge = .False. + + mn_phys%leading_edge(isd:isd+2,:) = .True. + mn_phys%leading_edge(ied-2:ied,:) = .True. + + mn_phys%leading_edge(:, jsd:jsd+2) = .True. + mn_phys%leading_edge(:, jed-2:jed) = .True. + + if (ioffset .eq. 1) then + mn_phys%leading_edge(isd+3:isd+5, :) = .True. + endif + if (ioffset .eq. -1) then + mn_phys%leading_edge(ied-5:ied-3, :) = .True. + endif + + if (joffset .eq. 1) then + mn_phys%leading_edge(: ,jsd+3:jsd+5) = .True. + endif + if (joffset .eq. -1) then + mn_phys%leading_edge(:, jed-5:jed-3) = .True. + endif + + + end subroutine mn_set_leading_edge + subroutine fv_moving_nest_init(Atm, this_grid) type(fv_atmos_type), allocatable, intent(in) :: Atm(:) integer, intent(in) :: this_grid @@ -335,6 +443,169 @@ subroutine deallocate_fv_moving_nest(n) end subroutine deallocate_fv_moving_nest + subroutine mn_apply_lakes(land_mask_grids) + type(mn_land_mask_grids), intent(inout) :: land_mask_grids + + integer :: i_idx, j_idx + + ! Alter hires full panel ls_mask_grid to set lakes to water(sea) values + do i_idx = lbound(land_mask_grids%ls_mask_grid,1), ubound(land_mask_grids%ls_mask_grid,1) + do j_idx = lbound(land_mask_grids%ls_mask_grid,1), ubound(land_mask_grids%ls_mask_grid,2) + !if (land_mask_grids%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. nint(land_mask_grids%land_frac_grid(i_idx, j_idx)) == 0 ) then + !!if (land_mask_grids%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. land_mask_grids%land_frac_grid(i_idx, j_idx) .lt. 0.999 ) then + + ! Use epsilon of 1.0e-6 on land_frac_grid, based on CCPP code in physics/physics/gcycle.F90 + ! Fixes a bug where land mask changes with first nest move if land_frac_grid = 0.5000 + ! TODO test wrapping these reals with int() or nint() + if (land_mask_grids%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. nint(land_mask_grids%land_frac_grid(i_idx, j_idx)-1.0e-6_kind_phys) .eq. 0 ) then + land_mask_grids%ls_mask_grid(i_idx, j_idx) = 0 + endif + ! Soil type adjustments from io/fv3atm_sfc_io.F90 + if (land_mask_grids%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. int(land_mask_grids%soil_type_grid(i_idx, j_idx)) .eq. 14 ) then + land_mask_grids%ls_mask_grid(i_idx, j_idx) = 0 + endif + if (land_mask_grids%ls_mask_grid(i_idx, j_idx) .eq. 1 .and. land_mask_grids%soil_type_grid(i_idx, j_idx) .lt. 0.8 ) then + land_mask_grids%ls_mask_grid(i_idx, j_idx) = 0 + endif + enddo + enddo + + end subroutine mn_apply_lakes + + subroutine mn_overwrite_with_nest_init_values_r8(tag, var_grid, nest_var_grid, refine, ioffset, joffset) + character(len=*) :: tag + real*8, allocatable, intent(inout) :: var_grid(:,:) + real*8, allocatable, intent(in) :: nest_var_grid(:,:) + + integer, intent(in) :: refine, ioffset, joffset + integer :: i,j, this_pe + + ! this_pe = mpp_pe() + + do i = lbound(nest_var_grid,1), ubound(nest_var_grid,1) + do j = lbound(nest_var_grid,2), ubound(nest_var_grid,2) + var_grid((ioffset-1)*refine+i, (joffset-1)*refine+j) = nest_var_grid(i,j) + enddo + enddo + + end subroutine mn_overwrite_with_nest_init_values_r8 + + subroutine mn_overwrite_with_nest_init_values_r4(tag, var_grid, nest_var_grid, refine, ioffset, joffset) + character(len=*) :: tag + real*4, allocatable, intent(inout) :: var_grid(:,:) + real*4, allocatable, intent(in) :: nest_var_grid(:,:) + + integer, intent(in) :: refine, ioffset, joffset + integer :: i,j, this_pe + + ! this_pe = mpp_pe() + + do i = lbound(nest_var_grid,1), ubound(nest_var_grid,1) + do j = lbound(nest_var_grid,2), ubound(nest_var_grid,2) + var_grid((ioffset-1)*refine+i, (joffset-1)*refine+j) = nest_var_grid(i,j) + enddo + enddo + + end subroutine mn_overwrite_with_nest_init_values_r4 + + subroutine deallocate_land_mask_grids(land_mask_grids) + type(mn_land_mask_grids), intent(inout) :: land_mask_grids + + if (allocated(land_mask_grids%orog_grid)) deallocate(land_mask_grids%orog_grid) + if (allocated(land_mask_grids%orog_std_grid)) deallocate(land_mask_grids%orog_std_grid) + if (allocated(land_mask_grids%ls_mask_grid)) deallocate(land_mask_grids%ls_mask_grid) + if (allocated(land_mask_grids%soil_type_grid)) deallocate(land_mask_grids%soil_type_grid) + if (allocated(land_mask_grids%land_frac_grid)) deallocate(land_mask_grids%land_frac_grid) + if (allocated(land_mask_grids%geolat_grid)) deallocate(land_mask_grids%geolat_grid) + if (allocated(land_mask_grids%geolon_grid)) deallocate(land_mask_grids%geolon_grid) + end subroutine deallocate_land_mask_grids + + + + subroutine alloc_set_facwf(fix_grids) + type(mn_fix_grids), intent(inout) :: fix_grids + + integer :: i,j + + allocate(fix_grids%facwf_grid(lbound(fix_grids%facsf_grid,1):ubound(fix_grids%facsf_grid,1),lbound(fix_grids%facsf_grid,2):ubound(fix_grids%facsf_grid,2))) + + ! For land points, set facwf = 1.0 - facsf + ! To match initialization behavior, set any -999s to 0 + do i=lbound(fix_grids%facsf_grid,1),ubound(fix_grids%facsf_grid,1) + do j=lbound(fix_grids%facsf_grid,2),ubound(fix_grids%facsf_grid,2) + if (fix_grids%facsf_grid(i,j) .lt. -100) then + fix_grids%facsf_grid(i,j) = 0 + fix_grids%facwf_grid(i,j) = 0 + else + fix_grids%facwf_grid(i,j) = 1.0 - fix_grids%facsf_grid(i,j) + endif + enddo + enddo + end subroutine alloc_set_facwf + + + + subroutine mn_static_overwrite_ls_from_nest(fp_ls, nest_ls, refine, ioffset, joffset) + type(mn_land_mask_grids), intent(inout) :: fp_ls + type(mn_land_mask_grids), intent(in) :: nest_ls + integer, intent(in) :: refine, ioffset, joffset + + ! Update full panel with nest init values (there are a few mismatches) + ! TODO maybe add orog_raw/orog_filt + call mn_overwrite_with_nest_init_values("ls_mask", fp_ls%ls_mask_grid, nest_ls%ls_mask_grid, refine, ioffset, joffset) + + !if (is_fine_pe) then + ! call validate_navigation_fields("INIT", Atm_block, GFS_control, GFS_sfcprop, parent_grid_num, child_grid_num) + !endif + + call mn_overwrite_with_nest_init_values("soil_type", fp_ls%soil_type_grid, nest_ls%soil_type_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("land_frac", fp_ls%land_frac_grid, nest_ls%land_frac_grid, refine, ioffset, joffset) + + end subroutine mn_static_overwrite_ls_from_nest + + subroutine mn_static_overwrite_fix_from_nest(fp_fix, nest_fix, refine, ioffset, joffset) + type(mn_fix_grids), intent(inout) :: fp_fix + type(mn_fix_grids), intent(in) :: nest_fix + integer, intent(in) :: refine, ioffset, joffset + + call mn_overwrite_with_nest_init_values("deep_soil_temp", fp_fix%deep_soil_temp_grid, nest_fix%deep_soil_temp_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("veg_type", fp_fix%veg_type_grid, nest_fix%veg_type_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("slope_type", fp_fix%slope_type_grid, nest_fix%slope_type_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("max_snow_alb", fp_fix%max_snow_alb_grid, nest_fix%max_snow_alb_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("facsf", fp_fix%facsf_grid, nest_fix%facsf_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("facwf", fp_fix%facwf_grid, nest_fix%facwf_grid, refine, ioffset, joffset) + + call mn_overwrite_with_nest_init_values("alvsf", fp_fix%alvsf_grid, nest_fix%alvsf_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("alvwf", fp_fix%alvwf_grid, nest_fix%alvwf_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("alnsf", fp_fix%alnsf_grid, nest_fix%alnsf_grid, refine, ioffset, joffset) + call mn_overwrite_with_nest_init_values("alnwf", fp_fix%alnwf_grid, nest_fix%alnwf_grid, refine, ioffset, joffset) + + end subroutine mn_static_overwrite_fix_from_nest + + subroutine deallocate_fix_grids(fix_grids) + type(mn_fix_grids), intent(inout) :: fix_grids + + if (allocated(fix_grids%deep_soil_temp_grid)) deallocate(fix_grids%deep_soil_temp_grid) + if (allocated(fix_grids%veg_frac_grid)) deallocate(fix_grids%veg_frac_grid) + if (allocated(fix_grids%veg_type_grid)) deallocate(fix_grids%veg_type_grid) + !if (allocated(fix_grids%veg_greenness_grid)) deallocate(fix_grids%veg_greenness_grid) + if (allocated(fix_grids%slope_type_grid)) deallocate(fix_grids%slope_type_grid) + if (allocated(fix_grids%max_snow_alb_grid)) deallocate(fix_grids%max_snow_alb_grid) + if (allocated(fix_grids%facsf_grid)) deallocate(fix_grids%facsf_grid) + if (allocated(fix_grids%facwf_grid)) deallocate(fix_grids%facwf_grid) + if (allocated(fix_grids%alvsf_grid)) deallocate(fix_grids%alvsf_grid) + if (allocated(fix_grids%alvwf_grid)) deallocate(fix_grids%alvwf_grid) + if (allocated(fix_grids%alnsf_grid)) deallocate(fix_grids%alnsf_grid) + if (allocated(fix_grids%alnwf_grid)) deallocate(fix_grids%alnwf_grid) + + end subroutine deallocate_fix_grids + + + + + + + subroutine allocate_fv_moving_nest_prog_type(isd, ied, jsd, jed, npz, mn_prog) integer, intent(in) :: isd, ied, jsd, jed, npz type(fv_moving_nest_prog_type), intent(inout) :: mn_prog @@ -351,16 +622,20 @@ subroutine deallocate_fv_moving_nest_prog_type(mn_prog) end subroutine deallocate_fv_moving_nest_prog_type - subroutine allocate_fv_moving_nest_physics_type(isd, ied, jsd, jed, npz, move_physics, move_nsst, lsoil, nmtvr, levs, ntot2d, ntot3d, mn_phys) + subroutine allocate_fv_moving_nest_physics_type(isd, ied, jsd, jed, npz, move_physics, move_noahmp, move_nsst, lsnow_lbound, lsnow_ubound, lsoil, nmtvr, levs, ntot2d, ntot3d, mn_phys) integer, intent(in) :: isd, ied, jsd, jed, npz - logical, intent(in) :: move_physics, move_nsst - integer, intent(in) :: lsoil, nmtvr, levs, ntot2d, ntot3d ! From IPD_Control + logical, intent(in) :: move_physics, move_noahmp, move_nsst + integer, intent(in) :: lsnow_lbound, lsnow_ubound, lsoil, nmtvr, levs, ntot2d, ntot3d ! From GFS_control type(fv_moving_nest_physics_type), intent(inout) :: mn_phys ! The local/temporary variables need to be allocated to the larger data (compute + halos) domain so that the nest motion code has halos to use allocate ( mn_phys%ts(isd:ied, jsd:jed) ) + !print '("[INFO] WDR allocate_fv_moving_nest_physics_type npe=",I0," lsnow_lbound=",I0," lsnow_ubound=",I0," lsoil=",I0)', mpp_pe(), lsnow_lbound, lsnow_ubound, lsoil + if (move_physics) then + allocate ( mn_phys%leading_edge (isd:ied, jsd:jed) ) + allocate ( mn_phys%slmsk(isd:ied, jsd:jed) ) allocate ( mn_phys%smc(isd:ied, jsd:jed, lsoil) ) allocate ( mn_phys%stc(isd:ied, jsd:jed, lsoil) ) @@ -445,8 +720,60 @@ subroutine allocate_fv_moving_nest_physics_type(isd, ied, jsd, jed, npz, move_p allocate ( mn_phys%qrain(isd:ied, jsd:jed) ) end if + if (move_noahmp) then + allocate ( mn_phys%soilcolor(isd:ied, jsd:jed) ) + allocate ( mn_phys%snowxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%tvxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%tgxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%canicexy(isd:ied, jsd:jed) ) + allocate ( mn_phys%canliqxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%eahxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%tahxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%cmxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%chxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%fwetxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%sneqvoxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%alboldxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%qsnowxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%wslakexy(isd:ied, jsd:jed) ) + allocate ( mn_phys%zwtxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%waxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%wtxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%lfmassxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%rtmassxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%stmassxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%woodxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%stblcpxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%fastcpxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%xsaixy(isd:ied, jsd:jed) ) + allocate ( mn_phys%xlaixy(isd:ied, jsd:jed) ) + allocate ( mn_phys%taussxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%smcwtdxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%deeprechxy(isd:ied, jsd:jed) ) + allocate ( mn_phys%rechxy(isd:ied, jsd:jed) ) + + allocate ( mn_phys%snicexy(isd:ied, jsd:jed, lsnow_lbound:lsnow_ubound) ) + allocate ( mn_phys%snliqxy(isd:ied, jsd:jed, lsnow_lbound:lsnow_ubound) ) + allocate ( mn_phys%smoiseq(isd:ied, jsd:jed, lsoil) ) + allocate ( mn_phys%snowd(isd:ied, jsd:jed) ) + allocate ( mn_phys%tsnoxy(isd:ied, jsd:jed, lsnow_lbound:lsnow_ubound) ) + allocate ( mn_phys%weasd(isd:ied, jsd:jed) ) + allocate ( mn_phys%zsnsoxy(isd:ied, jsd:jed, lsnow_lbound:lsoil) ) + + ! ICEFIX + allocate ( mn_phys%tiice(isd:ied, jsd:jed, 2) ) + allocate ( mn_phys%tisfc(isd:ied, jsd:jed) ) + allocate ( mn_phys%sncovr(isd:ied, jsd:jed) ) + allocate ( mn_phys%fice(isd:ied, jsd:jed) ) + allocate ( mn_phys%hice(isd:ied, jsd:jed) ) + + !allocate ( mn_phys%ustar1(isd:ied, jsd:jed) ) + endif + mn_phys%ts = +99999.9 if (move_physics) then + mn_phys%leading_edge = .false. + mn_phys%slmsk = +99999.9 mn_phys%smc = +99999.9 mn_phys%stc = +99999.9 @@ -532,6 +859,57 @@ subroutine allocate_fv_moving_nest_physics_type(isd, ied, jsd, jed, npz, move_p mn_phys%qrain = +99999.9 end if + + if (move_noahmp) then + mn_phys%soilcolor = +99999.9 + mn_phys%snowxy = +99999.9 + mn_phys%tvxy = +99999.9 + mn_phys%tgxy = +99999.9 + mn_phys%canicexy = +99999.9 + mn_phys%canliqxy = +99999.9 + mn_phys%eahxy = +99999.9 + mn_phys%tahxy = +99999.9 + mn_phys%cmxy = +99999.9 + mn_phys%chxy = +99999.9 + mn_phys%fwetxy = +99999.9 + mn_phys%sneqvoxy = +99999.9 + mn_phys%alboldxy = +99999.9 + mn_phys%qsnowxy = +99999.9 + mn_phys%wslakexy = +99999.9 + mn_phys%zwtxy = +99999.9 + mn_phys%waxy = +99999.9 + mn_phys%wtxy = +99999.9 + mn_phys%lfmassxy = +99999.9 + mn_phys%rtmassxy = +99999.9 + mn_phys%stmassxy = +99999.9 + mn_phys%woodxy = +99999.9 + mn_phys%stblcpxy = +99999.9 + mn_phys%fastcpxy = +99999.9 + mn_phys%xsaixy = +99999.9 + mn_phys%xlaixy = +99999.9 + mn_phys%taussxy = +99999.9 + mn_phys%smcwtdxy = +99999.9 + mn_phys%deeprechxy = +99999.9 + mn_phys%rechxy = +99999.9 + + mn_phys%snicexy = +99999.9 + mn_phys%snliqxy = +99999.9 + mn_phys%smoiseq = +99999.9 + mn_phys%snowd = +99999.9 + mn_phys%tsnoxy = +99999.9 + mn_phys%weasd = +99999.9 + mn_phys%zsnsoxy = +99999.9 + + mn_phys%tiice = +99999.9 + mn_phys%tisfc = +99999.9 + mn_phys%sncovr = +99999.9 + + mn_phys%fice = +99999.9 + mn_phys%hice = +99999.9 + + !mn_phys%ustar1 = +99999.9 + endif + end subroutine allocate_fv_moving_nest_physics_type @@ -547,6 +925,7 @@ subroutine deallocate_fv_moving_nest_physics_type(mn_phys) ! if move_phys if (allocated(mn_phys%smc)) then + deallocate( mn_phys%leading_edge ) deallocate( mn_phys%slmsk ) deallocate( mn_phys%smc ) deallocate( mn_phys%stc ) @@ -632,6 +1011,55 @@ subroutine deallocate_fv_moving_nest_physics_type(mn_phys) deallocate( mn_phys%qrain ) end if + ! NOAH MP LSM + if (allocated(mn_phys%snowxy)) then + deallocate ( mn_phys%soilcolor ) + deallocate ( mn_phys%snowxy ) + deallocate ( mn_phys%tvxy ) + deallocate ( mn_phys%tgxy ) + deallocate ( mn_phys%canicexy ) + deallocate ( mn_phys%canliqxy ) + deallocate ( mn_phys%eahxy ) + deallocate ( mn_phys%tahxy ) + deallocate ( mn_phys%cmxy ) + deallocate ( mn_phys%chxy ) + deallocate ( mn_phys%fwetxy ) + deallocate ( mn_phys%sneqvoxy ) + deallocate ( mn_phys%alboldxy ) + deallocate ( mn_phys%qsnowxy ) + deallocate ( mn_phys%wslakexy ) + deallocate ( mn_phys%zwtxy ) + deallocate ( mn_phys%waxy ) + deallocate ( mn_phys%wtxy ) + deallocate ( mn_phys%lfmassxy ) + deallocate ( mn_phys%rtmassxy ) + deallocate ( mn_phys%stmassxy ) + deallocate ( mn_phys%woodxy ) + deallocate ( mn_phys%stblcpxy ) + deallocate ( mn_phys%fastcpxy ) + deallocate ( mn_phys%xsaixy ) + deallocate ( mn_phys%xlaixy ) + deallocate ( mn_phys%taussxy ) + deallocate ( mn_phys%smcwtdxy ) + deallocate ( mn_phys%deeprechxy ) + deallocate ( mn_phys%rechxy ) + + deallocate ( mn_phys%snicexy ) + deallocate ( mn_phys%snliqxy ) + deallocate ( mn_phys%smoiseq ) + deallocate ( mn_phys%snowd ) + deallocate ( mn_phys%tsnoxy ) + deallocate ( mn_phys%weasd ) + deallocate ( mn_phys%zsnsoxy ) + + deallocate ( mn_phys%tiice ) + deallocate ( mn_phys%tisfc ) + deallocate ( mn_phys%sncovr ) + deallocate ( mn_phys%fice ) + deallocate ( mn_phys%hice ) + + endif + end subroutine deallocate_fv_moving_nest_physics_type end module fv_moving_nest_types_mod diff --git a/fv3/moving_nest/fv_moving_nest_utils.F90 b/fv3/moving_nest/fv_moving_nest_utils.F90 index 06136a2b15..932dc99840 100644 --- a/fv3/moving_nest/fv_moving_nest_utils.F90 +++ b/fv3/moving_nest/fv_moving_nest_utils.F90 @@ -66,13 +66,11 @@ module fv_moving_nest_utils_mod #else use IPD_typedefs, only: kind_phys => IPD_kind_phys #endif - #ifdef OVERLOAD_R4 use constantsR4_mod, only: grav #else use constants_mod, only: grav #endif - use boundary_mod, only: update_coarse_grid, update_coarse_grid_mpp use bounding_box_mod, only: bbox, bbox_get_C2F_index, fill_bbox use fms2_io_mod, only: read_data, write_data, open_file, close_file, register_axis, register_field @@ -94,6 +92,12 @@ module fv_moving_nest_utils_mod integer, parameter:: f_p = selected_real_kind(20) #endif +#ifdef OVERLOAD_R4 + real, parameter:: real_snan=x'FFBFFFFF' +#else + real, parameter:: real_snan=x'FFF7FFFFFFFFFFFF' +#endif + integer, parameter :: UWIND = 1 integer, parameter :: VWIND = 2 @@ -112,41 +116,50 @@ module fv_moving_nest_utils_mod interface fill_nest_halos_from_parent module procedure fill_nest_halos_from_parent_r4_2d - module procedure fill_nest_halos_from_parent_r4_3d + module procedure fill_nest_halos_from_parent_r4_3d_highz + module procedure fill_nest_halos_from_parent_r4_3d_lowhighz module procedure fill_nest_halos_from_parent_r4_4d module procedure fill_nest_halos_from_parent_r8_2d - module procedure fill_nest_halos_from_parent_r8_3d + module procedure fill_nest_halos_from_parent_r8_3d_highz + module procedure fill_nest_halos_from_parent_r8_3d_lowhighz module procedure fill_nest_halos_from_parent_r8_4d end interface fill_nest_halos_from_parent + interface alloc_halo_buffer module procedure alloc_halo_buffer_r4_2d - module procedure alloc_halo_buffer_r4_3d + module procedure alloc_halo_buffer_r4_3d_highz + module procedure alloc_halo_buffer_r4_3d_lowhighz module procedure alloc_halo_buffer_r4_4d module procedure alloc_halo_buffer_r8_2d - module procedure alloc_halo_buffer_r8_3d + module procedure alloc_halo_buffer_r8_3d_highz + module procedure alloc_halo_buffer_r8_3d_lowhighz module procedure alloc_halo_buffer_r8_4d end interface alloc_halo_buffer interface fill_nest_from_buffer module procedure fill_nest_from_buffer_r4_2d - module procedure fill_nest_from_buffer_r4_3d + module procedure fill_nest_from_buffer_r4_3d_highz + module procedure fill_nest_from_buffer_r4_3d_lowhighz module procedure fill_nest_from_buffer_r4_4d module procedure fill_nest_from_buffer_r8_2d - module procedure fill_nest_from_buffer_r8_3d + module procedure fill_nest_from_buffer_r8_3d_highz + module procedure fill_nest_from_buffer_r8_3d_lowhighz module procedure fill_nest_from_buffer_r8_4d end interface fill_nest_from_buffer interface fill_nest_from_buffer_cell_center module procedure fill_nest_from_buffer_cell_center_r4_2d - module procedure fill_nest_from_buffer_cell_center_r4_3d + module procedure fill_nest_from_buffer_cell_center_r4_3d_highz + module procedure fill_nest_from_buffer_cell_center_r4_3d_lowhighz module procedure fill_nest_from_buffer_cell_center_r4_4d module procedure fill_nest_from_buffer_cell_center_r8_2d - module procedure fill_nest_from_buffer_cell_center_r8_3d + module procedure fill_nest_from_buffer_cell_center_r8_3d_highz + module procedure fill_nest_from_buffer_cell_center_r8_3d_lowhighz module procedure fill_nest_from_buffer_cell_center_r8_4d end interface fill_nest_from_buffer_cell_center @@ -161,6 +174,28 @@ module fv_moving_nest_utils_mod module procedure fill_grid_from_supergrid_r8_4d end interface fill_grid_from_supergrid + ! Masked subroutines + interface fill_nest_halos_from_parent_masked + module procedure fill_nest_halos_from_parent_masked_r8_2d_const + module procedure fill_nest_halos_from_parent_masked_r8_2d_2d + module procedure fill_nest_halos_from_parent_masked_r8_3d_lowhighZ_const + module procedure fill_nest_halos_from_parent_masked_r8_3d_lowhighZ_1d + module procedure fill_nest_halos_from_parent_masked_r8_3d_lowhighZ_2d + end interface fill_nest_halos_from_parent_masked + + interface fill_nest_from_buffer_masked + module procedure fill_nest_from_buffer_masked_r8_2d_const + module procedure fill_nest_from_buffer_masked_r8_2d_2d + module procedure fill_nest_from_buffer_masked_r8_3d_1d + module procedure fill_nest_from_buffer_masked_r8_3d_2d + end interface fill_nest_from_buffer_masked + + interface fill_nest_from_buffer_cell_center_masked + module procedure fill_nest_from_buffer_cell_center_masked_2d_const + module procedure fill_nest_from_buffer_cell_center_masked_2d_2d + module procedure fill_nest_from_buffer_cell_center_masked_3d_1d + module procedure fill_nest_from_buffer_cell_center_masked_3d_2d + end interface fill_nest_from_buffer_cell_center_masked contains @@ -483,7 +518,7 @@ subroutine fill_nest_halos_from_parent_r8_2d(var_name, data_var, interp_type, wt end subroutine fill_nest_halos_from_parent_r8_2d - subroutine fill_nest_halos_from_parent_masked(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, mask_var, mask_val, default_val) + subroutine fill_nest_halos_from_parent_masked_r8_2d_const(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, mask_var, parent_mask_var, mask_val, default_val) character(len=*), intent(in) :: var_name real*8, allocatable, intent(inout) :: data_var(:,:) integer, intent(in) :: interp_type @@ -493,7 +528,8 @@ subroutine fill_nest_halos_from_parent_masked(var_name, data_var, interp_type, w logical, intent(in) :: is_fine_pe type(nest_domain_type), intent(inout) :: nest_domain integer, intent(in) :: position - real*4, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) integer, intent(in) :: mask_val real*8, intent(in) :: default_val @@ -529,10 +565,222 @@ subroutine fill_nest_halos_from_parent_masked(var_name, data_var, interp_type, w !! !!=========================================================== - call fill_nest_from_buffer_masked(interp_type, data_var, nbuffer, north_fine, north_coarse, NORTH, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) - call fill_nest_from_buffer_masked(interp_type, data_var, sbuffer, south_fine, south_coarse, SOUTH, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) - call fill_nest_from_buffer_masked(interp_type, data_var, ebuffer, east_fine, east_coarse, EAST, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) - call fill_nest_from_buffer_masked(interp_type, data_var, wbuffer, west_fine, west_coarse, WEST, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, nbuffer, north_fine, north_coarse, NORTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, sbuffer, south_fine, south_coarse, SOUTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, ebuffer, east_fine, east_coarse, EAST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, wbuffer, west_fine, west_coarse, WEST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + + endif + + deallocate(nbuffer) + deallocate(sbuffer) + deallocate(ebuffer) + deallocate(wbuffer) + + end subroutine fill_nest_halos_from_parent_masked_r8_2d_const + + subroutine fill_nest_halos_from_parent_masked_r8_2d_2d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, mask_var, parent_mask_var, mask_val, default_grid) + character(len=*), intent(in) :: var_name + real*8, allocatable, intent(inout) :: data_var(:,:) + integer, intent(in) :: interp_type + real, allocatable, intent(in) :: wt(:,:,:) ! TODO should this also be real*8? + integer, allocatable, intent(in) :: ind(:,:,:) + integer, intent(in) :: x_refine, y_refine + logical, intent(in) :: is_fine_pe + type(nest_domain_type), intent(inout) :: nest_domain + integer, intent(in) :: position + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real, allocatable, intent(in) :: default_grid(:,:) + + real*8, dimension(:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer + type(bbox) :: north_fine, north_coarse + type(bbox) :: south_fine, south_coarse + type(bbox) :: east_fine, east_coarse + type(bbox) :: west_fine, west_coarse + integer :: this_pe + integer :: nest_level = 1 ! TODO allow to vary + + this_pe = mpp_pe() + + !!=========================================================== + !! + !! Fill halo buffers + !! + !!=========================================================== + + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position) + + ! Passes data from coarse grid to fine grid's halo + call mpp_update_nest_fine(data_var, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level, position=position) + + if (is_fine_pe) then + + !!=========================================================== + !! + !! Apply halo data + !! + !!=========================================================== + + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, nbuffer, north_fine, north_coarse, NORTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, sbuffer, south_fine, south_coarse, SOUTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, ebuffer, east_fine, east_coarse, EAST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, wbuffer, west_fine, west_coarse, WEST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + + endif + + deallocate(nbuffer) + deallocate(sbuffer) + deallocate(ebuffer) + deallocate(wbuffer) + + end subroutine fill_nest_halos_from_parent_masked_r8_2d_2d + + + + + subroutine fill_nest_halos_from_parent_masked_r8_3d_lowhighz_const(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, low_z, high_z, mask_var, parent_mask_var, mask_val, default_val) + character(len=*), intent(in) :: var_name + real*8, allocatable, intent(inout) :: data_var(:,:,:) + integer, intent(in) :: interp_type + real, allocatable, intent(in) :: wt(:,:,:) ! TODO should this be real*8? + integer, allocatable, intent(in) :: ind(:,:,:) + integer, intent(in) :: x_refine, y_refine + logical, intent(in) :: is_fine_pe + type(nest_domain_type), intent(inout) :: nest_domain + integer, intent(in) :: position, low_z, high_z + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real*8, intent(in) :: default_val + + real*8 :: default_vector(low_z:high_z) + + default_vector = default_val + + call fill_nest_halos_from_parent_masked_r8_3d_lowhighz_1d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, low_z, high_z, mask_var, parent_mask_var, mask_val, default_vector) + + end subroutine fill_nest_halos_from_parent_masked_r8_3d_lowhighz_const + + + + subroutine fill_nest_halos_from_parent_masked_r8_3d_lowhighz_1d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, low_z, high_z, mask_var, parent_mask_var, mask_val, default_val) + character(len=*), intent(in) :: var_name + real*8, allocatable, intent(inout) :: data_var(:,:,:) + integer, intent(in) :: interp_type + real, allocatable, intent(in) :: wt(:,:,:) ! TODO should this be real*8? + integer, allocatable, intent(in) :: ind(:,:,:) + integer, intent(in) :: x_refine, y_refine + logical, intent(in) :: is_fine_pe + type(nest_domain_type), intent(inout) :: nest_domain + integer, intent(in) :: position, low_z, high_z + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real*8, intent(in) :: default_val(low_z:high_z) + + real*8, dimension(:,:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer + type(bbox) :: north_fine, north_coarse + type(bbox) :: south_fine, south_coarse + type(bbox) :: east_fine, east_coarse + type(bbox) :: west_fine, west_coarse + integer :: this_pe + integer :: nest_level = 1 ! TODO allow to vary + + this_pe = mpp_pe() + + !!=========================================================== + !! + !! Fill halo buffers + !! + !!=========================================================== + + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, low_z, high_z) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, low_z, high_z) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, low_z, high_z) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, low_z, high_z) + + ! Passes data from coarse grid to fine grid's halo + call mpp_update_nest_fine(data_var, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level, position=position) + + if (is_fine_pe) then + + !!=========================================================== + !! + !! Apply halo data + !! + !!=========================================================== + + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, nbuffer, north_fine, north_coarse, low_z, high_z, NORTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, sbuffer, south_fine, south_coarse, low_z, high_z, SOUTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, ebuffer, east_fine, east_coarse, low_z, high_z, EAST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, wbuffer, west_fine, west_coarse, low_z, high_z, WEST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) + + endif + + deallocate(nbuffer) + deallocate(sbuffer) + deallocate(ebuffer) + deallocate(wbuffer) + + end subroutine fill_nest_halos_from_parent_masked_r8_3d_lowhighz_1d + + + subroutine fill_nest_halos_from_parent_masked_r8_3d_lowhighz_2d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, low_z, high_z, mask_var, parent_mask_var, mask_val, default_grid) + character(len=*), intent(in) :: var_name + real*8, allocatable, intent(inout) :: data_var(:,:,:) + integer, intent(in) :: interp_type + real, allocatable, intent(in) :: wt(:,:,:) ! TODO should this be real*8? + integer, allocatable, intent(in) :: ind(:,:,:) + integer, intent(in) :: x_refine, y_refine + logical, intent(in) :: is_fine_pe + type(nest_domain_type), intent(inout) :: nest_domain + integer, intent(in) :: position, low_z, high_z + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real, allocatable, intent(in) :: default_grid(:,:) + + real*8, dimension(:,:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer + type(bbox) :: north_fine, north_coarse + type(bbox) :: south_fine, south_coarse + type(bbox) :: east_fine, east_coarse + type(bbox) :: west_fine, west_coarse + integer :: this_pe + integer :: nest_level = 1 ! TODO allow to vary + + this_pe = mpp_pe() + + !!=========================================================== + !! + !! Fill halo buffers + !! + !!=========================================================== + + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, low_z, high_z) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, low_z, high_z) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, low_z, high_z) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, low_z, high_z) + + ! Passes data from coarse grid to fine grid's halo + call mpp_update_nest_fine(data_var, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level, position=position) + + if (is_fine_pe) then + + !!=========================================================== + !! + !! Apply halo data + !! + !!=========================================================== + + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, nbuffer, north_fine, north_coarse, low_z, high_z, NORTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, sbuffer, south_fine, south_coarse, low_z, high_z, SOUTH, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, ebuffer, east_fine, east_coarse, low_z, high_z, EAST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + call fill_nest_from_buffer_masked(var_name, interp_type, data_var, wbuffer, west_fine, west_coarse, low_z, high_z, WEST, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) endif @@ -541,10 +789,11 @@ subroutine fill_nest_halos_from_parent_masked(var_name, data_var, interp_type, w deallocate(ebuffer) deallocate(wbuffer) - end subroutine fill_nest_halos_from_parent_masked + end subroutine fill_nest_halos_from_parent_masked_r8_3d_lowhighz_2d + - subroutine fill_nest_halos_from_parent_r4_3d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) + subroutine fill_nest_halos_from_parent_r4_3d_highz(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) character(len=*), intent(in) :: var_name real*4, allocatable, intent(inout) :: data_var(:,:,:) integer, intent(in) :: interp_type @@ -555,6 +804,22 @@ subroutine fill_nest_halos_from_parent_r4_3d(var_name, data_var, interp_type, wt type(nest_domain_type), intent(inout) :: nest_domain integer, intent(in) :: position, nz + + call fill_nest_halos_from_parent_r4_3d_lowhighz(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, 1, nz) + + end subroutine fill_nest_halos_from_parent_r4_3d_highz + + subroutine fill_nest_halos_from_parent_r4_3d_lowhighz(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, low_z, high_z) + character(len=*), intent(in) :: var_name + real*4, allocatable, intent(inout) :: data_var(:,:,:) + integer, intent(in) :: interp_type + real, allocatable, intent(in) :: wt(:,:,:) + integer, allocatable, intent(in) :: ind(:,:,:) + integer, intent(in) :: x_refine, y_refine + logical, intent(in) :: is_fine_pe + type(nest_domain_type), intent(inout) :: nest_domain + integer, intent(in) :: position, low_z, high_z + real*4, dimension(:,:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer type(bbox) :: north_fine, north_coarse type(bbox) :: south_fine, south_coarse @@ -571,10 +836,10 @@ subroutine fill_nest_halos_from_parent_r4_3d(var_name, data_var, interp_type, wt !! !!=========================================================== - call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, nz) - call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, nz) - call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, nz) - call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, nz) + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, low_z, high_z) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, low_z, high_z) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, low_z, high_z) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, low_z, high_z) ! Passes data from coarse grid to fine grid's halo call mpp_update_nest_fine(data_var, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level, position=position) @@ -587,10 +852,10 @@ subroutine fill_nest_halos_from_parent_r4_3d(var_name, data_var, interp_type, wt !! !!=========================================================== - call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, nz, NORTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, nz, SOUTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, nz, EAST, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, nz, WEST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, low_z, high_z, NORTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, low_z, high_z, SOUTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, low_z, high_z, EAST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, low_z, high_z, WEST, x_refine, y_refine, wt, ind) endif @@ -599,10 +864,9 @@ subroutine fill_nest_halos_from_parent_r4_3d(var_name, data_var, interp_type, wt deallocate(ebuffer) deallocate(wbuffer) - end subroutine fill_nest_halos_from_parent_r4_3d + end subroutine fill_nest_halos_from_parent_r4_3d_lowhighz - - subroutine fill_nest_halos_from_parent_r8_3d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) + subroutine fill_nest_halos_from_parent_r8_3d_highz(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) character(len=*), intent(in) :: var_name real*8, allocatable, intent(inout) :: data_var(:,:,:) integer, intent(in) :: interp_type @@ -613,6 +877,21 @@ subroutine fill_nest_halos_from_parent_r8_3d(var_name, data_var, interp_type, wt type(nest_domain_type), intent(inout) :: nest_domain integer, intent(in) :: position, nz + call fill_nest_halos_from_parent_r8_3d_lowhighz(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, 1, nz) + + end subroutine fill_nest_halos_from_parent_r8_3d_highz + + subroutine fill_nest_halos_from_parent_r8_3d_lowhighz(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, low_z, high_z) + character(len=*), intent(in) :: var_name + real*8, allocatable, intent(inout) :: data_var(:,:,:) + integer, intent(in) :: interp_type + real, allocatable, intent(in) :: wt(:,:,:) ! TODO should this be real*8? + integer, allocatable, intent(in) :: ind(:,:,:) + integer, intent(in) :: x_refine, y_refine + logical, intent(in) :: is_fine_pe + type(nest_domain_type), intent(inout) :: nest_domain + integer, intent(in) :: position, low_z, high_z + real*8, dimension(:,:,:), allocatable :: nbuffer, sbuffer, ebuffer, wbuffer type(bbox) :: north_fine, north_coarse type(bbox) :: south_fine, south_coarse @@ -629,10 +908,10 @@ subroutine fill_nest_halos_from_parent_r8_3d(var_name, data_var, interp_type, wt !! !!=========================================================== - call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, nz) - call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, nz) - call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, nz) - call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, nz) + call alloc_halo_buffer(nbuffer, north_fine, north_coarse, nest_domain, NORTH, position, low_z, high_z) + call alloc_halo_buffer(sbuffer, south_fine, south_coarse, nest_domain, SOUTH, position, low_z, high_z) + call alloc_halo_buffer(ebuffer, east_fine, east_coarse, nest_domain, EAST, position, low_z, high_z) + call alloc_halo_buffer(wbuffer, west_fine, west_coarse, nest_domain, WEST, position, low_z, high_z) ! Passes data from coarse grid to fine grid's halo call mpp_update_nest_fine(data_var, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level, position=position) @@ -645,10 +924,10 @@ subroutine fill_nest_halos_from_parent_r8_3d(var_name, data_var, interp_type, wt !! !!=========================================================== - call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, nz, NORTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, nz, SOUTH, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, nz, EAST, x_refine, y_refine, wt, ind) - call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, nz, WEST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, nbuffer, north_fine, north_coarse, low_z, high_z, NORTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, sbuffer, south_fine, south_coarse, low_z, high_z, SOUTH, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, ebuffer, east_fine, east_coarse, low_z, high_z, EAST, x_refine, y_refine, wt, ind) + call fill_nest_from_buffer(interp_type, data_var, wbuffer, west_fine, west_coarse, low_z, high_z, WEST, x_refine, y_refine, wt, ind) endif @@ -657,7 +936,7 @@ subroutine fill_nest_halos_from_parent_r8_3d(var_name, data_var, interp_type, wt deallocate(ebuffer) deallocate(wbuffer) - end subroutine fill_nest_halos_from_parent_r8_3d + end subroutine fill_nest_halos_from_parent_r8_3d_lowhighz subroutine fill_nest_halos_from_parent_r4_4d(var_name, data_var, interp_type, wt, ind, x_refine, y_refine, is_fine_pe, nest_domain, position, nz) @@ -836,17 +1115,27 @@ subroutine alloc_halo_buffer_r4_2d(buffer, bbox_fine, bbox_coarse, nest_domain, end subroutine alloc_halo_buffer_r4_2d - subroutine alloc_halo_buffer_r4_3d(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, nz) + subroutine alloc_halo_buffer_r4_3d_highz(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, high_z) real*4, dimension(:,:,:), allocatable, intent(out) :: buffer type(bbox), intent(out) :: bbox_fine, bbox_coarse type(nest_domain_type), intent(in) :: nest_domain - integer, intent(in) :: direction, position, nz + integer, intent(in) :: direction, position, high_z + + call alloc_halo_buffer_r4_3d_lowhighz(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, 1, high_z) + + end subroutine alloc_halo_buffer_r4_3d_highz + + subroutine alloc_halo_buffer_r4_3d_lowhighz(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, low_z, high_z) + real*4, dimension(:,:,:), allocatable, intent(out) :: buffer + type(bbox), intent(out) :: bbox_fine, bbox_coarse + type(nest_domain_type), intent(in) :: nest_domain + integer, intent(in) :: direction, position, low_z, high_z call bbox_get_C2F_index(nest_domain, bbox_fine, bbox_coarse, direction, position) if( bbox_coarse.ie .GE. bbox_coarse.is .AND. bbox_coarse.je .GE. bbox_coarse.js ) then - allocate(buffer(bbox_coarse.is:bbox_coarse.ie, bbox_coarse.js:bbox_coarse.je,1:nz)) + allocate(buffer(bbox_coarse.is:bbox_coarse.ie, bbox_coarse.js:bbox_coarse.je, low_z:high_z)) else ! The buffer must have some storage allocated, whether it's a useful buffer or just a dummy. allocate(buffer(1,1,1)) @@ -854,19 +1143,29 @@ subroutine alloc_halo_buffer_r4_3d(buffer, bbox_fine, bbox_coarse, nest_domain, buffer = 0 - end subroutine alloc_halo_buffer_r4_3d + end subroutine alloc_halo_buffer_r4_3d_lowhighz + + + subroutine alloc_halo_buffer_r8_3d_highz(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, high_z) + real*8, dimension(:,:,:), allocatable, intent(out) :: buffer + type(bbox), intent(out) :: bbox_fine, bbox_coarse + type(nest_domain_type), intent(in) :: nest_domain + integer, intent(in) :: direction, position, high_z + + call alloc_halo_buffer_r8_3d_lowhighz(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, 1, high_z) + end subroutine alloc_halo_buffer_r8_3d_highz - subroutine alloc_halo_buffer_r8_3d(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, nz) + subroutine alloc_halo_buffer_r8_3d_lowhighz(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, low_z, high_z) real*8, dimension(:,:,:), allocatable, intent(out) :: buffer type(bbox), intent(out) :: bbox_fine, bbox_coarse type(nest_domain_type), intent(in) :: nest_domain - integer, intent(in) :: direction, position, nz + integer, intent(in) :: direction, position, low_z, high_z call bbox_get_C2F_index(nest_domain, bbox_fine, bbox_coarse, direction, position) if( bbox_coarse.ie .GE. bbox_coarse.is .AND. bbox_coarse.je .GE. bbox_coarse.js ) then - allocate(buffer(bbox_coarse.is:bbox_coarse.ie, bbox_coarse.js:bbox_coarse.je,1:nz)) + allocate(buffer(bbox_coarse.is:bbox_coarse.ie, bbox_coarse.js:bbox_coarse.je, low_z:high_z)) else ! The buffer must have some storage allocated, whether it's a useful buffer or just a dummy. allocate(buffer(1,1,1)) @@ -874,7 +1173,7 @@ subroutine alloc_halo_buffer_r8_3d(buffer, bbox_fine, bbox_coarse, nest_domain, buffer = 0 - end subroutine alloc_halo_buffer_r8_3d + end subroutine alloc_halo_buffer_r8_3d_lowhighz subroutine alloc_halo_buffer_r4_4d(buffer, bbox_fine, bbox_coarse, nest_domain, direction, position, nz, n4d) @@ -1522,9 +1821,10 @@ subroutine fill_nest_from_buffer_r8_2d(interp_type, x, buffer, bbox_fine, bbox_c end subroutine fill_nest_from_buffer_r8_2d - subroutine fill_nest_from_buffer_masked(interp_type, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) + subroutine fill_nest_from_buffer_masked_r8_2d_const(var_name, interp_type, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) implicit none + character(len=*), intent(in) :: var_name integer, intent(in) :: interp_type real*8, allocatable, intent(inout) :: x(:,:) real*8, allocatable, intent(in) :: buffer(:,:) @@ -1533,6 +1833,7 @@ subroutine fill_nest_from_buffer_masked(interp_type, x, buffer, bbox_fine, bbox_ real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 integer, allocatable, intent(in) :: ind(:,:,:) real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) integer, intent(in) :: mask_val real*8, intent(in) :: default_val @@ -1542,12 +1843,14 @@ subroutine fill_nest_from_buffer_masked(interp_type, x, buffer, bbox_fine, bbox_ ! Output the interpolation type select case (interp_type) case (1) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 1 not implemented. var_name=",A16)', var_name call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) ! case (3) ! C grid staggered case (4) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 4 not implemented. var_name=",A16)', var_name call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) case (7) - call fill_nest_from_buffer_cell_center_masked("A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) + call fill_nest_from_buffer_cell_center_masked(var_name, "A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) case (9) !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, dir, wt) call mpp_error(FATAL, '2D fill_nest_from_buffer_nearest_neighbor not yet implemented.') @@ -1555,21 +1858,23 @@ subroutine fill_nest_from_buffer_masked(interp_type, x, buffer, bbox_fine, bbox_ call mpp_error(FATAL, 'interp_single_nest got invalid value for interp_type from namelist.') end select - end subroutine fill_nest_from_buffer_masked - + end subroutine fill_nest_from_buffer_masked_r8_2d_const - - subroutine fill_nest_from_buffer_r4_3d(interp_type, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + subroutine fill_nest_from_buffer_masked_r8_2d_2d(var_name, interp_type, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) implicit none + character(len=*), intent(in) :: var_name integer, intent(in) :: interp_type - real*4, allocatable, intent(inout) :: x(:,:,:) - real*4, allocatable, intent(in) :: buffer(:,:,:) + real*8, allocatable, intent(inout) :: x(:,:) + real*8, allocatable, intent(in) :: buffer(:,:) type(bbox), intent(in) :: bbox_fine, bbox_coarse - integer, intent(in) :: nz integer, intent(in) :: dir, x_refine, y_refine real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 integer, allocatable, intent(in) :: ind(:,:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real, allocatable, intent(in) :: default_grid(:,:) integer :: this_pe this_pe = mpp_pe() @@ -1577,31 +1882,39 @@ subroutine fill_nest_from_buffer_r4_3d(interp_type, x, buffer, bbox_fine, bbox_c ! Output the interpolation type select case (interp_type) case (1) - call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) - ! case (3) ! C grid staggered + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 1 not implemented. var_name=",A16)', var_name + call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) + ! case (3) ! C grid staggered case (4) - call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 4 not implemented. var_name=",A16)', var_name + call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) + case (7) + call fill_nest_from_buffer_cell_center_masked(var_name, "A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) case (9) - !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, nz, dir, wt) - call mpp_error(FATAL, 'fill_nest_from_buffer_nearest_neighbor is not yet implemented.') + !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, dir, wt) + call mpp_error(FATAL, '2D fill_nest_from_buffer_nearest_neighbor not yet implemented.') case default call mpp_error(FATAL, 'interp_single_nest got invalid value for interp_type from namelist.') end select - end subroutine fill_nest_from_buffer_r4_3d + end subroutine fill_nest_from_buffer_masked_r8_2d_2d - subroutine fill_nest_from_buffer_r8_3d(interp_type, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + subroutine fill_nest_from_buffer_masked_r8_3d_1d(var_name, interp_type, x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_vector) implicit none + character(len=*), intent(in) :: var_name integer, intent(in) :: interp_type real*8, allocatable, intent(inout) :: x(:,:,:) real*8, allocatable, intent(in) :: buffer(:,:,:) type(bbox), intent(in) :: bbox_fine, bbox_coarse - integer, intent(in) :: nz - integer, intent(in) :: dir, x_refine, y_refine + integer, intent(in) :: dir, x_refine, y_refine, low_z, high_z real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 integer, allocatable, intent(in) :: ind(:,:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real*8, intent(in) :: default_vector(low_z:high_z) integer :: this_pe this_pe = mpp_pe() @@ -1609,22 +1922,167 @@ subroutine fill_nest_from_buffer_r8_3d(interp_type, x, buffer, bbox_fine, bbox_c ! Output the interpolation type select case (interp_type) case (1) - call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 1 not implemented. var_name=",A16)', var_name + call mpp_error(FATAL, '3D fill_nest_from_buffer_nearest_neighbor not yet implemented.') + !call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) ! case (3) ! C grid staggered case (4) - call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 4 not implemented. var_name=",A16)', var_name + call mpp_error(FATAL, '3D fill_nest_from_buffer_nearest_neighbor not yet implemented.') + !call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) + case (7) + call fill_nest_from_buffer_cell_center_masked(var_name, "A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, low_z, high_z, default_vector) case (9) - call mpp_error(FATAL, 'nearest_neighbor is not yet implemented for fv_moving_nest_utils.F90::fill_nest_from_buffer_3D_kindphys') - !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, nz, dir, wt) + !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, dir, wt) + call mpp_error(FATAL, '3D fill_nest_from_buffer_nearest_neighbor not yet implemented.') case default call mpp_error(FATAL, 'interp_single_nest got invalid value for interp_type from namelist.') end select - end subroutine fill_nest_from_buffer_r8_3d + end subroutine fill_nest_from_buffer_masked_r8_3d_1d - !>@brief This subroutine fills the nest halo data from the coarse grid data by downscaling. - !>@details Applicable to any interpolation type + subroutine fill_nest_from_buffer_masked_r8_3d_2d(var_name, interp_type, x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + implicit none + + character(len=*), intent(in) :: var_name + integer, intent(in) :: interp_type + real*8, allocatable, intent(inout) :: x(:,:,:) + real*8, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: dir, x_refine, y_refine, low_z, high_z + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real, allocatable, intent(in) :: default_grid(:,:) + + integer :: this_pe + this_pe = mpp_pe() + + ! Output the interpolation type + select case (interp_type) + case (1) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 1 not implemented. var_name=",A16)', var_name + call mpp_error(FATAL, '3D fill_nest_from_buffer_nearest_neighbor not yet implemented.') + !call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) + ! case (3) ! C grid staggered + case (4) + print '("[WARN] fv_moving_nest_utils.F90 fill_nest_from_buffer_mask interp_type 4 not implemented. var_name=",A16)', var_name + call mpp_error(FATAL, '3D fill_nest_from_buffer_nearest_neighbor not yet implemented.') + !call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind) + case (7) + call fill_nest_from_buffer_cell_center_masked(var_name, "A", x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, low_z, high_z, default_grid) + case (9) + !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, dir, wt) + call mpp_error(FATAL, '3D fill_nest_from_buffer_nearest_neighbor not yet implemented.') + case default + call mpp_error(FATAL, 'interp_single_nest got invalid value for interp_type from namelist.') + end select + + end subroutine fill_nest_from_buffer_masked_r8_3d_2d + + + + subroutine fill_nest_from_buffer_r4_3d_highz(interp_type, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + implicit none + + integer, intent(in) :: interp_type + real*4, allocatable, intent(inout) :: x(:,:,:) + real*4, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: nz + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + + call fill_nest_from_buffer_r4_3d_lowhighz(interp_type, x, buffer, bbox_fine, bbox_coarse, 1, nz, dir, x_refine, y_refine, wt, ind) + + end subroutine fill_nest_from_buffer_r4_3d_highz + + subroutine fill_nest_from_buffer_r4_3d_lowhighz(interp_type, x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + implicit none + + integer, intent(in) :: interp_type + real*4, allocatable, intent(inout) :: x(:,:,:) + real*4, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: low_z, high_z + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + + integer :: this_pe + this_pe = mpp_pe() + + ! Output the interpolation type + select case (interp_type) + case (1) + call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + ! case (3) ! C grid staggered + case (4) + call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + case (9) + !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, wt) + call mpp_error(FATAL, 'fill_nest_from_buffer_nearest_neighbor is not yet implemented.') + case default + call mpp_error(FATAL, 'interp_single_nest got invalid value for interp_type from namelist.') + end select + + end subroutine fill_nest_from_buffer_r4_3d_lowhighz + + + subroutine fill_nest_from_buffer_r8_3d_highz(interp_type, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + implicit none + + integer, intent(in) :: interp_type + real*8, allocatable, intent(inout) :: x(:,:,:) + real*8, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: nz + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + + call fill_nest_from_buffer_r8_3d_lowhighz(interp_type, x, buffer, bbox_fine, bbox_coarse, 1, nz, dir, x_refine, y_refine, wt, ind) + + end subroutine fill_nest_from_buffer_r8_3d_highz + + subroutine fill_nest_from_buffer_r8_3d_lowhighz(interp_type, x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + implicit none + + integer, intent(in) :: interp_type + real*8, allocatable, intent(inout) :: x(:,:,:) + real*8, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: low_z, high_z + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + + integer :: this_pe + this_pe = mpp_pe() + + ! Output the interpolation type + select case (interp_type) + case (1) + call fill_nest_from_buffer_cell_center("A", x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + ! case (3) ! C grid staggered + case (4) + call fill_nest_from_buffer_cell_center("D", x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + case (9) + call mpp_error(FATAL, 'nearest_neighbor is not yet implemented for fv_moving_nest_utils.F90::fill_nest_from_buffer_3D_kindphys') + !call fill_nest_from_buffer_nearest_neighbor(x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, wt) + case default + call mpp_error(FATAL, 'interp_single_nest got invalid value for interp_type from namelist.') + end select + + end subroutine fill_nest_from_buffer_r8_3d_lowhighz + + + !>@brief This subroutine fills the nest halo data from the coarse grid data by downscaling. + !>@details Applicable to any interpolation type subroutine fill_nest_from_buffer_r4_4d(interp_type, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) implicit none @@ -1795,8 +2253,9 @@ subroutine fill_nest_from_buffer_cell_center_r8_2d(stagger, x, buffer, bbox_fine end subroutine fill_nest_from_buffer_cell_center_r8_2d - subroutine fill_nest_from_buffer_cell_center_masked(stagger, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, mask_val, default_val) + subroutine fill_nest_from_buffer_cell_center_masked_2d_const(var_name, stagger, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_val) implicit none + character(len=*), intent(in) :: var_name character ( len = 1 ), intent(in) :: stagger real*8, allocatable, intent(inout) :: x(:,:) real*8, allocatable, intent(in) :: buffer(:,:) @@ -1805,12 +2264,21 @@ subroutine fill_nest_from_buffer_cell_center_masked(stagger, x, buffer, bbox_fin real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 integer, allocatable, intent(in) :: ind(:,:,:) real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) integer, intent(in) :: mask_val real*8, intent(in) :: default_val character(len=8) :: dir_str integer :: i, j, k, ic, jc real :: tw + real :: dummy_val, dummy_mask + integer :: num_reset, num_weights + integer :: this_pe + + this_pe = mpp_pe() + + num_reset = 0 + dummy_val = real_snan select case(dir) case (NORTH) @@ -1842,30 +2310,453 @@ subroutine fill_nest_from_buffer_cell_center_masked(stagger, x, buffer, bbox_fin !if (mask_var(i,j) .eq. mask_val) then x(i,j) = 0.0 tw = 0.0 - if (buffer(ic,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) - if (buffer(ic,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc+1) - if (buffer(ic+1,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic+1,jc+1) - if (buffer(ic+1,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic+1,jc ) + num_weights = 0 + +! WDR Original -- seems like the wt values should range from 1-4, not all use wt(i,j,1) +! will likely alter land values of shifted physics fields in regression tests. +! old values were (slightly) incorrect -- averaged of the 4 nearby points instead of actual weights +! if (buffer(ic,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) +! if (buffer(ic,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc+1) +! if (buffer(ic+1,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic+1,jc+1) +! if (buffer(ic+1,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic+1,jc ) +! +! if (buffer(ic,jc) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic,jc+1) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic+1,jc+1) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic+1,jc) .gt. -1.0) tw = tw + wt(i,j,1) + + +! Intermediate: Corrected the weights +! if (buffer(ic,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) +! if (buffer(ic,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,2)*buffer(ic, jc+1) +! if (buffer(ic+1,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,3)*buffer(ic+1,jc+1) +! if (buffer(ic+1,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,4)*buffer(ic+1,jc ) +! +! if (buffer(ic,jc) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic,jc+1) .gt. -1.0) tw = tw + wt(i,j,2) +! if (buffer(ic+1,jc+1) .gt. -1.0) tw = tw + wt(i,j,3) +! if (buffer(ic+1,jc) .gt. -1.0) tw = tw + wt(i,j,4) + + +! print '("[INFO] MASK2D npe=",I0," ",A16," parent_mask_var(",I0,",",I0,")=",F15.5," mask_var(",I0,",",I0,")=",F15.5)', mpp_pe(), var_name, ic, jc, parent_mask_var(ic,jc), i, j, mask_var(i,j) + + !if (this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK2D SNOWXY npe=",I0," ",A16," parent_mask_var(",I0,",",I0,")=",F15.5," mask_var(",I0,",",I0,")=",F15.5)', mpp_pe(), var_name, ic, jc, parent_mask_var(ic,jc), i, j, mask_var(i,j) + + + ! Note that weights don't seem to always be exactly 0.0 when the corner points are aligned + ! Use the land sea mask to choose which points to add to weight and buffer + if (parent_mask_var(ic,jc) .eq. mask_var(i,j) .and. wt(i,j,1) .gt. 0.0001 ) then + num_weights = num_weights + 1 + x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) + tw = tw + wt(i,j,1) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY AA npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10)', this_pe, num_weights, ic, jc, buffer(ic,jc), i, j, x(i,j), tw, wt(i,j,1) + + endif + + if (parent_mask_var(ic,jc+1) .eq. mask_var(i,j) .and. wt(i,j,2) .gt. 0.0001) then + num_weights = num_weights + 2 + x(i,j) = x(i,j) + wt(i,j,2)*buffer(ic, jc+1) + tw = tw + wt(i,j,2) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY BB npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10)', this_pe, num_weights, ic, jc+1, buffer(ic,jc+1), i, j, x(i,j), tw, wt(i,j,2) + endif + + if (parent_mask_var(ic+1,jc+1) .eq. mask_var(i,j) .and. wt(i,j,3) .gt. 0.0001) then + num_weights = num_weights + 4 + x(i,j) = x(i,j) + wt(i,j,3)*buffer(ic+1,jc+1) + tw = tw + wt(i,j,3) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY CC npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10,",",E12.5," parent_mask(",I0,",",I0,")=",F8.3)', this_pe, num_weights, ic+1, jc+1, buffer(ic+1,jc+1), i, j, x(i,j), tw, wt(i,j,3), wt(i,j,3), ic+1, jc+1, parent_mask_var(ic+1, jc+1) + endif + + if (parent_mask_var(ic+1,jc) .eq. mask_var(i,j) .and. wt(i,j,4) .gt. 0.0001) then + num_weights = num_weights + 8 + x(i,j) = x(i,j) + wt(i,j,4)*buffer(ic+1,jc ) + tw = tw + wt(i,j,4) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY DD npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10)', this_pe, num_weights, ic+1, jc, buffer(ic+1,jc), i, j, x(i,j), tw, wt(i,j,4) + + endif - if (buffer(ic,jc) .gt. -1.0) tw = tw + wt(i,j,1) - if (buffer(ic,jc+1) .gt. -1.0) tw = tw + wt(i,j,1) - if (buffer(ic+1,jc+1) .gt. -1.0) tw = tw + wt(i,j,1) - if (buffer(ic+1,jc) .gt. -1.0) tw = tw + wt(i,j,1) if (tw .gt. 0.0) then x(i,j) = x(i,j) / tw else + num_reset = num_reset + 1 + dummy_val = buffer(ic, jc) + dummy_mask = mask_var(i,j) x(i,j) = default_val endif + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY 2d_const npe=",I0," num_weights=",I0," x(",I0,",",I0,")=",E12.5)', this_pe, num_weights, i, j, x(i,j) + + enddo enddo endif - end subroutine fill_nest_from_buffer_cell_center_masked +! if (.not. isnan(dummy_val)) print '("[INFO] WDR fill_nest_from_buffer_cell_center_masked npe=",I0," num_reset=",I0," var=",A12," mask_var=",F10.4," dummy_val=",F14.4," ",E15.8)', mpp_pe(), num_reset, trim(var_name), dummy_mask, dummy_val, dummy_val + end subroutine fill_nest_from_buffer_cell_center_masked_2d_const - subroutine fill_nest_from_buffer_cell_center_r4_3d(stagger, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + subroutine fill_nest_from_buffer_cell_center_masked_2d_2d(var_name, stagger, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, default_grid) + implicit none + character(len=*), intent(in) :: var_name + character ( len = 1 ), intent(in) :: stagger + real*8, allocatable, intent(inout) :: x(:,:) + real*8, allocatable, intent(in) :: buffer(:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val + real, allocatable, intent(in) :: default_grid(:,:) + + character(len=8) :: dir_str + integer :: i, j, k, ic, jc + real :: tw + real :: dummy_val, dummy_mask + integer :: num_reset, num_weights + integer :: this_pe + + this_pe = mpp_pe() + + num_reset = 0 + dummy_val = real_snan + + select case(dir) + case (NORTH) + dir_str = "NORTH" + case (SOUTH) + dir_str = "SOUTH" + case (EAST) + dir_str = "EAST" + case (WEST) + dir_str = "WEST" + case default + dir_str = "ERR DIR" + end select + + if( bbox_coarse%ie .GE. bbox_coarse%is .AND. bbox_coarse%je .GE. bbox_coarse%js ) then + do j=bbox_fine%js, bbox_fine%je + do i=bbox_fine%is, bbox_fine%ie + + ic = ind(i,j,1) + jc = ind(i,j,2) + + !x(i,j) = & + ! wt(i,j,1)*buffer(ic, jc ) + & + ! wt(i,j,2)*buffer(ic, jc+1) + & + ! wt(i,j,3)*buffer(ic+1,jc+1) + & + ! wt(i,j,4)*buffer(ic+1,jc ) + + ! Land type + !if (mask_var(i,j) .eq. mask_val) then + x(i,j) = 0.0 + tw = 0.0 + num_weights = 0 + +! WDR Original -- seems like the wt values should range from 1-4, not all use wt(i,j,1) +! will likely alter land values of shifted physics fields in regression tests. +! old values were (slightly) incorrect -- averaged of the 4 nearby points instead of actual weights +! if (buffer(ic,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) +! if (buffer(ic,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc+1) +! if (buffer(ic+1,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic+1,jc+1) +! if (buffer(ic+1,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic+1,jc ) +! +! if (buffer(ic,jc) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic,jc+1) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic+1,jc+1) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic+1,jc) .gt. -1.0) tw = tw + wt(i,j,1) + + +! Intermediate: Corrected the weights +! if (buffer(ic,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) +! if (buffer(ic,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,2)*buffer(ic, jc+1) +! if (buffer(ic+1,jc+1) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,3)*buffer(ic+1,jc+1) +! if (buffer(ic+1,jc) .gt. -1.0) x(i,j) = x(i,j) + wt(i,j,4)*buffer(ic+1,jc ) +! +! if (buffer(ic,jc) .gt. -1.0) tw = tw + wt(i,j,1) +! if (buffer(ic,jc+1) .gt. -1.0) tw = tw + wt(i,j,2) +! if (buffer(ic+1,jc+1) .gt. -1.0) tw = tw + wt(i,j,3) +! if (buffer(ic+1,jc) .gt. -1.0) tw = tw + wt(i,j,4) + + +! print '("[INFO] MASK2D npe=",I0," ",A16," parent_mask_var(",I0,",",I0,")=",F15.5," mask_var(",I0,",",I0,")=",F15.5)', mpp_pe(), var_name, ic, jc, parent_mask_var(ic,jc), i, j, mask_var(i,j) + + + + ! Note that weights don't seem to always be exactly 0.0 when the corner points are aligned + ! Use the land sea mask to choose which points to add to weight and buffer + if (parent_mask_var(ic,jc) .eq. mask_var(i,j) .and. wt(i,j,1) .gt. 0.0001 ) then + num_weights = num_weights + 1 + x(i,j) = x(i,j) + wt(i,j,1)*buffer(ic, jc ) + tw = tw + wt(i,j,1) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY AA npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10)', this_pe, num_weights, ic, jc, buffer(ic,jc), i, j, x(i,j), tw, wt(i,j,1) + + endif + + if (parent_mask_var(ic,jc+1) .eq. mask_var(i,j) .and. wt(i,j,2) .gt. 0.0001) then + num_weights = num_weights + 2 + x(i,j) = x(i,j) + wt(i,j,2)*buffer(ic, jc+1) + tw = tw + wt(i,j,2) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY BB npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10)', this_pe, num_weights, ic, jc+1, buffer(ic,jc+1), i, j, x(i,j), tw, wt(i,j,2) + endif + + if (parent_mask_var(ic+1,jc+1) .eq. mask_var(i,j) .and. wt(i,j,3) .gt. 0.0001) then + num_weights = num_weights + 4 + x(i,j) = x(i,j) + wt(i,j,3)*buffer(ic+1,jc+1) + tw = tw + wt(i,j,3) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY CC npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10,",",E12.5," parent_mask(",I0,",",I0,")=",F8.3)', this_pe, num_weights, ic+1, jc+1, buffer(ic+1,jc+1), i, j, x(i,j), tw, wt(i,j,3), wt(i,j,3), ic+1, jc+1, parent_mask_var(ic+1, jc+1) + endif + + if (parent_mask_var(ic+1,jc) .eq. mask_var(i,j) .and. wt(i,j,4) .gt. 0.0001) then + num_weights = num_weights + 8 + x(i,j) = x(i,j) + wt(i,j,4)*buffer(ic+1,jc ) + tw = tw + wt(i,j,4) + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY DD npe=",I0," num_weights=",I0," buffer(",I0,",",I0,")=",E12.5," snowxy(",I0,",",I0,")=",E12.5," tw=",F8.5," wt=",F14.10)', this_pe, num_weights, ic+1, jc, buffer(ic+1,jc), i, j, x(i,j), tw, wt(i,j,4) + + endif + + + if (tw .gt. 0.0) then + x(i,j) = x(i,j) / tw + else + num_reset = num_reset + 1 + dummy_val = buffer(ic, jc) + dummy_mask = mask_var(i,j) + x(i,j) = default_grid(i,j) + endif + + !if ( this_pe .eq. 89 .and. trim(var_name) .eq. "snowxy") print '("[INFO] MASK_SNOWXY 2d_2d npe=",I0," num_weights=",I0," x(",I0,",",I0,")=",E12.5)', this_pe, num_weights, i, j, x(i,j) + + + enddo + enddo + endif + +! if (.not. isnan(dummy_val)) print '("[INFO] WDR fill_nest_from_buffer_cell_center_masked npe=",I0," num_reset=",I0," var=",A12," mask_var=",F10.4," dummy_val=",F14.4," ",E15.8)', mpp_pe(), num_reset, trim(var_name), dummy_mask, dummy_val, dummy_val + + end subroutine fill_nest_from_buffer_cell_center_masked_2d_2d + + + subroutine fill_nest_from_buffer_cell_center_masked_3d_1d(var_name, stagger, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, low_z, high_z, default_vector) + implicit none + character(len=*), intent(in) :: var_name + character ( len = 1 ), intent(in) :: stagger + real*8, allocatable, intent(inout) :: x(:,:,:) + real*8, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val, low_z, high_z + real*8, intent(in) :: default_vector(low_z:high_z) + + character(len=8) :: dir_str + integer :: i, j, k, ic, jc + real :: tw + real :: dummy_val, dummy_mask + + dummy_val = real_snan + + select case(dir) + case (NORTH) + dir_str = "NORTH" + case (SOUTH) + dir_str = "SOUTH" + case (EAST) + dir_str = "EAST" + case (WEST) + dir_str = "WEST" + case default + dir_str = "ERR DIR" + end select + + if( bbox_coarse%ie .GE. bbox_coarse%is .AND. bbox_coarse%je .GE. bbox_coarse%js ) then + do j=bbox_fine%js, bbox_fine%je + do i=bbox_fine%is, bbox_fine%ie + + ic = ind(i,j,1) + jc = ind(i,j,2) + + !x(i,j) = & + ! wt(i,j,1)*buffer(ic, jc ) + & + ! wt(i,j,2)*buffer(ic, jc+1) + & + ! wt(i,j,3)*buffer(ic+1,jc+1) + & + ! wt(i,j,4)*buffer(ic+1,jc ) + + ! Land type + !if (mask_var(i,j) .eq. mask_val) then + + + do k=lbound(x,3), ubound(x,3) + x(i,j,k) = 0.0 + tw = 0.0 + + + +! print '("[INFO] MASK3D npe=",I0," ",A16," parent_mask_var(",I0,",",I0,")=",F15.5," mask_var(",I0,",",I0,")=",F15.5)', mpp_pe(), var_name, ic, jc, parent_mask_var(ic,jc), i, j, mask_var(i,j) + + + ! Use the land sea mask to choose which points to add to weight and buffer + if (parent_mask_var(ic,jc) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,1)*buffer(ic, jc ,k) + tw = tw + wt(i,j,1) + endif + + if (parent_mask_var(ic,jc+1) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,2)*buffer(ic, jc+1,k) + tw = tw + wt(i,j,2) + endif + + if (parent_mask_var(ic+1,jc+1) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,3)*buffer(ic+1,jc+1,k) + tw = tw + wt(i,j,3) + endif + + if (parent_mask_var(ic+1,jc) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,4)*buffer(ic+1,jc ,k) + tw = tw + wt(i,j,4) + endif + + + if (tw .gt. 0.0) then + x(i,j,k) = x(i,j,k) / tw + else + dummy_val = buffer(ic, jc,k) + dummy_mask = mask_var(i,j) + x(i,j,k) = default_vector(k) + endif + + enddo + enddo + enddo + endif + +! if (.not. isnan(dummy_val)) then +! print '("[INFO WDR CCM3 fill_nest_from_buffer_cell_center_masked_3d npe=",I0)', mpp_pe() +! print '("[INFO] WDR CCM3 fill_nest_from_buffer_cell_center_masked npe=",I0," var=",A16," mask_var=",F10.4," dummy_val=",F14.4," ",E15.8)', mpp_pe(), trim(var_name), dummy_mask, dummy_val, dummy_val +! endif + + end subroutine fill_nest_from_buffer_cell_center_masked_3d_1d + + + subroutine fill_nest_from_buffer_cell_center_masked_3d_2d(var_name, stagger, x, buffer, bbox_fine, bbox_coarse, dir, x_refine, y_refine, wt, ind, mask_var, parent_mask_var, mask_val, low_z, high_z, default_grid) + implicit none + character(len=*), intent(in) :: var_name + character ( len = 1 ), intent(in) :: stagger + real*8, allocatable, intent(inout) :: x(:,:,:) + real*8, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + real, allocatable, intent(in) :: mask_var(:,:) + real, allocatable, intent(in) :: parent_mask_var(:,:) + integer, intent(in) :: mask_val, low_z, high_z + real, allocatable, intent(in) :: default_grid(:,:) + + character(len=8) :: dir_str + integer :: i, j, k, ic, jc + real :: tw + real :: dummy_val, dummy_mask + + dummy_val = real_snan + + select case(dir) + case (NORTH) + dir_str = "NORTH" + case (SOUTH) + dir_str = "SOUTH" + case (EAST) + dir_str = "EAST" + case (WEST) + dir_str = "WEST" + case default + dir_str = "ERR DIR" + end select + + if( bbox_coarse%ie .GE. bbox_coarse%is .AND. bbox_coarse%je .GE. bbox_coarse%js ) then + do j=bbox_fine%js, bbox_fine%je + do i=bbox_fine%is, bbox_fine%ie + + ic = ind(i,j,1) + jc = ind(i,j,2) + + !x(i,j) = & + ! wt(i,j,1)*buffer(ic, jc ) + & + ! wt(i,j,2)*buffer(ic, jc+1) + & + ! wt(i,j,3)*buffer(ic+1,jc+1) + & + ! wt(i,j,4)*buffer(ic+1,jc ) + + ! Land type + !if (mask_var(i,j) .eq. mask_val) then + + + do k=lbound(x,3), ubound(x,3) + x(i,j,k) = 0.0 + tw = 0.0 + + + +! print '("[INFO] MASK3D npe=",I0," ",A16," parent_mask_var(",I0,",",I0,")=",F15.5," mask_var(",I0,",",I0,")=",F15.5)', mpp_pe(), var_name, ic, jc, parent_mask_var(ic,jc), i, j, mask_var(i,j) + + + ! Use the land sea mask to choose which points to add to weight and buffer + if (parent_mask_var(ic,jc) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,1)*buffer(ic, jc ,k) + tw = tw + wt(i,j,1) + endif + + if (parent_mask_var(ic,jc+1) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,2)*buffer(ic, jc+1,k) + tw = tw + wt(i,j,2) + endif + + if (parent_mask_var(ic+1,jc+1) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,3)*buffer(ic+1,jc+1,k) + tw = tw + wt(i,j,3) + endif + + if (parent_mask_var(ic+1,jc) .eq. mask_var(i,j)) then + x(i,j,k) = x(i,j,k) + wt(i,j,4)*buffer(ic+1,jc ,k) + tw = tw + wt(i,j,4) + endif + + + if (tw .gt. 0.0) then + x(i,j,k) = x(i,j,k) / tw + else + dummy_val = buffer(ic, jc,k) + dummy_mask = mask_var(i,j) + x(i,j,k) = default_grid(i,j) + endif + + enddo + enddo + enddo + endif + +! if (.not. isnan(dummy_val)) then +! print '("[INFO WDR CCM3 fill_nest_from_buffer_cell_center_masked_3d npe=",I0)', mpp_pe() +! print '("[INFO] WDR CCM3 fill_nest_from_buffer_cell_center_masked npe=",I0," var=",A16," mask_var=",F10.4," dummy_val=",F14.4," ",E15.8)', mpp_pe(), trim(var_name), dummy_mask, dummy_val, dummy_val +! endif + + end subroutine fill_nest_from_buffer_cell_center_masked_3d_2d + + + + subroutine fill_nest_from_buffer_cell_center_r4_3d_highz(stagger, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) implicit none character ( len = 1 ), intent(in) :: stagger real*4, allocatable, intent(inout) :: x(:,:,:) @@ -1876,6 +2767,21 @@ subroutine fill_nest_from_buffer_cell_center_r4_3d(stagger, x, buffer, bbox_fine real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 integer, allocatable, intent(in) :: ind(:,:,:) + call fill_nest_from_buffer_cell_center_r4_3d_lowhighz(stagger, x, buffer, bbox_fine, bbox_coarse, 1, nz, dir, x_refine, y_refine, wt, ind) + + end subroutine fill_nest_from_buffer_cell_center_r4_3d_highz + + subroutine fill_nest_from_buffer_cell_center_r4_3d_lowhighz(stagger, x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + implicit none + character ( len = 1 ), intent(in) :: stagger + real*4, allocatable, intent(inout) :: x(:,:,:) + real*4, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: low_z, high_z + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + character(len=8) :: dir_str integer :: i, j, k, ic, jc @@ -1893,7 +2799,7 @@ subroutine fill_nest_from_buffer_cell_center_r4_3d(stagger, x, buffer, bbox_fine end select if( bbox_coarse%ie .GE. bbox_coarse%is .AND. bbox_coarse%je .GE. bbox_coarse%js ) then - do k=1,nz + do k=low_z, high_z do j=bbox_fine%js, bbox_fine%je do i=bbox_fine%is, bbox_fine%ie !if (stagger == "A") then @@ -1915,9 +2821,9 @@ subroutine fill_nest_from_buffer_cell_center_r4_3d(stagger, x, buffer, bbox_fine enddo endif - end subroutine fill_nest_from_buffer_cell_center_r4_3d + end subroutine fill_nest_from_buffer_cell_center_r4_3d_lowhighz - subroutine fill_nest_from_buffer_cell_center_r8_3d(stagger, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) + subroutine fill_nest_from_buffer_cell_center_r8_3d_highz(stagger, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) implicit none character ( len = 1 ), intent(in) :: stagger real*8, allocatable, intent(inout) :: x(:,:,:) @@ -1928,6 +2834,21 @@ subroutine fill_nest_from_buffer_cell_center_r8_3d(stagger, x, buffer, bbox_fine real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 integer, allocatable, intent(in) :: ind(:,:,:) + call fill_nest_from_buffer_cell_center_r8_3d_lowhighz(stagger, x, buffer, bbox_fine, bbox_coarse, 1, nz, dir, x_refine, y_refine, wt, ind) + + end subroutine fill_nest_from_buffer_cell_center_r8_3d_highz + + subroutine fill_nest_from_buffer_cell_center_r8_3d_lowhighz(stagger, x, buffer, bbox_fine, bbox_coarse, low_z, high_z, dir, x_refine, y_refine, wt, ind) + implicit none + character ( len = 1 ), intent(in) :: stagger + real*8, allocatable, intent(inout) :: x(:,:,:) + real*8, allocatable, intent(in) :: buffer(:,:,:) + type(bbox), intent(in) :: bbox_fine, bbox_coarse + integer, intent(in) :: low_z, high_z + integer, intent(in) :: dir, x_refine, y_refine + real, allocatable, intent(in) :: wt(:,:,:) ! The final dimension is always 4 + integer, allocatable, intent(in) :: ind(:,:,:) + character(len=8) :: dir_str integer :: i, j, k, ic, jc @@ -1945,7 +2866,7 @@ subroutine fill_nest_from_buffer_cell_center_r8_3d(stagger, x, buffer, bbox_fine end select if( bbox_coarse%ie .GE. bbox_coarse%is .AND. bbox_coarse%je .GE. bbox_coarse%js ) then - do k=1,nz + do k=low_z, high_z do j=bbox_fine%js, bbox_fine%je do i=bbox_fine%is, bbox_fine%ie !if (stagger == "A") then @@ -1966,7 +2887,7 @@ subroutine fill_nest_from_buffer_cell_center_r8_3d(stagger, x, buffer, bbox_fine enddo endif - end subroutine fill_nest_from_buffer_cell_center_r8_3d + end subroutine fill_nest_from_buffer_cell_center_r8_3d_lowhighz subroutine fill_nest_from_buffer_cell_center_r4_4d(stagger, x, buffer, bbox_fine, bbox_coarse, nz, dir, x_refine, y_refine, wt, ind) diff --git a/fv3/moving_nest/fv_tracker.F90 b/fv3/moving_nest/fv_tracker.F90 index 5cda9083fe..bdeacf6a7b 100644 --- a/fv3/moving_nest/fv_tracker.F90 +++ b/fv3/moving_nest/fv_tracker.F90 @@ -827,19 +827,19 @@ subroutine output_partial_atcfunix(Atm,Time, & 313 format(A15,", ", & "W10 = ",F7.3," kn, PMIN = ",F8.3," mbar, ", & "LAT = ",F6.3,A1,", LON = ",F7.3,A1,", ", & - "RMW = ",F7.3," nmi") + "RMW = ",F7.3," nmi, NEST_IS = ",I6,", NEST_JS = ",I6) if (Tracker(n)%tracker_fixlon .gt. 180.0) then write(Moving_nest(n)%mn_flag%outatcf_lun+Atm%grid_number,313) timestr, & Tracker(n)%tracker_vmax*mps2kn,Tracker(n)%tracker_pmin/100., & abs(Tracker(n)%tracker_fixlat),get_lat_ns(Tracker(n)%tracker_fixlat), & abs(Tracker(n)%tracker_fixlon-360.0),get_lon_ew(Tracker(n)%tracker_fixlon-360.0), & - Tracker(n)%tracker_rmw*km2nmi + Tracker(n)%tracker_rmw*km2nmi,Atm%neststruct%ioffset,Atm%neststruct%joffset else write(Moving_nest(n)%mn_flag%outatcf_lun+Atm%grid_number,313) timestr, & Tracker(n)%tracker_vmax*mps2kn,Tracker(n)%tracker_pmin/100., & abs(Tracker(n)%tracker_fixlat),get_lat_ns(Tracker(n)%tracker_fixlat), & abs(Tracker(n)%tracker_fixlon),get_lon_ew(Tracker(n)%tracker_fixlon), & - Tracker(n)%tracker_rmw*km2nmi + Tracker(n)%tracker_rmw*km2nmi,Atm%neststruct%ioffset,Atm%neststruct%joffset end if end subroutine output_partial_atcfunix