From 9df837cf969140c7b0763425c78ae99485b603fa Mon Sep 17 00:00:00 2001 From: Jonathan Beezley Date: Tue, 12 Jan 2010 23:38:32 -0700 Subject: [PATCH] wrf svn trunk commit r4103 r4103 | xinzhang | 2010-01-12 08:21:07 -0700 (Tue, 12 Jan 2010) | 102 lines --- wrfv2_fire/Makefile | 18 +- wrfv2_fire/README.NMM | 94 +- wrfv2_fire/Registry/Registry.CONVERT | 6 +- wrfv2_fire/Registry/Registry.EM | 277 +- wrfv2_fire/Registry/Registry.EM_CHEM | 189 +- wrfv2_fire/Registry/Registry.EM_SST | 157 +- wrfv2_fire/Registry/Registry.NMM | 102 +- wrfv2_fire/Registry/Registry.NMM_CHEM | 446 +-- wrfv2_fire/Registry/Registry.NMM_NEST | 260 +- wrfv2_fire/Registry/Registry.wrfvar | 245 +- wrfv2_fire/Registry/registry.chem | 219 +- wrfv2_fire/Registry/registry.dimspec | 2 +- wrfv2_fire/Registry/registry.io_boilerplate | 730 +---- wrfv2_fire/arch/Config_new.pl | 22 +- wrfv2_fire/arch/configure_new.defaults | 122 +- wrfv2_fire/arch/noopt_exceptions | 35 +- wrfv2_fire/arch/noopt_exceptions_f | 123 +- wrfv2_fire/arch/postamble_new | 34 +- wrfv2_fire/arch/preamble_new | 8 + wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags | 2 +- wrfv2_fire/chem/KPP/util/wkc/Makefile | 2 +- wrfv2_fire/chem/Makefile | 41 +- wrfv2_fire/chem/aerosol_driver.F | 4 +- wrfv2_fire/chem/chem_driver.F | 157 +- wrfv2_fire/chem/chemics_init.F | 46 +- wrfv2_fire/chem/convert_emiss.F | 159 +- wrfv2_fire/chem/dry_dep_driver.F | 121 +- wrfv2_fire/chem/emissions_driver.F | 195 +- wrfv2_fire/chem/module_add_emiss_burn.F | 910 +++--- wrfv2_fire/chem/module_aerosols_sorgam.F | 170 +- wrfv2_fire/chem/module_bioemi_megan2.F | 4 +- wrfv2_fire/chem/module_chem_utilities.F | 9 +- wrfv2_fire/chem/module_ctrans_grell.F | 97 +- wrfv2_fire/chem/module_data_mgn2mech.F | 241 +- wrfv2_fire/chem/module_dep_simple.F | 63 +- wrfv2_fire/chem/module_emissions_anthropogenics.F | 35 +- wrfv2_fire/chem/module_ftuv_driver.F | 2 + wrfv2_fire/chem/module_gocart_dust.F | 6 +- wrfv2_fire/chem/module_input_chem_data.F | 83 +- wrfv2_fire/chem/module_isrpia.F | 2 +- wrfv2_fire/chem/module_mosaic_driver.F | 17 +- wrfv2_fire/chem/module_mosaic_therm.F | 32 +- wrfv2_fire/chem/module_optical_averaging.F | 593 +++- wrfv2_fire/chem/module_phot_fastj.F | 3 +- wrfv2_fire/chem/module_plumerise1.F | 207 +- wrfv2_fire/chem/optical_driver.F | 10 +- wrfv2_fire/chem/photolysis_driver.F | 28 +- wrfv2_fire/clean | 5 +- wrfv2_fire/compile | 19 +- wrfv2_fire/configure | 27 +- wrfv2_fire/dyn_em/Makefile | 30 +- wrfv2_fire/dyn_em/adapt_timestep_em.F | 217 +- wrfv2_fire/dyn_em/couple_or_uncouple_em.F | 5 + wrfv2_fire/dyn_em/module_advect_em.F | 7 +- wrfv2_fire/dyn_em/module_bc_em.F | 157 +- wrfv2_fire/dyn_em/module_big_step_utilities_em.F | 106 +- wrfv2_fire/dyn_em/module_diffusion_em.F | 551 +++- wrfv2_fire/dyn_em/module_em.F | 15 +- wrfv2_fire/dyn_em/module_first_rk_step_part1.F | 119 +- wrfv2_fire/dyn_em/module_first_rk_step_part2.F | 82 +- wrfv2_fire/dyn_em/module_initialize_real.F | 16 + wrfv2_fire/dyn_em/module_polarfft.F | 64 +- wrfv2_fire/dyn_em/nest_init_utils.F | 5 + wrfv2_fire/dyn_em/shift_domain_em.F | 10 + wrfv2_fire/dyn_em/solve_em.F | 601 +++- wrfv2_fire/dyn_em/start_em.F | 107 +- wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F | 374 +-- wrfv2_fire/dyn_nmm/module_ADVECTION.F | 862 +++++- wrfv2_fire/dyn_nmm/module_BNDRY_COND.F | 4 + wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F | 25 +- wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F | 10 +- wrfv2_fire/dyn_nmm/module_NEST_UTIL.F | 12 + wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F | 137 +- wrfv2_fire/dyn_nmm/module_initialize_real.F | 884 +++--- wrfv2_fire/dyn_nmm/module_si_io_nmm.F | 1651 ++++++++++- wrfv2_fire/dyn_nmm/shift_domain_nmm.F | 36 +- wrfv2_fire/dyn_nmm/solve_nmm.F | 1434 ++++++---- wrfv2_fire/dyn_nmm/start_domain_nmm.F | 912 +++--- wrfv2_fire/external/RSL_LITE/gen_comms.c | 60 +- wrfv2_fire/external/RSL_LITE/module_dm.F | 300 +- wrfv2_fire/external/RSL_LITE/rsl_bcast.c | 1 + wrfv2_fire/external/atm_pom/Makefile | 5 +- wrfv2_fire/external/atm_pom/atm_comm_pom.F | 5 +- wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc | 2 +- wrfv2_fire/external/fftpack/fftpack5/Makefile | 2 +- .../external/io_esmf/ext_esmf_read_field.F90 | 3 +- .../external/io_esmf/ext_esmf_write_field.F90 | 3 +- .../external/io_esmf/module_esmf_extensions.F90 | 61 +- wrfv2_fire/external/io_grib1/Makefile | 4 +- wrfv2_fire/external/io_grib1/WGRIB/Makefile | 8 +- .../external/io_grib1/grib1_util/read_grib.c | 3 +- wrfv2_fire/external/io_grib1/io_grib1.F | 28 +- wrfv2_fire/external/io_grib_share/Makefile | 2 +- .../external/io_grib_share/build/library_rules.mk | 2 +- wrfv2_fire/external/io_grib_share/gridnav.c | 104 +- wrfv2_fire/external/io_netcdf/wrf_io.F90 | 2 +- wrfv2_fire/external/io_pnetcdf/wrf_io.F90 | 2 +- wrfv2_fire/frame/Makefile | 167 +- wrfv2_fire/frame/collect_on_comm.c | 9 +- wrfv2_fire/frame/libmassv.F | 5 + wrfv2_fire/frame/module_comm_dm.F | 10 +- wrfv2_fire/frame/module_configure.F | 35 +- wrfv2_fire/frame/module_dm_stubs.F | 18 + wrfv2_fire/frame/module_domain.F | 438 ++- wrfv2_fire/frame/module_domain_type.F | 103 +- wrfv2_fire/frame/module_integrate.F | 10 +- wrfv2_fire/frame/module_io.F | 205 +- wrfv2_fire/frame/nl_get_0_routines.F | 14 +- wrfv2_fire/frame/nl_get_1_routines.F | 14 +- wrfv2_fire/frame/nl_set_0_routines.F | 14 +- wrfv2_fire/frame/nl_set_1_routines.F | 14 +- wrfv2_fire/frame/pack_utils.c | 60 + wrfv2_fire/main/Makefile | 1 + wrfv2_fire/main/ideal.F | 4 +- wrfv2_fire/main/module_wrf_top.F | 2 +- wrfv2_fire/main/ndown_em.F | 659 ++++- wrfv2_fire/main/nup_em.F | 13 +- wrfv2_fire/main/real_em.F | 22 +- wrfv2_fire/main/real_nmm.F | 84 +- wrfv2_fire/main/tc_em.F | 12 +- wrfv2_fire/main/wrf_ESMFMod.F | 246 +- wrfv2_fire/main/wrf_SST_ESMF.F | 104 +- wrfv2_fire/phys/Makefile | 75 +- wrfv2_fire/phys/module_bl_acm.F | 13 +- wrfv2_fire/phys/module_bl_gfs.F | 85 +- wrfv2_fire/phys/module_bl_mynn.F | 3 - wrfv2_fire/phys/module_bl_ysu.F | 657 +++-- wrfv2_fire/phys/module_cu_g3.F | 510 +++- wrfv2_fire/phys/module_cu_gd.F | 237 +- wrfv2_fire/phys/module_cu_sas.F | 250 +- wrfv2_fire/phys/module_cumulus_driver.F | 122 +- wrfv2_fire/phys/module_diagnostics.F | 2 + wrfv2_fire/phys/module_fddagd_driver.F | 12 +- wrfv2_fire/phys/module_fddaobs_driver.F | 283 +- wrfv2_fire/phys/module_fddaobs_rtfdda.F | 578 +++- wrfv2_fire/phys/module_fr_sfire_driver.F | 7 +- wrfv2_fire/phys/module_microphysics_driver.F | 292 +- wrfv2_fire/phys/module_mixactivate.F | 2 +- wrfv2_fire/phys/module_mp_lin.F | 24 +- wrfv2_fire/phys/module_mp_morr_two_moment.F | 162 +- wrfv2_fire/phys/module_mp_thompson.F | 1068 ++++---- wrfv2_fire/phys/module_mp_thompson07.F | 8 +- wrfv2_fire/phys/module_mp_wdm5.F | 889 ++++-- wrfv2_fire/phys/module_mp_wdm6.F | 1287 +++++++-- wrfv2_fire/phys/module_mp_wsm3.F | 811 ++++-- wrfv2_fire/phys/module_mp_wsm5.F | 765 ++++-- wrfv2_fire/phys/module_mp_wsm6.F | 1130 ++++++-- wrfv2_fire/phys/module_pbl_driver.F | 137 +- wrfv2_fire/phys/module_physics_init.F | 340 ++- wrfv2_fire/phys/module_ra_cam.F | 31 +- wrfv2_fire/phys/module_ra_gfdleta.F | 58 +- wrfv2_fire/phys/module_ra_gsfcsw.F | 38 +- wrfv2_fire/phys/module_ra_rrtm.F | 29 +- wrfv2_fire/phys/module_ra_rrtmg_lw.F | 28 +- wrfv2_fire/phys/module_ra_rrtmg_sw.F | 28 +- wrfv2_fire/phys/module_ra_sw.F | 97 +- wrfv2_fire/phys/module_radiation_driver.F | 129 +- wrfv2_fire/phys/module_sf_bep.F | 87 +- wrfv2_fire/phys/module_sf_myjsfc.F | 27 +- wrfv2_fire/phys/module_sf_mynn.F | 11 +- wrfv2_fire/phys/module_sf_noahdrv.F | 100 +- wrfv2_fire/phys/module_sf_noahlsm.F | 34 +- wrfv2_fire/phys/module_sf_pxlsm.F | 311 ++- wrfv2_fire/phys/module_sf_qnsesfc.F | 45 +- wrfv2_fire/phys/module_sf_ruclsm.F | 2897 +++++++++++++------- wrfv2_fire/phys/module_sf_sfclay.F | 56 +- wrfv2_fire/phys/module_sf_slab.F | 182 +- wrfv2_fire/phys/module_sf_urban.F | 539 +++- wrfv2_fire/phys/module_surface_driver.F | 387 ++- wrfv2_fire/run/GENPARM.TBL | 2 + wrfv2_fire/run/README.namelist | 18 + wrfv2_fire/run/URBPARM.TBL | 151 +- wrfv2_fire/run/gribmap.txt | 42 +- wrfv2_fire/share/Makefile | 76 +- wrfv2_fire/share/dfi.F | 346 ++- wrfv2_fire/share/init_modules.F | 31 +- wrfv2_fire/share/input_wrf.F | 493 +++- wrfv2_fire/share/interp_fcn.F | 10 +- wrfv2_fire/share/mediation_feedback_domain.F | 14 +- wrfv2_fire/share/mediation_force_domain.F | 14 +- wrfv2_fire/share/mediation_integrate.F | 1016 ++++--- wrfv2_fire/share/mediation_interp_domain.F | 14 +- wrfv2_fire/share/mediation_nest_move.F | 104 +- wrfv2_fire/share/mediation_wrfmain.F | 57 +- wrfv2_fire/share/module_bc.F | 11 +- wrfv2_fire/share/module_date_time.F | 11 +- wrfv2_fire/share/module_io_domain.F | 1391 +++------- wrfv2_fire/share/module_io_wrf.F | 29 +- wrfv2_fire/share/module_llxy.F | 6 +- wrfv2_fire/share/module_model_constants.F | 6 - wrfv2_fire/share/module_soil_pre.F | 394 +-- wrfv2_fire/share/output_wrf.F | 720 ++++- wrfv2_fire/share/set_timekeeping.F | 2763 ++++--------------- wrfv2_fire/share/solve_interface.F | 4 +- wrfv2_fire/share/solve_nmm.int | 4 +- wrfv2_fire/share/start_domain.F | 8 +- wrfv2_fire/share/start_domain_nmm.int | 2 +- wrfv2_fire/share/wrf_ext_read_field.F | 72 + wrfv2_fire/share/wrf_ext_write_field.F | 114 +- wrfv2_fire/share/wrf_fddaobs_in.F | 164 +- wrfv2_fire/share/wrf_timeseries.F | 30 +- wrfv2_fire/test/nmm_real/namelist.input | 6 +- wrfv2_fire/test/nmm_real/namelist.input.chem_nmm | 3 + wrfv2_fire/tools/Makefile | 6 +- wrfv2_fire/tools/data.h | 34 +- wrfv2_fire/tools/gen_allocs.c | 357 ++- wrfv2_fire/tools/gen_config.c | 31 +- wrfv2_fire/tools/gen_defs.c | 2 + wrfv2_fire/tools/gen_interp.c | 18 +- wrfv2_fire/tools/gen_scalar_indices.c | 18 +- wrfv2_fire/tools/gen_wrf_io.c | 828 +----- wrfv2_fire/tools/misc.c | 76 +- wrfv2_fire/tools/protos.h | 9 +- wrfv2_fire/tools/reg_parse.c | 179 +- wrfv2_fire/tools/registry.c | 14 +- wrfv2_fire/tools/registry.h | 25 - wrfv2_fire/tools/regtest.csh | 41 +- wrfv2_fire/tools/standard.c | 2 +- wrfv2_fire/var/Makefile | 4 +- wrfv2_fire/var/build/da.make | 259 +- wrfv2_fire/var/build/gen_be.make | 8 +- wrfv2_fire/var/build/makefile | 26 +- wrfv2_fire/var/build/setup.csh | 33 +- wrfv2_fire/var/build/setup.ksh | 29 +- .../var/da/da_airep/da_check_max_iv_airep.inc | 35 +- .../var/da/da_airep/da_get_innov_vector_airep.inc | 13 +- .../var/da/da_airsr/da_check_max_iv_airsr.inc | 31 +- .../var/da/da_airsr/da_get_innov_vector_airsr.inc | 12 +- .../var/da/da_bogus/da_check_max_iv_bogus.inc | 63 +- .../var/da/da_bogus/da_get_innov_vector_bogus.inc | 14 +- wrfv2_fire/var/da/da_buoy/da_check_max_iv_buoy.inc | 45 +- .../var/da/da_buoy/da_get_innov_vector_buoy.inc | 33 +- wrfv2_fire/var/da/da_control/da_control.f90 | 2 +- .../var/da/da_define_structures/da_random_seed.inc | 2 +- .../da/da_define_structures/da_zero_vp_type.inc | 2 +- wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv.inc | 3 + .../var/da/da_dynamics/da_psichi_to_uv_adj.inc | 6 + .../var/da/da_geoamv/da_check_max_iv_geoamv.inc | 17 +- .../da/da_geoamv/da_get_innov_vector_geoamv.inc | 12 +- .../var/da/da_gpspw/da_check_max_iv_gpspw.inc | 2 +- .../var/da/da_gpspw/da_get_innov_vector_gpspw.inc | 35 +- .../var/da/da_gpspw/da_get_innov_vector_gpsztd.inc | 30 +- .../var/da/da_gpsref/da_check_max_iv_gpsref.inc | 2 +- .../da/da_gpsref/da_get_innov_vector_gpsref.inc | 229 +- wrfv2_fire/var/da/da_gpsref/da_gpsref.f90 | 6 +- wrfv2_fire/var/da/da_gpsref/da_residual_gpsref.inc | 33 +- .../var/da/da_interpolation/da_interp_lin_2d.inc | 3 + .../da_interpolation/da_interp_lin_2d_partial.inc | 3 + .../var/da/da_interpolation/da_interp_lin_3d.inc | 3 + .../var/da/da_main/da_med_initialdata_input.inc | 2 +- .../var/da/da_main/da_med_initialdata_output.inc | 4 +- wrfv2_fire/var/da/da_main/da_solve.inc | 47 +- wrfv2_fire/var/da/da_main/da_wrfvar_finalize.inc | 6 +- wrfv2_fire/var/da/da_main/da_wrfvar_init1.inc | 2 +- wrfv2_fire/var/da/da_main/da_wrfvar_init2.inc | 17 +- wrfv2_fire/var/da/da_main/da_wrfvar_interface.inc | 6 +- wrfv2_fire/var/da/da_main/da_wrfvar_io.f90 | 2 +- wrfv2_fire/var/da/da_main/da_wrfvar_top.f90 | 7 +- .../var/da/da_metar/da_check_max_iv_metar.inc | 45 +- .../var/da/da_metar/da_get_innov_vector_metar.inc | 34 +- .../var/da/da_minimisation/da_calculate_gradj.inc | 42 +- .../var/da/da_minimisation/da_calculate_j.inc | 40 +- .../da/da_minimisation/da_calculate_residual.inc | 2 +- .../var/da/da_minimisation/da_get_innov_vector.inc | 9 +- .../da/da_minimisation/da_get_var_diagnostics.inc | 19 +- .../var/da/da_minimisation/da_minimisation.f90 | 6 +- .../var/da/da_minimisation/da_minimise_cg.inc | 11 +- .../da/da_minimisation/da_write_diagnostics.inc | 13 + wrfv2_fire/var/da/da_monitor/da_rad_diags.f90 | 2 +- .../var/da/da_mtgirs/da_check_max_iv_mtgirs.inc | 46 +- .../da/da_mtgirs/da_get_innov_vector_mtgirs.inc | 14 +- wrfv2_fire/var/da/da_obs/da_count_filtered_obs.inc | 9 +- .../var/da/da_obs/da_fill_obs_structures.inc | 17 +- wrfv2_fire/var/da/da_obs/da_obs.f90 | 3 +- wrfv2_fire/var/da/da_obs/da_obs_proc_station.inc | 5 +- wrfv2_fire/var/da/da_obs/da_use_obs_errfac.inc | 13 + wrfv2_fire/var/da/da_obs_io/da_obs_io.f90 | 11 +- .../var/da/da_obs_io/da_read_iv_for_multi_inc.inc | 31 + wrfv2_fire/var/da/da_obs_io/da_read_obs_ascii.inc | 26 +- wrfv2_fire/var/da/da_obs_io/da_read_obs_bufr.inc | 2101 +++++++++----- wrfv2_fire/var/da/da_obs_io/da_search_obs.inc | 27 +- .../var/da/da_obs_io/da_write_filtered_obs.inc | 8 +- .../var/da/da_obs_io/da_write_iv_for_multi_inc.inc | 37 +- .../var/da/da_obs_io/da_write_noise_to_ob.inc | 3 +- wrfv2_fire/var/da/da_obs_io/da_write_obs.inc | 8 +- .../var/da/da_par_util/da_copy_tile_dims.inc | 44 +- wrfv2_fire/var/da/da_par_util/da_cv_to_global.inc | 17 +- wrfv2_fire/var/da/da_par_util/da_cv_to_vv.inc | 11 +- wrfv2_fire/var/da/da_par_util/da_transpose_x2y.inc | 15 +- .../var/da/da_par_util/da_transpose_x2y_v2.inc | 15 +- wrfv2_fire/var/da/da_par_util/da_transpose_x2z.inc | 15 +- wrfv2_fire/var/da/da_par_util/da_transpose_y2x.inc | 15 +- .../var/da/da_par_util/da_transpose_y2x_v2.inc | 15 +- wrfv2_fire/var/da/da_par_util/da_transpose_y2z.inc | 15 +- wrfv2_fire/var/da/da_par_util/da_transpose_z2x.inc | 15 +- wrfv2_fire/var/da/da_par_util/da_transpose_z2y.inc | 15 +- wrfv2_fire/var/da/da_par_util/da_vv_to_cv.inc | 26 +- wrfv2_fire/var/da/da_physics/da_check_rh.inc | 13 +- wrfv2_fire/var/da/da_physics/da_integrat_dz.inc | 9 +- .../var/da/da_physics/da_transform_xtogpsref.inc | 9 +- wrfv2_fire/var/da/da_physics/da_trh_to_td.inc | 40 +- wrfv2_fire/var/da/da_physics/da_wrf_tpq_2_slp.inc | 11 +- .../var/da/da_pilot/da_check_max_iv_pilot.inc | 17 +- .../var/da/da_pilot/da_get_innov_vector_pilot.inc | 12 +- .../da/da_polaramv/da_check_max_iv_polaramv.inc | 17 +- .../da_polaramv/da_get_innov_vector_polaramv.inc | 12 +- .../da/da_profiler/da_check_max_iv_profiler.inc | 21 +- .../da_profiler/da_get_innov_vector_profiler.inc | 12 +- wrfv2_fire/var/da/da_pseudo/da_ao_stats_pseudo.inc | 1 + .../da/da_pseudo/da_get_innov_vector_pseudo.inc | 43 +- .../var/da/da_qscat/da_check_max_iv_qscat.inc | 14 +- .../var/da/da_qscat/da_get_innov_vector_qscat.inc | 14 +- .../var/da/da_radar/da_get_innov_vector_radar.inc | 9 + wrfv2_fire/var/da/da_radar/da_radar.f90 | 6 +- .../var/da/da_radiance/da_allocate_rad_iv.inc | 1 + .../var/da/da_radiance/da_cloud_sim_airs.inc | 2 +- wrfv2_fire/var/da/da_radiance/da_crtm.f90 | 2 +- .../da/da_radiance/da_get_innov_vector_crtm.inc | 16 +- .../da_radiance/da_get_innov_vector_radiance.inc | 4 +- .../da/da_radiance/da_get_innov_vector_rttov.inc | 3 + wrfv2_fire/var/da/da_radiance/da_qc_airs.inc | 7 +- wrfv2_fire/var/da/da_radiance/da_qc_amsua.inc | 7 +- wrfv2_fire/var/da/da_radiance/da_qc_amsub.inc | 7 +- wrfv2_fire/var/da/da_radiance/da_qc_crtm.inc | 22 +- wrfv2_fire/var/da/da_radiance/da_qc_hirs.inc | 7 +- wrfv2_fire/var/da/da_radiance/da_qc_mhs.inc | 7 +- wrfv2_fire/var/da/da_radiance/da_qc_rad.inc | 22 +- wrfv2_fire/var/da/da_radiance/da_qc_ssmis.inc | 7 +- .../var/da/da_radiance/da_read_obs_bufrairs.inc | 13 +- .../da_radiance/da_setup_radiance_structures.inc | 8 +- .../var/da/da_radiance/da_transform_xtoy_crtm.inc | 544 ++-- .../da/da_radiance/da_transform_xtoy_crtm_adj.inc | 546 ++-- .../var/da/da_radiance/da_transform_xtoy_rttov.inc | 3 + .../da/da_radiance/da_transform_xtoy_rttov_adj.inc | 9 +- .../var/da/da_radiance/da_write_iv_rad_ascii.inc | 5 +- .../var/da/da_radiance/da_write_oa_rad_ascii.inc | 5 +- .../var/da/da_recursive_filter/da_apply_rf.inc | 20 +- .../var/da/da_recursive_filter/da_apply_rf_1v.inc | 6 + .../da/da_recursive_filter/da_apply_rf_1v_adj.inc | 6 + .../var/da/da_recursive_filter/da_apply_rf_adj.inc | 22 +- .../var/da/da_recursive_filter/da_rfz_cv3.f90 | 3 + .../da_transform_through_rf.inc | 80 +- .../da_transform_through_rf_adj.inc | 63 +- .../var/da/da_satem/da_check_max_iv_satem.inc | 11 +- .../var/da/da_satem/da_get_innov_vector_satem.inc | 11 +- .../da_rescale_background_errors.inc | 3 + .../da/da_setup_structures/da_setup_be_global.inc | 18 +- .../da_setup_structures/da_setup_be_ncep_gfs.inc | 30 +- .../da_setup_be_nmm_regional.inc | 10 +- .../da_setup_structures/da_setup_be_regional.inc | 145 +- .../var/da/da_setup_structures/da_setup_cv.inc | 6 +- .../da/da_setup_structures/da_setup_firstguess.inc | 17 +- .../da_setup_flow_predictors.inc | 45 +- .../da_setup_obs_structures_ascii.inc | 13 +- .../da_setup_obs_structures_bufr.inc | 76 +- .../da/da_setup_structures/da_setup_structures.f90 | 12 +- .../var/da/da_ships/da_check_max_iv_ships.inc | 57 +- .../var/da/da_ships/da_get_innov_vector_ships.inc | 32 +- .../var/da/da_sound/da_check_max_iv_sonde_sfc.inc | 41 +- .../var/da/da_sound/da_check_max_iv_sound.inc | 36 +- .../da/da_sound/da_get_innov_vector_sonde_sfc.inc | 32 +- .../var/da/da_sound/da_get_innov_vector_sound.inc | 14 +- .../var/da/da_ssmi/da_check_max_iv_ssmi_rv.inc | 45 +- .../var/da/da_ssmi/da_check_max_iv_ssmt1.inc | 21 +- .../var/da/da_ssmi/da_check_max_iv_ssmt2.inc | 26 +- .../var/da/da_ssmi/da_get_innov_vector_ssmi_rv.inc | 10 +- .../var/da/da_ssmi/da_get_innov_vector_ssmi_tb.inc | 12 + .../var/da/da_ssmi/da_get_innov_vector_ssmt1.inc | 8 + .../var/da/da_ssmi/da_get_innov_vector_ssmt2.inc | 8 + .../var/da/da_synop/da_check_max_iv_synop.inc | 42 +- .../var/da/da_synop/da_get_innov_vector_synop.inc | 32 +- .../var/da/da_tamdar/da_check_max_iv_tamdar.inc | 32 +- .../da/da_tamdar/da_check_max_iv_tamdar_sfc.inc | 54 +- .../da/da_tamdar/da_get_innov_vector_tamdar.inc | 11 + .../da_tamdar/da_get_innov_vector_tamdar_sfc.inc | 35 +- wrfv2_fire/var/da/da_test/da_check.inc | 4 +- .../var/da/da_test/da_check_cvtovv_adjoint.inc | 2 +- wrfv2_fire/var/da/da_test/da_check_vp_errors.inc | 15 +- .../var/da/da_test/da_check_vptox_adjoint.inc | 12 +- .../var/da/da_test/da_check_vvtovp_adjoint.inc | 23 +- wrfv2_fire/var/da/da_test/da_test_vxtransform.inc | 4 +- wrfv2_fire/var/da/da_tools/da_convert_zk.inc | 5 +- .../da/da_transfer_model/da_transfer_kmatoxb.inc | 2 +- .../var/da/da_transfer_model/da_transfer_model.f90 | 2 +- .../da/da_transfer_model/da_transfer_wrftoxb.inc | 59 +- .../da/da_transfer_model/da_transfer_xatowrf.inc | 52 +- wrfv2_fire/var/da/da_varbc/da_varbc.f90 | 4 +- wrfv2_fire/var/da/da_varbc/da_varbc_coldstart.inc | 20 +- wrfv2_fire/var/da/da_varbc/da_varbc_init.inc | 3 - wrfv2_fire/var/da/da_varbc/da_varbc_precond.inc | 7 +- wrfv2_fire/var/da/da_varbc/da_varbc_update.inc | 15 +- wrfv2_fire/var/da/da_verif_obs/da_verif_obs.f90 | 57 +- .../da_add_flow_dependence_vp.inc | 10 +- .../da_add_flow_dependence_vp_adj.inc | 12 +- .../da_add_flow_dependence_xa.inc | 99 +- .../da_add_flow_dependence_xa_adj.inc | 97 +- .../var/da/da_vtox_transforms/da_apply_be.inc | 16 +- .../var/da/da_vtox_transforms/da_transform_bal.inc | 112 +- .../da/da_vtox_transforms/da_transform_bal_adj.inc | 130 +- .../da/da_vtox_transforms/da_transform_vptox.inc | 55 +- .../da_vtox_transforms/da_transform_vptox_adj.inc | 57 +- .../da/da_vtox_transforms/da_transform_vtovv.inc | 14 +- .../da_vtox_transforms/da_transform_vtovv_adj.inc | 14 +- .../da_transform_vtovv_global.inc | 20 +- .../da_transform_vtovv_global_adj.inc | 20 +- .../da/da_vtox_transforms/da_transform_vtox.inc | 4 +- .../da_vtox_transforms/da_transform_vtox_adj.inc | 6 +- .../da/da_vtox_transforms/da_transform_vvtovp.inc | 26 +- .../da_vtox_transforms/da_transform_vvtovp_adj.inc | 28 +- .../da_vtox_transforms/da_vertical_transform.inc | 68 +- wrfv2_fire/var/external/bufr/bfrini.inc | 14 +- wrfv2_fire/var/external/bufr/bufrlib.prm | 4 +- wrfv2_fire/var/external/bufr/closbf.inc | 35 + wrfv2_fire/var/external/bufr/conwin.inc | 6 +- wrfv2_fire/var/external/bufr/da_bufr.f90 | 235 +- wrfv2_fire/var/external/bufr/drstpl.inc | 12 +- wrfv2_fire/var/external/bufr/getwin.inc | 6 +- wrfv2_fire/var/external/bufr/inctab.inc | 12 +- wrfv2_fire/var/external/bufr/invcon.inc | 6 +- wrfv2_fire/var/external/bufr/invtag.inc | 18 +- wrfv2_fire/var/external/bufr/invwin.inc | 6 +- wrfv2_fire/var/external/bufr/ipkm.inc | 2 +- wrfv2_fire/var/external/bufr/lstjpb.inc | 12 +- wrfv2_fire/var/external/bufr/lstrpc.inc | 12 +- wrfv2_fire/var/external/bufr/lstrps.inc | 12 +- wrfv2_fire/var/external/bufr/makestab.inc | 27 +- wrfv2_fire/var/external/bufr/msgini.inc | 14 +- wrfv2_fire/var/external/bufr/nemtbd.inc | 6 +- wrfv2_fire/var/external/bufr/newwin.inc | 6 +- wrfv2_fire/var/external/bufr/nxtwin.inc | 6 +- wrfv2_fire/var/external/bufr/parusr.inc | 8 +- wrfv2_fire/var/external/bufr/parutg.inc | 12 +- wrfv2_fire/var/external/bufr/rcstpl.inc | 26 +- wrfv2_fire/var/external/bufr/rdcmps.inc | 20 +- wrfv2_fire/var/external/bufr/rdtree.inc | 18 +- wrfv2_fire/var/external/bufr/readns.inc | 14 +- wrfv2_fire/var/external/bufr/seqsdx.inc | 6 +- wrfv2_fire/var/external/bufr/stndrd.inc | 4 +- wrfv2_fire/var/external/bufr/tabent.inc | 12 +- wrfv2_fire/var/external/bufr/tabsub.inc | 27 +- wrfv2_fire/var/external/bufr/trybump.inc | 6 +- wrfv2_fire/var/external/bufr/ufbint.inc | 4 +- wrfv2_fire/var/external/bufr/ufbrep.inc | 4 +- wrfv2_fire/var/external/bufr/ufbrp.inc | 4 +- wrfv2_fire/var/external/bufr/ufbrw.inc | 22 +- wrfv2_fire/var/external/bufr/ufbseq.inc | 22 +- wrfv2_fire/var/external/bufr/usrtpl.inc | 22 +- wrfv2_fire/var/external/bufr/wrcmps.inc | 239 +- wrfv2_fire/var/external/bufr/wrtree.inc | 20 +- wrfv2_fire/var/gen_be/Makefile | 6 + wrfv2_fire/var/gen_be/gen_be_ensmean.f90 | 2 - wrfv2_fire/var/gen_be/gen_be_ep2.f90 | 74 +- wrfv2_fire/var/obsproc/MAP_plot/Dir_map/setup.F | 4 +- wrfv2_fire/var/obsproc/src/Makefile | 4 +- wrfv2_fire/var/obsproc/src/fm_decoder.F90 | 1 + wrfv2_fire/var/obsproc/src/module_diagnostics.F90 | 17 +- wrfv2_fire/var/obsproc/src/module_err_afwa.F90 | 19 +- wrfv2_fire/var/obsproc/src/obsproc.F90 | 9 +- 458 files changed, 32728 insertions(+), 18264 deletions(-) rewrite wrfv2_fire/Registry/registry.io_boilerplate (86%) rewrite wrfv2_fire/chem/module_add_emiss_burn.F (60%) rewrite wrfv2_fire/share/module_io_domain.F (60%) rewrite wrfv2_fire/share/set_timekeeping.F (75%) rewrite wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa.inc (61%) rewrite wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa_adj.inc (61%) diff --git a/wrfv2_fire/Makefile b/wrfv2_fire/Makefile index 903c35ef..f58793c3 100644 --- a/wrfv2_fire/Makefile +++ b/wrfv2_fire/Makefile @@ -25,6 +25,8 @@ DA_CONVERTOR_MODULES = $(DA_CONVERTOR_MOD_DIR) $(INCLUDE_MODULES) #EXP_MODULE_DIR = -I../dyn_exp #EXP_MODULES = $(EXP_MODULE_DIR) +# set this in the compile script now +#J = -j 6 NMM_MODULE_DIR = -I../dyn_nmm NMM_MODULES = $(NMM_MODULE_DIR) @@ -68,7 +70,8 @@ wrf : framework_only all_wrfvar : $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir - ( cd var/build; touch depend.txt; make links; make depend; $(MAKE) all_wrfvar ) +# ( cd var/build; touch depend.txt; make links; make depend; $(MAKE) $(J) all_wrfvar ) + ( cd var/build; make depend; $(MAKE) $(J) all_wrfvar ) ( cd var/obsproc; $(MAKE) BUFR_CPP="$(BUFR_CPP)" ) ### 3.a. rules to build the framework and then the experimental core @@ -442,7 +445,7 @@ ext : framework : @ echo '--------------------------------------' - ( cd frame ; $(MAKE) framework; \ + ( cd frame ; $(MAKE) $(J) framework; \ cd ../external/io_netcdf ; \ $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ @@ -464,7 +467,7 @@ framework : shared : @ echo '--------------------------------------' - ( cd share ; $(MAKE) ) + ( cd share ; $(MAKE) $(J) ) chemics : @ echo '--------------------------------------' @@ -472,11 +475,11 @@ chemics : physics : @ echo '--------------------------------------' - ( cd phys ; $(MAKE) ) + ( cd phys ; $(MAKE) $(J) ) em_core : @ echo '--------------------------------------' - ( cd dyn_em ; $(MAKE) ) + ( cd dyn_em ; $(MAKE) $(J) ) # rule used by configure to test if this will compile with MPI 2 calls MPI_Comm_f2c and _c2f mpi2_test : @@ -505,7 +508,10 @@ nmm_core : toolsdir : @ echo '--------------------------------------' - ( cd tools ; $(MAKE) CC_TOOLS="$(CC_TOOLS)" ) + ( cd tools ; $(MAKE) CC_TOOLS="$(CC_TOOLS) -DIWORDSIZE=$(IWORDSIZE) -DMAX_HISTORY=$(MAX_HISTORY)" ) + + +# ( cd tools ; $(MAKE) CC_TOOLS="$(CC_TOOLS) -DIO_MASK_SIZE=$(IO_MASK_SIZE)" ) # Use this target to build stand-alone tests of esmf_time_f90. # Only touches external/esmf_time_f90/. diff --git a/wrfv2_fire/README.NMM b/wrfv2_fire/README.NMM index 44d7c652..6b04357c 100644 --- a/wrfv2_fire/README.NMM +++ b/wrfv2_fire/README.NMM @@ -1,5 +1,5 @@ -WRF-NMM Model Version 3 (April 9, 2009) +WRF-NMM Model Version 3.1 (April 9, 2009) ---------------------------- WRF-NMM PUBLIC DOMAIN NOTICE @@ -109,57 +109,81 @@ How to configure, compile and run? ============================================================================= -What is in WRF-NMM V3? +What is in WRF-NMM V3.1? * Dynamics: - The WRF-NMM model is a fully compressible, non-hydrostatic model with a - hydrostatic option. + hydrostatic option. + - Supports One-way and two-way static nesting. - - Multiple domains and multiple nest levels - - Feedback option - - The terrain following hybrid pressure sigma vertical coordinate is used. - - The grid staggering is the Arakawa E-grid. - - The same time step is used for all terms. + + - The terrain following hybrid pressure sigma vertical coordinate is used. + + - The grid staggering is the Arakawa E-grid. + + - The same time step is used for all terms. + - Time stepping: - Horizontally propagating fast-waves: Forward-backward scheme - Veryically propagating sound waves: Implicit scheme + - Advection (time): T,U,V: - Horizontal: The Adams-Bashforth scheme - Vertical: The Crank-Nicholson scheme - TKE, water species: Forward, flux-corrected (called every two timesteps). + TKE, water species: Forward, flux-corrected (called every two timesteps)/Eulerian, Adams-Bashforth + and Crank-Nicholson with monotonization. + - Advection (space): T,U,V: - - Horizontal: Energy and enstrophy conserving, + - Horizontal: Energy and enstrophy conserving, quadratic conservative,second order - - Vertical: Quadratic conservative,second order TKE, - - Water species: Upstream, flux-corrected, positive definite, conservative - - Horizontal diffusion: Forward, second order "Smagorinsky-type" + + - Vertical: Quadratic conservative,second order, implicit + + - Tracers (water species and TKE): upstream, positive definite, conservative antifiltering + gradient restoration, optional, see next bullet. + + - Tracers (water species, TKE, and test tracer rrw): Eulerian with monotonization, coupled with + continuity equation, conservative, positive definite, monotone, optional. To turn on/off, set + the logical switch "euler" in solve_nmm.F to .true./.false. The monotonization parameter + steep in subroutine mono should be in the range 0.96-1.0. For most natural tracers steep=1. + should be adequate. Smaller values of steep are recommended for idealizaed tests with very + steep gradients. This option is available only with Ferrier microphysics. + + - Horizontal diffusion: Forward, second order "Smagorinsky-type" + - Vertical Diffusion: See "Free atmosphere turbulence above surface layer" section - in "Physics" section given in below. + in "Physics" section given in below. * Physics: - - Explicit Microphysics: ( WRF Single Moment 5 and 6 classes / Eta Ferrier (Used operationally at NCEP) / Thompson ) - - Cumulus parameterization ( Kain-Fritsch with shallow convection / - Betts-Miller-Janjic (Used operationally at NCEP) / - Grell-Devenyi ensemble / Simplified Arakawa-Schubert ) - - Free atmosphere turbulence above surface layer: Mellor-Yamada-Janjic (used operationally at NCEP) - - Planetary boundary layer ( Yosei University / Mellor-Yamada-Janjic (Used operationally -at NCEP) / GFS / QNSE ) - - Surface Layer ( similarity theory MM5 / Eta / MYJ (Used operationally -at NCEP) / GFS / QNSE ) - - Land Surface Model ( Noah land-surface model (4 levels) (Used operationally -at NCEP) / RUC LSM (6 levels)) - - Longwave Radiation ( RRTM / GFDL (Fels-Schwarzkopf) (Used operationally -at NCEP)) - - Shortwave Radiation ( Dudhia / GFDL (Lacis-Hansen) (Used operationally -at NCEP)) - - Gravity wave drag option - - Land-use categories determine surface properties; support for 24 category USGS and - 20 category MODIS (Noah LSM only in V3.1) + - Explicit Microphysics (WRF Single Moment 5 and 6 class / + Ferrier (Used operationally at NCEP.)/ Thompson [a new version in 2.2]) + + - Cumulus parameterization (Kain-Fritsch with shallow convection / + Betts-Miller-Janjic (Used operationally at NCEP.)/ Grell-Devenyi ensemble + / Simplified Arakawa-Schubert) + + - Free atmosphere turbulence above surface layer: Mellor-Yamada-Janjic (Used operationally at NCEP.) + + - Planetary boundary layer: YSU / Mellor-Yamada-Janjic (Used operationally at NCEP.) + / GFS + + - Surface layer: Similarity theory scheme with viscous sublayers + over both solid surfaces and water points (Janjic - Used operatinally at NCEP). + / GFS / YSU + + - Soil model: Noah land-surface model (4-level - Used operationally at NCEP) / + RUC LSM (6-level) + + - Radiation: + - Longwave radiation: GFDL Scheme (Fels-Schwarzkopf) (Used operationally at NCEP.) / RRTM + - Shortwave radiation: GFDL-scheme (Lacis-Hansen) (Used operationally at NCEP.) / Dudhia + + - Gravity wave drag with mountain wave blocking (Alpert; Kim and Arakawa) * WRF Software: @@ -175,8 +199,8 @@ at NCEP)) Efficient: 5-8% overhead on 64 processes of IBM - Enhanced I/O options: NetCDF and Parallel HDF5 formats - Nine auxiliary input and history output streams separately controllable through the namel -ist + Nine auxiliary input and history output streams separately controllable through the + namelist Output file names and time-stamps specifiable through namelist - Efficient execution on a range of computing platforms: IBM SP systems, (e.g. NCAR "bluevista","blueice","bluefire" Power5-based system) @@ -205,7 +229,7 @@ ist - Multi-level parallelism supporting shared-memory (OpenMP), distributed-memory (MPI), and hybrid share/distributed modes of execution - Serial compilation can be used for single-domain runs but not for runs with -nesting at this time. + nesting at this time. - Active data registry: defines and manages model state fields, I/O, configuration, and numerous other aspects of WRF through a single file, called the Registry diff --git a/wrfv2_fire/Registry/Registry.CONVERT b/wrfv2_fire/Registry/Registry.CONVERT index 23c846f9..532b6b4e 100644 --- a/wrfv2_fire/Registry/Registry.CONVERT +++ b/wrfv2_fire/Registry/Registry.CONVERT @@ -434,8 +434,10 @@ state real soilt160 ij misc 1 - i1 "SOIL state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" state real landmask ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" -state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" -state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real toposlpx ij misc 1 - i012rdu "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i012rdu "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real slope ij misc 1 - rdu "SLOPE" "ELEVATION SLOPE" "" +state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" state real shdmax ij misc 1 - - "SHDMAX" "ANNUAL MAX VEG FRACTION" "" state real shdmin ij misc 1 - - "SHDMIN" "ANNUAL MIN VEG FRACTION" "" state real snoalb ij misc 1 - - "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" diff --git a/wrfv2_fire/Registry/Registry.EM b/wrfv2_fire/Registry/Registry.EM index db63d28a..4da1190d 100644 --- a/wrfv2_fire/Registry/Registry.EM +++ b/wrfv2_fire/Registry/Registry.EM @@ -110,6 +110,7 @@ state real qc_gc igj dyn_em 1 Z i1 "QC" " state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" +state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice no concentration" "m-3" endif @@ -156,6 +157,7 @@ i1 real wwp ikj dyn_em 1 Z i1 real rw_tend ikj dyn_em 1 Z i1 real rw_tendf ikj dyn_em 1 Z i1 real w_save ikj dyn_em 1 Z + state real w_subs | dyn_em 1 - i3rh "W_SUBS" "large-scale vertical velocity" "m s-1" state real w_subs_tend | dyn_em 1 - i3rh "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1" @@ -260,10 +262,6 @@ i1 real cqu ikj dyn_em 1 - - i1 real cqv ikj dyn_em 1 - - i1 real cqw ikj dyn_em 1 - - i1 real pm1 ikj dyn_em 1 - - -state real sr ij dyn_em 1 - irh "sr" "fraction of frozen precipitation" -state real potevp ij dyn_em 1 - rh "potevp" "accumulated potential evaporation" "W m-2" -state real snopcx ij dyn_em 1 - rh "snopcx" "snow phase change heat flux" "W m-2" -state real soiltb ij dyn_em 1 - h "soiltb" "bottom soil temperature" "K" state real fnm k dyn_em 1 - irh "fnm" "upper weight for vertical stretching" "" state real fnp k dyn_em 1 - irh "fnp" "lower weight for vertical stretching" "" state real rdnw k dyn_em 1 - irh "rdnw" "inverse d(eta) values between full (w) levels" "" @@ -272,12 +270,15 @@ state real dnw k dyn_em 1 - irh "d state real dn k dyn_em 1 - irh "dn " "d(eta) values between half (mass) levels" "" state real t_base k dyn_em 1 - ir "t_base" "BASE STATE T IN IDEALIZED CASES" "K" state real z ikj dyn_em 1 - - " " " " " " -i1 real mu_3d ikj dyn_em 1 - state real z_at_w ikj dyn_em 1 Z state real cfn - misc - - irh "cfn" "extrapolation constant" "" state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" state integer step_number - misc - - ir "step_number" "" +# hydrostatic pressure vars +state real p_hyd ikj dyn_em 1 - irh "p_hyd" "hydrostatic pressure" "Pa" +state real p_hyd_w ikj dyn_em 1 Z irh "p_hyd_w" "hydrostatic pressure at full levels" "Pa" + # 2m and 10m output diagnostics state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" @@ -357,6 +358,8 @@ state real qs ikjftb moist 1 - \ i0rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" state real qg ikjftb moist 1 - \ i0rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qh ikjftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QHAIL" "Hail mixing ratio" "kg kg-1" state real - ikjftb dfi_moist 1 - - - state real dfi_qv ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QVAPOR" "Water vapor mixing ratio" "kg kg-1" @@ -370,10 +373,21 @@ state real dfi_qs ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QSNOW" "Snow mixing ratio" "kg kg-1" state real dfi_qg ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real dfi_qh ikjftb dfi_moist 1 - \ + rusdf=(bdy_interp:dt) "DFI_QHAIL" "Hail mixing ratio" "kg kg-1" + + +# LES---------------!JDM + +include registry.les + +#------------------- # Chem Scalars state real - ikjftb chem 1 - - - +# Tracer Scalars +state real - ikjftb tracer 1 - - - # Other Scalars state real - ikjftb scalar 1 - - - @@ -389,6 +403,20 @@ state real qnr ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNRAIN" "Rain Number concentration" "# kg(-1)" state real qng ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real qnh ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNHAIL" "Hail Number concentration" "# kg(-1)" + +#state real qzr ikjftb scalar 1 - \ +# i0rhusdf=(bdy_interp:dt) "QZRAIN" "Rain reflectivity" "# m(6) kg(-1)" +#state real qzi ikjftb scalar 1 - \ +# i0rhusdf=(bdy_interp:dt) "QZICE" "Ice reflectivity" "# m(6) kg(-1)" +#state real qzs ikjftb scalar 1 - \ +# i0rhusdf=(bdy_interp:dt) "QZSNOW" "Snow reflectivity" "# m(6) kg(-1)" +#state real qzg ikjftb scalar 1 - \ +# i0rhusdf=(bdy_interp:dt) "QZGRPL" "Graupel reflectivity" "# m(6) kg(-1)" +#state real qzh ikjftb scalar 1 - \ +# i0rhusdf=(bdy_interp:dt) "QZHAIL" "Hail reflectivity" "# m(6) kg(-1)" + state real qnn ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ikjftb scalar 1 - \ @@ -406,6 +434,20 @@ state real dfi_qnr ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" state real dfi_qng ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real dfi_qnh ikjftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)" + +#state real dfi_qzr ikjftb dfi_scalar 1 - \ +# rusdf=(bdy_interp:dt) "DFI_QZRAIN" "Rain reflectivity" "m(6) kg(-1)" +#state real dfi_qzi ikjftb dfi_scalar 1 - \ +# rusdf=(bdy_interp:dt) "DFI_QZICE" "Ice reflectivity" "m(6) kg(-1)" +#state real dfi_qzs ikjftb dfi_scalar 1 - \ +# rusdf=(bdy_interp:dt) "DFI_QZSNOW" "Snow reflectivity" "m(6) kg(-1)" +#state real dfi_qzg ikjftb dfi_scalar 1 - \ +# rusdf=(bdy_interp:dt) "DFI_QZGRPL" "Graupel reflectivity" "m(6) kg(-1)" +#state real dfi_qzh ikjftb dfi_scalar 1 - \ +# rusdf=(bdy_interp:dt) "DFI_QZHAIL" "Hail reflectivity" "m(6) kg(-1)" + state real dfi_qnn ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ @@ -477,8 +519,10 @@ state real soilt160 ij misc 1 - i1 "SOIL state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" -state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" -state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real toposlpx ij misc 1 - i012rdu "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i012rdu "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real slope ij misc 1 - rdu "SLOPE" "ELEVATION SLOPE" "" +state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" state real shdmax ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" state real shdmin ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" @@ -498,21 +542,21 @@ state real vegcat ij misc 1 - i12 "VEGC state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_glw ?! misc - - r "TS_GLW" "Downward long wave flux at surface" -state real ts_gsw ?! misc - - r "TS_GSW" "Net short wave flux at surface" -state real ts_hfx ?! misc - - r "TS_HFX" "Upward heat flux at surface" -state real ts_lh ?! misc - - r "TS_LH" "Upward moisture flux at surface" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" -state real ts_rainc ?! misc - - r "TS_RAINC" "Cumulus precip" -state real ts_rainnc ?! misc - - r "TS_RAINNC" "Grid-scale precip" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_glw ?! misc - - - "TS_GLW" "Downward long wave flux at surface" +state real ts_gsw ?! misc - - - "TS_GSW" "Net short wave flux at surface" +state real ts_hfx ?! misc - - - "TS_HFX" "Upward heat flux at surface" +state real ts_lh ?! misc - - - "TS_LH" "Upward moisture flux at surface" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" +state real ts_rainc ?! misc - - - "TS_RAINC" "Cumulus precip" +state real ts_rainnc ?! misc - - - "TS_RAINNC" "Grid-scale precip" # urban model variables state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" @@ -565,11 +609,12 @@ state real dfi_v ikj misc 1 - r "V_DFI" state real dfi_w ikj misc 1 - r "W_DFI" "w accumulation array" " " state real dfi_ww ikj misc 1 Z r "WW_DFI" "mu-coupled eta-dot" "Pa s-1" state real dfi_t ikj misc 1 - r "TT_DFI" "t accumulation array" " " +state real dfi_rh ikj misc 1 - r "RH_DFI" "initial relative humidity" " " state real dfi_ph ikj misc 1 - r "PH_DFI" "p accumulation array" " " state real dfi_pb ikj misc 1 - r "PB_DFI" "pb accumulation array" " " state real dfi_alt ikj misc 1 - r "ALT_DFI" "1/rho accumulation array" " " state real dfi_tke ikj misc 1 - r "TKE_DFI" "TURBULENCE KINETIC ENERGY" "m2 s-2" - +state real dfi_tten_rad ikj misc 1 - irh "RAD_TTEN_DFI" "RADAR POT. TEMP. TENDENCY" "K s-1" state real dfi_TSLB ilj misc 1 Z r "TSLB_dfi" "SOIL TEMPERATURE" "K" state real dfi_SMOIS ilj - 1 Z r "SMOIS_dfi" "SOIL MOISTURE" "m3 m-3" state real dfi_SNOW ij misc 1 - r "SNOW_dfi" "SNOW WATER EQUIVALENT" "kg m-2" @@ -603,16 +648,34 @@ state real TRB_URB4D i{ulay}j misc 1 Z r "T state real TW1_URB4D i{ulay}j misc 1 Z r "TW1_URB4D" "WALL LAYER TEMPERATURE" "K" state real TW2_URB4D i{ulay}j misc 1 Z r "TW2_URB4D" "WALL LAYER TEMPERATURE" "K" state real TGB_URB4D i{ulay}j misc 1 Z r "TGB_URB4D" "ROAD LAYER TEMPERATURE" "K" +state real TLEV_URB3D i{ulay}j misc 1 Z r "TLEV_URB3D" "INDOOR TEMPERATURE" "K" +state real QLEV_URB3D i{ulay}j misc 1 Z r "QLEV_URB3D" "SPECIFIC HUMIDITY" "dimensionless" +state real TW1LEV_URB3D i{ulay}j misc 1 Z r "TW1LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TW2LEV_URB3D i{ulay}j misc 1 Z r "TW2LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TGLEV_URB3D i{ulay}j misc 1 Z r "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING" "K" +state real TFLEV_URB3D i{ulay}j misc 1 Z r "TFLEV_URB3D" "FLOOR TEMPERATURE" "K" +state real SF_AC_URB3D ij misc 1 - r "SF_AC_URB3D" "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real LF_AC_URB3D ij misc 1 - r "LF_AC_URB3D" "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real CM_AC_URB3D ij misc 1 - r "CM_AC_URB3D" "CONSUMPTION OF THE AIR COND." "W m{-2}" +state real SFVENT_URB3D ij misc 1 - r "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real LFVENT_URB3D ij misc 1 - r "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real SFWIN1_URB3D i{ulay}j misc 1 Z r "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" +state real SFWIN2_URB3D i{ulay}j misc 1 Z r "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" state real SFW1_URB3D i{ulay}j misc 1 Z r "SFW1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFW2_URB3D i{ulay}j misc 1 Z r "SFW2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFR_URB3D i{ulay}j misc 1 Z r "SFR_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFG_URB3D i{ulay}j misc 1 Z r "SFG_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real CMR_SFCDIF ij misc 1 - r "CMR_SFCDIF" "" "" +state real CHR_SFCDIF ij misc 1 - r "CHR_SFCDIF" "" "" +state real CMC_SFCDIF ij misc 1 - r "CMC_SFCDIF" "" "" +state real CHC_SFCDIF ij misc 1 - r "CHC_SFCDIF" "" "" -# urban variables from radiation model -state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" -state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" -state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" +# solar location variables from radiation driver +state real COSZEN ij misc 1 - r "COSZEN" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real HRANG ij misc 1 - r "HRANG" "SOLAR HOUR ANGLE" "radians" +state real DECLIN - misc 1 - r "DECLIN" "SOLAR DECLINATION" "radians" +state real SOLCON - misc 1 - r "SOLCON" "SOLAR CONSTANT" "W m-2" # RUC LSM @@ -784,7 +847,7 @@ state real ht_int ij misc 1 - - " state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" state real ht_shad ijb misc 1 - hdf=(bdy_interp:dt) "HGT_SHAD" "Height of orographic shadow" "m" i1 real ht_loc ij misc 1 - - -i1 integer shadowmask ij misc 1 - - +state integer shadowmask ij misc 1 - - state integer min_ptchsz - misc 1 - r state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" @@ -833,8 +896,11 @@ state real RAINNCV ij misc 1 - r "R state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real HAILNC ij misc 1 - rhdu "HAILNC" "ACCUMULATED TOTAL GRID SCALE HAIL" "mm" state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" -state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" +state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" @@ -846,7 +912,11 @@ state real apr_as ij misc 1 - r "AP state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" -state real edt_out ij misc 1 - h "EDT_OUT" "EDT FROM GD SCHEME" "" +state real edt_out ij misc 1 - - "EDT_OUT" "EDT FROM GD SCHEME" "" +state real xmb_shallow ij misc 1 - rh "XMB_SHALLOW" "MASSFLUX FROM SHALLOW CONVECTION (G3 only)" "" +state integer k22_shallow ij misc 1 - rh "K22_SHALLOW" "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)" "" +state integer kbcon_shallow ij misc 1 - rh "KBCON_SHALLOW" "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)" "" +state integer ktop_shallow ij misc 1 - rh "KTOP_SHALLOW" "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)" "" state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real cugd_tten ikj misc 1 - h "CUGD_TTEN" "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME" "K s-1" @@ -868,6 +938,7 @@ state real SWDOWN ij misc 1 - rhd "S state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" # upward and downward clearsky and total diagnostic fluxes for CAM radiation state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" @@ -1006,8 +1077,9 @@ state real FLQC ij misc 1 - r "F state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real dfi_QVG ij misc 1 - r "QVG_dfi" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - i012rh "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real dfi_SOILT1 ij misc 1 - r "SOILT1_dfi" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" state real dfi_TSNAV ij misc 1 - r "TSNAV_dfi" "AVERAGE SNOW TEMPERATURE " "C" @@ -1017,6 +1089,10 @@ state real dfi_SNOWC ij misc 1 - r "S state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" state real tkesfcf ij misc 1 - r "tkesfcf" "TKE AT THE SURFACE" "m2 s-2" +state real sr ij dyn_em 1 - irh "sr" "fraction of frozen precipitation" +state real potevp ij dyn_em 1 - rh "potevp" "accumulated potential evaporation" "W m-2" +state real snopcx ij dyn_em 1 - rh "snopcx" "snow phase change heat flux" "W m-2" +state real soiltb ij dyn_em 1 - h "soiltb" "bottom soil temperature" "K" state integer STEPBL - misc 1 - r "STEPBL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" "" state real taucldi ikj misc 1 - r "TAUCLDI" "CLOUD OPTICAL THICKNESS FOR ICE" "" @@ -1040,27 +1116,27 @@ state integer save_topo_from_real - dyn_em 1 - irh "sa ## FDDA variables -state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" -state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" -state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" -state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" -state real RPHNDGDTEN ikj misc 1 - r "RPHNDGDTEN" "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING" "Pa m2 s-3" -state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" -state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" -state real - ikjf fdda3d 1 - - - -state real U_NDG_NEW ikjf fdda3d 1 X igr "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" -state real V_NDG_NEW ikjf fdda3d 1 Y igr "V_NDG_NEW" "NEW Y WIND FOR FDDA GRID NUDGING" "m s-1" -state real T_NDG_NEW ikjf fdda3d 1 - igr "T_NDG_NEW" "NEW PERT POT TEMP FOR FDDA GRID NUDGING" "K" -state real Q_NDG_NEW ikjf fdda3d 1 - igr "Q_NDG_NEW" "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" -state real PH_NDG_NEW ikjf fdda3d 1 Z igr "PH_NDG_NEW" "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" -state real U_NDG_OLD ikjf fdda3d 1 X igr "U_NDG_OLD" "OLD X WIND FOR FDDA GRID NUDGING" "m s-1" -state real V_NDG_OLD ikjf fdda3d 1 Y igr "V_NDG_OLD" "OLD Y WIND FOR FDDA GRID NUDGING" "m s-1" -state real T_NDG_OLD ikjf fdda3d 1 - igr "T_NDG_OLD" "OLD PERT POT TEMP FOR FDDA GRID NUDGING" "K" -state real Q_NDG_OLD ikjf fdda3d 1 - igr "Q_NDG_OLD" "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" -state real PH_NDG_OLD ikjf fdda3d 1 Z igr "PH_NDG_OLD" "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" -state real - ivjf fdda2d 1 Z - - -state real MU_NDG_NEW ivjf fdda2d 1 - igr "MU_NDG_NEW" "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" -state real MU_NDG_OLD ivjf fdda2d 1 - igr "MU_NDG_OLD" "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" +state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" +state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" +state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" +state real RPHNDGDTEN ikj misc 1 - r "RPHNDGDTEN" "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING" "Pa m2 s-3" +state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" +state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" +state real - ikjf fdda3d 1 - - - +state real U_NDG_NEW ikjf fdda3d 1 X i{10}r "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_NEW ikjf fdda3d 1 Y i{10}r "V_NDG_NEW" "NEW Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_NEW ikjf fdda3d 1 - i{10}r "T_NDG_NEW" "NEW PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_NEW ikjf fdda3d 1 - i{10}r "Q_NDG_NEW" "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_NEW ikjf fdda3d 1 Z i{10}r "PH_NDG_NEW" "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real U_NDG_OLD ikjf fdda3d 1 X i{10}r "U_NDG_OLD" "OLD X WIND FOR FDDA GRID NUDGING" "m s-1" +state real V_NDG_OLD ikjf fdda3d 1 Y i{10}r "V_NDG_OLD" "OLD Y WIND FOR FDDA GRID NUDGING" "m s-1" +state real T_NDG_OLD ikjf fdda3d 1 - i{10}r "T_NDG_OLD" "OLD PERT POT TEMP FOR FDDA GRID NUDGING" "K" +state real Q_NDG_OLD ikjf fdda3d 1 - i{10}r "Q_NDG_OLD" "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING" "kg/kg" +state real PH_NDG_OLD ikjf fdda3d 1 Z i{10}r "PH_NDG_OLD" "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING" "kg/kg" +state real - ivjf fdda2d 1 Z - - +state real MU_NDG_NEW ivjf fdda2d 1 - i{10}r "MU_NDG_NEW" "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" +state real MU_NDG_OLD ivjf fdda2d 1 - i{10}r "MU_NDG_OLD" "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING" "Pa" state real U10_NDG_OLD ij misc 1 X i9r "U10_NDG_OLD" "OLD U10 FOR SURFACE FDDA GRID NUDGING" "m s-1" state real U10_NDG_NEW ij misc 1 X i9r "U10_NDG_NEW" "NEW U10 FOR SURFACE FDDA GRID NUDGING" "m s-1" state real V10_NDG_OLD ij misc 1 Y i9r "V10_NDG_OLD" "OLD V10 FOR SURFACE FDDA GRID NUDGING" "m s-1" @@ -1163,9 +1239,10 @@ rconfig logical nocolons namelist,time_control 1 rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" # DFI namelist -rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" -rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" -rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" +rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" +rconfig integer dfi_radar namelist,dfi_control 1 0 rh "dfi_radar" "DFI radar switch" "" +rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" +rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" rconfig integer dfi_cutoff_seconds namelist,dfi_control 1 3600 rh "dfi_cutoff_seconds" "Digital filter cutoff time" "" rconfig integer dfi_time_dim namelist,dfi_control 1 1000 rh "dfi_time_dim" "MAX DIMENSION FOR HCOEFF" @@ -1186,6 +1263,7 @@ rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh rconfig integer time_step namelist,domains 1 - ih "time_step" rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" rconfig integer min_time_step namelist,domains max_domains -1 h "min_time_step" rconfig integer max_time_step namelist,domains max_domains -1 h "max_time_step" @@ -1193,6 +1271,7 @@ rconfig real target_cfl namelist,domains max_domains 1.2 rconfig integer max_step_increase_pct namelist,domains max_domains 5 h "max_step_increase_pct" rconfig integer starting_time_step namelist,domains max_domains -1 h "starting_time_step" rconfig logical step_to_output_time namelist,domains 1 .true. h "step_to_output_time" +rconfig integer adaptation_domain namelist,domains 1 1 h "adaptation_domain" rconfig logical use_adaptive_time_step namelist,domains 1 .false. h "use_adaptive_time_step" rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" @@ -1276,6 +1355,7 @@ rconfig real vmax_ratio namelist,tc max_bogus -999. i # Physics rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +#rconfig integer milbrandt_ccntype namelist,physics max_domains 0 rh "milbrandt select maritime(1)/continental(2)" "" "" rconfig integer gsfcgce_hail namelist,physics 1 0 rh "gsfcgce select hail/graupel" "" "" rconfig integer gsfcgce_2ice namelist,physics 1 0 rh "gsfcgce select 2ice/3ice" "" "" rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" @@ -1307,6 +1387,7 @@ rconfig integer ensdim namelist,physics 1 144 rconfig integer cugd_avedx namelist,physics 1 1 irh "cugd_avedx" "" "" rconfig integer clos_choice namelist,physics 1 0 rh "clos_choice" "" "" rconfig integer imomentum namelist,physics 1 0 rh "imomentum" "momentum transport in G3 scheme" "" +rconfig integer ishallow namelist,physics 1 0 rh "ishallow" "shallow convection in G3 scheme" "" rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" @@ -1333,6 +1414,7 @@ rconfig integer omlcall namelist,physics 1 0 rconfig real oml_hml0 namelist,physics 1 50 h "oml_hml0" "oml initial mixed layer depth value" "m" rconfig real oml_gamma namelist,physics 1 0.14 h "oml_gamma" "oml deep water lapse rate" "K m-1" rconfig integer isftcflx namelist,physics 1 0 h "isftcflx" "switch to control sfc fluxes" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" rconfig real shadlen namelist,physics 1 25000. - "shadow_length" "maximum length of orographic shadow" "m" rconfig integer slope_rad namelist,physics max_domains 0 - "slope_rad" "1: use slope-dependent radiation, 0:not" "" rconfig integer topo_shading namelist,physics max_domains 0 - "topo_shading" "1: apply topographic shading to radiation, 0:not" "" @@ -1340,6 +1422,7 @@ rconfig integer no_mp_heating namelist,physics 1 0 rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seaice" "Fractional sea-ice option" rconfig real bucket_mm namelist,physics 1 -1. h "bucket_mm" "bucket reset value for water accumulations -1: inactive" "" rconfig real bucket_J namelist,physics 1 -1. h "bucket_J" "bucket reset value for energy accumulations -1: inactive" "" +rconfig real mp_tend_lim namelist,physics 1 10. - "mp_tend_lim" "limit on temp tendency from mp latent heating" "K/s" rconfig integer grav_settling namelist,physics max_domains 0 h "grav_settling" "activate gravitationalsettling of fog 0=no, 1=yes" @@ -1392,11 +1475,30 @@ rconfig real obs_coef_pstr namelist,fdda max_domains rconfig integer obs_no_pbl_nudge_uv namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_t namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_t" "1=no temperature-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_q namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_q" "1=no moisture-nudging within pbl" "" +rconfig real obs_nudgezfullr1_uv namelist,fdda 1 50 rh "obs_nudgezfullr1_uv" "Vert infl full weight height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezrampr1_uv namelist,fdda 1 50 rh "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezfullr2_uv namelist,fdda 1 50 rh "obs_nudgezfullr2_uv" "Vert infl full weight height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezrampr2_uv namelist,fdda 1 50 rh "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezfullr4_uv namelist,fdda 1 50 rh "obs_nudgezfullr4_uv" "Vert infl full weight height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezrampr4_uv namelist,fdda 1 -5000 rh "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezfullr1_t namelist,fdda 1 50 rh "obs_nudgezfullr1_t" "Vert infl full weight height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezrampr1_t namelist,fdda 1 50 rh "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezfullr2_t namelist,fdda 1 50 rh "obs_nudgezfullr2_t" "Vert infl full weight height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezrampr2_t namelist,fdda 1 50 rh "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezfullr4_t namelist,fdda 1 50 rh "obs_nudgezfullr4_t" "Vert infl full weight height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezrampr4_t namelist,fdda 1 -5000 rh "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezfullr1_q namelist,fdda 1 50 rh "obs_nudgezfullr1_q" "Vert infl full weight height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezrampr1_q namelist,fdda 1 50 rh "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezfullr2_q namelist,fdda 1 50 rh "obs_nudgezfullr2_q" "Vert infl full weight height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezrampr2_q namelist,fdda 1 50 rh "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezfullr4_q namelist,fdda 1 50 rh "obs_nudgezfullr4_q" "Vert infl full weight height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezrampr4_q namelist,fdda 1 -5000 rh "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezfullmin namelist,fdda 1 50 rh "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0" "m" +rconfig real obs_nudgezrampmin namelist,fdda 1 50 rh "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m" +rconfig real obs_nudgezmax namelist,fdda 1 3000 rh "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m" rconfig real obs_sfcfact namelist,fdda 1 1.0 h "obs_sfcfact" "Scale factor applied to time window for surface obs" "" rconfig real obs_sfcfacr namelist,fdda 1 1.0 h "obs_sfcfacr" "Scale factor applied to horiz radius of influence for surface obs" "" rconfig real obs_dpsmx namelist,fdda 1 7.5 h "obs_dpsmx" "Max pressure change allowed within horiz radius of influence" "centibars" -rconfig real obs_lml_ht1 namelist,fdda 1 100. h "obs_lml_ht1" "Height 1 for spreading of lowest model level obs" "km" -rconfig real obs_lml_ht2 namelist,fdda 1 100. h "obs_lml_ht2" "Height 2 for spreading of lowest model level obs" "km" rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" rconfig real obs_twindo namelist,fdda max_domains 0 rh "obs_twindo" "Half-period time window for nudging" "hrs" @@ -1457,8 +1559,9 @@ rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" rconfig integer moist_adv_opt namelist,dynamics max_domains 1 rh "moist_adv_opt" "positive-definite RK3 transport switch" "" -rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 1 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" +rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 0 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" rconfig integer chem_adv_opt namelist,dynamics max_domains 1 rh "chem_adv_opt" "positive-definite RK3 transport switch" "" +rconfig integer tracer_adv_opt namelist,dynamics max_domains 1 rh "tracer_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer scalar_adv_opt namelist,dynamics max_domains 1 rh "scalar_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer tke_adv_opt namelist,dynamics max_domains 1 rh "tke_adv_opt" "positive-definite RK3 transport switch" "" rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" @@ -1481,7 +1584,7 @@ rconfig logical rotated_pole namelist,dynamics 1 .fa rconfig logical do_coriolis namelist,dynamics max_domains .true. irh "do_coriolis" "" "" rconfig logical do_curvature namelist,dynamics max_domains .true. irh "do_curvature" "" "" rconfig logical do_gradp namelist,dynamics max_domains .true. irh "do_gradp" "" "" - +g # Bdy_control rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" @@ -1567,7 +1670,9 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng +#package milbrandt3mom mp_physics==12 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr package thompson07 mp_physics==98 - moist:qv,qc,qr,qi,qs,qg;scalar:qni @@ -1582,7 +1687,9 @@ package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng +#package milbrandt3mom_dfi mp_physics_dfi==12 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr package thompson07_dfi mp_physics_dfi==98 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni @@ -1609,12 +1716,13 @@ package qnsesfcscheme sf_sfclay_physics==4 - - package mynnsfcscheme sf_sfclay_physics==5 - state:qke,tsq,qsq,cov package pxsfcscheme sf_sfclay_physics==7 - - -package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package bep_bemscheme sf_urban_physics==3 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - - -package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag +package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1 package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old package ysuscheme bl_pbl_physics==1 - - @@ -1650,11 +1758,11 @@ package dfi_bck dfi_stage==1 - - package dfi_fwd dfi_stage==2 - - package dfi_fst dfi_stage==3 - - -#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt +#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG +package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad ifdef RUC_CLOUD package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qni_gc endif @@ -1690,7 +1798,7 @@ halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong -halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar +halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 @@ -1716,10 +1824,10 @@ halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend halo HALO_EM_C dyn_em 4:u_2,v_2 halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut,muts -halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al -halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al -halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 -halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar;4:mu_2,al +halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,tracer,scalar;4:mu_1,mu_2 +halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,tracer,scalar;4:mu_1,mu_2 halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 halo HALO_EM_E_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 halo HALO_EM_MOIST_E_3 dyn_em 24:moist @@ -1730,6 +1838,9 @@ halo HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens, halo HALO_EM_CHEM_E_3 dyn_em 24:chem halo HALO_EM_CHEM_E_5 dyn_em 48:chem halo HALO_EM_CHEM_E_7 dyn_em 80:chem +halo HALO_EM_TRACER_E_3 dyn_em 24:tracer +halo HALO_EM_TRACER_E_5 dyn_em 48:tracer +halo HALO_EM_TRACER_E_7 dyn_em 80:tracer halo HALO_EM_SCALAR_E_3 dyn_em 24:scalar halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar @@ -1741,6 +1852,9 @@ halo HALO_EM_MOIST_OLD_E_7 dyn_em 80:moist_old halo HALO_EM_CHEM_OLD_E_3 dyn_em 24:chem_old halo HALO_EM_CHEM_OLD_E_5 dyn_em 48:chem_old halo HALO_EM_CHEM_OLD_E_7 dyn_em 80:chem_old +halo HALO_EM_TRACER_OLD_E_3 dyn_em 24:tracer_old +halo HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old +halo HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_old halo HALO_EM_SCALAR_OLD_E_3 dyn_em 24:scalar_old halo HALO_EM_SCALAR_OLD_E_5 dyn_em 48:scalar_old halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old @@ -1751,9 +1865,9 @@ halo HALO_EM_HYDRO_UV dyn_em 8:u_2,v_2 halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 halo HALO_EM_COUPLE_B dyn_em 48:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ - moist,chem,scalar + moist,chem,TRACER,scalar period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ - moist,chem,scalar + moist,chem,tracer,scalar ## For moving nests #halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 @@ -1770,16 +1884,20 @@ period PERIOD_BDY_EM_INIT dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2, period PERIOD_BDY_EM_MOIST dyn_em 4:moist period PERIOD_BDY_EM_CHEM dyn_em 4:chem +period PERIOD_BDY_EM_TRACER dyn_em 4:tracer period PERIOD_BDY_EM_SCALAR dyn_em 4:scalar period PERIOD_BDY_EM_TKE dyn_em 4:tke_2 period PERIOD_BDY_EM_MOIST2 dyn_em 4:moist period PERIOD_BDY_EM_CHEM2 dyn_em 4:chem +period PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer period PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar period PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old period PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old +period PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old period PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old period PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1 +period PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht period PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2 period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy,ustm @@ -1817,8 +1935,6 @@ typedef fdob_type logical NUDGE_T_PBL # Flag for temperature nudging within the typedef fdob_type logical NUDGE_Q_PBL # Flag for moisture nudging within the PBL typedef fdob_type real SFCFACT # scale factor applied to time window for surface obs typedef fdob_type real SFCFACR # scale factor applied to horiz radius of influence for surface obs -typedef fdob_type real LML_OBS_HT1_LEV # base-state model vertical coordinate of LML_OBS_HT1 -typedef fdob_type real LML_OBS_HT2_LEV # base-state model vertical coordinate of LML_OBS_HT2 typedef fdob_type real RINFMN # minimum radius of influence typedef fdob_type real RINFMX # maximum radius of influence typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small @@ -1827,6 +1943,14 @@ typedef fdob_type real DPSMX # max pres change (cb) allowed within inf typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization typedef fdob_type real KNOWN_LAT # Latitude of origin point (i,j)=(1,1) typedef fdob_type real KNOWN_LON # Longitude of origin point (i,j)=(1,1) +typedef fdob_type character SDATE # domain starting date (YYYY-MM-DD_hh:mm:ss) +typedef fdob_type real XTIME_AT_REST # xtime at restart time +typedef fdob_type real VIF_UV(6) # Vertical influence function parameters for wind nudging +typedef fdob_type real VIF_T(6) # Vertical influence function parameters for temperature nudging +typedef fdob_type real VIF_Q(6) # Vertical influence function parameters for moisture nudging +typedef fdob_type real VIF_FULLMIN # Minimum depth through which vert infl fcn remains 1.0 (m) +typedef fdob_type real VIF_RAMPMIN # Minimum depth through which vif decreases 1.0 to 0.0 (m) +typedef fdob_type real VIF_MAX # Maximum depth in which vif is nonzero (m) # table entries are of the form # @@ -1846,6 +1970,7 @@ typedef fdob_type real latprt [ - 1 - typedef fdob_type real lonprt [ - 1 - - "lonprt" "obs longitude for diagnostic printout" typedef fdob_type real mlatprt [ - 1 - - "mlatprt" "model latitude at obs location" typedef fdob_type real mlonprt [ - 1 - - "mlonprt" "model longitude at obs location" +typedef fdob_type real base_state k - 1 - - "base_state" "base-state height on half (mass) levels" "meters" state fdob_type fdob - - @@ -1875,6 +2000,7 @@ xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy +xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy # xpose variables for spectral nudging @@ -1886,4 +2012,5 @@ xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy ## include registry.fire +include registry.avgflx diff --git a/wrfv2_fire/Registry/Registry.EM_CHEM b/wrfv2_fire/Registry/Registry.EM_CHEM index 0591135e..30c4353c 100644 --- a/wrfv2_fire/Registry/Registry.EM_CHEM +++ b/wrfv2_fire/Registry/Registry.EM_CHEM @@ -101,6 +101,7 @@ state real qc_gc igj dyn_em 1 Z i1 "QC" " state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" +state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice no concentration" "m-3" endif @@ -268,6 +269,10 @@ state real cfn - misc - - irh "cfn state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" state integer step_number - misc - - ir "step_number" "" +# hydrostatic pressure vars +state real p_hyd ikj dyn_em 1 - irh "p_hyd" "hydrostatic pressure" "Pa" +state real p_hyd_w ikj dyn_em 1 Z irh "p_hyd_w" "hydrostatic pressure at full levels" "Pa" + # 2m and 10m output diagnostics state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" @@ -349,6 +354,8 @@ state real qs ikjftb moist 1 - \ i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" state real qg ikjftb moist 1 - \ i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qh ikjftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QHAIL" "Hail mixing ratio" "kg kg-1" state real - ikjftb dfi_moist 1 - - - state real dfi_qv ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QVAPOR" "Water vapor mixing ratio" "kg kg-1" @@ -362,7 +369,19 @@ state real dfi_qs ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QSNOW" "Snow mixing ratio" "kg kg-1" state real dfi_qg ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QGRAUP" "Graupel mixing ratio" "kg kg-1" +<<<<<<< .mine +state real dfi_qh ikjftb dfi_moist 1 - \ + rusdf=(bdy_interp:dt) "DFI_QHAIL" "Hail mixing ratio" "kg kg-1" +======= +# LES---------------!JDM + +include registry.les + +#------------------- + +>>>>>>> .r4075 +# Other Tracers in registry.chem # Other Scalars state real - ikjftb scalar 1 - - - state real qni ikjftb scalar 1 - \ @@ -377,6 +396,8 @@ state real qnr ikjftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNRAIN" "Rain Number concentration" "# kg(-1)" state real qng ikjftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real qnh ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNHAIL" "Hail Number concentration" "# kg(-1)" state real qnn ikjftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ikjftb scalar 1 - \ @@ -394,6 +415,8 @@ state real dfi_qnr ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" state real dfi_qng ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real dfi_qnh ikjftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)" state real dfi_qnn ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ @@ -467,8 +490,10 @@ state real soilt160 ij misc 1 - i1 "SOIL state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" -state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" -state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real toposlpx ij misc 1 - i012rdu "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i012rdu "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real slope ij misc 1 - rdu "SLOPE" "ELEVATION SLOPE" "" +state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" state real shdmax ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" state real shdmin ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" @@ -489,21 +514,21 @@ state real vegcat ij misc 1 - i12 "VEGC state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_glw ?! misc - - r "TS_GLW" "Downward long wave flux at surface" -state real ts_gsw ?! misc - - r "TS_GSW" "Net short wave flux at surface" -state real ts_hfx ?! misc - - r "TS_HFX" "Upward heat flux at surface" -state real ts_lh ?! misc - - r "TS_LH" "Upward moisture flux at surface" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" -state real ts_rainc ?! misc - - r "TS_RAINC" "Cumulus precip" -state real ts_rainnc ?! misc - - r "TS_RAINNC" "Grid-scale precip" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_glw ?! misc - - - "TS_GLW" "Downward long wave flux at surface" +state real ts_gsw ?! misc - - - "TS_GSW" "Net short wave flux at surface" +state real ts_hfx ?! misc - - - "TS_HFX" "Upward heat flux at surface" +state real ts_lh ?! misc - - - "TS_LH" "Upward moisture flux at surface" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" +state real ts_rainc ?! misc - - - "TS_RAINC" "Cumulus precip" +state real ts_rainnc ?! misc - - - "TS_RAINNC" "Grid-scale precip" # urban model variables state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" @@ -556,10 +581,12 @@ state real dfi_v ikj misc 1 - r "V_DFI" state real dfi_w ikj misc 1 - r "W_DFI" "w accumulation array" " " state real dfi_ww ikj misc 1 Z r "WW_DFI" "mu-coupled eta-dot" "Pa s-1" state real dfi_t ikj misc 1 - r "TT_DFI" "t accumulation array" " " +state real dfi_rh ikj misc 1 - r "RH_DFI" "initial relative humidity" " " state real dfi_ph ikj misc 1 - r "PH_DFI" "p accumulation array" " " state real dfi_pb ikj misc 1 - r "PB_DFI" "pb accumulation array" " " state real dfi_alt ikj misc 1 - r "ALT_DFI" "1/rho accumulation array" " " state real dfi_tke ikj misc 1 - r "TKE_DFI" "TURBULENCE KINETIC ENERGY" "m2 s-2" +state real dfi_tten_rad ikj misc 1 - irh "RAD_TTEN_DFI" "RADAR POT. TEMP. TENDENCY" "K s-1" state real dfi_TSLB ilj misc 1 Z r "TSLB_dfi" "SOIL TEMPERATURE" "K" state real dfi_SMOIS ilj - 1 Z r "SMOIS_dfi" "SOIL MOISTURE" "m3 m-3" @@ -594,16 +621,34 @@ state real TRB_URB4D i{ulay}j misc 1 Z r "T state real TW1_URB4D i{ulay}j misc 1 Z r "TW1_URB4D" "WALL LAYER TEMPERATURE" "K" state real TW2_URB4D i{ulay}j misc 1 Z r "TW2_URB4D" "WALL LAYER TEMPERATURE" "K" state real TGB_URB4D i{ulay}j misc 1 Z r "TGB_URB4D" "ROAD LAYER TEMPERATURE" "K" +state real TLEV_URB3D i{ulay}j misc 1 Z r "TLEV_URB3D" "INDOOR TEMPERATURE" "K" +state real QLEV_URB3D i{ulay}j misc 1 Z r "QLEV_URB3D" "SPECIFIC HUMIDITY" "dimensionless" +state real TW1LEV_URB3D i{ulay}j misc 1 Z r "TW1LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TW2LEV_URB3D i{ulay}j misc 1 Z r "TW2LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TGLEV_URB3D i{ulay}j misc 1 Z r "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING" "K" +state real TFLEV_URB3D i{ulay}j misc 1 Z r "TFLEV_URB3D" "FLOOR TEMPERATURE" "K" +state real SF_AC_URB3D ij misc 1 - r "SF_AC_URB3D" "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real LF_AC_URB3D ij misc 1 - r "LF_AC_URB3D" "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real CM_AC_URB3D ij misc 1 - r "CM_AC_URB3D" "CONSUMPTION OF THE AIR COND." "W m{-2}" +state real SFVENT_URB3D ij misc 1 - r "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real LFVENT_URB3D ij misc 1 - r "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real SFWIN1_URB3D i{ulay}j misc 1 Z r "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" +state real SFWIN2_URB3D i{ulay}j misc 1 Z r "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" state real SFW1_URB3D i{ulay}j misc 1 Z r "SFW1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFW2_URB3D i{ulay}j misc 1 Z r "SFW2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFR_URB3D i{ulay}j misc 1 Z r "SFR_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFG_URB3D i{ulay}j misc 1 Z r "SFG_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real CMR_SFCDIF ij misc 1 - r "CMR_SFCDIF" "" "" +state real CHR_SFCDIF ij misc 1 - r "CHR_SFCDIF" "" "" +state real CMC_SFCDIF ij misc 1 - r "CMC_SFCDIF" "" "" +state real CHC_SFCDIF ij misc 1 - r "CHC_SFCDIF" "" "" -# urban variables from radiation model -state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" -state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" -state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" +# solar location variables from radiation driver +state real COSZEN ij misc 1 - r "COSZEN" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real HRANG ij misc 1 - r "HRANG" "SOLAR HOUR ANGLE" "radians" +state real DECLIN - misc 1 - r "DECLIN" "SOLAR DECLINATION" "radians" +state real SOLCON - misc 1 - r "SOLCON" "SOLAR CONSTANT" "W m-2" # RUC LSM state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" @@ -788,7 +833,7 @@ state real ht_int ij misc 1 - - " state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" state real ht_shad ijb misc 1 - hdf=(bdy_interp:dt) "HGT_SHAD" "Height of orographic shadow" "m" i1 real ht_loc ij misc 1 - - -i1 integer shadowmask ij misc 1 - - +state integer shadowmask ij misc 1 - - state integer min_ptchsz - misc 1 - r state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" @@ -837,8 +882,11 @@ state real RAINNCV ij misc 1 - r "R state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real HAILNC ij misc 1 - rhdu "HAILNC" "ACCUMULATED TOTAL GRID SCALE HAIL" "mm" state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" +state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" @@ -850,7 +898,11 @@ state real apr_as ij misc 1 - rh "A state real apr_capma ij misc 1 - rh "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" state real apr_capme ij misc 1 - rh "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" state real apr_capmi ij misc 1 - rh "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" -state real edt_out ij misc 1 - h "EDT_OUT" "EDT FROM GD SCHEME" "" +state real edt_out ij misc 1 - - "EDT_OUT" "EDT FROM GD SCHEME" "" +state real xmb_shallow ij misc 1 - hr "XMB_SHALLOW" "MASSFLUX FROM SHALLOW CONVECTION (G3 only)" "" +state integer k22_shallow ij misc 1 - h "K22_SHALLOW" "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)" "" +state integer kbcon_shallow ij misc 1 - h "KBCON_SHALLOW" "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)" "" +state integer ktop_shallow ij misc 1 - h "KTOP_SHALLOW" "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)" "" state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real cugd_tten ikj misc 1 - h "CUGD_TTEN" "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME" "K s-1" @@ -875,6 +927,7 @@ state real SWDOWN ij misc 1 - rhd "S state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" # upward and downward clearsky and total diagnostic fluxes for CAM radiation state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" @@ -1013,8 +1066,9 @@ state real FLQC ij misc 1 - r "F state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real dfi_QVG ij misc 1 - r "QVG_dfi" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - i012rh "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real dfi_SOILT1 ij misc 1 - r "SOILT1_dfi" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" state real dfi_TSNAV ij misc 1 - r "TSNAV_dfi" "AVERAGE SNOW TEMPERATURE " "C" @@ -1171,6 +1225,7 @@ rconfig logical cycling namelist,time_control 1 # DFI namelist rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" +rconfig integer dfi_radar namelist,dfi_control 1 0 rh "dfi_radar" "DFI radar switch" "" rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" @@ -1193,6 +1248,7 @@ rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh rconfig integer time_step namelist,domains 1 - ih "time_step" rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" +rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" rconfig integer min_time_step namelist,domains max_domains -1 h "min_time_step" rconfig integer max_time_step namelist,domains max_domains -1 h "max_time_step" @@ -1200,6 +1256,7 @@ rconfig real target_cfl namelist,domains max_domains 1.2 rconfig integer max_step_increase_pct namelist,domains max_domains 5 h "max_step_increase_pct" rconfig integer starting_time_step namelist,domains max_domains -1 h "starting_time_step" rconfig logical step_to_output_time namelist,domains 1 .true. h "step_to_output_time" +rconfig integer adaptation_domain namelist,domains 1 1 h "adaptation_domain" rconfig logical use_adaptive_time_step namelist,domains 1 .false. h "use_adaptive_time_step" rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" @@ -1312,6 +1369,7 @@ rconfig integer maxens3 namelist,physics 1 16 rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" rconfig integer cugd_avedx namelist,physics 1 1 irh "cugd_avedx" "" "" rconfig integer imomentum namelist,physics 1 0 rh "imomentum" "momentum transport in G3 scheme" "" +rconfig integer ishallow namelist,physics 1 0 rh "ishallow" "shallow convection in G3 scheme" "" rconfig integer clos_choice namelist,physics 1 0 rh "clos_choice" "" "" rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" @@ -1338,6 +1396,7 @@ rconfig integer omlcall namelist,physics 1 0 rconfig real oml_hml0 namelist,physics 1 50 h "oml_hml0" "oml initial mixed layer depth value" "m" rconfig real oml_gamma namelist,physics 1 0.14 h "oml_gamma" "oml deep water lapse rate" "K m-1" rconfig integer isftcflx namelist,physics 1 0 h "isftcflx" "switch to control sfc fluxes" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" rconfig real shadlen namelist,physics 1 25000. - "shadow_length" "maximum length of orographic shadow" "m" rconfig integer slope_rad namelist,physics max_domains 0 - "slope_rad" "1: use slope-dependent radiation, 0:not" "" rconfig integer topo_shading namelist,physics max_domains 0 - "topo_shading" "1: apply topographic shading to radiation, 0:not" "" @@ -1345,6 +1404,7 @@ rconfig integer no_mp_heating namelist,physics 1 0 rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seaice" "Fractional sea-ice option" rconfig real bucket_mm namelist,physics 1 -1. h "bucket_mm" "bucket reset value for water accumulations -1: inactive" "" rconfig real bucket_J namelist,physics 1 -1. h "bucket_J" "bucket reset value for energy accumulations -1: inactive" "" +rconfig real mp_tend_lim namelist,physics 1 10. - "mp_tend_lim" "limit on temp tendency from mp latent heating" "K/s" rconfig integer grav_settling namelist,physics max_domains 0 h "grav_settling" "activate gravitationalsettling of fog 0=no, 1=yes" @@ -1397,11 +1457,30 @@ rconfig real obs_coef_pstr namelist,fdda max_domains rconfig integer obs_no_pbl_nudge_uv namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_t namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_t" "1=no temperature-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_q namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_q" "1=no moisture-nudging within pbl" "" +rconfig real obs_nudgezfullr1_uv namelist,fdda 1 50 rh "obs_nudgezfullr1_uv" "Vert infl full weight height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezrampr1_uv namelist,fdda 1 50 rh "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezfullr2_uv namelist,fdda 1 50 rh "obs_nudgezfullr2_uv" "Vert infl full weight height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezrampr2_uv namelist,fdda 1 50 rh "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezfullr4_uv namelist,fdda 1 50 rh "obs_nudgezfullr4_uv" "Vert infl full weight height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezrampr4_uv namelist,fdda 1 -5000 rh "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezfullr1_t namelist,fdda 1 50 rh "obs_nudgezfullr1_t" "Vert infl full weight height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezrampr1_t namelist,fdda 1 50 rh "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezfullr2_t namelist,fdda 1 50 rh "obs_nudgezfullr2_t" "Vert infl full weight height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezrampr2_t namelist,fdda 1 50 rh "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezfullr4_t namelist,fdda 1 50 rh "obs_nudgezfullr4_t" "Vert infl full weight height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezrampr4_t namelist,fdda 1 -5000 rh "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezfullr1_q namelist,fdda 1 50 rh "obs_nudgezfullr1_q" "Vert infl full weight height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezrampr1_q namelist,fdda 1 50 rh "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezfullr2_q namelist,fdda 1 50 rh "obs_nudgezfullr2_q" "Vert infl full weight height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezrampr2_q namelist,fdda 1 50 rh "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezfullr4_q namelist,fdda 1 50 rh "obs_nudgezfullr4_q" "Vert infl full weight height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezrampr4_q namelist,fdda 1 -5000 rh "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezfullmin namelist,fdda 1 50 rh "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0" "m" +rconfig real obs_nudgezrampmin namelist,fdda 1 50 rh "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m" +rconfig real obs_nudgezmax namelist,fdda 1 3000 rh "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m" rconfig real obs_sfcfact namelist,fdda 1 1.0 h "obs_sfcfact" "Scale factor applied to time window for surface obs" "" rconfig real obs_sfcfacr namelist,fdda 1 1.0 h "obs_sfcfacr" "Scale factor applied to horiz radius of influence for surface obs" "" rconfig real obs_dpsmx namelist,fdda 1 7.5 h "obs_dpsmx" "Max pressure change allowed within horiz radius of influence" "centibars" -rconfig real obs_lml_ht1 namelist,fdda 1 100. h "obs_lml_ht1" "Height 1 for spreading of lowest model level obs" "km" -rconfig real obs_lml_ht2 namelist,fdda 1 100. h "obs_lml_ht2" "Height 2 for spreading of lowest model level obs" "km" rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" rconfig real obs_twindo namelist,fdda max_domains 0 rh "obs_twindo" "Half-period time window for nudging" "hrs" @@ -1462,8 +1541,9 @@ rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" rconfig integer moist_adv_opt namelist,dynamics max_domains 1 rh "moist_adv_opt" "positive-definite RK3 transport switch" "" -rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 1 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" +rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 0 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" rconfig integer chem_adv_opt namelist,dynamics max_domains 1 rh "chem_adv_opt" "positive-definite RK3 transport switch" "" +rconfig integer tracer_adv_opt namelist,dynamics max_domains 1 rh "tracer_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer scalar_adv_opt namelist,dynamics max_domains 1 rh "scalar_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer tke_adv_opt namelist,dynamics max_domains 1 rh "tke_adv_opt" "positive-definite RK3 transport switch" "" rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" @@ -1573,6 +1653,7 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr @@ -1587,6 +1668,7 @@ package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr @@ -1614,12 +1696,13 @@ package qnsesfcscheme sf_sfclay_physics==4 - - package mynnsfcscheme sf_sfclay_physics==5 - state:qke,tsq,qsq,cov package pxsfcscheme sf_sfclay_physics==7 - - -package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package bep_bemscheme sf_urban_physics==3 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - - -package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag +package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1 package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old package ysuscheme bl_pbl_physics==1 - - @@ -1655,11 +1738,11 @@ package dfi_bck dfi_stage==1 - - package dfi_fwd dfi_stage==2 - - package dfi_fst dfi_stage==3 - - -#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt +#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG +package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad ifdef RUC_CLOUD package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qni_gc endif @@ -1694,7 +1777,7 @@ halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong -halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar +halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 @@ -1720,10 +1803,10 @@ halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend halo HALO_EM_C dyn_em 4:u_2,v_2 halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut,muts -halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al -halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,scalar;4:mu_2,al -halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 -halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,scalar;4:mu_1,mu_2 +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar;4:mu_2,al +halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,tracer,scalar;4:mu_1,mu_2 +halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,tracer,scalar;4:mu_1,mu_2 halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 halo HALO_EM_E_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 halo HALO_EM_MOIST_E_3 dyn_em 24:moist @@ -1734,6 +1817,9 @@ halo HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens, halo HALO_EM_CHEM_E_3 dyn_em 24:chem halo HALO_EM_CHEM_E_5 dyn_em 48:chem halo HALO_EM_CHEM_E_7 dyn_em 80:chem +halo HALO_EM_TRACER_E_3 dyn_em 24:tracer +halo HALO_EM_TRACER_E_5 dyn_em 48:tracer +halo HALO_EM_TRACER_E_7 dyn_em 80:tracer halo HALO_EM_SCALAR_E_3 dyn_em 24:scalar halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar @@ -1745,6 +1831,9 @@ halo HALO_EM_MOIST_OLD_E_7 dyn_em 80:moist_old halo HALO_EM_CHEM_OLD_E_3 dyn_em 24:chem_old halo HALO_EM_CHEM_OLD_E_5 dyn_em 48:chem_old halo HALO_EM_CHEM_OLD_E_7 dyn_em 80:chem_old +halo HALO_EM_TRACER_OLD_E_3 dyn_em 24:tracer_old +halo HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old +halo HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_old halo HALO_EM_SCALAR_OLD_E_3 dyn_em 24:scalar_old halo HALO_EM_SCALAR_OLD_E_5 dyn_em 48:scalar_old halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old @@ -1755,9 +1844,9 @@ halo HALO_EM_HYDRO_UV dyn_em 8:u_2,v_2 halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 halo HALO_EM_COUPLE_B dyn_em 48:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ - moist,chem,scalar + moist,chem,tracer,scalar period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2,\ - moist,chem,scalar + moist,chem,tracer,scalar # For moving nests halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 @@ -1774,16 +1863,20 @@ period PERIOD_BDY_EM_INIT dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2, period PERIOD_BDY_EM_MOIST dyn_em 4:moist period PERIOD_BDY_EM_CHEM dyn_em 4:chem +period PERIOD_BDY_EM_TRACER dyn_em 4:tracer period PERIOD_BDY_EM_SCALAR dyn_em 4:scalar period PERIOD_BDY_EM_TKE dyn_em 4:tke_2 period PERIOD_BDY_EM_MOIST2 dyn_em 4:moist period PERIOD_BDY_EM_CHEM2 dyn_em 4:chem +period PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer period PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar period PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old period PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old +period PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old period PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old period PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1 +period PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht period PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2 period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy,ustm @@ -1821,8 +1914,6 @@ typedef fdob_type logical NUDGE_T_PBL # Flag for temperature nudging within the typedef fdob_type logical NUDGE_Q_PBL # Flag for moisture nudging within the PBL typedef fdob_type real SFCFACT # scale factor applied to time window for surface obs typedef fdob_type real SFCFACR # scale factor applied to horiz radius of influence for surface obs -typedef fdob_type real LML_OBS_HT1_LEV # base-state model vertical coordinate of LML_OBS_HT1 -typedef fdob_type real LML_OBS_HT2_LEV # base-state model vertical coordinate of LML_OBS_HT2 typedef fdob_type real RINFMN # minimum radius of influence typedef fdob_type real RINFMX # maximum radius of influence typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small @@ -1831,6 +1922,14 @@ typedef fdob_type real DPSMX # max pres change (cb) allowed within inf typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization typedef fdob_type real KNOWN_LAT # Latitude of origin point (i,j)=(1,1) typedef fdob_type real KNOWN_LON # Longitude of origin point (i,j)=(1,1) +typedef fdob_type character SDATE # domain starting date (YYYY-MM-DD_hh:mm:ss) +typedef fdob_type real XTIME_AT_REST # xtime at restart time +typedef fdob_type real VIF_UV(6) # Vertical influence function parameters for wind nudging +typedef fdob_type real VIF_T(6) # Vertical influence function parameters for temperature nudging +typedef fdob_type real VIF_Q(6) # Vertical influence function parameters for moisture nudging +typedef fdob_type real VIF_FULLMIN # Minimum depth through which vert infl fcn remains 1.0 (m) +typedef fdob_type real VIF_RAMPMIN # Minimum depth through which vif decreases 1.0 to 0.0 (m) +typedef fdob_type real VIF_MAX # Maximum depth in which vif is nonzero (m) # table entries are of the form #
@@ -1850,6 +1949,7 @@ typedef fdob_type real latprt [ - 1 - typedef fdob_type real lonprt [ - 1 - - "lonprt" "obs longitude for diagnostic printout" typedef fdob_type real mlatprt [ - 1 - - "mlatprt" "model latitude at obs location" typedef fdob_type real mlonprt [ - 1 - - "mlonprt" "model longitude at obs location" +typedef fdob_type real base_state k - 1 - - "base_state" "base-state height on half (mass) levels" "meters" state fdob_type fdob - - @@ -1879,6 +1979,7 @@ xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy +xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy # xpose variables for spectral nudging @@ -1890,5 +1991,5 @@ xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy ## include registry.fire - +include registry.avgflx diff --git a/wrfv2_fire/Registry/Registry.EM_SST b/wrfv2_fire/Registry/Registry.EM_SST index ff9958c1..82122f9c 100644 --- a/wrfv2_fire/Registry/Registry.EM_SST +++ b/wrfv2_fire/Registry/Registry.EM_SST @@ -108,6 +108,7 @@ state real qc_gc igj dyn_em 1 Z i1 "QC" " state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" +state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice no concentration" "m-3" endif @@ -275,6 +276,10 @@ state real cfn - misc - - irh "cfn state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" state integer step_number - misc - - ir "step_number" "" +# hydrostatic pressure vars +state real p_hyd ikj dyn_em 1 - irh "p_hyd" "hydrostatic pressure" "Pa" +state real p_hyd_w ikj dyn_em 1 Z irh "p_hyd_w" "hydrostatic pressure at full levels" "Pa" + # 2m and 10m output diagnostics state real Q2 ij misc 1 - irhd "Q2" "QV at 2 M" "kg kg-1" state real T2 ij misc 1 - irhd "T2" "TEMP at 2 M" "K" @@ -354,6 +359,8 @@ state real qs ikjftb moist 1 - \ i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" state real qg ikjftb moist 1 - \ i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qh ikjftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QHAIL" "Hail mixing ratio" "kg kg-1" state real - ikjftb dfi_moist 1 - - - state real dfi_qv ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QVAPOR" "Water vapor mixing ratio" "kg kg-1" @@ -367,7 +374,14 @@ state real dfi_qs ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QSNOW" "Snow mixing ratio" "kg kg-1" state real dfi_qg ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real dfi_qh ikjftb dfi_moist 1 - \ + rusdf=(bdy_interp:dt) "DFI_QHAIL" "Hail mixing ratio" "kg kg-1" + +# LES---------------!JDM + +include registry.les +#------------------- # Chem Scalars state real - ikjftb chem 1 - - - @@ -386,6 +400,8 @@ state real qnr ikjftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNRAIN" "Rain Number concentration" "# kg(-1)" state real qng ikjftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real qnh ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNHAIL" "Hail Number concentration" "# kg(-1)" state real qnn ikjftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ikjftb scalar 1 - \ @@ -403,6 +419,8 @@ state real dfi_qnr ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" state real dfi_qng ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real dfi_qnh ikjftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)" state real dfi_qnn ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ @@ -475,8 +493,10 @@ state real soilt300 ij misc 1 - i1 "SOIL # added to output 5 for ESMF state real landmask ij misc 1 - i0125rh05d=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" -state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" -state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real toposlpx ij misc 1 - i012rdu "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i012rdu "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real slope ij misc 1 - rdu "SLOPE" "ELEVATION SLOPE" "" +state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" state real shdmax ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" state real shdmin ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" @@ -496,21 +516,21 @@ state real vegcat ij misc 1 - i12 "VEGC state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_glw ?! misc - - r "TS_GLW" "Downward long wave flux at surface" -state real ts_gsw ?! misc - - r "TS_GSW" "Net short wave flux at surface" -state real ts_hfx ?! misc - - r "TS_HFX" "Upward heat flux at surface" -state real ts_lh ?! misc - - r "TS_LH" "Upward moisture flux at surface" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" -state real ts_rainc ?! misc - - r "TS_RAINC" "Cumulus precip" -state real ts_rainnc ?! misc - - r "TS_RAINNC" "Grid-scale precip" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_glw ?! misc - - - "TS_GLW" "Downward long wave flux at surface" +state real ts_gsw ?! misc - - - "TS_GSW" "Net short wave flux at surface" +state real ts_hfx ?! misc - - - "TS_HFX" "Upward heat flux at surface" +state real ts_lh ?! misc - - - "TS_LH" "Upward moisture flux at surface" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" +state real ts_rainc ?! misc - - - "TS_RAINC" "Cumulus precip" +state real ts_rainnc ?! misc - - - "TS_RAINNC" "Grid-scale precip" # urban model variables state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" @@ -564,10 +584,12 @@ state real dfi_v ikj misc 1 - r "V_DFI" state real dfi_w ikj misc 1 - r "W_DFI" "w accumulation array" " " state real dfi_ww ikj misc 1 Z r "WW_DFI" "mu-coupled eta-dot" "Pa s-1" state real dfi_t ikj misc 1 - r "TT_DFI" "t accumulation array" " " +state real dfi_rh ikj misc 1 - r "RH_DFI" "initial relative humidity" " " state real dfi_ph ikj misc 1 - r "PH_DFI" "p accumulation array" " " state real dfi_pb ikj misc 1 - r "PB_DFI" "pb accumulation array" " " state real dfi_alt ikj misc 1 - r "ALT_DFI" "1/rho accumulation array" " " state real dfi_tke ikj misc 1 - r "TKE_DFI" "TURBULENCE KINETIC ENERGY" "m2 s-2" +state real dfi_tten_rad ikj misc 1 - irh "RAD_TTEN_DFI" "RADAR POT. TEMP. TENDENCY" "K s-1" state real dfi_TSLB ilj misc 1 Z r "TSLB_dfi" "SOIL TEMPERATURE" "K" state real dfi_SMOIS ilj - 1 Z r "SMOIS_dfi" "SOIL MOISTURE" "m3 m-3" @@ -602,17 +624,34 @@ state real TRB_URB4D i{ulay}j misc 1 Z r "T state real TW1_URB4D i{ulay}j misc 1 Z r "TW1_URB4D" "WALL LAYER TEMPERATURE" "K" state real TW2_URB4D i{ulay}j misc 1 Z r "TW2_URB4D" "WALL LAYER TEMPERATURE" "K" state real TGB_URB4D i{ulay}j misc 1 Z r "TGB_URB4D" "ROAD LAYER TEMPERATURE" "K" +state real TLEV_URB3D i{ulay}j misc 1 Z r "TLEV_URB3D" "INDOOR TEMPERATURE" "K" +state real QLEV_URB3D i{ulay}j misc 1 Z r "QLEV_URB3D" "SPECIFIC HUMIDITY" "dimensionless" +state real TW1LEV_URB3D i{ulay}j misc 1 Z r "TW1LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TW2LEV_URB3D i{ulay}j misc 1 Z r "TW2LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TGLEV_URB3D i{ulay}j misc 1 Z r "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING" "K" +state real TFLEV_URB3D i{ulay}j misc 1 Z r "TFLEV_URB3D" "FLOOR TEMPERATURE" "K" +state real SF_AC_URB3D ij misc 1 - r "SF_AC_URB3D" "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real LF_AC_URB3D ij misc 1 - r "LF_AC_URB3D" "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real CM_AC_URB3D ij misc 1 - r "CM_AC_URB3D" "CONSUMPTION OF THE AIR COND." "W m{-2}" +state real SFVENT_URB3D ij misc 1 - r "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real LFVENT_URB3D ij misc 1 - r "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real SFWIN1_URB3D i{ulay}j misc 1 Z r "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" +state real SFWIN2_URB3D i{ulay}j misc 1 Z r "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" state real SFW1_URB3D i{ulay}j misc 1 Z r "SFW1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFW2_URB3D i{ulay}j misc 1 Z r "SFW2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFR_URB3D i{ulay}j misc 1 Z r "SFR_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFG_URB3D i{ulay}j misc 1 Z r "SFG_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real CMR_SFCDIF ij misc 1 - r "CMR_SFCDIF" "" "" +state real CHR_SFCDIF ij misc 1 - r "CHR_SFCDIF" "" "" +state real CMC_SFCDIF ij misc 1 - r "CMC_SFCDIF" "" "" +state real CHC_SFCDIF ij misc 1 - r "CHC_SFCDIF" "" "" -# urban variables from radiation model -state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" -state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" -state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" - +# solar location variables from radiation driver +state real COSZEN ij misc 1 - r "COSZEN" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real HRANG ij misc 1 - r "HRANG" "SOLAR HOUR ANGLE" "radians" +state real DECLIN - misc 1 - r "DECLIN" "SOLAR DECLINATION" "radians" +state real SOLCON - misc 1 - r "SOLCON" "SOLAR CONSTANT" "W m-2" # RUC LSM state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" @@ -783,7 +822,7 @@ state real ht_int ij misc 1 - - " state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" state real ht_shad ijb misc 1 - hdf=(bdy_interp:dt) "HGT_SHAD" "Height of orographic shadow" "m" i1 real ht_loc ij misc 1 - - -i1 integer shadowmask ij misc 1 - - +state integer shadowmask ij misc 1 - - state integer min_ptchsz - misc 1 - r state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" @@ -832,8 +871,11 @@ state real RAINNCV ij misc 1 - r "R state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real HAILNC ij misc 1 - rhdu "HAILNC" "ACCUMULATED TOTAL GRID SCALE HAIL" "mm" state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" +state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" @@ -845,7 +887,7 @@ state real apr_as ij misc 1 - r "AP state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" -state real edt_out ij misc 1 - h "EDT_OUT" "EDT FROM GD SCHEME" "" +state real edt_out ij misc 1 - - "EDT_OUT" "EDT FROM GD SCHEME" "" state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real cugd_tten ikj misc 1 - h "CUGD_TTEN" "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME" "K s-1" @@ -867,6 +909,7 @@ state real SWDOWN ij misc 1 - rhd "S state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" # upward and downward clearsky and total diagnostic fluxes for CAM radiation state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" @@ -1005,8 +1048,9 @@ state real FLQC ij misc 1 - r "F state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real dfi_QVG ij misc 1 - r "QVG_dfi" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - i012rh "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real dfi_SOILT1 ij misc 1 - r "SOILT1_dfi" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" state real dfi_TSNAV ij misc 1 - r "TSNAV_dfi" "AVERAGE SNOW TEMPERATURE " "C" @@ -1164,6 +1208,7 @@ rconfig logical cycling namelist,time_control 1 # DFI namelist rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" +rconfig integer dfi_radar namelist,dfi_control 1 0 rh "dfi_radar" "DFI radar switch" "" rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" @@ -1186,13 +1231,14 @@ rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh rconfig integer time_step namelist,domains 1 - ih "time_step" rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" - +rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" rconfig integer min_time_step namelist,domains max_domains -1 h "min_time_step" rconfig integer max_time_step namelist,domains max_domains -1 h "max_time_step" rconfig real target_cfl namelist,domains max_domains 1.2 h "target_cfl" rconfig integer max_step_increase_pct namelist,domains max_domains 5 h "max_step_increase_pct" rconfig integer starting_time_step namelist,domains max_domains -1 h "starting_time_step" rconfig logical step_to_output_time namelist,domains 1 .true. h "step_to_output_time" +rconfig integer adaptation_domain namelist,domains 1 1 h "adaptation_domain" rconfig logical use_adaptive_time_step namelist,domains 1 .false. h "use_adaptive_time_step" rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" @@ -1333,6 +1379,7 @@ rconfig integer omlcall namelist,physics 1 0 rconfig real oml_hml0 namelist,physics 1 50 h "oml_hml0" "oml initial mixed layer depth value" "m" rconfig real oml_gamma namelist,physics 1 0.14 h "oml_gamma" "oml deep water lapse rate" "K m-1" rconfig integer isftcflx namelist,physics 1 0 h "isftcflx" "switch to control sfc fluxes" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" rconfig real shadlen namelist,physics 1 25000. - "shadow_length" "maximum length of orographic shadow" "m" rconfig integer slope_rad namelist,physics max_domains 0 - "slope_rad" "1: use slope-dependent radiation, 0:not" "" rconfig integer topo_shading namelist,physics max_domains 0 - "topo_shading" "1: apply topographic shading to radiation, 0:not" "" @@ -1340,6 +1387,7 @@ rconfig integer no_mp_heating namelist,physics 1 0 rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seaice" "Fractional sea-ice option" rconfig real bucket_mm namelist,physics 1 -1. h "bucket_mm" "bucket reset value for water accumulations -1: inactive" "" rconfig real bucket_J namelist,physics 1 -1. h "bucket_J" "bucket reset value for energy accumulations -1: inactive" "" +rconfig real mp_tend_lim namelist,physics 1 10. - "mp_tend_lim" "limit on temp tendency from mp latent heating" "K/s" rconfig integer grav_settling namelist,physics max_domains 0 h "grav_settling" "activate gravitationalsettling of fog 0=no, 1=yes" @@ -1392,11 +1440,30 @@ rconfig real obs_coef_pstr namelist,fdda max_domains rconfig integer obs_no_pbl_nudge_uv namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_t namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_t" "1=no temperature-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_q namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_q" "1=no moisture-nudging within pbl" "" +rconfig real obs_nudgezfullr1_uv namelist,fdda 1 50 rh "obs_nudgezfullr1_uv" "Vert infl full weight height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezrampr1_uv namelist,fdda 1 50 rh "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezfullr2_uv namelist,fdda 1 50 rh "obs_nudgezfullr2_uv" "Vert infl full weight height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezrampr2_uv namelist,fdda 1 50 rh "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezfullr4_uv namelist,fdda 1 50 rh "obs_nudgezfullr4_uv" "Vert infl full weight height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezrampr4_uv namelist,fdda 1 -5000 rh "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezfullr1_t namelist,fdda 1 50 rh "obs_nudgezfullr1_t" "Vert infl full weight height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezrampr1_t namelist,fdda 1 50 rh "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezfullr2_t namelist,fdda 1 50 rh "obs_nudgezfullr2_t" "Vert infl full weight height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezrampr2_t namelist,fdda 1 50 rh "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezfullr4_t namelist,fdda 1 50 rh "obs_nudgezfullr4_t" "Vert infl full weight height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezrampr4_t namelist,fdda 1 -5000 rh "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezfullr1_q namelist,fdda 1 50 rh "obs_nudgezfullr1_q" "Vert infl full weight height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezrampr1_q namelist,fdda 1 50 rh "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezfullr2_q namelist,fdda 1 50 rh "obs_nudgezfullr2_q" "Vert infl full weight height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezrampr2_q namelist,fdda 1 50 rh "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezfullr4_q namelist,fdda 1 50 rh "obs_nudgezfullr4_q" "Vert infl full weight height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezrampr4_q namelist,fdda 1 -5000 rh "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezfullmin namelist,fdda 1 50 rh "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0" "m" +rconfig real obs_nudgezrampmin namelist,fdda 1 50 rh "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m" +rconfig real obs_nudgezmax namelist,fdda 1 3000 rh "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m" rconfig real obs_sfcfact namelist,fdda 1 1.0 h "obs_sfcfact" "Scale factor applied to time window for surface obs" "" rconfig real obs_sfcfacr namelist,fdda 1 1.0 h "obs_sfcfacr" "Scale factor applied to horiz radius of influence for surface obs" "" rconfig real obs_dpsmx namelist,fdda 1 7.5 h "obs_dpsmx" "Max pressure change allowed within horiz radius of influence" "centibars" -rconfig real obs_lml_ht1 namelist,fdda 1 100. h "obs_lml_ht1" "Height 1 for spreading of lowest model level obs" "km" -rconfig real obs_lml_ht2 namelist,fdda 1 100. h "obs_lml_ht2" "Height 2 for spreading of lowest model level obs" "km" rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" rconfig real obs_twindo namelist,fdda max_domains 0 rh "obs_twindo" "Half-period time window for nudging" "hrs" @@ -1457,7 +1524,7 @@ rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" rconfig integer moist_adv_opt namelist,dynamics max_domains 1 rh "moist_adv_opt" "positive-definite RK3 transport switch" "" -rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 1 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" +rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 0 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" rconfig integer chem_adv_opt namelist,dynamics max_domains 1 rh "chem_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer scalar_adv_opt namelist,dynamics max_domains 1 rh "scalar_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer tke_adv_opt namelist,dynamics max_domains 1 rh "tke_adv_opt" "positive-definite RK3 transport switch" "" @@ -1567,6 +1634,7 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr @@ -1582,6 +1650,7 @@ package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr @@ -1609,12 +1678,13 @@ package qnsesfcscheme sf_sfclay_physics==4 - - package mynnsfcscheme sf_sfclay_physics==5 - state:qke,tsq,qsq,cov package pxsfcscheme sf_sfclay_physics==7 - - -package noahucmscheme sf_urban_physics==1 - state:trb_urb4,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d -package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep +package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package bep_bemscheme sf_urban_physics==3 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - - -package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag +package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1 package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old package ysuscheme bl_pbl_physics==1 - - @@ -1650,11 +1720,11 @@ package dfi_bck dfi_stage==1 - - package dfi_fwd dfi_stage==2 - - package dfi_fst dfi_stage==3 - - -#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt +#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG +package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad ifdef RUC_CLOUD package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qni_gc endif @@ -1780,6 +1850,7 @@ period PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old period PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old period PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1 +period PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht period PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2 period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy,ustm @@ -1817,8 +1888,6 @@ typedef fdob_type logical NUDGE_T_PBL # Flag for temperature nudging within the typedef fdob_type logical NUDGE_Q_PBL # Flag for moisture nudging within the PBL typedef fdob_type real SFCFACT # scale factor applied to time window for surface obs typedef fdob_type real SFCFACR # scale factor applied to horiz radius of influence for surface obs -typedef fdob_type real LML_OBS_HT1_LEV # base-state model vertical coordinate of LML_OBS_HT1 -typedef fdob_type real LML_OBS_HT2_LEV # base-state model vertical coordinate of LML_OBS_HT2 typedef fdob_type real RINFMN # minimum radius of influence typedef fdob_type real RINFMX # maximum radius of influence typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small @@ -1827,6 +1896,14 @@ typedef fdob_type real DPSMX # max pres change (cb) allowed within inf typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization typedef fdob_type real KNOWN_LAT # Latitude of origin point (i,j)=(1,1) typedef fdob_type real KNOWN_LON # Longitude of origin point (i,j)=(1,1) +typedef fdob_type character SDATE # domain starting date (YYYY-MM-DD_hh:mm:ss) +typedef fdob_type real XTIME_AT_REST # xtime at restart time +typedef fdob_type real VIF_UV(6) # Vertical influence function parameters for wind nudging +typedef fdob_type real VIF_T(6) # Vertical influence function parameters for temperature nudging +typedef fdob_type real VIF_Q(6) # Vertical influence function parameters for moisture nudging +typedef fdob_type real VIF_FULLMIN # Minimum depth through which vert infl fcn remains 1.0 (m) +typedef fdob_type real VIF_RAMPMIN # Minimum depth through which vif decreases 1.0 to 0.0 (m) +typedef fdob_type real VIF_MAX # Maximum depth in which vif is nonzero (m) # table entries are of the form #
@@ -1846,6 +1923,7 @@ typedef fdob_type real latprt [ - 1 - typedef fdob_type real lonprt [ - 1 - - "lonprt" "obs longitude for diagnostic printout" typedef fdob_type real mlatprt [ - 1 - - "mlatprt" "model latitude at obs location" typedef fdob_type real mlonprt [ - 1 - - "mlonprt" "model longitude at obs location" +typedef fdob_type real base_state k - 1 - - "base_state" "base-state height on half (mass) levels" "meters" state fdob_type fdob - - @@ -1886,4 +1964,5 @@ xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy ## include registry.fire +include registry.avgflx diff --git a/wrfv2_fire/Registry/Registry.NMM b/wrfv2_fire/Registry/Registry.NMM index 62d1ad49..acff6b34 100644 --- a/wrfv2_fire/Registry/Registry.NMM +++ b/wrfv2_fire/Registry/Registry.NMM @@ -43,9 +43,48 @@ include registry.dimspec #### 7. Edit the Registry file and create the state data assocaited with this #### solver. Single entry: -state real x ikj dyn_exp 2 - ih "TOYVAR" +state real x ikj dyn_exp 2 - irh "TOYVAR" #### +############# +rconfig integer ntracers namelist,physics 1 4 - + +# option 1 +#dimspec ntracevars - constant=4 c number of 4d tracer variables +#state real - ijk{ntracevars}f tracers 1 - - - - +#state real t1 ijk{ntracevars}f tracers 1 - r - - +#state real t2 ijk{ntracevars}f tracers 1 - r - - +#state real t3 ijk{ntracevars}f tracers 1 - r - - +#state real t4 ijk{ntracevars}f tracers 1 - r - - +#package tracer_option_1 ntracers==4 - tracers:t1,t2,t3,t4 + +# option 2 +state real - ijkf szj 1 - - - - +state real szj1 ijkf szj 1 - rh "szj1" "szj" "units" +state real szj2 ijkf szj 1 - rh "szj2" "szj" "units" +state real szj3 ijkf szj 1 - rh "szj3" "szj" "units" +state real szj4 ijkf szj 1 - rh "szj4" "szj" "units" + +state real - ijkf s1z 1 - - - - +state real s1z1 ijkf s1z 1 - rh "s1z1" "s1z" "units" +state real s1z2 ijkf s1z 1 - rh "s1z2" "s1z" "units" +state real s1z3 ijkf s1z 1 - rh "s1z3" "s1z" "units" +state real s1z4 ijkf s1z 1 - rh "s1z4" "s1z" "units" + +state real - ijkf spz 1 - - - - +state real spz1 ijkf spz 1 - rh "spz1" "spz" "units" +state real spz2 ijkf spz 1 - rh "spz2" "spz" "units" +state real spz3 ijkf spz 1 - rh "spz3" "spz" "units" +state real spz4 ijkf spz 1 - rh "spz4" "spz" "units" + +state real - ijkf tcs 1 - - - - +state real tcs1 ijkf tcs 1 - rh "tcs1" "tcs" "units" +state real tcs2 ijkf tcs 1 - rh "tcs2" "tcs" "units" +state real tcs3 ijkf tcs 1 - rh "tcs3" "tcs" "units" +state real tcs4 ijkf tcs 1 - rh "tcs4" "tcs" "units" + +package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3,s1z4;spz:spz1,spz2,spz3,spz4;tcs:tcs1,tcs2,tcs3,tcs4 + ################################################################################ ################################################################################ ################################################################################ @@ -72,7 +111,7 @@ state real soilcat ij misc 1 - i12 "SOILCA state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" -state real XICE_gc ij misc 1 - i01r "SEAICE" "SEA ICE" "" +state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" @@ -99,9 +138,20 @@ state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M # # pdb is only 2d but registry doesn't support 2d bdy arrays right now... +state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " +state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " +state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " +state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" + # flag for nest movement state logical moved - misc 1 - - +state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" +state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" +# For random number in SAS convection in HWRF + +state real store_rand ij dyn_nmm 1 - rh "RANDOM" "RANDOM NUMBER FOR SAS" + # # module_MASKS # @@ -252,6 +302,7 @@ state integer lvl ij dyn_nmm 1 - ir # module_CLDWTR.F # state real cwm ijkb dyn_nmm 1 - rh "CWM" "Total condensate" "kg kg-1" +state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" state real f_ice ikj dyn_nmm 1 - rh "F_ICE" "Frozen fraction of CWM" "" state real f_rain ikj dyn_nmm 1 - rh "F_RAIN" "Rain fraction of liquid part of CWM" "" state real f_rimef ikj dyn_nmm 1 - rh "F_RIMEF" "Rime factor" "" @@ -272,7 +323,7 @@ state real cmc ij dyn_nmm 1 - i01rh "CMC" "Canopy state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" state real pctsno ij dyn_nmm 1 - irh state real soiltb ij dyn_nmm 1 - i01rh "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i01rh "VEGFRC" "Vegetation fraction" "" +state real vegfrc ij dyn_nmm 1 - i014rh "VEGFRC" "Vegetation fraction" "" state real shdmin ij dyn_nmm 1 - - state real shdmax ij dyn_nmm 1 - - state real sh2o ilj dyn_nmm 1 Z irh "SH2O" "Unfrozen soil moisture volume fraction" "" @@ -461,15 +512,15 @@ state real soilcbot isj misc 1 Z - "" #------------------------------------------------------------------------------------------------------------------------------- # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -487,6 +538,8 @@ state real qr ijkft moist 1 - rh "QRAI state real qi ijkft moist 1 - rh "QICE" "Ice mixing ratio" "kg kg-1" state real qs ijkft moist 1 - rh "QSNOW" "Snow mixing ratio" "kg kg-1" state real qg ijkft moist 1 - rh "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qh ijkft moist 1 - rh "QHAIL" "Hail mixing ratio" "kg kg-1" + # # Other Scalars state real - ijkftb scalar 1 - - - @@ -494,6 +547,8 @@ state real qni ijkftb scalar 1 - i01rusdf=(bdy state real qns ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNS" "Snow Number concentration" "# kg(-1)" state real qnr ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNR" "Rain Number concentration" "# kg(-1)" state real qng ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNG" "Graupel Number concentration" "# kg(-1)" +state real qnh ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNHAIL" "Hail Number concentration" "# kg(-1)" + state real qnn ikjftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ikjftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" @@ -585,10 +640,10 @@ state real SFCRUNOFF ij misc 1 - rh "SF state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" state integer IVGTYP ij misc 1 - irh "IVGTYP" "VEGETATION TYPE" "" state integer ISLTYP ij misc 1 - irh "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i01rh "VEGFRA" "VEGETATION FRACTION" "" +state real VEGFRA ij misc 1 - i014rh "VEGFRA" "VEGETATION FRACTION" "" state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" -state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "NA" +state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "" @@ -596,7 +651,7 @@ state real ACSNOM ij misc 1 - irh "A state real RMOL ij misc 1 - ir "RMOL" "" "" state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "" state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state real SST ij misc 1 - i01rh "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i014rh "SST" "SEA SURFACE TEMPERATURE" "K" state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" @@ -615,6 +670,7 @@ state real FLQC ij misc 1 - r "F state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" # added as state for HALO_NMM_MG2, mep @@ -797,6 +853,8 @@ rconfig real p_top_requested namelist,domains 1 5000 # Physics rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" +rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" @@ -827,11 +885,12 @@ rconfig integer mp_zero_out namelist,physics 1 0 rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" -rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" # nmm variables rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" @@ -892,7 +951,9 @@ rconfig real tke_upper_bound namelist,dynamics max_domains 1000. rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" - +rconfig logical euler_adv namelist,dynamics 1 .false. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" +rconfig integer idtadt namelist,dynamics 1 1 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" +rconfig integer idtadc namelist,dynamics 1 1 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" # Bdy_control rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" @@ -965,15 +1026,18 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr package thompson07 mp_physics==98 - moist:qv,qc,qr,qi,qs,qg;scalar:qni +package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs package rrtmscheme ra_lw_physics==1 - - package camlwscheme ra_lw_physics==3 - - package rrtmg_lwscheme ra_lw_physics==4 - - package gfdllwscheme ra_lw_physics==99 - - +package hwrflwscheme ra_lw_physics==98 package heldsuarez ra_lw_physics==31 - - package swradscheme ra_sw_physics==1 - - @@ -981,6 +1045,7 @@ package gsfcswscheme ra_sw_physics==2 - - package camswscheme ra_sw_physics==3 - - package rrtmg_swscheme ra_sw_physics==4 - - package gfdlswscheme ra_sw_physics==99 - - +package hwrfswscheme ra_sw_physics==98 package sfclayscheme sf_sfclay_physics==1 - - package myjsfcscheme sf_sfclay_physics==2 - - @@ -1097,3 +1162,6 @@ halo HALO_NMM_MG3 dyn_nmm 8:p_gc halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt +halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 +halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt +halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs diff --git a/wrfv2_fire/Registry/Registry.NMM_CHEM b/wrfv2_fire/Registry/Registry.NMM_CHEM index 20fcab9d..49aa74d6 100755 --- a/wrfv2_fire/Registry/Registry.NMM_CHEM +++ b/wrfv2_fire/Registry/Registry.NMM_CHEM @@ -41,11 +41,6 @@ include registry.dimspec -#### 7. Edit the Registry file and create the state data assocaited with this -#### solver. Single entry: -state real x ijk dyn_exp 2 - ih "TOYVAR" -#### - ################################################################################ ################################################################################ ################################################################################ @@ -71,7 +66,7 @@ state real vegcat ij misc 1 - i12 "VEGCAT state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" -state real XICE_gc ij misc 1 - i01r "SEAICE" "SEA ICE" "" +state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" @@ -98,14 +93,93 @@ state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M # # pdb is only 2d but registry doesn't support 2d bdy arrays right now... +# The following arrays were added to avoid using _b and _bt arrays for nesting. +# This is gopal' doing: + +state integer nrnd1 z dyn_nmm 1 - r "NRND1" + +#for HWRF: zhang's doing: added a 'r' at end to store these variables in restart file +state real pdnest_b ij dyn_nmm 1 - r +state real pdnest_bt ij dyn_nmm 1 - r +state real tnest_b ijk dyn_nmm 1 - r +state real tnest_bt ijk dyn_nmm 1 - r +state real qnest_b ijk dyn_nmm 1 - r +state real qnest_bt ijk dyn_nmm 1 - r +state real unest_b ijk dyn_nmm 1 - r +state real unest_bt ijk dyn_nmm 1 - r +state real vnest_b ijk dyn_nmm 1 - r +state real vnest_bt ijk dyn_nmm 1 - r +state real q2nest_b ijk dyn_nmm 1 - r +state real q2nest_bt ijk dyn_nmm 1 - r +state real cwmnest_b ijk dyn_nmm 1 - r +state real cwmnest_bt ijk dyn_nmm 1 - r + +# +# For the moving nest. This is gopal's doing +# + +state real pdyn ij dyn_nmm 1 - r "PDYN" "DYNAMIC PRESSURE USED FOR TRACKING GRID MOTION" +state real mslp ij dyn_nmm 1 - r "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" +state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" +state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" +state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" +state logical mvnest - dyn_nmm 1 - rm "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" +#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart +state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " +state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " +state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " +state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" + +#for HWRF: # flag for nest movement -state logical moved - misc 1 - - +state logical moved - misc 1 - r + +state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" +state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" +# For random number in SAS convection in HWRF + +state real store_rand ij dyn_nmm 1 - rh "RANDOM" "RANDOM NUMBER FOR SAS" + +# Location of the SOUTH-WEST nested pointed in terms of parent grid + +state integer IIH ij dyn_nmm 1 - r +state integer JJH ij dyn_nmm 1 - r +state integer IIV ij dyn_nmm 1 - r +state integer JJV ij dyn_nmm 1 - r + +# Bi-linear weights + +state real HBWGT1 ij dyn_nmm 1 - r +state real HBWGT2 ij dyn_nmm 1 - r +state real HBWGT3 ij dyn_nmm 1 - r +state real HBWGT4 ij dyn_nmm 1 - r +state real VBWGT1 ij dyn_nmm 1 - r +state real VBWGT2 ij dyn_nmm 1 - r +state real VBWGT3 ij dyn_nmm 1 - r +state real VBWGT4 ij dyn_nmm 1 - r +#end of HWRF: # -# module_LOOPS +state real HLON ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) +state real HLAT ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) +state real VLON ij dyn_nmm 1 - irh +state real VLAT ij dyn_nmm 1 - irh + # -state integer lmh ij dyn_nmm 1 - irh "LMH" "Lowest model layer at mass points from domain top" "" -state integer lmv ij dyn_nmm 1 - irh "LMV" "Lowest model layer at velocity points from domain top" "" +rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain" +rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain" +#for HWRF: +rconfig logical analysis namelist,time_control max_domains .false. irh "days" "analysis control for the nested domain" + +state real PSTD k dyn_nmm 1 Z r +state integer KZMAX - dyn_nmm - - r +state real Z3D ijk dyn_nmm 1 Z rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Z3D" "HEIGHT ARRAY FIELD VALID FOR PARENT ONLY" +state real T3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS" +state real Q3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS" +#end of HWRF: + +state real HRES_FIS ij dyn_nmm 1 - r "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" + # # module_MASKS # @@ -113,25 +187,23 @@ state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Heig state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 - i01rh "SM" "Sea mask; =1 for sea, =0 for land" "" -state real sice ij dyn_nmm 1 - irh "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" -state real htm ijk dyn_nmm 1 - r "HTM" "Height mask; =1 at all mass points above ground" "" -state real vtm ijk dyn_nmm 1 - r "VTM" "Velocity mask; =1 at all velocity points above ground" "" +state real sm ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sice ij dyn_nmm 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" # # module_VRBLS # -state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" -state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" -state real pd ijb dyn_nmm 1 - i01rh "PD" "Mass at I,J in the sigma domain" "Pa" -state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" -state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" -state real t ijkb dyn_nmm 1 - i01rh "T" "Sensible temperature" "K" -state real q ijkb dyn_nmm 1 - i01rh "Q" "Specific humidity" "kg kg-1" -state real u ijkb dyn_nmm 1 - i01rh "U" "U component of wind" "m s-1" -state real v ijkb dyn_nmm 1 - i01rh "V" "V component of wind" "m s-1" -state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" -state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" -state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" +state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" +state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" +state real pd ijb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_mass_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,HRES_FIS,SM,PDTOP,PT,PSTD,KZMAX)f=(nmm_bdymass_hinterp:pdnest_b,pdnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,HRES_FIS,SM,PDTOP,PT,PSTD,KZMAX) "PD" "Mass at I,J in the sigma domain" "Pa" +state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" +state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" +state real t ijkb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_scalar_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,T3D,PD,PSTD,PDTOP,PT,ETA1,ETA2)f=(nmm_bdy_scalar:dt,tnest_b,tnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,T3d,PD,PSTD,PDTOP,PT,ETA1,ETA2) "T" "Sensible temperature" "K" +state real q ijkb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_scalar_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Q3D,PD,PSTD,PDTOP,PT,ETA1,ETA2)f=(nmm_bdy_scalar:dt,qnest_b,qnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Q3d,PD,PSTD,PDTOP,PT,ETA1,ETA2) "Q" "Specific humidity" "kg kg-1" +state real u ijkb dyn_nmm 1 - i01rhu=(nmm_vfeedback:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)d=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)f=(nmm_bdy_vinterp:unest_b,unest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "U" "U component of wind" "m s-1" +state real v ijkb dyn_nmm 1 - i01rhu=(nmm_vfeedback:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)d=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)f=(nmm_bdy_vinterp:vnest_b,vnest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "V" "V component of wind" "m s-1" +state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" +state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" +state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" # # module_DYNAM # @@ -151,17 +223,19 @@ state real aeta k dyn_nmm 1 - i01r state real f4q2 k dyn_nmm 1 - ir state real etax k dyn_nmm 1 - i01r state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01r "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01r "AETA1" "Midlayer sigma value in pressure domain" "" +state real deta1 k dyn_nmm 1 - i01rh "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01rh "AETA1" "Midlayer sigma value in pressure domain" "" state real eta1 k dyn_nmm 1 Z i01rh "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01r "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01r "AETA2" "Midlayer sigma value in sigma domain" "" +state real deta2 k dyn_nmm 1 - i01rh "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01rh "AETA2" "Midlayer sigma value in sigma domain" "" state real eta2 k dyn_nmm 1 Z i01rh "ETA2" "Interface sigma value in sigma domain" "" state real em q dyn_nmm 1 - ir state real emt q dyn_nmm 1 - ir -state real adt ij dyn_nmm 1 - - "ADT" "Change of T due to advection" "K" -state real adu ij dyn_nmm 1 - - "ADU" "Change of U due to advection" "m s-1" -state real adv ij dyn_nmm 1 - - "ADV" "Change of V due to advection" "m s-1" +#for HWRF: add to restart +state real adt ij dyn_nmm 1 - r "ADT" "Change of T due to advection" "K" +state real adu ij dyn_nmm 1 - r "ADU" "Change of U due to advection" "m s-1" +state real adv ij dyn_nmm 1 - r "ADV" "Change of V due to advection" "m s-1" +#end HWRF: state real em_loc q dyn_nmm 1 - r state real emt_loc q dyn_nmm 1 - r state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" @@ -172,59 +246,66 @@ state real f4d - dyn_nmm - - ir state real f4q - dyn_nmm - - ir state real ef4t - dyn_nmm - - ir state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" -state real dlmd - dyn_nmm - - ir "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - ir "DPHD" "North-south angular distance H-to-V points" "degrees" +#end HWRF: +state real dlmd - dyn_nmm - - irh "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - irh "DPHD" "North-south angular distance H-to-V points" "degrees" state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" # # module_CONTIN # -state real pdsl ij dyn_nmm 1 - - "PDSL" "Sigma-domain pressure at sigma=1" "Pa" -state real pdslo ij dyn_nmm 1 - - "PDSLO" "PDSL from previous timestep" "Pa" +#for HWRF: add to restart +state real pdsl ij dyn_nmm 1 - r "PDSL" "Sigma-domain pressure at sigma=1" "Pa" +state real pdslo ij dyn_nmm 1 - r "PDSLO" "PDSL from previous timestep" "Pa" +#end HWRF: state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" state real div ijk dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" -state real few ijk dyn_nmm 1 - - "FEW" "Integrated east-west mass flux" "Pa m2 s-1" -state real fne ijk dyn_nmm 1 - - "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" -state real fns ijk dyn_nmm 1 - - "FNS" "Integrated north-south mass flux" "Pa m2 s-1" -state real fse ijk dyn_nmm 1 - - "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +#for HWRF: add to restart +state real few ijk dyn_nmm 1 - r "FEW" "Integrated east-west mass flux" "Pa m2 s-1" +state real fne ijk dyn_nmm 1 - r "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" +state real fns ijk dyn_nmm 1 - r "FNS" "Integrated north-south mass flux" "Pa m2 s-1" +state real fse ijk dyn_nmm 1 - r "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +#end HWRF: state real omgalf ijk dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" -state real petdt ijk dyn_nmm 1 - - "PETDT" "Vertical mass flux" "Pa s-1" +#for HWRF: add to restart +state real petdt ijk dyn_nmm 1 - r "PETDT" "Vertical mass flux" "Pa s-1" +#end HWRF: state real rtop ijk dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" # # module_PVRBLS # state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" -state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" -state real ustar ij dyn_nmm 1 - irh "USTAR" "Friction velocity" "m s-1" -state real z0 ij dyn_nmm 1 - i01rh "Z0" "Roughness height" "m" +state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" +state real ustar ij dyn_nmm 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "USTAR" "Friction velocity" "m s-1" +state real z0 ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Z0" "Roughness height" "m" state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" -state real ths ij dyn_nmm 1 - irh "THS" "Surface potential temperature" "K" -state real mavail ij dyn_nmm 1 - irh -state real qsh ij dyn_nmm 1 - irh "QS" "Surface specific humidity" "kg kg-1" +state real ths ij dyn_nmm 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "THS" "Surface potential temperature" "K" +state real mavail ij dyn_nmm 1 - i +state real qsh ij dyn_nmm 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QS" "Surface specific humidity" "kg kg-1" state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" state real taux ij dyn_nmm 1 - irh "TAUX" "Instantaneous stress along X direction in KG/M/S^2" state real tauy ij dyn_nmm 1 - irh "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" state real aprec ij dyn_nmm 1 - rh -state real acprec ij dyn_nmm 1 - rh "ACPREC" "Accumulated total precipitation" "m" +state real acprec ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ACPREC" "Accumulated total precipitation" "m" state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" state real accliq ij dyn_nmm 1 - r state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water snow amount" "m" state real si ij dyn_nmm 1 - irh "SI" "Snow depth" "m" -state real cldefi ij dyn_nmm 1 - rh "CLDEFI" "Convective cloud efficiency" "" +state real cldefi ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CLDEFI" "Convective cloud efficiency" "" state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" state real rf ij dyn_nmm 1 - r -state real th10 ij dyn_nmm 1 - rh "TH10" "10-m potential temperature" "K" -state real q10 ij dyn_nmm 1 - rh "Q10" "10-m specific humidity" "kg kg-1" -state real pshltr ij dyn_nmm 1 - rh "PSHLTR" "2-m pressure" "Pa" -state real tshltr ij dyn_nmm 1 - rh "TSHLTR" "2-m sensible temperature" "K" -state real qshltr ij dyn_nmm 1 - rh "QSHLTR" "2-m specific humidity" "kg kg-1" -state real q2 ijkb dyn_nmm 1 - irh "Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real t_adj ijk dyn_nmm 1 - r "T_ADJ" "T change due to precip in phys step" "K" +state real th10 ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TH10" "10-m potential temperature from MYJ" "K" +state real q10 ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Q10" "10-m specific humidity from MYJ" "kg kg-1" +state real pshltr ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "PSHLTR" "2-m pressure from MYJ" "Pa" +state real tshltr ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TSHLTR" "2-m potential temperature from MYJ" "K" +state real qshltr ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QSHLTR" "2-m specific humidity from MYJ" "kg kg-1" +state real q2 ijkb dyn_nmm 1 - irhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:q2nest_b,q2nest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Q2" "2 * Turbulence kinetic energy" "m2 s-2" +state real t_adj ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "T_ADJ" "T change due to precip in phys step" "K" state real t_old ijk dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" state real zero_3d ijk dyn_nmm 1 - r state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" @@ -233,7 +314,7 @@ state real AKMS_OUT ij dyn_nmm 1 - rh "AKMS_OUT" "Output # # module_PHYS # -state real albase ij dyn_nmm 1 - i01rh "ALBASE" "Base albedo" "" +state real albase ij dyn_nmm 1 - i01rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ALBASE" "Base albedo" "" state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" @@ -244,46 +325,47 @@ state real epsr ij dyn_nmm 1 - irh "EPSR" "Radiati state real gffc ij dyn_nmm 1 - ir state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" -state real NMM_TSK ij dyn_nmm 1 - i01r "TSK" "Skin temperature" "K" +state real NMM_TSK ij dyn_nmm 1 - i01rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TSK" "Skin temperature" "K" state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" -state real mxsnal ij dyn_nmm 1 - i01rh "MXSNAL" "Maximum deep snow albedo" "" -state real radin ij dyn_nmm 1 - r +state real mxsnal ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "MXSNAL" "Maximum deep snow albedo" "" +state real radin ij dyn_nmm 1 - r state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" -state real sigt4 ij dyn_nmm 1 - rh "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" -state real tg ij dyn_nmm 1 - i01rh "TGROUND" "Deep ground soil temperature" "K" +state real sigt4 ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" +state real tg ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TGROUND" "Deep ground soil temperature" "K" state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" state integer lvl ij dyn_nmm 1 - ir # # module_CLDWTR.F # -state real cwm ijkb dyn_nmm 1 - rh "CWM" "Total condensate" "kg kg-1" -state real f_ice ikj dyn_nmm 1 - rh "F_ICE" "Frozen fraction of CWM" "" -state real f_rain ikj dyn_nmm 1 - rh "F_RAIN" "Rain fraction of liquid part of CWM" "" -state real f_rimef ikj dyn_nmm 1 - rh "F_RIMEF" "Rime factor" "" -state real cldfra ijk misc 1 - rh "CLDFRA" "Cloud fraction" "" +state real cwm ijkb dyn_nmm 1 - rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:cwmnest_b,cwmnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CWM" "Total condensate" "kg kg-1" +state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" +state real f_ice ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_ICE" "Frozen fraction of CWM" "" +state real f_rain ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RAIN" "Rain fraction of liquid part of CWM" "" +state real f_rimef ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RIMEF" "Rime factor" "" +state real cldfra ijk dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" -state real cfrach ij dyn_nmm 1 - rh "CFRACH" "High cloud fraction" "" -state real cfracl ij dyn_nmm 1 - rh "CFRACL" "Low cloud fraction" "" -state real cfracm ij dyn_nmm 1 - rh "CFRACM" "Middle cloud fraction" "" +state real cfrach ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CFRACH" "High cloud fraction" "" +state real cfracl ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CFRACL" "Low cloud fraction" "" +state real cfracm ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CFRACM" "Middle cloud fraction" "" state logical micro_start - dyn_nmm - - - # # module_SOIL.F # -state integer islope ij dyn_nmm 1 - i01rh +state integer islope ij dyn_nmm 1 - i01rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLOPE" state real dzsoil k dyn_nmm 1 - irh "DZSOIL" "Thickness of soil layers" "m" state real rtdpth k dyn_nmm 1 - i01r state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Depths of centers of soil layers" "m" -state real cmc ij dyn_nmm 1 - i01rh "CMC" "Canopy moisture" "m" +state real cmc ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CMC" "Canopy moisture" "m" state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" state real pctsno ij dyn_nmm 1 - irh -state real soiltb ij dyn_nmm 1 - i01rh "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i01rh "VEGFRC" "Vegetation fraction" "" +state real soiltb ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SOILTB" "Deep ground soil temperature" "K" +state real vegfrc ij dyn_nmm 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRC" "Vegetation fraction" "" state real shdmin ij dyn_nmm 1 - - state real shdmax ij dyn_nmm 1 - - -state real sh2o ilj dyn_nmm 1 Z irh "SH2O" "Unfrozen soil moisture volume fraction" "" -state real smc ilj dyn_nmm 1 Z irh "SMC" "Soil moisture volume fraction" "" -state real stc ilj dyn_nmm 1 Z irh "STC" "Soil temperature" "K" +state real sh2o ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SH2O" "Unfrozen soil moisture volume fraction" "" +state real smc ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SMC" "Soil moisture volume fraction" "" +state real stc ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "STC" "Soil temperature" "K" # # module_GWD.F # @@ -311,9 +393,9 @@ state real VGWDsfc ij dyn_nmm 1 - h "VGWDsfc" "Surface state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" -state real dwdt ijk dyn_nmm 1 - r "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z rh "PINT" "Model layer interface pressure" "Pa" +state real dwdt ijk dyn_nmm 1 - rd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" +state real pdwdt ijk dyn_nmm 1 - r +state real pint ijk dyn_nmm 1 Z irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "PINT" "Model layer interface pressure" "Pa" state real w ijk dyn_nmm 1 Z rh "W" "Vertical velocity" "m s-1" state real z ijk dyn_nmm 1 Z - "Z" "Distance from ground" "m" # @@ -323,16 +405,18 @@ state real acfrcv ij dyn_nmm 1 - rh "ACFRCV" "Accum con state real acfrst ij dyn_nmm 1 - rh "ACFRST" "Accum stratiform cloud fraction" "" state real ssroff ij dyn_nmm 1 - rh "SSROFF" "Surface runoff" "mm" state real bgroff ij dyn_nmm 1 - rh "BGROFF" "Subsurface runoff" "mm" -state real rlwin ij dyn_nmm 1 - rh "RLWIN" "Downward longwave at surface" "W m-2" +state real rlwin ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RLWIN" "Downward longwave at surface" "W m-2" state real rlwout ij dyn_nmm 1 - - state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" state real alwin ij dyn_nmm 1 - rh "ALWIN" "Accum LW down at surface" "W m-2" state real alwout ij dyn_nmm 1 - rh "ALWOUT" "Accum RADOT (see above)" "W m-2" state real alwtoa ij dyn_nmm 1 - rh "ALWTOA" "Accum RLWTOA" "W m-2" -state real rswin ij dyn_nmm 1 - rh "RSWIN" "Downward shortwave at surface" "W m-2" +state real rswin ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWIN" "Downward shortwave at surface" "W m-2" state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" -state real rswtoa ij dyn_nmm 1 - - "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +#for HWRF: add to restart +state real rswtoa ij dyn_nmm 1 - r "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +#end HWRF state real aswin ij dyn_nmm 1 - rh "ASWIN" "Accum SW down at surface" "W m-2" state real aswout ij dyn_nmm 1 - rh "ASWOUT" "Accum RSWOUT" "W m-2" state real aswtoa ij dyn_nmm 1 - rh "ASWTOA" "Accum RSWTOA" "W m-2" @@ -349,13 +433,16 @@ state real t02_min ij dyn_nmm 1 - rh "T02_MIN" "Hourly Min state real t02_max ij dyn_nmm 1 - rh "T02_MAX" "Hourly Max Shelter Temperature" "K" state real rh02_min ij dyn_nmm 1 - rh "RH02_MIN" "Hourly Min Relative Humidity" "" state real rh02_max ij dyn_nmm 1 - rh "RH02_MAX" "Hourly Max Relative Humidity" "" -state real rlwtt ijk dyn_nmm 1 - r "RLWTT" "Longwave temperature tendency" "K s-1" -state real rswtt ijk dyn_nmm 1 - r "RSWTT" "Shortwave temperature tendency" "K s-1" -state real tcucn ijk dyn_nmm 1 - - "TCUCN" "Accum convec temperature tendency" "K s-1" -state real train ijk dyn_nmm 1 - - "TRAIN" "Accum stratiform temp tendency" "K s-1" +state real rlwtt ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RLWTT" "Longwave temperature tendency" "K s-1" +state real rswtt ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWTT" "Shortwave temperature tendency" "K s-1" +#for HWRF: add to restart +state real tcucn ijk dyn_nmm 1 - r "TCUCN" "Accum convec temperature tendency" "K s-1" +state real train ijk dyn_nmm 1 - r "TRAIN" "Accum stratiform temp tendency" "K s-1" +#end HWRF state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" state integer nphs0 - dyn_nmm - - rh +state integer ncnvc0 - dyn_nmm - - rh state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" @@ -384,7 +471,6 @@ state integer ihwg q dyn_nmm 1 - - state integer iveg q dyn_nmm 1 - - state integer ivwg q dyn_nmm 1 - - state integer iradg r dyn_nmm 1 - - -state integer indx3_wrk zqn dyn_nmm 1 - - "INDX3_WRK" "Array of 3rd (J) indices for local arrays" "" state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" @@ -449,7 +535,7 @@ state real soilt020 ij misc 1 - i1 "SOIL state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" -state real landmask ij misc 1 - i01rh "LANDMASK" "description" "units" +state real landmask ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "LANDMASK" "description" "units" state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" @@ -457,7 +543,7 @@ state real greenmax ij misc 1 - i1 "GREE state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" -state real toposoil ij misc 1 - i1 "SOILHGT" "description" "units" +state real toposoil ij misc 1 - i1d=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SOILHGT" "description" "units" state real landusef iuj misc 1 Z - "LANDUSEF" "description" "units" state real soilctop isj misc 1 Z - "SOILCTOP" "description" "units" state real soilcbot isj misc 1 Z - "SOILCBOT" "description" "units" @@ -467,15 +553,15 @@ state real soilcbot isj misc 1 Z - "SOILC #------------------------------------------------------------------------------------------------------------------------------- # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -487,12 +573,12 @@ state real ts_clw ?! misc - - r "TS # dry code will will still link properly) # state real - ijkft moist 1 - - - -state real qv ijkft moist 1 h rh "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real qc ijkft moist 1 h rh "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real qr ijkft moist 1 h rh "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real qi ijkft moist 1 h rh "QICE" "Ice mixing ratio" "kg kg-1" -state real qs ijkft moist 1 h rh "QSNOW" "Snow mixing ratio" "kg kg-1" -state real qg ijkft moist 1 h rh "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qv ijkft moist 1 - rh "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ijkft moist 1 - rh "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ijkft moist 1 - rh "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ijkft moist 1 - rh "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ijkft moist 1 - rh "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ijkft moist 1 - rh "QGRAUP" "Graupel mixing ratio" "kg kg-1" # # Other Scalars state real - ijkftb scalar 1 - - - @@ -577,21 +663,21 @@ state real RAINCV ij misc 1 - - "" state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" -state real T2 ij misc 1 - irh "T2" "TEMP at 2 M" "" -state real U10 ij misc 1 - irh "U10" "U at 10 M" " " -state real V10 ij misc 1 - irh "V10" "V at 10 M" " " -state real XICE ij misc 1 - i01r "XICE" "SEA ICE" "" +state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" +state real U10 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "U10" "U at 10 M" " " +state real V10 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "V10" "V at 10 M" " " +state real XICE ij misc 1 - i01rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "XICE" "SEA ICE" "" state real LAI ij misc 1 - i0124rh "LAI" "Leaf area index" "area/area" state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" -state integer IVGTYP ij misc 1 - irh "IVGTYP" "VEGETATION TYPE" "" -state integer ISLTYP ij misc 1 - irh "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i01rh "VEGFRA" "VEGETATION FRACTION" "" +state integer IVGTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "IVGTYP" "VEGETATION TYPE" "" +state integer ISLTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLTYP" "SOIL TYPE" " " +state real VEGFRA ij misc 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRA" "VEGETATION FRACTION" "" state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" -state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "NA" +state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "" @@ -599,25 +685,26 @@ state real ACSNOM ij misc 1 - irh "A state real RMOL ij misc 1 - irh "RMOL" "" "" state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "" state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state real SST ij misc 1 - i01rh "SST" "SEA SURFACE TEMPERATURE" "K" -state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" -state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" +state real SST ij misc 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SST" "SEA SURFACE TEMPERATURE" "K" +state real WEASD ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" +state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" state real NOAHRES ij misc 1 - rh "NOAHRES" "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}" -state real tke_myj ijk misc 1 - r "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real tke_myj ijk misc 1 - ir "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" state real EL_MYJ ikj misc 1 - - "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" state real EXCH_H ikj misc 1 - r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" state real EXCH_M ikj misc 1 - r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" -state real THZ0 ij misc 1 - irh "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" -state real QZ0 ij misc 1 - irh "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" -state real UZ0 ij misc 1 - irh "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real VZ0 ij misc 1 - irh "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real THZ0 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" +state real QZ0 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" +state real UZ0 ij misc 1 - irhd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real VZ0 ij misc 1 - irhd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" # added as state for HALO_NMM_MG2, mep @@ -631,19 +718,16 @@ state real dvdt ijk misc 1 - - state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" -i1 real TSHLTR ij misc 1 - - "TSHLTR" "SHELTER THETA FROM MYJ" "K" -i1 real QSHLTR ij misc 1 - - "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" -i1 real TH10 ij misc 1 - - "TH10" "10-M THETA FROM MYJ" "K" -i1 real Q10 ij misc 1 - - "Q10" "10-M SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" -state real HTOP ij misc 1 - irh "HTOP" "TOP OF CONVECTION LEVEL" "" -state real HBOT ij misc 1 - irh "HBOT" "BOT OF CONVECTION LEVEL" "" -state real HTOPR ij misc 1 - irh "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" -state real HBOTR ij misc 1 - irh "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" +state real HTOP ij misc 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" -state REAL CUPPT ij misc 1 - rh "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" +state REAL CUPPT ij misc 1 - rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" @@ -678,8 +762,8 @@ state real GD_CLOUD2 ijk misc 1 - rh "G # time averaged stuff state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME" "K/sec" state real RQVFTEN ikj misc 1 - r "RQVFTEN" "MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME" "kg/sec" -state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index) "SNOWH" "PHYSICAL SNOW DEPTH" "" -state real RHOSN ij misc 1 - i01rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real SNOWH ij misc 1 - i01rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SNOWH" "PHYSICAL SNOW DEPTH" "" +state real RHOSN ij misc 1 - i01rd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RHOSN" " SNOW DENSITY" "kg m-3" state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" @@ -703,10 +787,11 @@ state real lu_state p misc - - - state integer number_at_same_level - - - - - "number_at_same_level" "" "" # State for derived time quantities. -state integer itimestep - - - - h "itimestep" "" "" +#for HWRF: add to restart +state integer itimestep - - - - rh "itimestep" "" "" state real xtime - - - - h "xtime" "minutes since simulation start" "" -state real julian - - - - - "julian" "day of year" "" - +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + # input file descriptor for lbcs on parent domain had2chem_tim=had2chem_tim+timef()-btimx state integer lbc_fid - - - - - "lbc_fid" "" "" @@ -718,6 +803,12 @@ state logical patched - - - - - "pa # indicates whether to read input from file or generate #state logical input_from_file - - - - - "input_from_file" "" "" +# vortex center indices; need for restarts of moving nests +state real xi - misc - - r +state real xj - misc - - r +state real vc_i - misc - - r +state real vc_j - misc - - r + ###### # # Variables that are set at run-time to control configuration (namelist-settable) @@ -749,20 +840,24 @@ rconfig integer fine_input_stream namelist,time_control max_doma include registry.io_boilerplate include registry.chem -rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" -rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" -rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +#for HWRF: added a 'r' for restart +rconfig integer JULYR namelist,time_control max_domains 0 hr "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 hr "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. hr "GMT" "" "" +#for HWRF: end rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +#for HWRF: +rconfig character anl_outname namelist,time_control max_domains "wrfanl_d_" - "name of analysis outfile" "" "" rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" -rconfig real tstart namelist,time_control max_domains 0 rh "tstart" "forecast hour at the start of the NMM integration" +rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" @@ -803,6 +898,8 @@ rconfig real dt derived max_domains 2. rconfig integer ts_buf_size namelist,domains 1 200 - "ts_buf_size" "Size of time series buffer" rconfig integer max_ts_locs namelist,domains 1 5 - "max_ts_locs" "Maximum number of time series locations" rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer corral_dist namelist,domains max_domains 8 rconfig integer move_id namelist,domains max_moves 0 rconfig integer move_interval namelist,domains max_moves 999999999 rconfig integer move_cd_x namelist,domains max_moves 0 @@ -821,6 +918,10 @@ rconfig real p_top_requested namelist,domains 1 5000 irh # Physics rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +#for HWRF: +rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" +rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" +#end HWRF: rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" @@ -849,12 +950,14 @@ rconfig integer num_soil_cat namelist,physics 1 16 rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" -rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" +rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" rconfig integer sf_urban_physics namelist,physics max_domains 0 h "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM, 2=BEP_UCM" "" rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" # nmm variables @@ -864,13 +967,13 @@ rconfig integer nphs namelist,physics max_domains 10 rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" -rconfig real tprec namelist,physics max_domains 3. rh "tprec" "number of hours in bucket for total precipitation" -rconfig real theat namelist,physics max_domains 6. rh "theat" "number of hours in bucket for gridscale and convective heating rates" -rconfig real tclod namelist,physics max_domains 6. rh "tclod" "number of hours in bucket for cloud amounts" -rconfig real trdsw namelist,physics max_domains 6. rh "trdsw" "number of hours in bucket for short wave fluxes" -rconfig real trdlw namelist,physics max_domains 6. rh "trdlw" "number of hours in bucket for long wave fluxes" -rconfig real tsrfc namelist,physics max_domains 6. rh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" -rconfig logical pcpflg namelist,physics max_domains .false. rh "pcpflg" "logical switch that turns on/off the precipitation assimilation" +rconfig real tprec namelist,physics max_domains 3. irh "tprec" "number of hours in bucket for total precipitation" +rconfig real theat namelist,physics max_domains 6. irh "theat" "number of hours in bucket for gridscale and convective heating rates" +rconfig real tclod namelist,physics max_domains 6. irh "tclod" "number of hours in bucket for cloud amounts" +rconfig real trdsw namelist,physics max_domains 6. irh "trdsw" "number of hours in bucket for short wave fluxes" +rconfig real trdlw namelist,physics max_domains 6. irh "trdlw" "number of hours in bucket for long wave fluxes" +rconfig real tsrfc namelist,physics max_domains 6. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" +rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" rconfig real sfenth namelist,physics max_domains 1.0 irh "sea spray parameter" rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" @@ -884,6 +987,7 @@ rconfig logical cu_rad_feedback namelist,physics max_domains .f rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" rconfig integer movemin namelist,physics max_domains 10 irh "nmm input 12" + # Dynamics # dynamics option (see package definitions, below) rconfig integer dyn_opt namelist,dynamics 1 - @@ -918,6 +1022,9 @@ rconfig real tke_upper_bound namelist,dynamics max_domains 1000. rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" +rconfig logical euler_adv namelist,dynamics 1 .false. irh "euler_adv" "Logical flag to turn on/off Eulerian pasive advection" "" +rconfig integer idtadt namelist,dynamics 1 1 irh "idtadt" "Fundamental timesteps between calls to Eulerian advection for dynamics" "" +rconfig integer idtadc namelist,dynamics 1 1 irh "idtadc" "Fundamental timesteps between calls to Eulerian advection for chemistry" "" # Bdy_control rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" @@ -973,6 +1080,12 @@ rconfig integer isice derived max_domains rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" +#rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" +#rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" +#rconfig integer simulation_start_day derived 1 0 h "simulation_start_day" "start of simulation through restarts" "2-digit day" +#rconfig integer simulation_start_hour derived 1 0 h "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +#rconfig integer simulation_start_minute derived 1 0 h "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +#rconfig integer simulation_start_second derived 1 0 h "simulation_start_second" "start of simulation through restarts" "2-digit second" # # Single dummy declaration to define a nodyn dyn option @@ -997,21 +1110,25 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr package thompson07 mp_physics==98 - moist:qv,qc,qr,qi,qs,qg;scalar:qni +package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs package rrtmscheme ra_lw_physics==1 - - package camlwscheme ra_lw_physics==3 - - package rrtmg_lwscheme ra_lw_physics==4 - - package gfdllwscheme ra_lw_physics==99 - moist:qv,qc,qr,qi +package hwrflwscheme ra_lw_physics==98 package swradscheme ra_sw_physics==1 - - package gsfcswscheme ra_sw_physics==2 - - package camswscheme ra_sw_physics==3 - - package rrtmg_swscheme ra_sw_physics==4 - - package gfdlswscheme ra_sw_physics==99 - - +package hwrfswscheme ra_sw_physics==98 package heldsuarez ra_lw_physics==31 - - package sfclayscheme sf_sfclay_physics==1 - - @@ -1062,11 +1179,10 @@ package io_pnetcdf io_form_restart==11 - - # NMM communications -#halo HALO_NMM_INIT_1 dyn_nmm 120:LMH,LMV,HBM2 halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 -halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE,HTM -halo HALO_NMM_INIT_4 dyn_nmm 120:VTM,DX_NMM,WPDAR +halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE +halo HALO_NMM_INIT_4 dyn_nmm 120:DX_NMM,WPDAR halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT @@ -1106,24 +1222,25 @@ halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD -halo HALO_NMM_A dyn_nmm 24:pd,t,u,v,q,cwm,dwdt,div;24:pint -halo HALO_NMM_A_2 dyn_nmm 24:CHEM +#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) +#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) +halo HALO_NMM_A dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;24:pint halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar halo HALO_NMM_B dyn_nmm 24:div -halo HALO_NMM_C dyn_nmm 8:u,v -halo HALO_NMM_D dyn_nmm 24:pd +halo HALO_NMM_C dyn_nmm 48:u,v +halo HALO_NMM_D dyn_nmm 48:pd halo HALO_NMM_E dyn_nmm 24:petdt halo HALO_NMM_F dyn_nmm 24:t,u,v halo HALO_NMM_F1 dyn_nmm 80:pdslo -halo HALO_NMM_G dyn_nmm 24:u,v;24:z -halo HALO_NMM_H dyn_nmm 24:w,lmh -halo HALO_NMM_I dyn_nmm 48:q,q2,cwm +halo HALO_NMM_G dyn_nmm 48:u,v;24:z +halo HALO_NMM_H dyn_nmm 24:w +halo HALO_NMM_I dyn_nmm 48:q,q2,cwm,rrw halo HALO_NMM_I_2 dyn_nmm 48:CHEM halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm halo HALO_NMM_J_2 dyn_nmm 8:CHEM halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_K dyn_nmm 8:q2;24:t,u,v,q,w,z +halo HALO_NMM_K dyn_nmm 24:q2;24:t,u,v,q,w,z halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 halo HALO_NMM_L_2 dyn_nmm 8:CHEM halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar @@ -1134,3 +1251,14 @@ halo HALO_NMM_MG3 dyn_nmm 8:p_gc halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt +# following halos added for nesting purpose (gopal's doing): + +halo HALO_NMM_ZZ dyn_nmm 8:pdnest_b,unest_b,vnest_b,tnest_b,qnest_b,cwmnest_b,q2nest_b,pdnest_bt,unest_bt,vnest_bt,tnest_bt,qnest_bt,cwmnest_bt,q2nest_bt +halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws +halo HALO_NMM_INTERP_DOWN1 dyn_nmm 120:sm,fis,t,u,v,q,q2,z3d,q3d,t3d,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef +halo HALO_NMM_FORCE_DOWN1 dyn_nmm 120:t,u,v,q,q2,cwm,z3d,q3d,t3d #,qv,qc,qr,qi,qs,qg +halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4 + +halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 +halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt +halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs diff --git a/wrfv2_fire/Registry/Registry.NMM_NEST b/wrfv2_fire/Registry/Registry.NMM_NEST index 3cb4f991..76c508dc 100644 --- a/wrfv2_fire/Registry/Registry.NMM_NEST +++ b/wrfv2_fire/Registry/Registry.NMM_NEST @@ -41,10 +41,44 @@ include registry.dimspec -#### 7. Edit the Registry file and create the state data assocaited with this -#### solver. Single entry: -state real x ikj dyn_exp 2 - ih "TOYVAR" -#### +############# +rconfig integer ntracers namelist,physics 1 4 - + +# option 1 +#dimspec ntracevars - constant=4 c number of 4d tracer variables +#state real - ijk{ntracevars}f tracers 1 - - - - +#state real t1 ijk{ntracevars}f tracers 1 - r - - +#state real t2 ijk{ntracevars}f tracers 1 - r - - +#state real t3 ijk{ntracevars}f tracers 1 - r - - +#state real t4 ijk{ntracevars}f tracers 1 - r - - +#package tracer_option_1 ntracers==4 - tracers:t1,t2,t3,t4 + +# option 2 +state real - ijkf szj 1 - - - - +state real szj1 ijkf szj 1 - rh "szj1" "szj" "units" +state real szj2 ijkf szj 1 - rh "szj2" "szj" "units" +state real szj3 ijkf szj 1 - rh "szj3" "szj" "units" +state real szj4 ijkf szj 1 - rh "szj4" "szj" "units" + +state real - ijkf s1z 1 - - - - +state real s1z1 ijkf s1z 1 - rh "s1z1" "s1z" "units" +state real s1z2 ijkf s1z 1 - rh "s1z2" "s1z" "units" +state real s1z3 ijkf s1z 1 - rh "s1z3" "s1z" "units" +state real s1z4 ijkf s1z 1 - rh "s1z4" "s1z" "units" + +state real - ijkf spz 1 - - - - +state real spz1 ijkf spz 1 - rh "spz1" "spz" "units" +state real spz2 ijkf spz 1 - rh "spz2" "spz" "units" +state real spz3 ijkf spz 1 - rh "spz3" "spz" "units" +state real spz4 ijkf spz 1 - rh "spz4" "spz" "units" + +state real - ijkf tcs 1 - - - - +state real tcs1 ijkf tcs 1 - rh "tcs1" "tcs" "units" +state real tcs2 ijkf tcs 1 - rh "tcs2" "tcs" "units" +state real tcs3 ijkf tcs 1 - rh "tcs3" "tcs" "units" +state real tcs4 ijkf tcs 1 - rh "tcs4" "tcs" "units" + +package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3,s1z4;spz:spz1,spz2,spz3,spz4;tcs:tcs1,tcs2,tcs3,tcs4 ################################################################################ ################################################################################ @@ -72,7 +106,7 @@ state real soilcat ij misc 1 - i12 "SOILCA state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" -state real XICE_gc ij misc 1 - i01r "SEAICE" "SEA ICE" "" +state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" @@ -102,20 +136,23 @@ state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M # The following arrays were added to avoid using _b and _bt arrays for nesting. # This is gopal' doing: -state real pdnest_b ij dyn_nmm 1 - - -state real pdnest_bt ij dyn_nmm 1 - - -state real tnest_b ijk dyn_nmm 1 - - -state real tnest_bt ijk dyn_nmm 1 - - -state real qnest_b ijk dyn_nmm 1 - - -state real qnest_bt ijk dyn_nmm 1 - - -state real unest_b ijk dyn_nmm 1 - - -state real unest_bt ijk dyn_nmm 1 - - -state real vnest_b ijk dyn_nmm 1 - - -state real vnest_bt ijk dyn_nmm 1 - - -state real q2nest_b ijk dyn_nmm 1 - - -state real q2nest_bt ijk dyn_nmm 1 - - -state real cwmnest_b ijk dyn_nmm 1 - - -state real cwmnest_bt ijk dyn_nmm 1 - - +state integer nrnd1 z dyn_nmm 1 - r "NRND1" + +#for HWRF: zhang's doing: added a 'r' at end to store these variables in restart file +state real pdnest_b ij dyn_nmm 1 - r +state real pdnest_bt ij dyn_nmm 1 - r +state real tnest_b ijk dyn_nmm 1 - r +state real tnest_bt ijk dyn_nmm 1 - r +state real qnest_b ijk dyn_nmm 1 - r +state real qnest_bt ijk dyn_nmm 1 - r +state real unest_b ijk dyn_nmm 1 - r +state real unest_bt ijk dyn_nmm 1 - r +state real vnest_b ijk dyn_nmm 1 - r +state real vnest_bt ijk dyn_nmm 1 - r +state real q2nest_b ijk dyn_nmm 1 - r +state real q2nest_bt ijk dyn_nmm 1 - r +state real cwmnest_b ijk dyn_nmm 1 - r +state real cwmnest_bt ijk dyn_nmm 1 - r # # For the moving nest. This is gopal's doing @@ -127,42 +164,60 @@ state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WI state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" state logical mvnest - dyn_nmm 1 - rm "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" +#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart +state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " +state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " +state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " +state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" + +#for HWRF: # flag for nest movement -state logical moved - misc 1 - - +state logical moved - misc 1 - r + +state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" +state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" +# For random number in SAS convection in HWRF + +state real store_rand ij dyn_nmm 1 - rh "RANDOM" "RANDOM NUMBER FOR SAS" -# Location of the SOUTH-WEST nested pointed in terms of parent grid +# Location of the SOUTH-WEST nested pointed in terms of parent grid -state integer IIH ij dyn_nmm 1 - - -state integer JJH ij dyn_nmm 1 - - -state integer IIV ij dyn_nmm 1 - - -state integer JJV ij dyn_nmm 1 - - +state integer IIH ij dyn_nmm 1 - r +state integer JJH ij dyn_nmm 1 - r +state integer IIV ij dyn_nmm 1 - r +state integer JJV ij dyn_nmm 1 - r # Bi-linear weights -state real HBWGT1 ij dyn_nmm 1 - - -state real HBWGT2 ij dyn_nmm 1 - - -state real HBWGT3 ij dyn_nmm 1 - - -state real HBWGT4 ij dyn_nmm 1 - - -state real VBWGT1 ij dyn_nmm 1 - - -state real VBWGT2 ij dyn_nmm 1 - - -state real VBWGT3 ij dyn_nmm 1 - - -state real VBWGT4 ij dyn_nmm 1 - - +state real HBWGT1 ij dyn_nmm 1 - r +state real HBWGT2 ij dyn_nmm 1 - r +state real HBWGT3 ij dyn_nmm 1 - r +state real HBWGT4 ij dyn_nmm 1 - r +state real VBWGT1 ij dyn_nmm 1 - r +state real VBWGT2 ij dyn_nmm 1 - r +state real VBWGT3 ij dyn_nmm 1 - r +state real VBWGT4 ij dyn_nmm 1 - r +#end of HWRF: # state real HLON ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) state real HLAT ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) -state real VLON ij dyn_nmm 1 - - -state real VLAT ij dyn_nmm 1 - - +state real VLON ij dyn_nmm 1 - irh +state real VLAT ij dyn_nmm 1 - irh # rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain" rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain" +#for HWRF: +rconfig logical analysis namelist,time_control max_domains .false. irh "days" "analysis control for the nested domain" -state real PSTD k dyn_nmm 1 Z - +state real PSTD k dyn_nmm 1 Z r state integer KZMAX - dyn_nmm - - r -state real Z3D ijk dyn_nmm 1 Z rd=(nmm_copy:IIH,JJH) "Z3D" "HEIGHT ARRAY FIELD VALID FOR PARENT ONLY" -state real T3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS" -state real Q3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS" +state real Z3D ijk dyn_nmm 1 Z rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Z3D" "HEIGHT ARRAY FIELD VALID FOR PARENT ONLY" +state real T3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS" +state real Q3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS" +#end of HWRF: + state real HRES_FIS ij dyn_nmm 1 - r "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" # @@ -208,17 +263,19 @@ state real aeta k dyn_nmm 1 - i01r state real f4q2 k dyn_nmm 1 - ir state real etax k dyn_nmm 1 - i01r state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01r "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01r "AETA1" "Midlayer sigma value in pressure domain" "" +state real deta1 k dyn_nmm 1 - i01rh "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01rh "AETA1" "Midlayer sigma value in pressure domain" "" state real eta1 k dyn_nmm 1 Z i01rh "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01r "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01r "AETA2" "Midlayer sigma value in sigma domain" "" +state real deta2 k dyn_nmm 1 - i01rh "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01rh "AETA2" "Midlayer sigma value in sigma domain" "" state real eta2 k dyn_nmm 1 Z i01rh "ETA2" "Interface sigma value in sigma domain" "" state real em q dyn_nmm 1 - ir state real emt q dyn_nmm 1 - ir -state real adt ij dyn_nmm 1 - - "ADT" "Change of T due to advection" "K" -state real adu ij dyn_nmm 1 - - "ADU" "Change of U due to advection" "m s-1" -state real adv ij dyn_nmm 1 - - "ADV" "Change of V due to advection" "m s-1" +#for HWRF: add to restart +state real adt ij dyn_nmm 1 - r "ADT" "Change of T due to advection" "K" +state real adu ij dyn_nmm 1 - r "ADU" "Change of U due to advection" "m s-1" +state real adv ij dyn_nmm 1 - r "ADV" "Change of V due to advection" "m s-1" +#end HWRF: state real em_loc q dyn_nmm 1 - r state real emt_loc q dyn_nmm 1 - r state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" @@ -228,24 +285,32 @@ state real ent - dyn_nmm - - ir state real f4d - dyn_nmm - - ir state real f4q - dyn_nmm - - ir state real ef4t - dyn_nmm - - ir +#for HWRF: add to restart state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" -state real dlmd - dyn_nmm - - ir "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - ir "DPHD" "North-south angular distance H-to-V points" "degrees" +#end HWRF: +state real dlmd - dyn_nmm - - irh "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - irh "DPHD" "North-south angular distance H-to-V points" "degrees" state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" # # module_CONTIN # -state real pdsl ij dyn_nmm 1 - - "PDSL" "Sigma-domain pressure at sigma=1" "Pa" -state real pdslo ij dyn_nmm 1 - - "PDSLO" "PDSL from previous timestep" "Pa" +#for HWRF: add to restart +state real pdsl ij dyn_nmm 1 - r "PDSL" "Sigma-domain pressure at sigma=1" "Pa" +state real pdslo ij dyn_nmm 1 - r "PDSLO" "PDSL from previous timestep" "Pa" +#end HWRF: state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" state real div ijk dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" -state real few ijk dyn_nmm 1 - - "FEW" "Integrated east-west mass flux" "Pa m2 s-1" -state real fne ijk dyn_nmm 1 - - "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" -state real fns ijk dyn_nmm 1 - - "FNS" "Integrated north-south mass flux" "Pa m2 s-1" -state real fse ijk dyn_nmm 1 - - "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +#for HWRF: add to restart +state real few ijk dyn_nmm 1 - r "FEW" "Integrated east-west mass flux" "Pa m2 s-1" +state real fne ijk dyn_nmm 1 - r "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" +state real fns ijk dyn_nmm 1 - r "FNS" "Integrated north-south mass flux" "Pa m2 s-1" +state real fse ijk dyn_nmm 1 - r "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +#end HWRF: state real omgalf ijk dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" -state real petdt ijk dyn_nmm 1 - - "PETDT" "Vertical mass flux" "Pa s-1" +#for HWRF: add to restart +state real petdt ijk dyn_nmm 1 - r "PETDT" "Vertical mass flux" "Pa s-1" +#end HWRF: state real rtop ijk dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" # # module_PVRBLS @@ -315,6 +380,7 @@ state integer lvl ij dyn_nmm 1 - ir # module_CLDWTR.F # state real cwm ijkb dyn_nmm 1 - rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:cwmnest_b,cwmnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CWM" "Total condensate" "kg kg-1" +state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" state real f_ice ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_ICE" "Frozen fraction of CWM" "" state real f_rain ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RAIN" "Rain fraction of liquid part of CWM" "" state real f_rimef ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RIMEF" "Rime factor" "" @@ -335,7 +401,7 @@ state real cmc ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH, state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" state real pctsno ij dyn_nmm 1 - irh state real soiltb ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRC" "Vegetation fraction" "" +state real vegfrc ij dyn_nmm 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRC" "Vegetation fraction" "" state real shdmin ij dyn_nmm 1 - - state real shdmax ij dyn_nmm 1 - - state real sh2o ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SH2O" "Unfrozen soil moisture volume fraction" "" @@ -370,7 +436,7 @@ state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" state real dwdt ijk dyn_nmm 1 - rd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "PINT" "Model layer interface pressure" "Pa" +state real pint ijk dyn_nmm 1 Z irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "PINT" "Model layer interface pressure" "Pa" state real w ijk dyn_nmm 1 Z rh "W" "Vertical velocity" "m s-1" state real z ijk dyn_nmm 1 Z - "Z" "Distance from ground" "m" # @@ -389,7 +455,9 @@ state real alwtoa ij dyn_nmm 1 - rh "ALWTOA" "Accum RLW state real rswin ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWIN" "Downward shortwave at surface" "W m-2" state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" -state real rswtoa ij dyn_nmm 1 - - "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +#for HWRF: add to restart +state real rswtoa ij dyn_nmm 1 - r "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +#end HWRF state real aswin ij dyn_nmm 1 - rh "ASWIN" "Accum SW down at surface" "W m-2" state real aswout ij dyn_nmm 1 - rh "ASWOUT" "Accum RSWOUT" "W m-2" state real aswtoa ij dyn_nmm 1 - rh "ASWTOA" "Accum RSWTOA" "W m-2" @@ -408,11 +476,14 @@ state real rh02_min ij dyn_nmm 1 - rh "RH02_MIN" "Hourly Min state real rh02_max ij dyn_nmm 1 - rh "RH02_MAX" "Hourly Max Relative Humidity" "" state real rlwtt ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RLWTT" "Longwave temperature tendency" "K s-1" state real rswtt ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWTT" "Shortwave temperature tendency" "K s-1" -state real tcucn ijk dyn_nmm 1 - - "TCUCN" "Accum convec temperature tendency" "K s-1" -state real train ijk dyn_nmm 1 - - "TRAIN" "Accum stratiform temp tendency" "K s-1" +#for HWRF: add to restart +state real tcucn ijk dyn_nmm 1 - r "TCUCN" "Accum convec temperature tendency" "K s-1" +state real train ijk dyn_nmm 1 - r "TRAIN" "Accum stratiform temp tendency" "K s-1" +#end HWRF state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" state integer nphs0 - dyn_nmm - - rh +state integer ncnvc0 - dyn_nmm - - rh state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" @@ -524,15 +595,15 @@ state real soilcbot isj misc 1 Z - "" #------------------------------------------------------------------------------------------------------------------------------- # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -648,10 +719,10 @@ state real SFCRUNOFF ij misc 1 - rh "SF state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" state integer IVGTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "IVGTYP" "VEGETATION TYPE" "" state integer ISLTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRA" "VEGETATION FRACTION" "" +state real VEGFRA ij misc 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRA" "VEGETATION FRACTION" "" state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" -state real ALBBCK ij misc 1 - i012r "ALBBCK" "BACKGROUND ALBEDO" "NA" +state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "" @@ -659,13 +730,13 @@ state real ACSNOM ij misc 1 - irh "A state real RMOL ij misc 1 - ir "RMOL" "" "" state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "" state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state real SST ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SST" "SEA SURFACE TEMPERATURE" "K" state real WEASD ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "" -state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" +state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" state real NOAHRES ij misc 1 - rh "NOAHRES" "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}" -state real tke_myj ijk misc 1 - r "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" +state real tke_myj ijk misc 1 - ir "tke_myj" "TKE FROM MELLOR-YAMADA-JANJIC" "m2 s-2" state real EL_MYJ ikj misc 1 - - "el_myj" "MIXING LENGTH FROM MELLOR-YAMADA-JANJIC" "m" state real EXCH_H ikj misc 1 - r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" state real EXCH_M ikj misc 1 - r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" @@ -678,6 +749,7 @@ state real FLQC ij misc 1 - r "F state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" # added as state for HALO_NMM_MG2, mep @@ -744,7 +816,8 @@ state real lu_state p misc - - - state integer number_at_same_level - - - - - "number_at_same_level" "" "" # State for derived time quantities. -state integer itimestep - - - - h "itimestep" "" "" +#for HWRF: add to restart +state integer itimestep - - - - rh "itimestep" "" "" state real xtime - - - - h "xtime" "minutes since simulation start" "" state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" @@ -794,15 +867,19 @@ rconfig integer fine_input_stream namelist,time_control max_doma include registry.io_boilerplate -rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" -rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" -rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +#for HWRF: added a 'r' for restart +rconfig integer JULYR namelist,time_control max_domains 0 hr "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 hr "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. hr "GMT" "" "" +#for HWRF: end rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +#for HWRF: +rconfig character anl_outname namelist,time_control max_domains "wrfanl_d_" - "name of analysis outfile" "" "" rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" @@ -868,6 +945,10 @@ rconfig real p_top_requested namelist,domains 1 5 # Physics rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +#for HWRF: +rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" +rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" +#end HWRF: rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" @@ -897,12 +978,13 @@ rconfig integer mp_zero_out namelist,physics 1 0 rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" -rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" +rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" rconfig integer sf_urban_physics namelist,physics max_domains 0 h "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" # nmm variables @@ -932,6 +1014,7 @@ rconfig logical cu_rad_feedback namelist,physics max_domains .f rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" rconfig integer movemin namelist,physics max_domains 10 irh "nmm input 12" + # Dynamics # dynamics option (see package definitions, below) rconfig integer dyn_opt namelist,dynamics 1 - @@ -966,7 +1049,9 @@ rconfig real tke_upper_bound namelist,dynamics max_domains 1000. rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" - +rconfig logical euler_adv namelist,dynamics 1 .false. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" +rconfig integer idtadt namelist,dynamics 1 1 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" +rconfig integer idtadc namelist,dynamics 1 1 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" # Bdy_control rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" @@ -1050,21 +1135,25 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr package thompson07 mp_physics==98 - moist:qv,qc,qr,qi,qs,qg;scalar:qni +package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs package rrtmscheme ra_lw_physics==1 - - package camlwscheme ra_lw_physics==3 - - package rrtmg_lwscheme ra_lw_physics==4 - - package gfdllwscheme ra_lw_physics==99 - - +package hwrflwscheme ra_lw_physics==98 package swradscheme ra_sw_physics==1 - - package gsfcswscheme ra_sw_physics==2 - - package camswscheme ra_sw_physics==3 - - package rrtmg_swscheme ra_sw_physics==4 - - package gfdlswscheme ra_sw_physics==99 - - +package hwrfswscheme ra_sw_physics==98 package heldsuarez ra_lw_physics==31 - - package sfclayscheme sf_sfclay_physics==1 - - @@ -1158,19 +1247,19 @@ halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD -#zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) -#zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) +#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) +#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) halo HALO_NMM_A dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;24:pint halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar halo HALO_NMM_B dyn_nmm 24:div halo HALO_NMM_C dyn_nmm 48:u,v -halo HALO_NMM_D dyn_nmm 24:pd +halo HALO_NMM_D dyn_nmm 48:pd halo HALO_NMM_E dyn_nmm 24:petdt halo HALO_NMM_F dyn_nmm 24:t,u,v halo HALO_NMM_F1 dyn_nmm 80:pdslo halo HALO_NMM_G dyn_nmm 48:u,v;24:z halo HALO_NMM_H dyn_nmm 24:w -halo HALO_NMM_I dyn_nmm 48:q,q2,cwm +halo HALO_NMM_I dyn_nmm 48:q,q2,cwm,rrw halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar @@ -1192,3 +1281,6 @@ halo HALO_NMM_INTERP_DOWN1 dyn_nmm 120:sm,fis,t,u,v,q,q2,z3d,q3d,t3d,pd,albase,n halo HALO_NMM_FORCE_DOWN1 dyn_nmm 120:t,u,v,q,q2,cwm,z3d,q3d,t3d #,qv,qc,qr,qi,qs,qg halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4 +halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 +halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt +halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs diff --git a/wrfv2_fire/Registry/Registry.wrfvar b/wrfv2_fire/Registry/Registry.wrfvar index 97e9bd7d..bb78146a 100644 --- a/wrfv2_fire/Registry/Registry.wrfvar +++ b/wrfv2_fire/Registry/Registry.wrfvar @@ -110,6 +110,7 @@ state real qc_gc igj dyn_em 1 Z i1 "QC" " state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" +state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice no concentration" "m-3" endif @@ -297,6 +298,10 @@ state real cfn - misc - - irh "cfn state real cfn1 - misc - - irh "cfn1" "extrapolation constant" "" state integer step_number - misc - - ir "step_number" "" +# hydrostatic pressure vars +state real p_hyd ijk dyn_em 1 - irh "p_hyd" "hydrostatic pressure" "Pa" +state real p_hyd_w ijk dyn_em 1 Z irh "p_hyd_w" "hydrostatic pressure at full levels" "Pa" + # For KMA, pressure coefficient. state real kma_a k misc 1 Z - "A" "KMA Constants A to convert surface presure to full level pressure" "dimensionless" state real kma_b k misc 1 Z - "B" "KMA Constants B to convert surface presure to full level pressure" "dimensionless" @@ -386,6 +391,8 @@ state real qs ijkftb moist 1 - \ i01rhusdf=(bdy_interp:dt) "QSNOW" "Snow mixing ratio" "kg kg-1" state real qg ijkftb moist 1 - \ i01rhusdf=(bdy_interp:dt) "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qh ijkftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QHAIL" "Hail mixing ratio" "kg kg-1" state real - ijkftb dfi_moist 1 - - - state real dfi_qv ijkftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QVAPOR" "Water vapor mixing ratio" "kg kg-1" @@ -399,7 +406,14 @@ state real dfi_qs ijkftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QSNOW" "Snow mixing ratio" "kg kg-1" state real dfi_qg ijkftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real dfi_qh ijkftb dfi_moist 1 - \ + rusdf=(bdy_interp:dt) "DFI_QHAIL" "Hail mixing ratio" "kg kg-1" + +# LES---------------!JDM + +#include registry.les +#------------------- # Chem Scalars state real - ijkftb chem 1 - - - @@ -420,9 +434,11 @@ state real qnr ijkftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNRAIN" "Rain Number concentration" "# kg(-1)" state real qng ijkftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" -state real qnn ikjftb scalar 1 - \ +state real qnh ijkftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNHAIL" "Hail Number concentration" "# kg(-1)" +state real qnn ijkftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" -state real qnc ikjftb scalar 1 - \ +state real qnc ijkftb scalar 1 - \ i01rhusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" state real - ijkftb dfi_scalar 1 - - - state real dfi_qndrop ijkftb dfi_scalar 1 - \ @@ -437,6 +453,8 @@ state real dfi_qnr ijkftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" state real dfi_qng ijkftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" +state real dfi_qnh ijkftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)" state real dfi_qnn ijkftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" state real dfi_qnc ijkftb dfi_scalar 1 - \ @@ -508,8 +526,10 @@ state real soilt160 ij misc 1 - i1 "SOIL state real soilt300 ij misc 1 - i1 "SOILT300" "LAYER SOIL TEMPERATURE" "K" state real landmask ij misc 1 - i012rhd=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real topostdv ij misc 1 - i12 "TOPOSTDV" "ELEVATION STD DEV" "m" -state real toposlpx ij misc 1 - i12 "TOPOSLPX" "ELEVATION X SLOPE" "" -state real toposlpy ij misc 1 - i12 "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real toposlpx ij misc 1 - i012rdu "TOPOSLPX" "ELEVATION X SLOPE" "" +state real toposlpy ij misc 1 - i012rdu "TOPOSLPY" "ELEVATION Y SLOPE" "" +state real slope ij misc 1 - rdu "SLOPE" "ELEVATION SLOPE" "" +state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" state real shdmax ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" state real shdmin ij misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" @@ -530,21 +550,21 @@ state real vegcat ij misc 1 - i12 "VEGC state real TSLB ijl misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" # Time series variables -state real ts_hour ?! misc - - r "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - r "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - r "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - r "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - r "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - r "TS_PSFC" "Surface pressure" -state real ts_glw ?! misc - - r "TS_GLW" "Downward long wave flux at surface" -state real ts_gsw ?! misc - - r "TS_GSW" "Net short wave flux at surface" -state real ts_hfx ?! misc - - r "TS_HFX" "Upward heat flux at surface" -state real ts_lh ?! misc - - r "TS_LH" "Upward moisture flux at surface" -state real ts_tsk ?! misc - - r "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - r "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - r "TS_CLW" "Column integrated cloud water" -state real ts_rainc ?! misc - - r "TS_RAINC" "Cumulus precip" -state real ts_rainnc ?! misc - - r "TS_RAINNC" "Grid-scale precip" +state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" +state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" +state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" +state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" +state real ts_t ?! misc - - - "TS_T" "Surface temperature" +state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" +state real ts_glw ?! misc - - - "TS_GLW" "Downward long wave flux at surface" +state real ts_gsw ?! misc - - - "TS_GSW" "Net short wave flux at surface" +state real ts_hfx ?! misc - - - "TS_HFX" "Upward heat flux at surface" +state real ts_lh ?! misc - - - "TS_LH" "Upward moisture flux at surface" +state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" +state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" +state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" +state real ts_rainc ?! misc - - - "TS_RAINC" "Cumulus precip" +state real ts_rainnc ?! misc - - - "TS_RAINNC" "Grid-scale precip" # urban model variables state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" @@ -597,10 +617,12 @@ state real dfi_v ijk misc 1 - r "V_DFI" state real dfi_w ijk misc 1 - r "W_DFI" "w accumulation array" " " state real dfi_ww ijk misc 1 Z r "WW_DFI" "mu-coupled eta-dot" "Pa s-1" state real dfi_t ijk misc 1 - r "TT_DFI" "t accumulation array" " " +state real dfi_rh ijk misc 1 - r "RH_DFI" "initial relative humidity" " " state real dfi_ph ijk misc 1 - r "PH_DFI" "p accumulation array" " " state real dfi_pb ijk misc 1 - r "PB_DFI" "pb accumulation array" " " state real dfi_alt ijk misc 1 - r "ALT_DFI" "1/rho accumulation array" " " state real dfi_tke ijk misc 1 - r "TKE_DFI" "TURBULENCE KINETIC ENERGY" "m2 s-2" +state real dfi_tten_rad ijk misc 1 - irh "RAD_TTEN_DFI" "RADAR POT. TEMP. TENDENCY" "K s-1" state real dfi_TSLB ijl misc 1 Z r "TSLB_dfi" "SOIL TEMPERATURE" "K" state real dfi_SMOIS ijl - 1 Z r "SMOIS_dfi" "SOIL MOISTURE" "m3 m-3" @@ -635,16 +657,34 @@ state real TRB_URB4D i{ulay}j misc 1 Z r "T state real TW1_URB4D i{ulay}j misc 1 Z r "TW1_URB4D" "WALL LAYER TEMPERATURE" "K" state real TW2_URB4D i{ulay}j misc 1 Z r "TW2_URB4D" "WALL LAYER TEMPERATURE" "K" state real TGB_URB4D i{ulay}j misc 1 Z r "TGB_URB4D" "ROAD LAYER TEMPERATURE" "K" +state real TLEV_URB3D i{ulay}j misc 1 Z r "TLEV_URB3D" "INDOOR TEMPERATURE" "K" +state real QLEV_URB3D i{ulay}j misc 1 Z r "QLEV_URB3D" "SPECIFIC HUMIDITY" "dimensionless" +state real TW1LEV_URB3D i{ulay}j misc 1 Z r "TW1LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TW2LEV_URB3D i{ulay}j misc 1 Z r "TW2LEV_URB3D" "WINDOW TEMPERATURE" "K" +state real TGLEV_URB3D i{ulay}j misc 1 Z r "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING" "K" +state real TFLEV_URB3D i{ulay}j misc 1 Z r "TFLEV_URB3D" "FLOOR TEMPERATURE" "K" +state real SF_AC_URB3D ij misc 1 - rh "SF_AC_URB3D" "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real LF_AC_URB3D ij misc 1 - r "LF_AC_URB3D" "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}" +state real CM_AC_URB3D ij misc 1 - rh "CM_AC_URB3D" "CONSUMPTION OF THE AIR COND." "W m{-2}" +state real SFVENT_URB3D ij misc 1 - r "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real LFVENT_URB3D ij misc 1 - r "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}" +state real SFWIN1_URB3D i{ulay}j misc 1 Z r "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" +state real SFWIN2_URB3D i{ulay}j misc 1 Z r "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW" "W m{-2}" state real SFW1_URB3D i{ulay}j misc 1 Z r "SFW1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFW2_URB3D i{ulay}j misc 1 Z r "SFW2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFR_URB3D i{ulay}j misc 1 Z r "SFR_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real SFG_URB3D i{ulay}j misc 1 Z r "SFG_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real CMR_SFCDIF ij misc 1 - r "CMR_SFCDIF" "" "" +state real CHR_SFCDIF ij misc 1 - r "CHR_SFCDIF" "" "" +state real CMC_SFCDIF ij misc 1 - r "CMC_SFCDIF" "" "" +state real CHC_SFCDIF ij misc 1 - r "CHC_SFCDIF" "" "" -# urban variables from radiation model -state real COSZ_URB2D ij misc 1 - r "COSZ_URB" "COS of SOLAR ZENITH ANGLE" "dimensionless" -state real OMG_URB2D ij misc 1 - r "OMG_URB" "SOLAR HOUR ANGLE" "dimensionless" -state real DECLIN_URB - misc 1 - r "DECLIN_URB" "SOLAR DECLINATION" "dimensionless" +# solar location variables from radiation driver +state real COSZEN ij misc 1 - r "COSZEN" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real HRANG ij misc 1 - r "HRANG" "SOLAR HOUR ANGLE" "radians" +state real DECLIN - misc 1 - r "DECLIN" "SOLAR DECLINATION" "radians" +state real SOLCON - misc 1 - r "SOLCON" "SOLAR CONSTANT" "W m-2" # RUC LSM @@ -689,15 +729,15 @@ state real Q10 ij misc 1 - r "Q1 i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" # MYNN PBL variables -state real qke ikj misc 1 - rh "qke" "twice TKE FROM MYNN" "m2 s-2" -state real tsq ikj misc 1 - r "tsq" "liquid water pottemp variance" "K2" -state real qsq ikj misc 1 - r "qsq" "liquid water variance" "(kg/kg)**2" -state real cov ikj misc 1 - r "cov" "liquid water-liquid water pottemp covaria\ +state real qke ijk misc 1 - rh "qke" "twice TKE FROM MYNN" "m2 s-2" +state real tsq ijk misc 1 - r "tsq" "liquid water pottemp variance" "K2" +state real qsq ijk misc 1 - r "qsq" "liquid water variance" "(kg/kg)**2" +state real cov ijk misc 1 - r "cov" "liquid water-liquid water pottemp covaria\ nce" "K kg/kg" state real ch ij misc 1 - - "ch" "drag coeff for heat" "" -#state real K_m ikj misc 1 - - "K_m" "EXCHANGE COEFFICIENT for momentum " -#state real K_h ikj misc 1 - - "K_h" "EXCHANGE COEFFICIENT for heat " -#state real K_q ikj misc 1 - - "K_q" "EXCHANGE COEFFICIENT for qke " +#state real K_m ijk misc 1 - - "K_m" "EXCHANGE COEFFICIENT for momentum " +#state real K_h ijk misc 1 - - "K_h" "EXCHANGE COEFFICIENT for heat " +#state real K_q ijk misc 1 - - "K_q" "EXCHANGE COEFFICIENT for qke " # Additional for gravity wave drag state real DUSFCG ij misc 1 - - "DUSFCG" "COLUMN U STRESS DIAGOSTIC" "" "" @@ -714,28 +754,28 @@ state real OL3 ij misc 1 - i012rhdus "OL state real OL4 ij misc 1 - i012rhdus "OL4" "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION" "" "" # BEP urban scheme variables -state real a_u_bep ikj misc 1 Z - "a_u_bep" "IMPLICIT FOR X-COMP." "s-1" -state real a_v_bep ikj misc 1 Z - "a_v_bep" "IMPLICIT FOR Y-COMP." "s-1" -state real a_t_bep ikj misc 1 Z - "a_t_bep" "IMPLICIT FOR Pot. Temp" "s-1" -state real a_q_bep ikj misc 1 Z - "a_q_bep" "IMPLICIT FOR Moisture" "s-1" -state real a_e_bep ikj misc 1 Z - "a_e_bep" "IMPLICIT FOR TKE" "s-1" -state real b_u_bep ikj misc 1 Z - "b_u_bep" "EXPLICIT FOR X-COMP." "m s-2" -state real b_v_bep ikj misc 1 Z - "b_v_bep" "EXPLICIT FOR Y-COMP." "m s-2" -state real b_t_bep ikj misc 1 Z - "b_t_bep" "EXPLICIT FOR Pot. Temp" "K s-1" -state real b_q_bep ikj misc 1 Z - "b_q_bep" "EXPLICIT FOR Moisture" "kg s-1" -state real b_e_bep ikj misc 1 Z - "b_e_bep" "EXPLICIT FOR TKE" "m2 s-3" -state real dlg_bep ikj misc 1 Z - "dlg_bep" "length scale 1" "m" -state real dl_u_bep ikj misc 1 Z - "dl_u_bep" "urban length scale" "m" -state real sf_bep ikj misc 1 Z - "sf_bep" "surface grid" "-" -state real vl_bep ikj misc 1 Z - "vl_bep" "volume grid" "-" +state real a_u_bep ijk misc 1 Z - "a_u_bep" "IMPLICIT FOR X-COMP." "s-1" +state real a_v_bep ijk misc 1 Z - "a_v_bep" "IMPLICIT FOR Y-COMP." "s-1" +state real a_t_bep ijk misc 1 Z - "a_t_bep" "IMPLICIT FOR Pot. Temp" "s-1" +state real a_q_bep ijk misc 1 Z - "a_q_bep" "IMPLICIT FOR Moisture" "s-1" +state real a_e_bep ijk misc 1 Z - "a_e_bep" "IMPLICIT FOR TKE" "s-1" +state real b_u_bep ijk misc 1 Z - "b_u_bep" "EXPLICIT FOR X-COMP." "m s-2" +state real b_v_bep ijk misc 1 Z - "b_v_bep" "EXPLICIT FOR Y-COMP." "m s-2" +state real b_t_bep ijk misc 1 Z - "b_t_bep" "EXPLICIT FOR Pot. Temp" "K s-1" +state real b_q_bep ijk misc 1 Z - "b_q_bep" "EXPLICIT FOR Moisture" "kg s-1" +state real b_e_bep ijk misc 1 Z - "b_e_bep" "EXPLICIT FOR TKE" "m2 s-3" +state real dlg_bep ijk misc 1 Z - "dlg_bep" "length scale 1" "m" +state real dl_u_bep ijk misc 1 Z - "dl_u_bep" "urban length scale" "m" +state real sf_bep ijk misc 1 Z - "sf_bep" "surface grid" "-" +state real vl_bep ijk misc 1 Z - "vl_bep" "volume grid" "-" # BOULAC PBL variables -state real tke_pbl ikj misc 1 - rh "tke_pbl" "TKE FROM Bougeault and Lacarrere" "m2 s-2" -state real el_pbl ikj misc 1 - h "el_pbl" "Length scale FROM Bougeault and Lacarrere" "m" +state real tke_pbl ijk misc 1 - rh "tke_pbl" "TKE FROM Bougeault and Lacarrere" "m2 s-2" +state real el_pbl ijk misc 1 - h "el_pbl" "Length scale FROM Bougeault and Lacarrere" "m" # Diagnostic PBL variables -state real wu_tur ikj misc 1 - r "wu_tur" "Turbulent flux of momentum(x)" "m2 s-2" -state real wv_tur ikj misc 1 - r "wv_tur" "Turbulent flux of momentum(y)" "m2 s-2" -state real wt_tur ikj misc 1 - r "wt_tur" "Turbulent flux of temperature" "K m s-1" -state real wq_tur ikj misc 1 - r "wq_tur" "Turbulent flux of water vapor" "- m s-1" +state real wu_tur ijk misc 1 - r "wu_tur" "Turbulent flux of momentum(x)" "m2 s-2" +state real wv_tur ijk misc 1 - r "wv_tur" "Turbulent flux of momentum(y)" "m2 s-2" +state real wt_tur ijk misc 1 - r "wt_tur" "Turbulent flux of temperature" "K m s-1" +state real wq_tur ijk misc 1 - r "wq_tur" "Turbulent flux of water vapor" "- m s-1" # gfdl (eta) radiation State Variables state real HTOP ij misc 1 - r "HTOP" "TOP OF CONVECTION LEVEL" "" @@ -816,7 +856,7 @@ state real ht_int ij misc 1 - - " state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" state real ht_shad ijb misc 1 - hdf=(bdy_interp:dt) "HGT_SHAD" "Height of orographic shadow" "m" i1 real ht_loc ij misc 1 - - -i1 integer shadowmask ij misc 1 - - +state integer shadowmask ij misc 1 - - state integer min_ptchsz - misc 1 - r state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" @@ -865,8 +905,11 @@ state real RAINNCV ij misc 1 - r "R state real RAINBL ij misc 1 - r "RAINBL" "PBL TIME-STEP TOTAL PRECIPITATION" "mm" state real SNOWNC ij misc 1 - rhdu "SNOWNC" "ACCUMULATED TOTAL GRID SCALE SNOW AND ICE" "mm" state real GRAUPELNC ij misc 1 - rhdu "GRAUPELNC" "ACCUMULATED TOTAL GRID SCALE GRAUPEL" "mm" +state real HAILNC ij misc 1 - rhdu "HAILNC" "ACCUMULATED TOTAL GRID SCALE HAIL" "mm" state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" +state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" +state real refl_10cm ijk dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" @@ -878,7 +921,7 @@ state real apr_as ij misc 1 - r "AP state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm hour-1" state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm hour-1" state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm hour-1" -state real edt_out ij misc 1 - h "EDT_OUT" "EDT FROM GD SCHEME" "" +state real edt_out ij misc 1 - - "EDT_OUT" "EDT FROM GD SCHEME" "" state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real cugd_tten ijk misc 1 - h "CUGD_TTEN" "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME" "K s-1" @@ -900,6 +943,7 @@ state real SWDOWN ij misc 1 - rhd "S state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" +state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" # upward and downward clearsky and total diagnostic fluxes for CAM radiation state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" @@ -1038,8 +1082,9 @@ state real FLQC ij misc 1 - r "F state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" state real dfi_QVG ij misc 1 - r "QVG_dfi" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" +state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE" "kg kg-1" +state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" +state real SOILT1 ij misc 1 - i012rh "SOILT1" "TEMPERATURE INSIDE SNOW " "K" state real dfi_SOILT1 ij misc 1 - r "SOILT1_dfi" "TEMPERATURE INSIDE SNOW " "K" state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" state real dfi_TSNAV ij misc 1 - r "TSNAV_dfi" "AVERAGE SNOW TEMPERATURE " "C" @@ -1139,6 +1184,7 @@ state real HML ij misc 1 - rd=(interp_m state real H0ML ij misc 1 - rd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "H0ML" "INITIAL OCEAN MIXED-LAYER DEPTH" "m" state real HUML ij misc 1 - rd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "HUML" "OCEAN MIXED-LAYER DEPTH * U-CURRENT" " m2s-1 " state real HVML ij misc 1 - rd=(interp_mask_water_field:lu_index)u=(copy_fcnm) "HVML" "OCEAN MIXED-LAYER DEPTH * V-CURRENT" " m2s-1 " + # #--------------------------------------------------------------------------------------------------------------------------------------- # @@ -1169,6 +1215,7 @@ rconfig logical print_detail_spectral namelist,wrfvar1 1 .false. - "pr rconfig logical print_detail_testing namelist,wrfvar1 1 .false. - "print_detail_testing" "" "" rconfig logical print_detail_parallel namelist,wrfvar1 1 .false. - "print_detail_parallel" "" "" rconfig logical print_detail_be namelist,wrfvar1 1 .false. - "print_detail_be" "" "" +rconfig logical print_detail_outerloop namelist,wrfvar1 1 .false. - "print_detail_outerloop" "" "" rconfig logical check_max_iv_print namelist,wrfvar1 1 .true. - "check_max_iv_print" "" "" rconfig logical check_buddy_print namelist,wrfvar1 1 .false. - "check_buddy_print" "" "" @@ -1245,6 +1292,7 @@ rconfig logical omb_set_rand namelist,wrfvar5 1 .false. - "omb rconfig logical omb_add_noise namelist,wrfvar5 1 .false. - "omb_add_noise" "" "" rconfig logical position_lev_dependant namelist,wrfvar5 1 .false. - "position_lev_dependant" "" "" rconfig integer obs_qc_pointer namelist,wrfvar5 1 0 - "obs_qc_pointer" "" "" +rconfig integer qmarker_retain namelist,wrfvar5 1 3 - "qmarker_retain" "" "" rconfig integer max_sound_input namelist,wrfvar5 1 50000000 - "max_sound_input" "" "" rconfig integer max_mtgirs_input namelist,wrfvar5 1 50000000 - "max_mtgirs_input" "" "" rconfig integer max_tamdar_input namelist,wrfvar5 1 50000000 - "max_tamdar_input" "" "" @@ -1274,6 +1322,7 @@ rconfig integer report_start namelist,wrfvar5 1 1 - "rep rconfig integer report_end namelist,wrfvar5 1 10000000 - "report_end" "" "" rconfig integer tovs_start namelist,wrfvar5 1 1 - "tovs_start" "" "" rconfig integer tovs_end namelist,wrfvar5 1 10000000 - "tovs_end" "" "" +rconfig logical gpsref_thinning namelist,wrfvar5 1 .false. - "gpsref_thinning" "" "" rconfig integer max_ext_its namelist,wrfvar6 1 1 - "max_ext_its" "" "" rconfig integer ntmax namelist,wrfvar6 1 200 - "ntmax" "" "" @@ -1292,16 +1341,16 @@ rconfig real as3 namelist,wrfvar7 3 -1.0 - "as3 rconfig real as4 namelist,wrfvar7 3 -1.0 - "as4" "" "" rconfig real as5 namelist,wrfvar7 3 -1.0 - "as5" "" "" rconfig integer rf_passes namelist,wrfvar7 1 6 - "rf_passes" "" "" -rconfig real var_scaling1 namelist,wrfvar7 1 1.0 - "var_scaling1" "" "" -rconfig real var_scaling2 namelist,wrfvar7 1 1.0 - "var_scaling2" "" "" -rconfig real var_scaling3 namelist,wrfvar7 1 1.0 - "var_scaling3" "" "" -rconfig real var_scaling4 namelist,wrfvar7 1 1.0 - "var_scaling4" "" "" -rconfig real var_scaling5 namelist,wrfvar7 1 1.0 - "var_scaling5" "" "" -rconfig real len_scaling1 namelist,wrfvar7 1 1.0 - "len_scaling1" "" "" -rconfig real len_scaling2 namelist,wrfvar7 1 1.0 - "len_scaling2" "" "" -rconfig real len_scaling3 namelist,wrfvar7 1 1.0 - "len_scaling3" "" "" -rconfig real len_scaling4 namelist,wrfvar7 1 1.0 - "len_scaling4" "" "" -rconfig real len_scaling5 namelist,wrfvar7 1 1.0 - "len_scaling5" "" "" +rconfig real var_scaling1 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling1" "" "" +rconfig real var_scaling2 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling2" "" "" +rconfig real var_scaling3 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling3" "" "" +rconfig real var_scaling4 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling4" "" "" +rconfig real var_scaling5 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling5" "" "" +rconfig real len_scaling1 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling1" "" "" +rconfig real len_scaling2 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling2" "" "" +rconfig real len_scaling3 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling3" "" "" +rconfig real len_scaling4 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling4" "" "" +rconfig real len_scaling5 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling5" "" "" rconfig real je_factor namelist,wrfvar7 1 1.0 - "je_factor" "" "" rconfig real power_truncation namelist,wrfvar7 1 1.0 - "power_truncation" "" "" @@ -1330,6 +1379,7 @@ rconfig logical warnings_are_fatal namelist,wrfvar9 1 .false. - "wa rconfig logical test_transforms namelist,wrfvar10 1 .false. - "test_transforms" "" "" rconfig logical test_statistics namelist,wrfvar10 1 .false. - "test_statistics" "" "" rconfig logical interpolate_stats namelist,wrfvar10 1 .true. - "interpolate_stats" "" "" +rconfig real be_eta namelist,wrfvar10 99 0.0 - "interpolate_stats" "" "" rconfig logical test_dm_exact namelist,wrfvar10 1 .false. - "test_dm_exact" "" "" rconfig integer cv_options_hum namelist,wrfvar11 1 1 - "cv_options_hum" "" "" @@ -1397,6 +1447,7 @@ rconfig integer simulated_rad_ngrid namelist,wrfvar14 1 0 - "si rconfig logical use_varbc namelist,wrfvar14 1 .false. - "use_varbc" "" "" rconfig logical freeze_varbc namelist,wrfvar14 1 .false. - "freeze_varbc" "" "" rconfig real varbc_factor namelist,wrfvar14 1 1.0 - "varbc_factor" "" "" +rconfig integer varbc_nbgerr namelist,wrfvar14 1 1 - "varbc_nbgerr" "" "" rconfig integer varbc_nobsmin namelist,wrfvar14 1 10 - "varbc_nobsmin" "" "" rconfig logical use_airs_mmr namelist,wrfvar14 1 .false. - "use_airs_mmr" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" @@ -1487,6 +1538,7 @@ rconfig logical cycling namelist,time_control 1 # DFI namelist rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" +rconfig integer dfi_radar namelist,dfi_control 1 0 rh "dfi_radar" "DFI radar switch" "" rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" @@ -1509,13 +1561,14 @@ rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh rconfig integer time_step namelist,domains 1 - ih "time_step" rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" - +rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" rconfig integer min_time_step namelist,domains max_domains -1 h "min_time_step" rconfig integer max_time_step namelist,domains max_domains -1 h "max_time_step" rconfig real target_cfl namelist,domains max_domains 1.2 h "target_cfl" rconfig integer max_step_increase_pct namelist,domains max_domains 5 h "max_step_increase_pct" rconfig integer starting_time_step namelist,domains max_domains -1 h "starting_time_step" rconfig logical step_to_output_time namelist,domains 1 .true. h "step_to_output_time" +rconfig integer adaptation_domain namelist,domains 1 1 h "adaptation_domain" rconfig logical use_adaptive_time_step namelist,domains 1 .false. h "use_adaptive_time_step" rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" @@ -1655,6 +1708,7 @@ rconfig integer omlcall namelist,physics 1 0 rconfig real oml_hml0 namelist,physics 1 50 h "oml_hml0" "oml initial mixed layer depth value" "m" rconfig real oml_gamma namelist,physics 1 0.14 h "oml_gamma" "oml deep water lapse rate" "K m-1" rconfig integer isftcflx namelist,physics 1 0 h "isftcflx" "switch to control sfc fluxes" "" +rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" rconfig real shadlen namelist,physics 1 25000. - "shadow_length" "maximum length of orographic shadow" "m" rconfig integer slope_rad namelist,physics max_domains 0 - "slope_rad" "1: use slope-dependent radiation, 0:not" "" rconfig integer topo_shading namelist,physics max_domains 0 - "topo_shading" "1: apply topographic shading to radiation, 0:not" "" @@ -1662,6 +1716,7 @@ rconfig integer no_mp_heating namelist,physics 1 0 rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seaice" "Fractional sea-ice option" rconfig real bucket_mm namelist,physics 1 -1. h "bucket_mm" "bucket reset value for water accumulations -1: inactive" "" rconfig real bucket_J namelist,physics 1 -1. h "bucket_J" "bucket reset value for energy accumulations -1: inactive" "" +rconfig real mp_tend_lim namelist,physics 1 10. - "mp_tend_lim" "limit on temp tendency from mp latent heating" "K/s" rconfig integer grav_settling namelist,physics max_domains 0 h "grav_settling" "activate gravitationalsettling of fog 0=no, 1=yes" @@ -1714,11 +1769,30 @@ rconfig real obs_coef_pstr namelist,fdda max_domains rconfig integer obs_no_pbl_nudge_uv namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_t namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_t" "1=no temperature-nudging within pbl" "" rconfig integer obs_no_pbl_nudge_q namelist,fdda max_domains 0 rh "obs_no_pbl_nudge_q" "1=no moisture-nudging within pbl" "" +rconfig real obs_nudgezfullr1_uv namelist,fdda 1 50 rh "obs_nudgezfullr1_uv" "Vert infl full weight height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezrampr1_uv namelist,fdda 1 50 rh "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds" "" +rconfig real obs_nudgezfullr2_uv namelist,fdda 1 50 rh "obs_nudgezfullr2_uv" "Vert infl full weight height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezrampr2_uv namelist,fdda 1 50 rh "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds" "" +rconfig real obs_nudgezfullr4_uv namelist,fdda 1 50 rh "obs_nudgezfullr4_uv" "Vert infl full weight height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezrampr4_uv namelist,fdda 1 -5000 rh "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds" "" +rconfig real obs_nudgezfullr1_t namelist,fdda 1 50 rh "obs_nudgezfullr1_t" "Vert infl full weight height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezrampr1_t namelist,fdda 1 50 rh "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature" "" +rconfig real obs_nudgezfullr2_t namelist,fdda 1 50 rh "obs_nudgezfullr2_t" "Vert infl full weight height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezrampr2_t namelist,fdda 1 50 rh "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature" "" +rconfig real obs_nudgezfullr4_t namelist,fdda 1 50 rh "obs_nudgezfullr4_t" "Vert infl full weight height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezrampr4_t namelist,fdda 1 -5000 rh "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature" "" +rconfig real obs_nudgezfullr1_q namelist,fdda 1 50 rh "obs_nudgezfullr1_q" "Vert infl full weight height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezrampr1_q namelist,fdda 1 50 rh "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture" "" +rconfig real obs_nudgezfullr2_q namelist,fdda 1 50 rh "obs_nudgezfullr2_q" "Vert infl full weight height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezrampr2_q namelist,fdda 1 50 rh "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture" "" +rconfig real obs_nudgezfullr4_q namelist,fdda 1 50 rh "obs_nudgezfullr4_q" "Vert infl full weight height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezrampr4_q namelist,fdda 1 -5000 rh "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture" "" +rconfig real obs_nudgezfullmin namelist,fdda 1 50 rh "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0" "m" +rconfig real obs_nudgezrampmin namelist,fdda 1 50 rh "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m" +rconfig real obs_nudgezmax namelist,fdda 1 3000 rh "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m" rconfig real obs_sfcfact namelist,fdda 1 1.0 h "obs_sfcfact" "Scale factor applied to time window for surface obs" "" rconfig real obs_sfcfacr namelist,fdda 1 1.0 h "obs_sfcfacr" "Scale factor applied to horiz radius of influence for surface obs" "" rconfig real obs_dpsmx namelist,fdda 1 7.5 h "obs_dpsmx" "Max pressure change allowed within horiz radius of influence" "centibars" -rconfig real obs_lml_ht1 namelist,fdda 1 100. h "obs_lml_ht1" "Height 1 for spreading of lowest model level obs" "km" -rconfig real obs_lml_ht2 namelist,fdda 1 100. h "obs_lml_ht2" "Height 2 for spreading of lowest model level obs" "km" rconfig real obs_rinxy namelist,fdda max_domains 0 rh "obs_rinxy" "Horizontal radius of influence" "km" rconfig real obs_rinsig namelist,fdda 1 0 h "obs_rinsig" "Vertical radius of influence" "sigma" rconfig real obs_twindo namelist,fdda max_domains 0 rh "obs_twindo" "Half-period time window for nudging" "hrs" @@ -1779,7 +1853,7 @@ rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rconfig integer h_sca_adv_order namelist,dynamics max_domains 5 rh "h_sca_adv_order" "" "" rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" rconfig integer moist_adv_opt namelist,dynamics max_domains 1 rh "moist_adv_opt" "positive-definite RK3 transport switch" "" -rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 1 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" +rconfig integer moist_adv_dfi_opt namelist,dynamics max_domains 0 rh "moist_adv_dfi_opt" "positive-definite RK3 transport switch" "" rconfig integer chem_adv_opt namelist,dynamics max_domains 1 rh "chem_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer scalar_adv_opt namelist,dynamics max_domains 1 rh "scalar_adv_opt" "positive-definite RK3 transport switch" "" rconfig integer tke_adv_opt namelist,dynamics max_domains 1 rh "tke_adv_opt" "positive-definite RK3 transport switch" "" @@ -1898,6 +1972,7 @@ package etampnew mp_physics==5 - moist:qv,qc,q package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr @@ -1913,6 +1988,7 @@ package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr @@ -1950,12 +2026,13 @@ package qnsesfcscheme sf_sfclay_physics==4 - - package mynnsfcscheme sf_sfclay_physics==5 - state:qke,tsq,qsq,cov package pxsfcscheme sf_sfclay_physics==7 - - -package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d +package bep_bemscheme sf_urban_physics==3 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - - -package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag +package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1 package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old package ysuscheme bl_pbl_physics==1 - - @@ -1990,11 +2067,11 @@ package dfi_bck dfi_stage==1 - - package dfi_fwd dfi_stage==2 - - package dfi_fst dfi_stage==3 - - -#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt +#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG -package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG +package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad ifdef RUC_CLOUD package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qni_gc endif @@ -2122,6 +2199,7 @@ period PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old period PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old period PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1 +period PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht period PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2 period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy,ustm @@ -2473,8 +2551,6 @@ typedef fdob_type logical NUDGE_T_PBL # Flag for temperature nudging within the typedef fdob_type logical NUDGE_Q_PBL # Flag for moisture nudging within the PBL typedef fdob_type real SFCFACT # scale factor applied to time window for surface obs typedef fdob_type real SFCFACR # scale factor applied to horiz radius of influence for surface obs -typedef fdob_type real LML_OBS_HT1_LEV # base-state model vertical coordinate of LML_OBS_HT1 -typedef fdob_type real LML_OBS_HT2_LEV # base-state model vertical coordinate of LML_OBS_HT2 typedef fdob_type real RINFMN # minimum radius of influence typedef fdob_type real RINFMX # maximum radius of influence typedef fdob_type real PFREE # pressure level (cb) where terrain effect becomes small @@ -2483,6 +2559,14 @@ typedef fdob_type real DPSMX # max pres change (cb) allowed within inf typedef fdob_type real TFACI # scale factor used for ramp-down in dynamic initialization typedef fdob_type real KNOWN_LAT # Latitude of origin point (i,j)=(1,1) typedef fdob_type real KNOWN_LON # Longitude of origin point (i,j)=(1,1) +typedef fdob_type character SDATE # domain starting date (YYYY-MM-DD_hh:mm:ss) +typedef fdob_type real XTIME_AT_REST # xtime at restart time +typedef fdob_type real VIF_UV(6) # Vertical influence function parameters for wind nudging +typedef fdob_type real VIF_T(6) # Vertical influence function parameters for temperature nudging +typedef fdob_type real VIF_Q(6) # Vertical influence function parameters for moisture nudging +typedef fdob_type real VIF_FULLMIN # Minimum depth through which vert infl fcn remains 1.0 (m) +typedef fdob_type real VIF_RAMPMIN # Minimum depth through which vif decreases 1.0 to 0.0 (m) +typedef fdob_type real VIF_MAX # Maximum depth in which vif is nonzero (m) # table entries are of the form #
@@ -2502,6 +2586,7 @@ typedef fdob_type real latprt [ - 1 - typedef fdob_type real lonprt [ - 1 - - "lonprt" "obs longitude for diagnostic printout" typedef fdob_type real mlatprt [ - 1 - - "mlatprt" "model latitude at obs location" typedef fdob_type real mlonprt [ - 1 - - "mlonprt" "model longitude at obs location" +typedef fdob_type real base_state k - 1 - - "base_state" "base-state height on half (mass) levels" "meters" state fdob_type fdob - - @@ -2534,12 +2619,12 @@ xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy # xpose variables for spectral nudging -state real dif_analysis ikj - 1 -state real dif_xxx ikjx - 1 -state real dif_yyy ikjy - 1 +state real dif_analysis ijk - 1 +state real dif_xxx ijkx - 1 +state real dif_yyy ijky - 1 xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy ## -include registry.fire +#include registry.fire diff --git a/wrfv2_fire/Registry/registry.chem b/wrfv2_fire/Registry/registry.chem index e9a35c27..168372c6 100644 --- a/wrfv2_fire/Registry/registry.chem +++ b/wrfv2_fire/Registry/registry.chem @@ -135,55 +135,54 @@ state real ebu_ch3coch3 ikjf ebu 1 Z h "eb state real ebu_ch3oh ikjf ebu 1 Z h "ebu_ch3oh" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_mek ikjf ebu 1 Z h "ebu_mek" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_toluene ikjf ebu 1 Z h "ebu_toluene" "biomass burning emiss" "mol km^-2 hr^-1" -kkkkkkkkkfk # additional arrays needed for biomass burning emissions input -state real - ijf ebu_in - - - - "Biomass burnung input " "" -state real ebu_in_no ijf ebu_in 1 - i07 "ebu_in_no" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_co ijf ebu_in 1 - i07 "ebu_in_co" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_co2 ijf ebu_in 1 - i07 "ebu_in_co2" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_eth ijf ebu_in 1 - i07 "ebu_in_eth" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_hc3 ijf ebu_in 1 - i07 "ebu_in_hc3" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_hc5 ijf ebu_in 1 - i07 "ebu_in_hc5" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_hc8 ijf ebu_in 1 - i07 "ebu_in_hc8" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ete ijf ebu_in 1 - i07 "ebu_in_ete" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_olt ijf ebu_in 1 - i07 "ebu_in_olt" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_oli ijf ebu_in 1 - i07 "ebu_in_oli" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_pm25 ijf ebu_in 1 - i07 "ebu_in_pm25" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_pm10 ijf ebu_in 1 - i07 "ebu_in_pm10" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_dien ijf ebu_in 1 - i07 "ebu_in_dien" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_iso ijf ebu_in 1 - i07 "ebu_in_iso" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_api ijf ebu_in 1 - i07 "ebu_in_api" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_lim ijf ebu_in 1 - i07 "ebu_in_lim" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_tol ijf ebu_in 1 - i07 "ebu_in_tol" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_xyl ijf ebu_in 1 - i07 "ebu_in_xyl" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_csl ijf ebu_in 1 - i07 "ebu_in_csl" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_hcho ijf ebu_in 1 - i07 "ebu_in_hcho" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ald ijf ebu_in 1 - i07 "ebu_in_ald" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ket ijf ebu_in 1 - i07 "ebu_in_ket" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_macr ijf ebu_in 1 - i07 "ebu_in_macr" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ora1 ijf ebu_in 1 - i07 "ebu_in_ora1" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ora2 ijf ebu_in 1 - i07 "ebu_in_ora2" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_nh3 ijf ebu_in 1 - i07 "ebu_in_nh3" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_so2 ijf ebu_in 1 - i07 "ebu_in_so2" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_dms ijf ebu_in 1 - i07 "ebu_in_dms" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_oc ijf ebu_in 1 - i07 "ebu_in_oc" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_bc ijf ebu_in 1 - i07 "ebu_in_bc" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_sulf ijf ebu_in 1 - i07 "ebu_in_sulf" "EMISSIONS" "mol km^-2 hr^-1" +state real - i]jf ebu_in - - - - "Biomass burnung input " "" +state real ebu_in_no i]jf ebu_in 1 - i07 "ebu_in_no" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_co i]jf ebu_in 1 - i07 "ebu_in_co" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_co2 i]jf ebu_in 1 - i07 "ebu_in_co2" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_eth i]jf ebu_in 1 - i07 "ebu_in_eth" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_hc3 i]jf ebu_in 1 - i07 "ebu_in_hc3" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_hc5 i]jf ebu_in 1 - i07 "ebu_in_hc5" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_hc8 i]jf ebu_in 1 - i07 "ebu_in_hc8" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ete i]jf ebu_in 1 - i07 "ebu_in_ete" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_olt i]jf ebu_in 1 - i07 "ebu_in_olt" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_oli i]jf ebu_in 1 - i07 "ebu_in_oli" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_pm25 i]jf ebu_in 1 - i07 "ebu_in_pm25" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_pm10 i]jf ebu_in 1 - i07 "ebu_in_pm10" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_dien i]jf ebu_in 1 - i07 "ebu_in_dien" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_iso i]jf ebu_in 1 - i07 "ebu_in_iso" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_api i]jf ebu_in 1 - i07 "ebu_in_api" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_lim i]jf ebu_in 1 - i07 "ebu_in_lim" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_tol i]jf ebu_in 1 - i07 "ebu_in_tol" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_xyl i]jf ebu_in 1 - i07 "ebu_in_xyl" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_csl i]jf ebu_in 1 - i07 "ebu_in_csl" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_hcho i]jf ebu_in 1 - i07 "ebu_in_hcho" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ald i]jf ebu_in 1 - i07 "ebu_in_ald" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ket i]jf ebu_in 1 - i07 "ebu_in_ket" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_macr i]jf ebu_in 1 - i07 "ebu_in_macr" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ora1 i]jf ebu_in 1 - i07 "ebu_in_ora1" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ora2 i]jf ebu_in 1 - i07 "ebu_in_ora2" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_nh3 i]jf ebu_in 1 - i07 "ebu_in_nh3" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_so2 i]jf ebu_in 1 - i07 "ebu_in_so2" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_dms i]jf ebu_in 1 - i07 "ebu_in_dms" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_oc i]jf ebu_in 1 - i07 "ebu_in_oc" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_bc i]jf ebu_in 1 - i07 "ebu_in_bc" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_sulf i]jf ebu_in 1 - i07 "ebu_in_sulf" "EMISSIONS" "mol km^-2 hr^-1" # additional arrays for mozcart biomass burning -state real ebu_in_bigalk ijf ebu_in 1 - i07 "ebu_in_bigalk" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_bigene ijf ebu_in 1 - i07 "ebu_in_bigene" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_c2h4 ijf ebu_in 1 - i07 "ebu_in_c2h4" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_c2h5oh ijf ebu_in 1 - i07 "ebu_in_c2h5oh" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_c2h6 ijf ebu_in 1 - i07 "ebu_in_c2h6" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_c3h6 ijf ebu_in 1 - i07 "ebu_in_c3h6" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_c3h8 ijf ebu_in 1 - i07 "ebu_in_c3h8" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ch2o ijf ebu_in 1 - i07 "ebu_in_ch2o" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ch3cho ijf ebu_in 1 - i07 "ebu_in_ch3cho" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ch3coch3 ijf ebu_in 1 - i07 "ebu_in_ch3coch3" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ch3oh ijf ebu_in 1 - i07 "ebu_in_ch3oh" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_mek ijf ebu_in 1 - i07 "ebu_in_mek" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_toluene ijf ebu_in 1 - i07 "ebu_in_toluene" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_bigalk i]jf ebu_in 1 - i07 "ebu_in_bigalk" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_bigene i]jf ebu_in 1 - i07 "ebu_in_bigene" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_c2h4 i]jf ebu_in 1 - i07 "ebu_in_c2h4" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_c2h5oh i]jf ebu_in 1 - i07 "ebu_in_c2h5oh" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_c2h6 i]jf ebu_in 1 - i07 "ebu_in_c2h6" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_c3h6 i]jf ebu_in 1 - i07 "ebu_in_c3h6" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_c3h8 i]jf ebu_in 1 - i07 "ebu_in_c3h8" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ch2o i]jf ebu_in 1 - i07 "ebu_in_ch2o" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ch3cho i]jf ebu_in 1 - i07 "ebu_in_ch3cho" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ch3coch3 i]jf ebu_in 1 - i07 "ebu_in_ch3coch3" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ch3oh i]jf ebu_in 1 - i07 "ebu_in_ch3oh" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_mek i]jf ebu_in 1 - i07 "ebu_in_mek" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_toluene i]jf ebu_in 1 - i07 "ebu_in_toluene" "EMISSIONS" "mol km^-2 hr^-1" # state real mean_fct_agtf ij misc 1 - i07h "mean_fct_agtf" "mean fraction of tropical forest" "?" state real mean_fct_agef ij misc 1 - i07h "mean_fct_agef" "mean fraction of extra tropical forest" "?" @@ -193,47 +192,11 @@ state real firesize_agtf ij misc 1 - i07h state real firesize_agef ij misc 1 - i07h "firesize_agef" "mean firesize for extratropical forest" "?" state real firesize_agsv ij misc 1 - i07h "firesize_agsv" "mean firesize for savanna" "?" state real firesize_aggr ij misc 1 - i07h "firesize_aggr" "mean firesize for grassland" "?" -# deposition velocities -state real dvel_o3 ij misc 1 Z h "dvel_o3" "O3 deposition velocity " "cm/s" -state real dvel_no ij misc 1 Z h "dvel_no" "NO deposition velocity " "cm/s" -state real dvel_no2 ij misc 1 Z h "dvel_no2" "NO2 deposition velocity " "cm/s" -state real dvel_nh3 ij misc 1 Z h "dvel_nh3" "NH3 deposition velocity " "cm/s" -state real dvel_hno3 ij misc 1 Z h "dvel_hno3" "HNO3 deposition velocity " "cm/s" -state real dvel_hno4 ij misc 1 Z h "dvel_hno4" "HNO4 deposition velocity " "cm/s" -state real dvel_h2o2 ij misc 1 Z h "dvel_h2o2" "H2O2 deposition velocity " "cm/s" -state real dvel_co ij misc 1 Z h "dvel_co" "CO deposition velocity " "cm/s" -state real dvel_ch3ooh ij misc 1 Z h "dvel_ch3ooh" "CH3OOH deposition velocity " "cm/s" -state real dvel_hcho ij misc 1 Z h "dvel_hcho" "HCHO deposition velocity " "cm/s" -state real dvel_ch3oh ij misc 1 Z h "dvel_ch3oh" "CH3OH deposition velocity " "cm/s" -state real dvel_eo2 ij misc 1 Z h "dvel_eo2" "EO2 deposition velocity " "cm/s" -state real dvel_ald ij misc 1 Z h "dvel_ald" "ALD deposition velocity " "cm/s" -state real dvel_ch3cooh ij misc 1 Z h "dvel_ch3cooh" "CH3COOH deposition velocity " "cm/s" -state real dvel_acet ij misc 1 Z h "dvel_acet" "ACET deposition velocity " "cm/s" -state real dvel_mgly ij misc 1 Z h "dvel_mgly" "MGLY deposition velocity " "cm/s" -state real dvel_paa ij misc 1 Z h "dvel_paa" "PAA deposition velocity " "cm/s" -state real dvel_pooh ij misc 1 Z h "dvel_pooh" "POOH deposition velocity " "cm/s" -state real dvel_pan ij misc 1 Z h "dvel_pan" "PAN deposition velocity " "cm/s" -state real dvel_mpan ij misc 1 Z h "dvel_mpan" "MPAN deposition velocity " "cm/s" -state real dvel_mco3 ij misc 1 Z h "dvel_mco3" "MCO3 deposition velocity " "cm/s" -state real dvel_mvkooh ij misc 1 Z h "dvel_mvkooh" "MVKOOH deposition velocity " "cm/s" -state real dvel_c2h5oh ij misc 1 Z h "dvel_c2h5oh" "C2H5OH deposition velocity " "cm/s" -state real dvel_etooh ij misc 1 Z h "dvel_etooh" "ETOOH deposition velocity " "cm/s" -state real dvel_prooh ij misc 1 Z h "dvel_prooh" "PROOH deposition velocity " "cm/s" -state real dvel_acetp ij misc 1 Z h "dvel_acetp" "ACETP deposition velocity " "cm/s" -state real dvel_onit ij misc 1 Z h "dvel_onit" "ONIT deposition velocity " "cm/s" -state real dvel_onitr ij misc 1 Z h "dvel_onitr" "ONITR deposition velocity " "cm/s" -state real dvel_isooh ij misc 1 Z h "dvel_isooh" "ISOOH deposition velocity " "cm/s" -state real dvel_acetol ij misc 1 Z h "dvel_acetol" "ACETOL deposition velocity " "cm/s" -state real dvel_glyald ij misc 1 Z h "dvel_glyald" "GLYALD deposition velocity " "cm/s" -state real dvel_hydrald ij misc 1 Z h "dvel_hydrald" "HYDRALD deposition velocity " "cm/s" -state real dvel_alkooh ij misc 1 Z h "dvel_alkooh" "ALKOOH deposition velocity " "cm/s" -state real dvel_mekooh ij misc 1 Z h "dvel_mekooh" "MEKOOH deposition velocity " "cm/s" -state real dvel_tolooh ij misc 1 Z h "dvel_tolooh" "TOLOOH deposition velocity " "cm/s" -state real dvel_xooh ij misc 1 Z h "dvel_xooh" "XOOH deposition velocity " "cm/s" -state real dvel_so2 ij misc 1 Z h "dvel_so2" "SO2 deposition velocity " "cm/s" -state real dvel_so4 ij misc 1 Z h "dvel_so4" "SO4 deposition velocity " "cm/s" -state real dvel_terpooh ij misc 1 Z h "dvel_terpooh" "TERPOOH deposition velocity " "cm/s" +# Lightning +state real ic_flshrate ij misc 1 - rh "IC_FR" "Cuml. IC Flash rate" "number" +state real cg_flshrate ij misc 1 - rh "CG_FR" "Cuml. CG Flash rate" "number" +# # state real - ikjf ext_coef - - - - "Extinction coefficients" "" state real extcof3 ikjf ext_coef 1 Z h "EXTCOF3" "Extinction coefficients for .3um" "km^-1" @@ -664,27 +627,28 @@ state real tracer_19 ikjftb chem 1 - irhusdf=(bdy_inte state real tracer_20 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "tracer_20" "tracer20 mix ratio" "ppmv" state real tracer_ens ikjftb chem 1 - irhusdf=(bdy_interp:dt) "tracer_ens" "tracer- ensemble average mix ratio" "ppmv" -state real - ikjftb scalar 1 - - - -state real tr17_0 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_0" "tr17_0" - -state real tr17_1 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_1" "tr17_1" - -state real tr17_2 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_2" "tr17_2" - -state real tr17_3 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_3" "tr17_3" - -state real tr17_4 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_4" "tr17_4" - -state real tr17_5 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_5" "tr17_5" - -state real tr17_6 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_6" "tr17_6" - -state real tr17_7 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_7" "tr17_7" - -state real tr17_8 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_8" "tr17_8" - -state real tr17_9 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr17_9" "tr17_9" - -state real tr18_0 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_0" "tr18_0" - -state real tr18_1 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_1" "tr18_1" - -state real tr18_2 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_2" "tr18_2" - -state real tr18_3 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_3" "tr18_3" - -state real tr18_4 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_4" "tr18_4" - -state real tr18_5 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_5" "tr18_5" - -state real tr18_6 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_6" "tr18_6" - -state real tr18_7 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_7" "tr18_7" - -state real tr18_8 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_8" "tr18_8" - -state real tr18_9 ikjftb scalar 1 - i08rhusdf=(bdy_interp:dt) "tr18_9" "tr18_9" - +state real - ikjftb tracer 1 - - - +state real smoke ikjftb tracer 1 - irhusdf=(bdy_interp:dt) "smoke" "tracing smoke" - +state real tr17_0 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_0" "tr17_0" - +state real tr17_1 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_1" "tr17_1" - +state real tr17_2 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_2" "tr17_2" - +state real tr17_3 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_3" "tr17_3" - +state real tr17_4 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_4" "tr17_4" - +state real tr17_5 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_5" "tr17_5" - +state real tr17_6 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_6" "tr17_6" - +state real tr17_7 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_7" "tr17_7" - +state real tr17_8 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_8" "tr17_8" - +state real tr17_9 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr17_9" "tr17_9" - +state real tr18_0 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_0" "tr18_0" - +state real tr18_1 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_1" "tr18_1" - +state real tr18_2 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_2" "tr18_2" - +state real tr18_3 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_3" "tr18_3" - +state real tr18_4 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_4" "tr18_4" - +state real tr18_5 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_5" "tr18_5" - +state real tr18_6 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_6" "tr18_6" - +state real tr18_7 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_7" "tr18_7" - +state real tr18_8 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_8" "tr18_8" - +state real tr18_9 ikjftb tracer 1 - i08rhusdf=(bdy_interp:dt) "tr18_9" "tr18_9" - #Aerosol variables inside the chem array... # the first two are for simple advection of total pm25 and pm10 mass @@ -1065,8 +1029,6 @@ state integer STEPPHOT - misc 1 - r "ST state integer STEPCHEM - misc 1 - r "STEPCHEM" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CHEM MECH CALLS" "NA" state integer STEPFIREPL - misc 1 - r "STEPFIREPL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CALLSTO PLUMERISE FIRE ROUTINE" "NA" -# Scalar arrays for tracers - # rconfig character emi_inname namelist,chem 1 "wrfchemi_d_" - "name of chem emissions infile" "" "" @@ -1088,8 +1050,23 @@ rconfig integer ne_area namelist,chem 1 4 rconfig integer kemit namelist,chem 1 9 irh "kemit" "" "" rconfig integer nmegan namelist,chem 1 138 irh "nmegan" "" "" rconfig integer kfuture namelist,chem 1 1 - "kfuture" "" "" +rconfig integer kfire namelist,chem 1 1 - "kfire" "" "" rconfig integer errosion_dim namelist,chem 1 3 - "errosion_dim" "" "" rconfig integer biomass_emiss_opt namelist,chem max_domains 0 rh "biomass_emiss_opt" "" "" +# Lightning +rconfig integer lightning_opt namelist,chem max_domains 0 rh "lightning_opt" "" "" +rconfig integer lightning_time_step namelist,chem max_domains 0 rh "lightning_time_step" "" "" +rconfig integer lightning_start_seconds namelist,chem max_domains 0 rh "lightning_start_seconds" "" "" +rconfig real temp_upper namelist,chem max_domains -45. rh "temp_upper" "" "" +rconfig real temp_lower namelist,chem max_domains -15. rh "temp_lower" "" "" +rconfig real N_IC namelist,chem max_domains 0. rh "N_IC" "" "" +rconfig real N_CG namelist,chem max_domains 0. rh "N_CG" "" "" +rconfig integer passive_ltng namelist,chem max_domains 1 rh "passive_ltng" "" "" +rconfig integer lflash_data namelist,chem 1 1 rh "lflash_data" "" "" +rconfig real flashrate_factor namelist,chem max_domains 1. rh "flashrate_factor" "" "" +rconfig integer flashrate_method namelist,chem max_domains 1 rh "flashrate_method" "" "" +rconfig integer iccg_method namelist,chem max_domains 1 rh "iccg_method" "" "" +rconfig integer cellcount_method namelist,chem max_domains 1 rh "cellcount_method" "" "" # Default chemistry settings are: passive/prescribed aerosols (chem_opt=0) @@ -1105,7 +1082,9 @@ rconfig integer cldchem_onoff namelist,chem max_domains rconfig integer vertmix_onoff namelist,chem max_domains 1 rh "vertmix_onoff" "" "" rconfig integer chem_in_opt namelist,chem max_domains 0 rh "chem_in_opt" "" "" rconfig integer phot_opt namelist,chem max_domains 0 rh "phot_opt" "" "" -rconfig integer drydep_opt namelist,chem max_domains 0 rh "drydep_opt" "" "" +rconfig integer gas_drydep_opt namelist,chem max_domains 1 rh "gas_drydep_opt" "" "" +rconfig integer aer_drydep_opt namelist,chem max_domains 1 rh "aer_drydep_opt" "" "" +rconfig integer aer_aerodynres_opt namelist,chem max_domains 1 rh "aer_aerodynres_opt" "" "" rconfig integer emiss_opt namelist,chem max_domains 4 rh "emiss_opt" "" "" rconfig integer dust_opt namelist,chem 1 0 rh "dust_opt" "" "" rconfig integer dmsemis_opt namelist,chem 1 0 rh "dmsemis_opt" "" "" @@ -1119,10 +1098,11 @@ rconfig integer gas_ic_opt namelist,chem max_domains rconfig integer aer_bc_opt namelist,chem max_domains 1 rh "aer_bc_opt" "" "" rconfig integer aer_ic_opt namelist,chem max_domains 1 rh "aer_ic_opt" "" "" rconfig logical have_bcs_chem namelist,chem max_domains .false. rh "have_bcs_chem" "" "" +rconfig logical have_bcs_tracer namelist,chem max_domains .false. rh "have_bcs_tracer" "" "" rconfig integer aer_ra_feedback namelist,chem max_domains 0 rh "aer_ra_feedback" "" "" rconfig integer aer_op_opt namelist,chem max_domains 1 rh "aer_op_opt" "" "" rconfig integer opt_pars_out namelist,chem 1 0 h "opt_pars_out" "" "" -rconfig integer scalar_opt namelist,chem max_domains 0 rh "scalar_opt" "" "" +rconfig integer tracer_opt namelist,chem max_domains 0 rh "tracer_opt" "" "" # CHEMISTRY PACKAGE DEFINITIONS # @@ -1139,8 +1119,8 @@ package cbmz_mosaic_8bin chem_opt==8 - chem:so2,sulf package cbmz_mosaic_4bin_aq chem_opt==9 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04 package cbmz_mosaic_8bin_aq chem_opt==10 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04,so4_cw05,no3_cw05,cl_cw05,nh4_cw05,na_cw05,oin_cw05,oc_cw05,bc_cw05,num_cw05,so4_cw06,no3_cw06,cl_cw06,nh4_cw06,na_cw06,oin_cw06,oc_cw06,bc_cw06,num_cw06,so4_cw07,no3_cw07,cl_cw07,nh4_cw07,na_cw07,oin_cw07,oc_cw07,bc_cw07,num_cw07,so4_cw08,no3_cw08,cl_cw08,nh4_cw08,na_cw08,oin_cw08,oc_cw08,bc_cw08,num_cw08 -package radm2sorg_aq chem_opt==11 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw -package racmsorg_aq chem_opt==12 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw +package radm2sorg_aq chem_opt==11 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw +package racmsorg_aq chem_opt==12 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw package chem_tracer chem_opt==13 - chem:so2,no,ald,hcho,ora2,co package chem_trace2 chem_opt==14 - chem:tracer_1 package chem_trace_ens chem_opt==15 - chem:tracer_1,tracer_2,tracer_3,tracer_4,tracer_5,tracer_6,tracer_7,tracer_8,tracer_9,tracer_10,tracer_11,tracer_12,tracer_13,tracer_14,tracer_15,tracer_16,tracer_17,tracer_18,tracer_19,tracer_20,tracer_ens @@ -1166,7 +1146,8 @@ package mozart_kpp chem_opt==111 - chem:o3,o1 # KPP mechanism from mozart + gocart package mozcart_kpp chem_opt==112 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,so4,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4 - +# KPP mechanism from CBMZ +package cbmz_bb_kpp chem_opt==120 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,ch4,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2 # KPP mechanism from MATCH-MPI Mainz used for global chemistry package nmhc9_kpp chem_opt==200 - chem:o3,h2o2,ch4,op1,hcho,ch3oh,co,hno3,no3,n2o5,hno4,no,no2,isopr,mvk,iso2,isooh,mvko2,mvkooh,ison,aca,acol,hcooh,mpan,naca,pan,pa,paa,mglo,c2h6,eTooh,ald,c3h8,pRooh,acet,acooh,eTo2,pRo2,aco2,c3h6,c3h6ooh,c2h4,c4h10,buooh,mek,mekooh,mEcoco,c3h6o2,c4h9o2,meko2,onit,pRono2,ch3o2,acetol,acetp,aceto2,ch3cooh,c4h9ooh,mEoh,ho,ho2,mEo2,mEo2no2 @@ -1196,7 +1177,7 @@ package gocart_ecptec emiss_opt==6 - emis_ant: package photmad phot_opt==1 - - package photfastj phot_opt==2 - - package ftuv phot_opt==3 - - -package wesely drydep_opt==1 - - +package wesely gas_drydep_opt==1 - - package gunther1 bio_emiss_opt==1 - - package beis313 bio_emiss_opt==2 - - package megan2 bio_emiss_opt==3 - state:mebio_isop,mebio_apin,mebio_bcar,mebio_acet,mebio_mbo,mebio_no,msebio_isop,mlai,pftp_bt,pftp_nt,pftp_sb,pftp_hb,mtsa,mswdown,EFmegan @@ -1238,6 +1219,10 @@ package aer_bc_pnnl aer_bc_opt==101 - package aer_ic_default aer_ic_opt==1 - - package aer_ic_pnnl aer_ic_opt==101 - - -package scalar_me scalar_opt==1 - scalar:tr17_0,tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8,tr17_9,tr18_0,tr18_1,tr18_2,tr18_3,tr18_4,tr18_5,tr18_6,tr18_7,tr18_8,tr18_9 -package scalar_sUS scalar_opt==2 - scalar:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8 +package tracer_smoke tracer_opt==1 - tracer:smoke +package tracer_me tracer_opt==2 - tracer:tr17_0,tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8,tr17_9,tr18_0,tr18_1,tr18_2,tr18_3,tr18_4,tr18_5,tr18_6,tr18_7,tr18_8,tr18_9 +package tracer_sUS tracer_opt==3 - tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8 + +# Lightning +package crmpickering lightning_opt==1 - state:ic_flshrate,cg_flshrate diff --git a/wrfv2_fire/Registry/registry.dimspec b/wrfv2_fire/Registry/registry.dimspec index 8f37aefd..b7d5510c 100644 --- a/wrfv2_fire/Registry/registry.dimspec +++ b/wrfv2_fire/Registry/registry.dimspec @@ -1,5 +1,4 @@ -# Available characters for dimspec: 0123456789@%+=|?.!&[{}] #
dimspec i 1 standard_domain x west_east @@ -65,5 +64,6 @@ dimspec o 3 namelist=ne_area z bio_emissions_d dimspec + 2 namelist=kemit z emissions_zdim dimspec nm 2 namelist=nmegan z megan_species dimspec dust 2 namelist=kfuture z klevs_for_dust +dimspec ] 2 namelist=kfire z klevs_for_fire dimspec . 3 namelist=errosion_dim z dust_errosion_dimension endif diff --git a/wrfv2_fire/Registry/registry.io_boilerplate b/wrfv2_fire/Registry/registry.io_boilerplate dissimilarity index 86% index 750cfd4b..1ba5d961 100644 --- a/wrfv2_fire/Registry/registry.io_boilerplate +++ b/wrfv2_fire/Registry/registry.io_boilerplate @@ -1,592 +1,138 @@ - -# registry.io_boilerplate -# -# Included by registry program -# -# Contains a number of standard state variables associated with I/O -# -# - -# Output file descriptor for a domain -state integer oid - - - - - "oid" "" "" -state integer auxhist1_oid - - - - - "auxhist1_oid" "" "" -state integer auxhist2_oid - - - - - "auxhist2_oid" "" "" -state integer auxhist3_oid - - - - - "auxhist3_oid" "" "" -state integer auxhist4_oid - - - - - "auxhist4_oid" "" "" -state integer auxhist5_oid - - - - - "auxhist5_oid" "" "" -state integer auxhist6_oid - - - - - "auxhist6_oid" "" "" -state integer auxhist7_oid - - - - - "auxhist7_oid" "" "" -state integer auxhist8_oid - - - - - "auxhist8_oid" "" "" -state integer auxhist9_oid - - - - - "auxhist9_oid" "" "" -state integer auxhist10_oid - - - - - "auxhist10_oid" "" "" -state integer auxhist11_oid - - - - - "auxhist11_oid" "" "" - -state integer auxinput1_oid - - - - - "auxinput1_oid" "" "" -state integer auxinput2_oid - - - - - "auxinput2_oid" "" "" -state integer auxinput3_oid - - - - - "auxinput3_oid" "" "" -state integer auxinput4_oid - - - - - "auxinput4_oid" "" "" -state integer auxinput5_oid - - - - - "auxinput5_oid" "" "" -state integer auxinput6_oid - - - - - "auxinput6_oid" "" "" -state integer auxinput7_oid - - - - - "auxinput7_oid" "" "" -state integer auxinput8_oid - - - - - "auxinput8_oid" "" "" -state integer auxinput9_oid - - - - - "auxinput9_oid" "" "" -state integer auxinput10_oid - - - - - "auxinput10_oid" "" "" -state integer auxinput11_oid - - - - - "auxinput11_oid" "" "" - -rconfig integer history_interval namelist,time_control max_domains 0 h "history_interval" "" "MINUTES" -rconfig integer frames_per_outfile namelist,time_control max_domains 10 h "frames_per_outfile" "" "" -rconfig integer frames_per_auxhist1 namelist,time_control max_domains 10 h "frames_per_auxhist1" "" "" -rconfig integer frames_per_auxhist2 namelist,time_control max_domains 10 h "frames_per_auxhist2" "" "" -rconfig integer frames_per_auxhist3 namelist,time_control max_domains 10 h "frames_per_auxhist3" "" "" -rconfig integer frames_per_auxhist4 namelist,time_control max_domains 10 h "frames_per_auxhist4" "" "" -rconfig integer frames_per_auxhist5 namelist,time_control max_domains 10 h "frames_per_auxhist5" "" "" -rconfig integer frames_per_auxhist6 namelist,time_control max_domains 10 h "frames_per_auxhist6" "" "" -rconfig integer frames_per_auxhist7 namelist,time_control max_domains 10 h "frames_per_auxhist7" "" "" -rconfig integer frames_per_auxhist8 namelist,time_control max_domains 10 h "frames_per_auxhist8" "" "" -rconfig integer frames_per_auxhist9 namelist,time_control max_domains 10 h "frames_per_auxhist9" "" "" -rconfig integer frames_per_auxhist10 namelist,time_control max_domains 10 h "frames_per_auxhist10" "" "" -rconfig integer frames_per_auxhist11 namelist,time_control max_domains 10 h "frames_per_auxhist11" "" "" -rconfig logical restart namelist,time_control 1 .false. h "restart" "" "" -rconfig integer restart_interval namelist,time_control 1 0 h "restart_interval" "" "MINUTES" -rconfig integer io_form_input namelist,time_control 1 2 h "io_form_input" "" "" -rconfig integer io_form_history namelist,time_control 1 2 h "io_form_history" "" "" -rconfig integer io_form_restart namelist,time_control 1 2 h "io_form_restart" "" "" -rconfig integer io_form_boundary namelist,time_control 1 2 h "io_form_boundary" "" "" -rconfig integer debug_level namelist,time_control 1 0 - "debug_level" "" "" -rconfig logical self_test_domain namelist,time_control 1 .false. - "self_test_domain" "" "" - - -rconfig character history_outname namelist,time_control 1 "wrfout_d_" - "name of history outfile" "" "" -rconfig character auxhist1_outname namelist,time_control 1 "auxhist1_d_" - "name of auxhist1 outfile" "" "" -rconfig character auxhist2_outname namelist,time_control 1 "auxhist2_d_" - "name of auxhist2 outfile" "" "" -rconfig character auxhist3_outname namelist,time_control 1 "auxhist3_d_" - "name of auxhist3 outfile" "" "" -rconfig character auxhist4_outname namelist,time_control 1 "auxhist4_d_" - "name of auxhist4 outfile" "" "" -rconfig character auxhist5_outname namelist,time_control 1 "auxhist5_d_" - "name of auxhist5 outfile" "" "" -rconfig character auxhist6_outname namelist,time_control 1 "auxhist6_d_" - "name of auxhist6 outfile" "" "" -rconfig character auxhist7_outname namelist,time_control 1 "auxhist7_d_" - "name of auxhist7 outfile" "" "" -rconfig character auxhist8_outname namelist,time_control 1 "auxhist8_d_" - "name of auxhist8 outfile" "" "" -rconfig character auxhist9_outname namelist,time_control 1 "auxhist9_d_" - "name of auxhist9 outfile" "" "" -rconfig character auxhist10_outname namelist,time_control 1 "auxhist10_d_" - "name of auxhist10 outfile" "" "" -rconfig character auxhist11_outname namelist,time_control 1 "auxhist11_d_" - "name of auxhist11 outfile" "" "" - -rconfig character history_inname namelist,time_control 1 "wrfhist_d_" - "name of history infile" "" "" -rconfig character auxhist1_inname namelist,time_control 1 "auxhist1_d_" - "name of auxhist1 infile" "" "" -rconfig character auxhist2_inname namelist,time_control 1 "auxhist2_d_" - "name of auxhist2 infile" "" "" -rconfig character auxhist3_inname namelist,time_control 1 "auxhist3_d_" - "name of auxhist3 infile" "" "" -rconfig character auxhist4_inname namelist,time_control 1 "auxhist4_d_" - "name of auxhist4 infile" "" "" -rconfig character auxhist5_inname namelist,time_control 1 "auxhist5_d_" - "name of auxhist5 infile" "" "" -rconfig character auxhist6_inname namelist,time_control 1 "auxhist6_d_" - "name of auxhist6 infile" "" "" -rconfig character auxhist7_inname namelist,time_control 1 "auxhist7_d_" - "name of auxhist7 infile" "" "" -rconfig character auxhist8_inname namelist,time_control 1 "auxhist8_d_" - "name of auxhist8 infile" "" "" -rconfig character auxhist9_inname namelist,time_control 1 "auxhist9_d_" - "name of auxhist9 infile" "" "" -rconfig character auxhist10_inname namelist,time_control 1 "auxhist10_d_" - "name of auxhist10 infile" "" "" -rconfig character auxhist11_inname namelist,time_control 1 "auxhist11_d_" - "name of auxhist11 infile" "" "" - -rconfig character auxinput1_outname namelist,time_control 1 "auxinput1_d_" - "name of auxinput1 outfile" "" "" -rconfig character auxinput2_outname namelist,time_control 1 "auxinput2_d_" - "name of auxinput2 outfile" "" "" -rconfig character auxinput3_outname namelist,time_control 1 "auxinput3_d_" - "name of auxinput3 outfile" "" "" -rconfig character auxinput4_outname namelist,time_control 1 "auxinput4_d_" - "name of auxinput4 outfile" "" "" -rconfig character auxinput5_outname namelist,time_control 1 "auxinput5_d_" - "name of auxinput5 outfile" "" "" -rconfig character auxinput6_outname namelist,time_control 1 "auxinput6_d_" - "name of auxinput6 outfile" "" "" -rconfig character auxinput7_outname namelist,time_control 1 "auxinput7_d_" - "name of auxinput7 outfile" "" "" -rconfig character auxinput8_outname namelist,time_control 1 "auxinput8_d_" - "name of auxinput8 outfile" "" "" -rconfig character auxinput9_outname namelist,time_control 1 "auxinput9_d_" - "name of auxinput9 outfile" "" "" -rconfig character auxinput10_outname namelist,time_control 1 "auxinput10_d_" - "name of auxinput10 outfile" "" "" -rconfig character auxinput11_outname namelist,time_control 1 "auxinput11_d_" - "name of auxinput11 outfile" "" "" - -ifdef EM_CORE=1 -rconfig character auxinput1_inname namelist,time_control 1 "met_em.d." - "name of auxinput1 infile" "" "" -endif -ifdef NMM_CORE=1 -rconfig character auxinput1_inname namelist,time_control 1 "met_nmm.d." - "name of auxinput1 infile" "" "" -endif - -rconfig character auxinput2_inname namelist,time_control 1 "auxinput2_d" - "name of auxinput2 infile" "" "" -rconfig character auxinput3_inname namelist,time_control 1 "auxinput3_d" - "name of auxinput3 infile" "" "" -rconfig character auxinput4_inname namelist,time_control 1 "auxinput4_d" - "name of auxinput4 infile" "" "" -rconfig character auxinput5_inname namelist,time_control 1 "auxinput5_d" - "name of auxinput5 infile" "" "" -rconfig character auxinput6_inname namelist,time_control 1 "auxinput6_d" - "name of auxinput6 infile" "" "" -rconfig character auxinput7_inname namelist,time_control 1 "auxinput7_d" - "name of auxinput7 infile" "" "" -rconfig character auxinput8_inname namelist,time_control 1 "auxinput8_d" - "name of auxinput8 infile" "" "" -rconfig character sgfdda_inname namelist,fdda 1 "sgfdda_d" - "name of sgfdda infile" "" "" -rconfig character gfdda_inname namelist,fdda 1 "gfdda_d" - "name of gfdda infile" "" "" -rconfig character auxinput11_inname namelist,time_control 1 "auxinput11_d" - "name of auxinput11 infile" "" "" - -rconfig integer history_interval_d namelist,time_control max_domains 0 h "history_interval_d" "" "DAYS" -rconfig integer history_interval_h namelist,time_control max_domains 0 h "history_interval_h" "" "HOURS" -rconfig integer history_interval_m namelist,time_control max_domains 0 h "history_interval_m" "" "MINUTES" -rconfig integer history_interval_s namelist,time_control max_domains 0 h "history_interval_s" "" "SECONDS" - -rconfig integer inputout_interval_d namelist,time_control max_domains 0 h "inputout_interval_d" "" "DAYS" -rconfig integer inputout_interval_h namelist,time_control max_domains 0 h "inputout_interval_h" "" "HOURS" -rconfig integer inputout_interval_m namelist,time_control max_domains 0 h "inputout_interval_m" "" "MINUTES" -rconfig integer inputout_interval_s namelist,time_control max_domains 0 h "inputout_interval_s" "" "SECONDS" -rconfig integer inputout_interval namelist,time_control max_domains 0 h "inputout_interval" "" "MINUTES" - -rconfig integer auxhist1_interval_d namelist,time_control max_domains 0 h "auxhist1_interval_d" "" "DAYS" -rconfig integer auxhist1_interval_h namelist,time_control max_domains 0 h "auxhist1_interval_h" "" "HOURS" -rconfig integer auxhist1_interval_m namelist,time_control max_domains 0 h "auxhist1_interval_m" "" "MINUTES" -rconfig integer auxhist1_interval_s namelist,time_control max_domains 0 h "auxhist1_interval_s" "" "SECONDS" -rconfig integer auxhist1_interval namelist,time_control max_domains 0 h "auxhist1_interval" "" "MINUTES" - -rconfig integer auxhist2_interval_d namelist,time_control max_domains 0 h "auxhist2_interval_d" "" "DAYS" -rconfig integer auxhist2_interval_h namelist,time_control max_domains 0 h "auxhist2_interval_h" "" "HOURS" -rconfig integer auxhist2_interval_m namelist,time_control max_domains 0 h "auxhist2_interval_m" "" "MINUTES" -rconfig integer auxhist2_interval_s namelist,time_control max_domains 0 h "auxhist2_interval_s" "" "SECONDS" -rconfig integer auxhist2_interval namelist,time_control max_domains 0 h "auxhist2_interval" "" "MINUTES" - -rconfig integer auxhist3_interval_d namelist,time_control max_domains 0 h "auxhist3_interval_d" "" "DAYS" -rconfig integer auxhist3_interval_h namelist,time_control max_domains 0 h "auxhist3_interval_h" "" "HOURS" -rconfig integer auxhist3_interval_m namelist,time_control max_domains 0 h "auxhist3_interval_m" "" "MINUTES" -rconfig integer auxhist3_interval_s namelist,time_control max_domains 0 h "auxhist3_interval_s" "" "SECONDS" -rconfig integer auxhist3_interval namelist,time_control max_domains 0 h "auxhist3_interval" "" "MINUTES" - -rconfig integer auxhist4_interval_d namelist,time_control max_domains 0 h "auxhist4_interval_d" "" "DAYS" -rconfig integer auxhist4_interval_h namelist,time_control max_domains 0 h "auxhist4_interval_h" "" "HOURS" -rconfig integer auxhist4_interval_m namelist,time_control max_domains 0 h "auxhist4_interval_m" "" "MINUTES" -rconfig integer auxhist4_interval_s namelist,time_control max_domains 0 h "auxhist4_interval_s" "" "SECONDS" -rconfig integer auxhist4_interval namelist,time_control max_domains 0 h "auxhist4_interval" "" "MINUTES" - -rconfig integer auxhist5_interval_d namelist,time_control max_domains 0 h "auxhist5_interval_d" "" "DAYS" -rconfig integer auxhist5_interval_h namelist,time_control max_domains 0 h "auxhist5_interval_h" "" "HOURS" -rconfig integer auxhist5_interval_m namelist,time_control max_domains 0 h "auxhist5_interval_m" "" "MINUTES" -rconfig integer auxhist5_interval_s namelist,time_control max_domains 0 h "auxhist5_interval_s" "" "SECONDS" -rconfig integer auxhist5_interval namelist,time_control max_domains 0 h "auxhist5_interval" "" "MINUTES" - -rconfig integer auxhist6_interval_d namelist,time_control max_domains 0 h "auxhist6_interval_d" "" "DAYS" -rconfig integer auxhist6_interval_h namelist,time_control max_domains 0 h "auxhist6_interval_h" "" "HOURS" -rconfig integer auxhist6_interval_m namelist,time_control max_domains 0 h "auxhist6_interval_m" "" "MINUTES" -rconfig integer auxhist6_interval_s namelist,time_control max_domains 0 h "auxhist6_interval_s" "" "SECONDS" -rconfig integer auxhist6_interval namelist,time_control max_domains 0 h "auxhist6_interval" "" "MINUTES" - -rconfig integer auxhist7_interval_d namelist,time_control max_domains 0 h "auxhist7_interval_d" "" "DAYS" -rconfig integer auxhist7_interval_h namelist,time_control max_domains 0 h "auxhist7_interval_h" "" "HOURS" -rconfig integer auxhist7_interval_m namelist,time_control max_domains 0 h "auxhist7_interval_m" "" "MINUTES" -rconfig integer auxhist7_interval_s namelist,time_control max_domains 0 h "auxhist7_interval_s" "" "SECONDS" -rconfig integer auxhist7_interval namelist,time_control max_domains 0 h "auxhist7_interval" "" "MINUTES" - -rconfig integer auxhist8_interval_d namelist,time_control max_domains 0 h "auxhist8_interval_d" "" "DAYS" -rconfig integer auxhist8_interval_h namelist,time_control max_domains 0 h "auxhist8_interval_h" "" "HOURS" -rconfig integer auxhist8_interval_m namelist,time_control max_domains 0 h "auxhist8_interval_m" "" "MINUTES" -rconfig integer auxhist8_interval_s namelist,time_control max_domains 0 h "auxhist8_interval_s" "" "SECONDS" -rconfig integer auxhist8_interval namelist,time_control max_domains 0 h "auxhist8_interval" "" "MINUTES" - -rconfig integer auxhist9_interval_d namelist,time_control max_domains 0 h "auxhist9_interval_d" "" "DAYS" -rconfig integer auxhist9_interval_h namelist,time_control max_domains 0 h "auxhist9_interval_h" "" "HOURS" -rconfig integer auxhist9_interval_m namelist,time_control max_domains 0 h "auxhist9_interval_m" "" "MINUTES" -rconfig integer auxhist9_interval_s namelist,time_control max_domains 0 h "auxhist9_interval_s" "" "SECONDS" -rconfig integer auxhist9_interval namelist,time_control max_domains 0 h "auxhist9_interval" "" "MINUTES" - -rconfig integer auxhist10_interval_d namelist,time_control max_domains 0 h "auxhist10_interval_d" "" "DAYS" -rconfig integer auxhist10_interval_h namelist,time_control max_domains 0 h "auxhist10_interval_h" "" "HOURS" -rconfig integer auxhist10_interval_m namelist,time_control max_domains 0 h "auxhist10_interval_m" "" "MINUTES" -rconfig integer auxhist10_interval_s namelist,time_control max_domains 0 h "auxhist10_interval_s" "" "SECONDS" -rconfig integer auxhist10_interval namelist,time_control max_domains 0 h "auxhist10_interval" "" "MINUTES" - -rconfig integer auxhist11_interval_d namelist,time_control max_domains 0 h "auxhist11_interval_d" "" "DAYS" -rconfig integer auxhist11_interval_h namelist,time_control max_domains 0 h "auxhist11_interval_h" "" "HOURS" -rconfig integer auxhist11_interval_m namelist,time_control max_domains 0 h "auxhist11_interval_m" "" "MINUTES" -rconfig integer auxhist11_interval_s namelist,time_control max_domains 0 h "auxhist11_interval_s" "" "SECONDS" -rconfig integer auxhist11_interval namelist,time_control max_domains 0 h "auxhist11_interval" "" "MINUTES" - -rconfig integer auxinput1_interval_d namelist,time_control max_domains 0 h "auxinput1_interval_d" "" "DAYS" -rconfig integer auxinput1_interval_h namelist,time_control max_domains 0 h "auxinput1_interval_h" "" "HOURS" -rconfig integer auxinput1_interval_m namelist,time_control max_domains 0 h "auxinput1_interval_m" "" "MINUTES" -rconfig integer auxinput1_interval_s namelist,time_control max_domains 0 h "auxinput1_interval_s" "" "SECONDS" -rconfig integer auxinput1_interval namelist,time_control max_domains 0 h "auxinput1_interval" "" "MINUTES" - -rconfig integer auxinput2_interval_d namelist,time_control max_domains 0 h "auxinput2_interval_d" "" "DAYS" -rconfig integer auxinput2_interval_h namelist,time_control max_domains 0 h "auxinput2_interval_h" "" "HOURS" -rconfig integer auxinput2_interval_m namelist,time_control max_domains 0 h "auxinput2_interval_m" "" "MINUTES" -rconfig integer auxinput2_interval_s namelist,time_control max_domains 0 h "auxinput2_interval_s" "" "SECONDS" -rconfig integer auxinput2_interval namelist,time_control max_domains 0 h "auxinput2_interval" "" "MINUTES" - -rconfig integer auxinput3_interval_d namelist,time_control max_domains 0 h "auxinput3_interval_d" "" "DAYS" -rconfig integer auxinput3_interval_h namelist,time_control max_domains 0 h "auxinput3_interval_h" "" "HOURS" -rconfig integer auxinput3_interval_m namelist,time_control max_domains 0 h "auxinput3_interval_m" "" "MINUTES" -rconfig integer auxinput3_interval_s namelist,time_control max_domains 0 h "auxinput3_interval_s" "" "SECONDS" -rconfig integer auxinput3_interval namelist,time_control max_domains 0 h "auxinput3_interval" "" "MINUTES" - -rconfig integer auxinput4_interval_d namelist,time_control max_domains 0 h "auxinput4_interval_d" "" "DAYS" -rconfig integer auxinput4_interval_h namelist,time_control max_domains 0 h "auxinput4_interval_h" "" "HOURS" -rconfig integer auxinput4_interval_m namelist,time_control max_domains 0 h "auxinput4_interval_m" "" "MINUTES" -rconfig integer auxinput4_interval_s namelist,time_control max_domains 0 h "auxinput4_interval_s" "" "SECONDS" -rconfig integer auxinput4_interval namelist,time_control max_domains 0 h "auxinput4_interval" "" "MINUTES" - -rconfig integer auxinput5_interval_d namelist,time_control max_domains 0 h "auxinput5_interval_d" "" "DAYS" -rconfig integer auxinput5_interval_h namelist,time_control max_domains 0 h "auxinput5_interval_h" "" "HOURS" -rconfig integer auxinput5_interval_m namelist,time_control max_domains 0 h "auxinput5_interval_m" "" "MINUTES" -rconfig integer auxinput5_interval_s namelist,time_control max_domains 0 h "auxinput5_interval_s" "" "SECONDS" -rconfig integer auxinput5_interval namelist,time_control max_domains 0 h "auxinput5_interval" "" "MINUTES" - -rconfig integer auxinput6_interval_d namelist,time_control max_domains 0 h "auxinput6_interval_d" "" "DAYS" -rconfig integer auxinput6_interval_h namelist,time_control max_domains 0 h "auxinput6_interval_h" "" "HOURS" -rconfig integer auxinput6_interval_m namelist,time_control max_domains 0 h "auxinput6_interval_m" "" "MINUTES" -rconfig integer auxinput6_interval_s namelist,time_control max_domains 0 h "auxinput6_interval_s" "" "SECONDS" -rconfig integer auxinput6_interval namelist,time_control max_domains 0 h "auxinput6_interval" "" "MINUTES" - -rconfig integer auxinput7_interval_d namelist,time_control max_domains 0 h "auxinput7_interval_d" "" "DAYS" -rconfig integer auxinput7_interval_h namelist,time_control max_domains 0 h "auxinput7_interval_h" "" "HOURS" -rconfig integer auxinput7_interval_m namelist,time_control max_domains 0 h "auxinput7_interval_m" "" "MINUTES" -rconfig integer auxinput7_interval_s namelist,time_control max_domains 0 h "auxinput7_interval_s" "" "SECONDS" -rconfig integer auxinput7_interval namelist,time_control max_domains 0 h "auxinput7_interval" "" "MINUTES" - -rconfig integer auxinput8_interval_d namelist,time_control max_domains 0 h "auxinput8_interval_d" "" "DAYS" -rconfig integer auxinput8_interval_h namelist,time_control max_domains 0 h "auxinput8_interval_h" "" "HOURS" -rconfig integer auxinput8_interval_m namelist,time_control max_domains 0 h "auxinput8_interval_m" "" "MINUTES" -rconfig integer auxinput8_interval_s namelist,time_control max_domains 0 h "auxinput8_interval_s" "" "SECONDS" -rconfig integer auxinput8_interval namelist,time_control max_domains 0 h "auxinput8_interval" "" "MINUTES" - -rconfig integer sgfdda_interval_d namelist,fdda max_domains 0 h "sgfdda_interval_d" "" "DAYS" -rconfig integer sgfdda_interval_h namelist,fdda max_domains 0 h "sgfdda_interval_h" "" "HOURS" -rconfig integer sgfdda_interval_m namelist,fdda max_domains 0 h "sgfdda_interval_m" "" "MINUTES" -rconfig integer sgfdda_interval_s namelist,fdda max_domains 0 h "sgfdda_interval_s" "" "SECONDS" -rconfig integer sgfdda_interval namelist,fdda max_domains 0 h "sgfdda_interval" "" "MINUTES" - -rconfig integer gfdda_interval_d namelist,fdda max_domains 0 h "gfdda_interval_d" "" "DAYS" -rconfig integer gfdda_interval_h namelist,fdda max_domains 0 h "gfdda_interval_h" "" "HOURS" -rconfig integer gfdda_interval_m namelist,fdda max_domains 0 h "gfdda_interval_m" "" "MINUTES" -rconfig integer gfdda_interval_s namelist,fdda max_domains 0 h "gfdda_interval_s" "" "SECONDS" -rconfig integer gfdda_interval namelist,fdda max_domains 0 h "gfdda_interval" "" "MINUTES" - -rconfig integer auxinput11_interval_d namelist,time_control max_domains 0 h "auxinput11_interval_d" "" "DAYS" -rconfig integer auxinput11_interval_h namelist,time_control max_domains 0 h "auxinput11_interval_h" "" "HOURS" -rconfig integer auxinput11_interval_m namelist,time_control max_domains 0 h "auxinput11_interval_m" "" "MINUTES" -rconfig integer auxinput11_interval_s namelist,time_control max_domains 0 h "auxinput11_interval_s" "" "SECONDS" -rconfig integer auxinput11_interval namelist,time_control max_domains 0 h "auxinput11_interval" "" "MINUTES" - - -rconfig integer restart_interval_d namelist,time_control 1 0 h "restart_interval_d" "" "DAYS" -rconfig integer restart_interval_h namelist,time_control 1 0 h "restart_interval_h" "" "HOURS" -rconfig integer restart_interval_m namelist,time_control 1 0 h "restart_interval_m" "" "MINUTES" -rconfig integer restart_interval_s namelist,time_control 1 0 h "restart_interval_s" "" "SECONDS" - - -rconfig integer history_begin_y namelist,time_control max_domains 0 h "history_begin_y" "" "YEARS from start of run" -rconfig integer history_begin_d namelist,time_control max_domains 0 h "history_begin_d" "" "DAYS from start of run" -rconfig integer history_begin_h namelist,time_control max_domains 0 h "history_begin_h" "" "HOURS from start of run" -rconfig integer history_begin_m namelist,time_control max_domains 0 h "history_begin_m" "" "MINUTES from start of run" -rconfig integer history_begin_s namelist,time_control max_domains 0 h "history_begin_s" "" "SECONDS from start of run" - -rconfig integer inputout_begin_y namelist,time_control max_domains 0 h "inputout_begin_y" "" "YEARS from start of run" -rconfig integer inputout_begin_d namelist,time_control max_domains 0 h "inputout_begin_d" "" "DAYS from start of run" -rconfig integer inputout_begin_h namelist,time_control max_domains 0 h "inputout_begin_h" "" "HOURS from start of run" -rconfig integer inputout_begin_m namelist,time_control max_domains 0 h "inputout_begin_m" "" "MINUTES from start of run" -rconfig integer inputout_begin_s namelist,time_control max_domains 0 h "inputout_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist1_begin_y namelist,time_control max_domains 0 h "auxhist1_begin_y" "" "YEARS from start of run" -rconfig integer auxhist1_begin_d namelist,time_control max_domains 0 h "auxhist1_begin_d" "" "DAYS from start of run" -rconfig integer auxhist1_begin_h namelist,time_control max_domains 0 h "auxhist1_begin_h" "" "HOURS from start of run" -rconfig integer auxhist1_begin_m namelist,time_control max_domains 0 h "auxhist1_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist1_begin_s namelist,time_control max_domains 0 h "auxhist1_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist2_begin_y namelist,time_control max_domains 0 h "auxhist2_begin_y" "" "YEARS from start of run" -rconfig integer auxhist2_begin_d namelist,time_control max_domains 0 h "auxhist2_begin_d" "" "DAYS from start of run" -rconfig integer auxhist2_begin_h namelist,time_control max_domains 0 h "auxhist2_begin_h" "" "HOURS from start of run" -rconfig integer auxhist2_begin_m namelist,time_control max_domains 0 h "auxhist2_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist2_begin_s namelist,time_control max_domains 0 h "auxhist2_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist3_begin_y namelist,time_control max_domains 0 h "auxhist3_begin_y" "" "YEARS from start of run" -rconfig integer auxhist3_begin_d namelist,time_control max_domains 0 h "auxhist3_begin_d" "" "DAYS from start of run" -rconfig integer auxhist3_begin_h namelist,time_control max_domains 0 h "auxhist3_begin_h" "" "HOURS from start of run" -rconfig integer auxhist3_begin_m namelist,time_control max_domains 0 h "auxhist3_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist3_begin_s namelist,time_control max_domains 0 h "auxhist3_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist4_begin_y namelist,time_control max_domains 0 h "auxhist4_begin_y" "" "YEARS from start of run" -rconfig integer auxhist4_begin_d namelist,time_control max_domains 0 h "auxhist4_begin_d" "" "DAYS from start of run" -rconfig integer auxhist4_begin_h namelist,time_control max_domains 0 h "auxhist4_begin_h" "" "HOURS from start of run" -rconfig integer auxhist4_begin_m namelist,time_control max_domains 0 h "auxhist4_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist4_begin_s namelist,time_control max_domains 0 h "auxhist4_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist5_begin_y namelist,time_control max_domains 0 h "auxhist5_begin_y" "" "YEARS from start of run" -rconfig integer auxhist5_begin_d namelist,time_control max_domains 0 h "auxhist5_begin_d" "" "DAYS from start of run" -rconfig integer auxhist5_begin_h namelist,time_control max_domains 0 h "auxhist5_begin_h" "" "HOURS from start of run" -rconfig integer auxhist5_begin_m namelist,time_control max_domains 0 h "auxhist5_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist5_begin_s namelist,time_control max_domains 0 h "auxhist5_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist6_begin_y namelist,time_control max_domains 0 h "auxhist6_begin_y" "" "YEARS from start of run" -rconfig integer auxhist6_begin_d namelist,time_control max_domains 0 h "auxhist6_begin_d" "" "DAYS from start of run" -rconfig integer auxhist6_begin_h namelist,time_control max_domains 0 h "auxhist6_begin_h" "" "HOURS from start of run" -rconfig integer auxhist6_begin_m namelist,time_control max_domains 0 h "auxhist6_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist6_begin_s namelist,time_control max_domains 0 h "auxhist6_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist7_begin_y namelist,time_control max_domains 0 h "auxhist7_begin_y" "" "YEARS from start of run" -rconfig integer auxhist7_begin_d namelist,time_control max_domains 0 h "auxhist7_begin_d" "" "DAYS from start of run" -rconfig integer auxhist7_begin_h namelist,time_control max_domains 0 h "auxhist7_begin_h" "" "HOURS from start of run" -rconfig integer auxhist7_begin_m namelist,time_control max_domains 0 h "auxhist7_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist7_begin_s namelist,time_control max_domains 0 h "auxhist7_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist8_begin_y namelist,time_control max_domains 0 h "auxhist8_begin_y" "" "YEARS from start of run" -rconfig integer auxhist8_begin_d namelist,time_control max_domains 0 h "auxhist8_begin_d" "" "DAYS from start of run" -rconfig integer auxhist8_begin_h namelist,time_control max_domains 0 h "auxhist8_begin_h" "" "HOURS from start of run" -rconfig integer auxhist8_begin_m namelist,time_control max_domains 0 h "auxhist8_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist8_begin_s namelist,time_control max_domains 0 h "auxhist8_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist9_begin_y namelist,time_control max_domains 0 h "auxhist9_begin_y" "" "YEARS from start of run" -rconfig integer auxhist9_begin_d namelist,time_control max_domains 0 h "auxhist9_begin_d" "" "DAYS from start of run" -rconfig integer auxhist9_begin_h namelist,time_control max_domains 0 h "auxhist9_begin_h" "" "HOURS from start of run" -rconfig integer auxhist9_begin_m namelist,time_control max_domains 0 h "auxhist9_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist9_begin_s namelist,time_control max_domains 0 h "auxhist9_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist10_begin_y namelist,time_control max_domains 0 h "auxhist10_begin_y" "" "YEARS from start of run" -rconfig integer auxhist10_begin_d namelist,time_control max_domains 0 h "auxhist10_begin_d" "" "DAYS from start of run" -rconfig integer auxhist10_begin_h namelist,time_control max_domains 0 h "auxhist10_begin_h" "" "HOURS from start of run" -rconfig integer auxhist10_begin_m namelist,time_control max_domains 0 h "auxhist10_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist10_begin_s namelist,time_control max_domains 0 h "auxhist10_begin_s" "" "SECONDS from start of run" - -rconfig integer auxhist11_begin_y namelist,time_control max_domains 0 h "auxhist11_begin_y" "" "YEARS from start of run" -rconfig integer auxhist11_begin_d namelist,time_control max_domains 0 h "auxhist11_begin_d" "" "DAYS from start of run" -rconfig integer auxhist11_begin_h namelist,time_control max_domains 0 h "auxhist11_begin_h" "" "HOURS from start of run" -rconfig integer auxhist11_begin_m namelist,time_control max_domains 0 h "auxhist11_begin_m" "" "MINUTES from start of run" -rconfig integer auxhist11_begin_s namelist,time_control max_domains 0 h "auxhist11_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput1_begin_y namelist,time_control max_domains 0 h "auxinput1_begin_y" "" "YEARS from start of run" -rconfig integer auxinput1_begin_d namelist,time_control max_domains 0 h "auxinput1_begin_d" "" "DAYS from start of run" -rconfig integer auxinput1_begin_h namelist,time_control max_domains 0 h "auxinput1_begin_h" "" "HOURS from start of run" -rconfig integer auxinput1_begin_m namelist,time_control max_domains 0 h "auxinput1_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput1_begin_s namelist,time_control max_domains 0 h "auxinput1_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput2_begin_y namelist,time_control max_domains 0 h "auxinput2_begin_y" "" "YEARS from start of run" -rconfig integer auxinput2_begin_d namelist,time_control max_domains 0 h "auxinput2_begin_d" "" "DAYS from start of run" -rconfig integer auxinput2_begin_h namelist,time_control max_domains 0 h "auxinput2_begin_h" "" "HOURS from start of run" -rconfig integer auxinput2_begin_m namelist,time_control max_domains 0 h "auxinput2_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput2_begin_s namelist,time_control max_domains 0 h "auxinput2_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput3_begin_y namelist,time_control max_domains 0 h "auxinput3_begin_y" "" "YEARS from start of run" -rconfig integer auxinput3_begin_d namelist,time_control max_domains 0 h "auxinput3_begin_d" "" "DAYS from start of run" -rconfig integer auxinput3_begin_h namelist,time_control max_domains 0 h "auxinput3_begin_h" "" "HOURS from start of run" -rconfig integer auxinput3_begin_m namelist,time_control max_domains 0 h "auxinput3_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput3_begin_s namelist,time_control max_domains 0 h "auxinput3_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput4_begin_y namelist,time_control max_domains 0 h "auxinput4_begin_y" "" "YEARS from start of run" -rconfig integer auxinput4_begin_d namelist,time_control max_domains 0 h "auxinput4_begin_d" "" "DAYS from start of run" -rconfig integer auxinput4_begin_h namelist,time_control max_domains 0 h "auxinput4_begin_h" "" "HOURS from start of run" -rconfig integer auxinput4_begin_m namelist,time_control max_domains 0 h "auxinput4_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput4_begin_s namelist,time_control max_domains 0 h "auxinput4_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput5_begin_y namelist,time_control max_domains 0 h "auxinput5_begin_y" "" "YEARS from start of run" -rconfig integer auxinput5_begin_d namelist,time_control max_domains 0 h "auxinput5_begin_d" "" "DAYS from start of run" -rconfig integer auxinput5_begin_h namelist,time_control max_domains 0 h "auxinput5_begin_h" "" "HOURS from start of run" -rconfig integer auxinput5_begin_m namelist,time_control max_domains 0 h "auxinput5_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput5_begin_s namelist,time_control max_domains 0 h "auxinput5_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput6_begin_y namelist,time_control max_domains 0 h "auxinput6_begin_y" "" "YEARS from start of run" -rconfig integer auxinput6_begin_d namelist,time_control max_domains 0 h "auxinput6_begin_d" "" "DAYS from start of run" -rconfig integer auxinput6_begin_h namelist,time_control max_domains 0 h "auxinput6_begin_h" "" "HOURS from start of run" -rconfig integer auxinput6_begin_m namelist,time_control max_domains 0 h "auxinput6_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput6_begin_s namelist,time_control max_domains 0 h "auxinput6_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput7_begin_y namelist,time_control max_domains 0 h "auxinput7_begin_y" "" "YEARS from start of run" -rconfig integer auxinput7_begin_d namelist,time_control max_domains 0 h "auxinput7_begin_d" "" "DAYS from start of run" -rconfig integer auxinput7_begin_h namelist,time_control max_domains 0 h "auxinput7_begin_h" "" "HOURS from start of run" -rconfig integer auxinput7_begin_m namelist,time_control max_domains 0 h "auxinput7_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput7_begin_s namelist,time_control max_domains 0 h "auxinput7_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput8_begin_y namelist,time_control max_domains 0 h "auxinput8_begin_y" "" "YEARS from start of run" -rconfig integer auxinput8_begin_d namelist,time_control max_domains 0 h "auxinput8_begin_d" "" "DAYS from start of run" -rconfig integer auxinput8_begin_h namelist,time_control max_domains 0 h "auxinput8_begin_h" "" "HOURS from start of run" -rconfig integer auxinput8_begin_m namelist,time_control max_domains 0 h "auxinput8_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput8_begin_s namelist,time_control max_domains 0 h "auxinput8_begin_s" "" "SECONDS from start of run" - -rconfig integer sgfdda_begin_y namelist,fdda max_domains 0 h "sgfdda_begin_y" "" "YEARS from start of run" -rconfig integer sgfdda_begin_d namelist,fdda max_domains 0 h "sgfdda_begin_d" "" "DAYS from start of run" -rconfig integer sgfdda_begin_h namelist,fdda max_domains 0 h "sgfdda_begin_h" "" "HOURS from start of run" -rconfig integer sgfdda_begin_m namelist,fdda max_domains 0 h "sgfdda_begin_m" "" "MINUTES from start of run" -rconfig integer sgfdda_begin_s namelist,fdda max_domains 0 h "sgfdda_begin_s" "" "SECONDS from start of run" - -rconfig integer gfdda_begin_y namelist,fdda max_domains 0 h "gfdda_begin_y" "" "YEARS from start of run" -rconfig integer gfdda_begin_d namelist,fdda max_domains 0 h "gfdda_begin_d" "" "DAYS from start of run" -rconfig integer gfdda_begin_h namelist,fdda max_domains 0 h "gfdda_begin_h" "" "HOURS from start of run" -rconfig integer gfdda_begin_m namelist,fdda max_domains 0 h "gfdda_begin_m" "" "MINUTES from start of run" -rconfig integer gfdda_begin_s namelist,fdda max_domains 0 h "gfdda_begin_s" "" "SECONDS from start of run" - -rconfig integer auxinput11_begin_y namelist,time_control max_domains 0 h "auxinput11_begin_y" "" "YEARS from start of run" -rconfig integer auxinput11_begin_d namelist,time_control max_domains 0 h "auxinput11_begin_d" "" "DAYS from start of run" -rconfig integer auxinput11_begin_h namelist,time_control max_domains 0 h "auxinput11_begin_h" "" "HOURS from start of run" -rconfig integer auxinput11_begin_m namelist,time_control max_domains 0 h "auxinput11_begin_m" "" "MINUTES from start of run" -rconfig integer auxinput11_begin_s namelist,time_control max_domains 0 h "auxinput11_begin_s" "" "SECONDS from start of run" - -rconfig integer restart_begin_y namelist,time_control 1 0 h "restart_begin_y" "" "YEARS from start of run" -rconfig integer restart_begin_d namelist,time_control 1 0 h "restart_begin_d" "" "DAYS from start of run" -rconfig integer restart_begin_h namelist,time_control 1 0 h "restart_begin_h" "" "HOURS from start of run" -rconfig integer restart_begin_m namelist,time_control 1 0 h "restart_begin_m" "" "MINUTES from start of run" -rconfig integer restart_begin_s namelist,time_control 1 0 h "restart_begin_s" "" "SECONDS from start of run" - -rconfig integer history_end_y namelist,time_control max_domains 0 h "history_end_y" "" "YEARS from start of run" -rconfig integer history_end_d namelist,time_control max_domains 0 h "history_end_d" "" "DAYS from start of run" -rconfig integer history_end_h namelist,time_control max_domains 0 h "history_end_h" "" "HOURS from start of run" -rconfig integer history_end_m namelist,time_control max_domains 0 h "history_end_m" "" "MINUTES from start of run" -rconfig integer history_end_s namelist,time_control max_domains 0 h "history_end_s" "" "SECONDS from start of run" - -rconfig integer inputout_end_y namelist,time_control max_domains 0 h "inputout_end_y" "" "YEARS from start of run" -rconfig integer inputout_end_d namelist,time_control max_domains 0 h "inputout_end_d" "" "DAYS from start of run" -rconfig integer inputout_end_h namelist,time_control max_domains 0 h "inputout_end_h" "" "HOURS from start of run" -rconfig integer inputout_end_m namelist,time_control max_domains 0 h "inputout_end_m" "" "MINUTES from start of run" -rconfig integer inputout_end_s namelist,time_control max_domains 0 h "inputout_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist1_end_y namelist,time_control max_domains 0 h "auxhist1_end_y" "" "YEARS from start of run" -rconfig integer auxhist1_end_d namelist,time_control max_domains 0 h "auxhist1_end_d" "" "DAYS from start of run" -rconfig integer auxhist1_end_h namelist,time_control max_domains 0 h "auxhist1_end_h" "" "HOURS from start of run" -rconfig integer auxhist1_end_m namelist,time_control max_domains 0 h "auxhist1_end_m" "" "MINUTES from start of run" -rconfig integer auxhist1_end_s namelist,time_control max_domains 0 h "auxhist1_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist2_end_y namelist,time_control max_domains 0 h "auxhist2_end_y" "" "YEARS from start of run" -rconfig integer auxhist2_end_d namelist,time_control max_domains 0 h "auxhist2_end_d" "" "DAYS from start of run" -rconfig integer auxhist2_end_h namelist,time_control max_domains 0 h "auxhist2_end_h" "" "HOURS from start of run" -rconfig integer auxhist2_end_m namelist,time_control max_domains 0 h "auxhist2_end_m" "" "MINUTES from start of run" -rconfig integer auxhist2_end_s namelist,time_control max_domains 0 h "auxhist2_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist3_end_y namelist,time_control max_domains 0 h "auxhist3_end_y" "" "YEARS from start of run" -rconfig integer auxhist3_end_d namelist,time_control max_domains 0 h "auxhist3_end_d" "" "DAYS from start of run" -rconfig integer auxhist3_end_h namelist,time_control max_domains 0 h "auxhist3_end_h" "" "HOURS from start of run" -rconfig integer auxhist3_end_m namelist,time_control max_domains 0 h "auxhist3_end_m" "" "MINUTES from start of run" -rconfig integer auxhist3_end_s namelist,time_control max_domains 0 h "auxhist3_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist4_end_y namelist,time_control max_domains 0 h "auxhist4_end_y" "" "YEARS from start of run" -rconfig integer auxhist4_end_d namelist,time_control max_domains 0 h "auxhist4_end_d" "" "DAYS from start of run" -rconfig integer auxhist4_end_h namelist,time_control max_domains 0 h "auxhist4_end_h" "" "HOURS from start of run" -rconfig integer auxhist4_end_m namelist,time_control max_domains 0 h "auxhist4_end_m" "" "MINUTES from start of run" -rconfig integer auxhist4_end_s namelist,time_control max_domains 0 h "auxhist4_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist5_end_y namelist,time_control max_domains 0 h "auxhist5_end_y" "" "YEARS from start of run" -rconfig integer auxhist5_end_d namelist,time_control max_domains 0 h "auxhist5_end_d" "" "DAYS from start of run" -rconfig integer auxhist5_end_h namelist,time_control max_domains 0 h "auxhist5_end_h" "" "HOURS from start of run" -rconfig integer auxhist5_end_m namelist,time_control max_domains 0 h "auxhist5_end_m" "" "MINUTES from start of run" -rconfig integer auxhist5_end_s namelist,time_control max_domains 0 h "auxhist5_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist6_end_y namelist,time_control max_domains 0 h "auxhist6_end_y" "" "YEARS from start of run" -rconfig integer auxhist6_end_d namelist,time_control max_domains 0 h "auxhist6_end_d" "" "DAYS from start of run" -rconfig integer auxhist6_end_h namelist,time_control max_domains 0 h "auxhist6_end_h" "" "HOURS from start of run" -rconfig integer auxhist6_end_m namelist,time_control max_domains 0 h "auxhist6_end_m" "" "MINUTES from start of run" -rconfig integer auxhist6_end_s namelist,time_control max_domains 0 h "auxhist6_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist7_end_y namelist,time_control max_domains 0 h "auxhist7_end_y" "" "YEARS from start of run" -rconfig integer auxhist7_end_d namelist,time_control max_domains 0 h "auxhist7_end_d" "" "DAYS from start of run" -rconfig integer auxhist7_end_h namelist,time_control max_domains 0 h "auxhist7_end_h" "" "HOURS from start of run" -rconfig integer auxhist7_end_m namelist,time_control max_domains 0 h "auxhist7_end_m" "" "MINUTES from start of run" -rconfig integer auxhist7_end_s namelist,time_control max_domains 0 h "auxhist7_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist8_end_y namelist,time_control max_domains 0 h "auxhist8_end_y" "" "YEARS from start of run" -rconfig integer auxhist8_end_d namelist,time_control max_domains 0 h "auxhist8_end_d" "" "DAYS from start of run" -rconfig integer auxhist8_end_h namelist,time_control max_domains 0 h "auxhist8_end_h" "" "HOURS from start of run" -rconfig integer auxhist8_end_m namelist,time_control max_domains 0 h "auxhist8_end_m" "" "MINUTES from start of run" -rconfig integer auxhist8_end_s namelist,time_control max_domains 0 h "auxhist8_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist9_end_y namelist,time_control max_domains 0 h "auxhist9_end_y" "" "YEARS from start of run" -rconfig integer auxhist9_end_d namelist,time_control max_domains 0 h "auxhist9_end_d" "" "DAYS from start of run" -rconfig integer auxhist9_end_h namelist,time_control max_domains 0 h "auxhist9_end_h" "" "HOURS from start of run" -rconfig integer auxhist9_end_m namelist,time_control max_domains 0 h "auxhist9_end_m" "" "MINUTES from start of run" -rconfig integer auxhist9_end_s namelist,time_control max_domains 0 h "auxhist9_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist10_end_y namelist,time_control max_domains 0 h "auxhist10_end_y" "" "YEARS from start of run" -rconfig integer auxhist10_end_d namelist,time_control max_domains 0 h "auxhist10_end_d" "" "DAYS from start of run" -rconfig integer auxhist10_end_h namelist,time_control max_domains 0 h "auxhist10_end_h" "" "HOURS from start of run" -rconfig integer auxhist10_end_m namelist,time_control max_domains 0 h "auxhist10_end_m" "" "MINUTES from start of run" -rconfig integer auxhist10_end_s namelist,time_control max_domains 0 h "auxhist10_end_s" "" "SECONDS from start of run" - -rconfig integer auxhist11_end_y namelist,time_control max_domains 0 h "auxhist11_end_y" "" "YEARS from start of run" -rconfig integer auxhist11_end_d namelist,time_control max_domains 0 h "auxhist11_end_d" "" "DAYS from start of run" -rconfig integer auxhist11_end_h namelist,time_control max_domains 0 h "auxhist11_end_h" "" "HOURS from start of run" -rconfig integer auxhist11_end_m namelist,time_control max_domains 0 h "auxhist11_end_m" "" "MINUTES from start of run" -rconfig integer auxhist11_end_s namelist,time_control max_domains 0 h "auxhist11_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput1_end_y namelist,time_control max_domains 0 h "auxinput1_end_y" "" "YEARS from start of run" -rconfig integer auxinput1_end_d namelist,time_control max_domains 0 h "auxinput1_end_d" "" "DAYS from start of run" -rconfig integer auxinput1_end_h namelist,time_control max_domains 0 h "auxinput1_end_h" "" "HOURS from start of run" -rconfig integer auxinput1_end_m namelist,time_control max_domains 0 h "auxinput1_end_m" "" "MINUTES from start of run" -rconfig integer auxinput1_end_s namelist,time_control max_domains 0 h "auxinput1_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput2_end_y namelist,time_control max_domains 0 h "auxinput2_end_y" "" "YEARS from start of run" -rconfig integer auxinput2_end_d namelist,time_control max_domains 0 h "auxinput2_end_d" "" "DAYS from start of run" -rconfig integer auxinput2_end_h namelist,time_control max_domains 0 h "auxinput2_end_h" "" "HOURS from start of run" -rconfig integer auxinput2_end_m namelist,time_control max_domains 0 h "auxinput2_end_m" "" "MINUTES from start of run" -rconfig integer auxinput2_end_s namelist,time_control max_domains 0 h "auxinput2_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput3_end_y namelist,time_control max_domains 0 h "auxinput3_end_y" "" "YEARS from start of run" -rconfig integer auxinput3_end_d namelist,time_control max_domains 0 h "auxinput3_end_d" "" "DAYS from start of run" -rconfig integer auxinput3_end_h namelist,time_control max_domains 0 h "auxinput3_end_h" "" "HOURS from start of run" -rconfig integer auxinput3_end_m namelist,time_control max_domains 0 h "auxinput3_end_m" "" "MINUTES from start of run" -rconfig integer auxinput3_end_s namelist,time_control max_domains 0 h "auxinput3_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput4_end_y namelist,time_control max_domains 0 h "auxinput4_end_y" "" "YEARS from start of run" -rconfig integer auxinput4_end_d namelist,time_control max_domains 0 h "auxinput4_end_d" "" "DAYS from start of run" -rconfig integer auxinput4_end_h namelist,time_control max_domains 0 h "auxinput4_end_h" "" "HOURS from start of run" -rconfig integer auxinput4_end_m namelist,time_control max_domains 0 h "auxinput4_end_m" "" "MINUTES from start of run" -rconfig integer auxinput4_end_s namelist,time_control max_domains 0 h "auxinput4_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput5_end_y namelist,time_control max_domains 0 h "auxinput5_end_y" "" "YEARS from start of run" -rconfig integer auxinput5_end_d namelist,time_control max_domains 0 h "auxinput5_end_d" "" "DAYS from start of run" -rconfig integer auxinput5_end_h namelist,time_control max_domains 0 h "auxinput5_end_h" "" "HOURS from start of run" -rconfig integer auxinput5_end_m namelist,time_control max_domains 0 h "auxinput5_end_m" "" "MINUTES from start of run" -rconfig integer auxinput5_end_s namelist,time_control max_domains 0 h "auxinput5_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput6_end_y namelist,time_control max_domains 0 h "auxinput6_end_y" "" "YEARS from start of run" -rconfig integer auxinput6_end_d namelist,time_control max_domains 0 h "auxinput6_end_d" "" "DAYS from start of run" -rconfig integer auxinput6_end_h namelist,time_control max_domains 0 h "auxinput6_end_h" "" "HOURS from start of run" -rconfig integer auxinput6_end_m namelist,time_control max_domains 0 h "auxinput6_end_m" "" "MINUTES from start of run" -rconfig integer auxinput6_end_s namelist,time_control max_domains 0 h "auxinput6_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput7_end_y namelist,time_control max_domains 0 h "auxinput7_end_y" "" "YEARS from start of run" -rconfig integer auxinput7_end_d namelist,time_control max_domains 0 h "auxinput7_end_d" "" "DAYS from start of run" -rconfig integer auxinput7_end_h namelist,time_control max_domains 0 h "auxinput7_end_h" "" "HOURS from start of run" -rconfig integer auxinput7_end_m namelist,time_control max_domains 0 h "auxinput7_end_m" "" "MINUTES from start of run" -rconfig integer auxinput7_end_s namelist,time_control max_domains 0 h "auxinput7_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput8_end_y namelist,time_control max_domains 0 h "auxinput8_end_y" "" "YEARS from start of run" -rconfig integer auxinput8_end_d namelist,time_control max_domains 0 h "auxinput8_end_d" "" "DAYS from start of run" -rconfig integer auxinput8_end_h namelist,time_control max_domains 0 h "auxinput8_end_h" "" "HOURS from start of run" -rconfig integer auxinput8_end_m namelist,time_control max_domains 0 h "auxinput8_end_m" "" "MINUTES from start of run" -rconfig integer auxinput8_end_s namelist,time_control max_domains 0 h "auxinput8_end_s" "" "SECONDS from start of run" - -rconfig integer sgfdda_end_y namelist,fdda max_domains 0 h "sgfdda_end_y" "" "YEARS from start of run" -rconfig integer sgfdda_end_d namelist,fdda max_domains 0 h "sgfdda_end_d" "" "DAYS from start of run" -rconfig integer sgfdda_end_h namelist,fdda max_domains 0 h "sgfdda_end_h" "" "HOURS from start of run" -rconfig integer sgfdda_end_m namelist,fdda max_domains 0 h "sgfdda_end_m" "" "MINUTES from start of run" -rconfig integer sgfdda_end_s namelist,fdda max_domains 0 h "sgfdda_end_s" "" "SECONDS from start of run" - -rconfig integer gfdda_end_y namelist,fdda max_domains 0 h "gfdda_end_y" "" "YEARS from start of run" -rconfig integer gfdda_end_d namelist,fdda max_domains 0 h "gfdda_end_d" "" "DAYS from start of run" -rconfig integer gfdda_end_h namelist,fdda max_domains 0 h "gfdda_end_h" "" "HOURS from start of run" -rconfig integer gfdda_end_m namelist,fdda max_domains 0 h "gfdda_end_m" "" "MINUTES from start of run" -rconfig integer gfdda_end_s namelist,fdda max_domains 0 h "gfdda_end_s" "" "SECONDS from start of run" - -rconfig integer auxinput11_end_y namelist,time_control max_domains 0 h "auxinput11_end_y" "" "YEARS from start of run" -rconfig integer auxinput11_end_d namelist,time_control max_domains 0 h "auxinput11_end_d" "" "DAYS from start of run" -rconfig integer auxinput11_end_h namelist,time_control max_domains 0 h "auxinput11_end_h" "" "HOURS from start of run" -rconfig integer auxinput11_end_m namelist,time_control max_domains 0 h "auxinput11_end_m" "" "MINUTES from start of run" -rconfig integer auxinput11_end_s namelist,time_control max_domains 0 h "auxinput11_end_s" "" "SECONDS from start of run" - -rconfig integer io_form_auxinput1 namelist,time_control 1 2 h "io_form_auxinput1" "" "" -rconfig integer io_form_auxinput2 namelist,time_control 1 2 h "io_form_auxinput2" "" "" -rconfig integer io_form_auxinput3 namelist,time_control 1 2 h "io_form_auxinput3" "" "" -rconfig integer io_form_auxinput4 namelist,time_control 1 2 h "io_form_auxinput4" "" "" -rconfig integer io_form_auxinput5 namelist,time_control 1 2 h "io_form_auxinput5" "" "" -rconfig integer io_form_auxinput6 namelist,time_control 1 2 h "io_form_auxinput6" "" "" -rconfig integer io_form_auxinput7 namelist,time_control 1 2 h "io_form_auxinput7" "" "" -rconfig integer io_form_auxinput8 namelist,time_control 1 2 h "io_form_auxinput8" "" "" -rconfig integer io_form_sgfdda namelist,fdda 1 2 h "io_form_sgfdda" "" "" -rconfig integer io_form_gfdda namelist,fdda 1 2 h "io_form_gfdda" "" "" -rconfig integer io_form_auxinput11 namelist,time_control 1 2 h "io_form_auxinput11" "" "" -rconfig integer io_form_auxhist1 namelist,time_control 1 2 h "io_form_auxhist1" "" "" -rconfig integer io_form_auxhist2 namelist,time_control 1 2 h "io_form_auxhist2" "" "" -rconfig integer io_form_auxhist3 namelist,time_control 1 2 h "io_form_auxhist3" "" "" -rconfig integer io_form_auxhist4 namelist,time_control 1 2 h "io_form_auxhist4" "" "" -rconfig integer io_form_auxhist5 namelist,time_control 1 2 h "io_form_auxhist5" "" "" -rconfig integer io_form_auxhist6 namelist,time_control 1 2 h "io_form_auxhist6" "" "" -rconfig integer io_form_auxhist7 namelist,time_control 1 2 h "io_form_auxhist7" "" "" -rconfig integer io_form_auxhist8 namelist,time_control 1 2 h "io_form_auxhist8" "" "" -rconfig integer io_form_auxhist9 namelist,time_control 1 2 h "io_form_auxhist9" "" "" -rconfig integer io_form_auxhist10 namelist,time_control 1 2 h "io_form_auxhist10" "" "" -rconfig integer io_form_auxhist11 namelist,time_control 1 2 h "io_form_auxhist11" "" "" - -rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" -rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" -rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" -rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" -rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" -rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" -rconfig logical reset_simulation_start namelist,time_control 1 .false. h "reset_simulation_start" "set simulation start date equal to start date of this run" "logical" - -rconfig integer sr_x namelist,domains max_domains 0 -rconfig integer sr_y namelist,domains max_domains 0 - + +# registry.io_boilerplate +# +# Included by registry program +# +# Contains a number of standard state variables associated with I/O +# +# + + +# these definitions supercede the definitions in the io_boilerplate_temporary.inc file that follows +ifdef EM_CORE=1 +rconfig character auxinput1_inname namelist,time_control 1 "met_em.d." - "name of auxinput1 infile" "" "" +rconfig integer io_form_auxinput1 namelist,time_control 1 2 +endif +ifdef NMM_CORE=1 +rconfig character auxinput1_inname namelist,time_control 1 "met_nmm.d." - "name of auxinput1 infile" "" "" +rconfig integer io_form_auxinput1 namelist,time_control 1 2 +endif + +# the following file is automatically generated by the registry before reading the registry file. +# see comment above about how to supercede these automatically generated definitions +include io_boilerplate_temporary.inc + +# Output file descriptor for a domain +state integer oid - - - - - "oid" "" "" +rconfig integer history_interval namelist,time_control max_domains 0 h "history_interval" "" "MINUTES" +rconfig integer frames_per_outfile namelist,time_control max_domains 10 h "frames_per_outfile" "" "" +rconfig logical restart namelist,time_control 1 .false. h "restart" "" "" +rconfig integer restart_interval namelist,time_control 1 0 h "restart_interval" "" "MINUTES" +rconfig integer io_form_input namelist,time_control 1 2 h "io_form_input" "" "" +rconfig integer io_form_history namelist,time_control 1 2 h "io_form_history" "" "" +rconfig integer io_form_restart namelist,time_control 1 2 h "io_form_restart" "" "" +rconfig integer io_form_boundary namelist,time_control 1 2 h "io_form_boundary" "" "" +rconfig integer debug_level namelist,time_control 1 0 - "debug_level" "" "" +rconfig logical self_test_domain namelist,time_control 1 .false. - "self_test_domain" "" "" +rconfig character history_outname namelist,time_control 1 "wrfout_d_" - "name of history outfile" "" "" +rconfig character history_inname namelist,time_control 1 "wrfhist_d_" - "name of history infile" "" "" + +rconfig integer history_interval_d namelist,time_control max_domains 0 h "history_interval_d" "" "DAYS" +rconfig integer history_interval_h namelist,time_control max_domains 0 h "history_interval_h" "" "HOURS" +rconfig integer history_interval_m namelist,time_control max_domains 0 h "history_interval_m" "" "MINUTES" +rconfig integer history_interval_s namelist,time_control max_domains 0 h "history_interval_s" "" "SECONDS" + +rconfig integer inputout_interval_d namelist,time_control max_domains 0 h "inputout_interval_d" "" "DAYS" +rconfig integer inputout_interval_h namelist,time_control max_domains 0 h "inputout_interval_h" "" "HOURS" +rconfig integer inputout_interval_m namelist,time_control max_domains 0 h "inputout_interval_m" "" "MINUTES" +rconfig integer inputout_interval_s namelist,time_control max_domains 0 h "inputout_interval_s" "" "SECONDS" +rconfig integer inputout_interval namelist,time_control max_domains 0 h "inputout_interval" "" "MINUTES" + +rconfig integer restart_interval_d namelist,time_control 1 0 h "restart_interval_d" "" "DAYS" +rconfig integer restart_interval_h namelist,time_control 1 0 h "restart_interval_h" "" "HOURS" +rconfig integer restart_interval_m namelist,time_control 1 0 h "restart_interval_m" "" "MINUTES" +rconfig integer restart_interval_s namelist,time_control 1 0 h "restart_interval_s" "" "SECONDS" + +rconfig integer history_begin_y namelist,time_control max_domains 0 h "history_begin_y" "" "YEARS from start of run" +rconfig integer history_begin_d namelist,time_control max_domains 0 h "history_begin_d" "" "DAYS from start of run" +rconfig integer history_begin_h namelist,time_control max_domains 0 h "history_begin_h" "" "HOURS from start of run" +rconfig integer history_begin_m namelist,time_control max_domains 0 h "history_begin_m" "" "MINUTES from start of run" +rconfig integer history_begin_s namelist,time_control max_domains 0 h "history_begin_s" "" "SECONDS from start of run" + +rconfig integer inputout_begin_y namelist,time_control max_domains 0 h "inputout_begin_y" "" "YEARS from start of run" +rconfig integer inputout_begin_d namelist,time_control max_domains 0 h "inputout_begin_d" "" "DAYS from start of run" +rconfig integer inputout_begin_h namelist,time_control max_domains 0 h "inputout_begin_h" "" "HOURS from start of run" +rconfig integer inputout_begin_m namelist,time_control max_domains 0 h "inputout_begin_m" "" "MINUTES from start of run" +rconfig integer inputout_begin_s namelist,time_control max_domains 0 h "inputout_begin_s" "" "SECONDS from start of run" + +rconfig integer restart_begin_y namelist,time_control 1 0 h "restart_begin_y" "" "YEARS from start of run" +rconfig integer restart_begin_d namelist,time_control 1 0 h "restart_begin_d" "" "DAYS from start of run" +rconfig integer restart_begin_h namelist,time_control 1 0 h "restart_begin_h" "" "HOURS from start of run" +rconfig integer restart_begin_m namelist,time_control 1 0 h "restart_begin_m" "" "MINUTES from start of run" +rconfig integer restart_begin_s namelist,time_control 1 0 h "restart_begin_s" "" "SECONDS from start of run" + +rconfig integer history_end_y namelist,time_control max_domains 0 h "history_end_y" "" "YEARS from start of run" +rconfig integer history_end_d namelist,time_control max_domains 0 h "history_end_d" "" "DAYS from start of run" +rconfig integer history_end_h namelist,time_control max_domains 0 h "history_end_h" "" "HOURS from start of run" +rconfig integer history_end_m namelist,time_control max_domains 0 h "history_end_m" "" "MINUTES from start of run" +rconfig integer history_end_s namelist,time_control max_domains 0 h "history_end_s" "" "SECONDS from start of run" +rconfig integer inputout_end_y namelist,time_control max_domains 0 h "inputout_end_y" "" "YEARS from start of run" +rconfig integer inputout_end_d namelist,time_control max_domains 0 h "inputout_end_d" "" "DAYS from start of run" +rconfig integer inputout_end_h namelist,time_control max_domains 0 h "inputout_end_h" "" "HOURS from start of run" +rconfig integer inputout_end_m namelist,time_control max_domains 0 h "inputout_end_m" "" "MINUTES from start of run" +rconfig integer inputout_end_s namelist,time_control max_domains 0 h "inputout_end_s" "" "SECONDS from start of run" + +rconfig integer simulation_start_year derived 1 0 - "simulation_start_year" "start of simulation through restarts" "4-digit year" +rconfig integer simulation_start_month derived 1 0 - "simulation_start_month" "start of simulation through restarts" "2-digit month" +rconfig integer simulation_start_day derived 1 0 - "simulation_start_day" "start of simulation through restarts" "2-digit day" +rconfig integer simulation_start_hour derived 1 0 - "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +rconfig integer simulation_start_minute derived 1 0 - "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +rconfig integer simulation_start_second derived 1 0 - "simulation_start_second" "start of simulation through restarts" "2-digit second" +rconfig logical reset_simulation_start namelist,time_control 1 .false. h "reset_simulation_start" "set simulation start date equal to start date of this run" "logical" + +rconfig integer sr_x namelist,domains max_domains 0 +rconfig integer sr_y namelist,domains max_domains 0 + +ifdef EM_CORE=1 +rconfig character sgfdda_inname namelist,fdda 1 "sgfdda_d" - "name of sgfdda infile" "" "" +rconfig character gfdda_inname namelist,fdda 1 "gfdda_d" - "name of gfdda infile" "" "" +rconfig integer sgfdda_interval_d namelist,fdda max_domains 0 h "sgfdda_interval_d" "" "DAYS" +rconfig integer sgfdda_interval_h namelist,fdda max_domains 0 h "sgfdda_interval_h" "" "HOURS" +rconfig integer sgfdda_interval_m namelist,fdda max_domains 0 h "sgfdda_interval_m" "" "MINUTES" +rconfig integer sgfdda_interval_s namelist,fdda max_domains 0 h "sgfdda_interval_s" "" "SECONDS" +rconfig integer sgfdda_interval_y namelist,fdda max_domains 0 h "sgfdda_interval_y" "" "YEARS" +rconfig integer sgfdda_interval namelist,fdda max_domains 0 h "sgfdda_interval" "" "MINUTES" +rconfig integer gfdda_interval_d namelist,fdda max_domains 0 h "gfdda_interval_d" "" "DAYS" +rconfig integer gfdda_interval_h namelist,fdda max_domains 0 h "gfdda_interval_h" "" "HOURS" +rconfig integer gfdda_interval_m namelist,fdda max_domains 0 h "gfdda_interval_m" "" "MINUTES" +rconfig integer gfdda_interval_s namelist,fdda max_domains 0 h "gfdda_interval_s" "" "SECONDS" +rconfig integer gfdda_interval_y namelist,fdda max_domains 0 h "gfdda_interval_y" "" "YEARS" +rconfig integer gfdda_interval namelist,fdda max_domains 0 h "gfdda_interval" "" "MINUTES" +rconfig integer sgfdda_begin_y namelist,fdda max_domains 0 h "sgfdda_begin_y" "" "YEARS from start of run" +rconfig integer sgfdda_begin_d namelist,fdda max_domains 0 h "sgfdda_begin_d" "" "DAYS from start of run" +rconfig integer sgfdda_begin_h namelist,fdda max_domains 0 h "sgfdda_begin_h" "" "HOURS from start of run" +rconfig integer sgfdda_begin_m namelist,fdda max_domains 0 h "sgfdda_begin_m" "" "MINUTES from start of run" +rconfig integer sgfdda_begin_s namelist,fdda max_domains 0 h "sgfdda_begin_s" "" "SECONDS from start of run" +rconfig integer gfdda_begin_y namelist,fdda max_domains 0 h "gfdda_begin_y" "" "YEARS from start of run" +rconfig integer gfdda_begin_d namelist,fdda max_domains 0 h "gfdda_begin_d" "" "DAYS from start of run" +rconfig integer gfdda_begin_h namelist,fdda max_domains 0 h "gfdda_begin_h" "" "HOURS from start of run" +rconfig integer gfdda_begin_m namelist,fdda max_domains 0 h "gfdda_begin_m" "" "MINUTES from start of run" +rconfig integer gfdda_begin_s namelist,fdda max_domains 0 h "gfdda_begin_s" "" "SECONDS from start of run" +rconfig integer sgfdda_end_y namelist,fdda max_domains 0 h "sgfdda_end_y" "" "YEARS from start of run" +rconfig integer sgfdda_end_d namelist,fdda max_domains 0 h "sgfdda_end_d" "" "DAYS from start of run" +rconfig integer sgfdda_end_h namelist,fdda max_domains 0 h "sgfdda_end_h" "" "HOURS from start of run" +rconfig integer sgfdda_end_m namelist,fdda max_domains 0 h "sgfdda_end_m" "" "MINUTES from start of run" +rconfig integer sgfdda_end_s namelist,fdda max_domains 0 h "sgfdda_end_s" "" "SECONDS from start of run" +rconfig integer gfdda_end_y namelist,fdda max_domains 0 h "gfdda_end_y" "" "YEARS from start of run" +rconfig integer gfdda_end_d namelist,fdda max_domains 0 h "gfdda_end_d" "" "DAYS from start of run" +rconfig integer gfdda_end_h namelist,fdda max_domains 0 h "gfdda_end_h" "" "HOURS from start of run" +rconfig integer gfdda_end_m namelist,fdda max_domains 0 h "gfdda_end_m" "" "MINUTES from start of run" +rconfig integer gfdda_end_s namelist,fdda max_domains 0 h "gfdda_end_s" "" "SECONDS from start of run" +rconfig integer io_form_sgfdda namelist,fdda 1 2 h "io_form_sgfdda" "" "" +rconfig integer io_form_gfdda namelist,fdda 1 2 h "io_form_gfdda" "" "" +endif + +# for reading in stream variable-set reconfiguration information at run time +rconfig character iofields_filename namelist,time_control max_domains "NONE_SPECIFIED" +rconfig logical ignore_iofields_warning namelist,time_control 1 .true. + diff --git a/wrfv2_fire/arch/Config_new.pl b/wrfv2_fire/arch/Config_new.pl index 946c057d..094d2f15 100644 --- a/wrfv2_fire/arch/Config_new.pl +++ b/wrfv2_fire/arch/Config_new.pl @@ -30,6 +30,7 @@ $sw_nmm_core = "-DNMM_CORE=\$\(WRF_NMM_CORE\)" ; $sw_em_core = "-DEM_CORE=\$\(WRF_EM_CORE\)" ; $sw_exp_core = "-DEXP_CORE=\$\(WRF_EXP_CORE\)" ; $sw_coamps_core = "-DCOAMPS_CORE=\$\(WRF_COAMPS_CORE\)" ; +$sw_dfi_radar = "-DDFI_RADAR=\$\(WRF_DFI_RADAR\)" ; $sw_dmparallel = "" ; $sw_ompparallel = "" ; $sw_stubmpi = "" ; @@ -58,6 +59,7 @@ while ( substr( $ARGV[0], 0, 1 ) eq "-" ) if ( substr( $ARGV[0], 1, 3 ) eq "os=" ) { $sw_os = substr( $ARGV[0], 4 ) ; +printf "sw_os $sw_os\n" ; } if ( substr( $ARGV[0], 1, 5 ) eq "mach=" ) { @@ -92,6 +94,7 @@ while ( substr( $ARGV[0], 0, 1 ) eq "-" ) $sw_nmm_core = "-DNMM_CORE=0" ; $sw_exp_core = "-DEXP_CORE=0" ; $sw_coamps_core = "-DCOAMPS_CORE=0" ; + $sw_dfi_radar = "-DDFI_RADAR=0" ; } if ( index ( $sw_wrf_core , "DA_CORE" ) > -1 ) { @@ -100,6 +103,16 @@ while ( substr( $ARGV[0], 0, 1 ) eq "-" ) $sw_nmm_core = "-DNMM_CORE=0" ; $sw_exp_core = "-DEXP_CORE=0" ; $sw_coamps_core = "-DCOAMPS_CORE=0" ; + $sw_dfi_radar = "-DDFI_RADAR=0" ; + } + if ( index ( $sw_wrf_core , "DFI_RADAR" ) > -1 ) + { + $sw_em_core = "-DEM_CORE=1" ; + $sw_da_core = "-DDA_CORE=0" ; + $sw_nmm_core = "-DNMM_CORE=0" ; + $sw_exp_core = "-DEXP_CORE=0" ; + $sw_coamps_core = "-DCOAMPS_CORE=0" ; + $sw_dfi_radar = "-DDFI_RADAR=1" ; } if ( index ( $sw_wrf_core , "NMM_CORE" ) > -1 ) { @@ -108,6 +121,7 @@ while ( substr( $ARGV[0], 0, 1 ) eq "-" ) $sw_nmm_core = "-DNMM_CORE=1" ; $sw_exp_core = "-DEXP_CORE=0" ; $sw_coamps_core = "-DCOAMPS_CORE=0" ; + $sw_dfi_radar = "-DDFI_RADAR=0" ; } if ( index ( $sw_wrf_core , "EXP_CORE" ) > -1 ) { @@ -116,6 +130,7 @@ while ( substr( $ARGV[0], 0, 1 ) eq "-" ) $sw_nmm_core = "-DNMM_CORE=0" ; $sw_exp_core = "-DEXP_CORE=1" ; $sw_coamps_core = "-DCOAMPS_CORE=0" ; + $sw_dfi_radar = "-DDFI_RADAR=0" ; } if ( index ( $sw_wrf_core , "COAMPS_CORE" ) > -1 ) { @@ -124,6 +139,7 @@ while ( substr( $ARGV[0], 0, 1 ) eq "-" ) $sw_nmm_core = "-DNMM_CORE=0" ; $sw_exp_core = "-DEXP_CORE=0" ; $sw_coamps_core = "-DCOAMPS_CORE=1" ; + $sw_dfi_radar = "-DDFI_RADAR=0" ; } } if ( substr( $ARGV[0], 1, 13 ) eq "compileflags=" ) @@ -301,6 +317,9 @@ while ( ) $_ =~ s/CONFIGURE_COMMS_LIB/$sw_comms_lib/g ; $_ =~ s/CONFIGURE_COMMS_INCLUDE/$sw_comms_include/g ; $_ =~ s/CONFIGURE_COMMS_EXTERNAL/$sw_comms_external/g ; + if ( $sw_os ne "CYGWIN_NT" ) { + $_ =~ s/#NOWIN// ; + } $_ =~ s/CONFIGURE_DMPARALLEL/$sw_dmparallelflag/g ; $_ =~ s/CONFIGURE_STUBMPI/$sw_stubmpi/g ; $_ =~ s/CONFIGURE_NESTOPT/$sw_nest_opt/g ; @@ -450,7 +469,7 @@ while ( ) $response = 1 ; } elsif ( $ENV{HWRF} ) { printf "HWRF requires moving nests"; - $response = 2; + $response = "2\n"; } else { $response = ; } @@ -547,6 +566,7 @@ while ( ) $_ =~ s:CONFIGURE_NMM_CORE:$sw_nmm_core:g ; $_ =~ s:CONFIGURE_COAMPS_CORE:$sw_coamps_core:g ; $_ =~ s:CONFIGURE_EXP_CORE:$sw_exp_core:g ; + $_ =~ s:CONFIGURE_DFI_RADAR:$sw_dfi_radar:g ; @preamble = ( @preamble, $_ ) ; } diff --git a/wrfv2_fire/arch/configure_new.defaults b/wrfv2_fire/arch/configure_new.defaults index 2e9ee656..2fc66c47 100644 --- a/wrfv2_fire/arch/configure_new.defaults +++ b/wrfv2_fire/arch/configure_new.defaults @@ -27,7 +27,8 @@ FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-none FCSUFFIX = BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -65,7 +66,8 @@ FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-huge FCSUFFIX = BYTESWAPIO = -fendian=big -FCBASEOPTS = -Wno=101,139,155,158 $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -103,7 +105,8 @@ FORMAT_FIXED = -Mfixed FORMAT_FREE = -Mfree FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -141,7 +144,8 @@ FORMAT_FIXED = -Mfixed FORMAT_FREE = -Mfree FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -206,7 +210,8 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian -FCBASEOPTS = -w -ftz -align all -fno-alias -fp-model precise $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -279,8 +284,9 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian -FCBASEOPTS = -w -ftz -align all -fno-alias -fp-model precise $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) -#FCBASEOPTS = -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) +#FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lmpi MODULE_SRCH_FLAG = TRADFLAG = -traditional @@ -356,8 +362,9 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian -FCBASEOPTS = -w -ftz -align all -fno-alias -fp-model precise $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) -#FCBASEOPTS = -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) +#FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lmpi MODULE_SRCH_FLAG = TRADFLAG = -traditional @@ -396,7 +403,8 @@ FORMAT_FIXED = -fixedform FORMAT_FREE = -freeform FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w -fno-second-underscore $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w -fno-second-underscore $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -434,7 +442,8 @@ FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-none FCSUFFIX = BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = /lib/cpp -C -P @@ -472,7 +481,8 @@ FORMAT_FIXED = -Mfixed FORMAT_FREE = -Mfree FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional CPP = cpp -C -P -xassembler-with-cpp @@ -512,7 +522,8 @@ FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian # added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name -FCBASEOPTS = -w -ftz -align all -fno-alias -fp-model precise -fno-common $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -fp-model precise -fno-common $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = cpp -C -P -xassembler-with-cpp @@ -552,7 +563,8 @@ FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian # added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name -FCBASEOPTS = -w -ftz -align all -fno-alias -fp-model precise -fno-common $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -fp-model precise -fno-common $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = cpp -C -P -xassembler-with-cpp @@ -577,7 +589,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DG95 -DMACOS -DF2CSTYLE -DNO_RRTM_PHYSICS -DNONSTANDARD_SYSTEM_SUBR +ARCH_LOCAL = -DG95 -DMACOS -DF2CSTYLE -DNO_RRTM_PHYSICS -DNONSTANDARD_SYSTEM_SUBR -DRCONFIG_CHARLEN=64 CFLAGS_LOCAL = -DMACOS -DF2CSTYLE LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -590,7 +602,8 @@ FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-huge FCSUFFIX = BYTESWAPIO = -fendian=big -FCBASEOPTS = -Wno=101,139,155,158 $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lSystemStubs MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional @@ -631,7 +644,8 @@ FORMAT_FIXED = -qfixed FORMAT_FREE = -qfree=f90 FCSUFFIX = -qsuffix=f=f90 BYTESWAPIO = -FCBASEOPTS = -qsave $(FCDEBUG) -qmaxmem=32767 -qspillsize=32767 -w +FCBASEOPTS_NO_G = -qsave -qmaxmem=32767 -qspillsize=32767 -w +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main TRADFLAG = CPP = cpp -C -P @@ -671,7 +685,8 @@ FORMAT_FIXED = -qfixed FORMAT_FREE = -qfree=f90 FCSUFFIX = -qsuffix=f=f90 BYTESWAPIO = -FCBASEOPTS = -w -qspill=20000 -qmaxmem=32767 $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF +FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=32767 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = CPP = /lib/cpp -C -P @@ -714,7 +729,8 @@ FORMAT_FIXED = -Mfixed FORMAT_FREE = -Mfree FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = /lib/cpp -C -P $(TRADFLAG) @@ -764,7 +780,8 @@ FORMAT_FIXED = -Mfixed FORMAT_FREE = -Mfree FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = /lib/cpp -C -P $(TRADFLAG) @@ -811,7 +828,8 @@ FORMAT_FIXED = -fixedform FORMAT_FREE = -freeform FCSUFFIX = BYTESWAPIO = -byteswapio -FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional CPP = /lib/cpp -C -P $(TRADFLAG) @@ -853,7 +871,8 @@ FORMAT_FIXED = -qfixed FORMAT_FREE = -qfree=f90 FCSUFFIX = -qsuffix=f=f90 BYTESWAPIO = -FCBASEOPTS = -w -qspill=20000 -qmaxmem=64000 $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) $(MPI_INC) #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) $(MPI_INC) #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = # this might be different on different systems but we want the xlf version of cpp, not Linux's @@ -897,7 +916,8 @@ FORMAT_FIXED = -qfixed FORMAT_FREE = -qfree=f90 FCSUFFIX = -qsuffix=f=f90 BYTESWAPIO = -FCBASEOPTS = -w -qspill=20000 -qmaxmem=64000 $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = # this might be different on different systems but we want the xlf version of cpp, not Linux's @@ -937,7 +957,8 @@ FORMAT_FIXED = -qfixed FORMAT_FREE = -qfree=f90 FCSUFFIX = -qsuffix=f=f90 BYTESWAPIO = -FCBASEOPTS = -w -qspill=20000 -qmaxmem=32767 $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=32767 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = # this might be different on different systems but we want the xlf version of cpp, not Linux @@ -948,5 +969,58 @@ M4 = m4 -B 14000 RANLIB = ranlib CC_TOOLS = xlc -q64 ########################################################### +#ARCH CYGWIN_NT i686, PGI compiler on Windows # serial smpar dmpar dm+sm +# +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -mp -Minfo=mp +SFC = pgf90 +SCC = pgcc +DM_FC = pgf90 -Mmpi=msmpi +DM_CC = pgcc -Mmpi=msmpi +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -r$(RWORDSIZE) -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR +CFLAGS_LOCAL = -w -O3 -DMEMCPY_FOR_BCOPY -DLANDREAD_STUB +LDFLAGS_LOCAL = Ws2_32.lib # -lnetcdff +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -fastsse -Mvect=noaltcode -Mprefetch=distance:8 -Mfprelaxed -tp core2-64 # -Minfo=all +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) +FORMAT_FIXED = -Mfixed +FORMAT_FREE = -Mfree +FCSUFFIX = +BYTESWAPIO = -byteswapio +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG= -module $(WRF_SRC_ROOT_DIR)/main +TRADFLAG = +CPP = pgprepro +AR = ar +ARFLAGS = cr +M4 = NA +RANLIB = ranlib +CC_TOOLS = $(SCC) + +LIB_EXTERNAL = \ + ../external/io_netcdf/libwrfio_nf.a CONFIGURE_NETCDF_PATH/lib/libnetcdf.lib +ESMF_IO_LIB = ../external/esmf_time_f90/libesmf_time.a +LIB_BUNDLED = \ + ../external/fftpack/fftpack5/libfftpack.a \ + ../external/io_grib1/libio_grib1.a \ + ../external/io_grib_share/libio_grib_share.a \ + ../external/io_int/libwrfio_int.a \ + $(ESMF_IO_LIB) \ + CONFIGURE_COMMS_LIB \ + ../frame/module_internal_header_util.o \ + ../frame/pack_utils.o + + +########################################################### #ARCH NULL diff --git a/wrfv2_fire/arch/noopt_exceptions b/wrfv2_fire/arch/noopt_exceptions index 4400d3ec..faba7cb8 100644 --- a/wrfv2_fire/arch/noopt_exceptions +++ b/wrfv2_fire/arch/noopt_exceptions @@ -9,11 +9,25 @@ mediation_force_domain.o : mediation_force_domain.F mediation_integrate.o : mediation_integrate.F mediation_interp_domain.o : mediation_interp_domain.F module_comm_dm.o : module_comm_dm.F +module_comm_dm_0.o : module_comm_dm_0.F +module_comm_dm_1.o : module_comm_dm_1.F +module_comm_dm_2.o : module_comm_dm_2.F +module_comm_dm_3.o : module_comm_dm_3.F +module_comm_nesting_dm.o : module_comm_nesting_dm.F module_configure.o : module_configure.F module_dm.o : module_dm.F module_domain.o : module_domain.F module_domain_type.o : module_domain_type.F -module_alloc_space.o : module_alloc_space.F +module_alloc_space_0.o : module_alloc_space_0.F +module_alloc_space_1.o : module_alloc_space_1.F +module_alloc_space_2.o : module_alloc_space_2.F +module_alloc_space_3.o : module_alloc_space_3.F +module_alloc_space_4.o : module_alloc_space_4.F +module_alloc_space_5.o : module_alloc_space_5.F +module_alloc_space_6.o : module_alloc_space_6.F +module_alloc_space_7.o : module_alloc_space_7.F +module_alloc_space_8.o : module_alloc_space_8.F +module_alloc_space_9.o : module_alloc_space_9.F module_tiles.o : module_tiles.F module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F module_initialize.o : module_initialize.F @@ -223,12 +237,23 @@ wrf_inputout.o \ wrf_restartin.o \ wrf_restartout.o \ module_state_description.o \ -nl_set_0_routines.o \ -nl_set_1_routines.o \ -nl_get_0_routines.o \ -nl_get_1_routines.o \ module_alloc_space.o \ +module_alloc_space_0.o \ +module_alloc_space_1.o \ +module_alloc_space_2.o \ +module_alloc_space_3.o \ +module_alloc_space_4.o \ +module_alloc_space_5.o \ +module_alloc_space_6.o \ +module_alloc_space_7.o \ +module_alloc_space_8.o \ +module_alloc_space_9.o \ module_comm_dm.o \ +module_comm_dm_0.o \ +module_comm_dm_1.o \ +module_comm_dm_2.o \ +module_comm_dm_3.o \ +module_comm_nesting_dm.o \ module_configure.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb diff --git a/wrfv2_fire/arch/noopt_exceptions_f b/wrfv2_fire/arch/noopt_exceptions_f index 1d352da6..5767a2a1 100644 --- a/wrfv2_fire/arch/noopt_exceptions_f +++ b/wrfv2_fire/arch/noopt_exceptions_f @@ -12,11 +12,25 @@ init_modules_em.o : init_modules_em.F input_wrf.o : input_wrf.F module_io.o : module_io.F module_comm_dm.o : module_comm_dm.F +module_comm_dm_0.o : module_comm_dm_0.F +module_comm_dm_1.o : module_comm_dm_1.F +module_comm_dm_2.o : module_comm_dm_2.F +module_comm_dm_3.o : module_comm_dm_3.F +module_comm_nesting_dm.o : module_comm_nesting_dm.F module_configure.o : module_configure.F module_dm.o : module_dm.F module_domain.o : module_domain.F module_domain_type.o : module_domain_type.F -module_alloc_space.o : module_alloc_space.F +module_alloc_space_0.o : module_alloc_space_0.F +module_alloc_space_1.o : module_alloc_space_1.F +module_alloc_space_2.o : module_alloc_space_2.F +module_alloc_space_3.o : module_alloc_space_3.F +module_alloc_space_4.o : module_alloc_space_4.F +module_alloc_space_5.o : module_alloc_space_5.F +module_alloc_space_6.o : module_alloc_space_6.F +module_alloc_space_7.o : module_alloc_space_7.F +module_alloc_space_8.o : module_alloc_space_8.F +module_alloc_space_9.o : module_alloc_space_9.F module_tiles.o : module_tiles.F module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F module_initialize.o : module_initialize.F @@ -39,50 +53,6 @@ solve_interface.o : solve_interface.F start_domain.o : start_domain.F start_domain_nmm.o : start_domain_nmm.F start_em.o : start_em.F -wrf_auxhist10in.o : wrf_auxhist10in.F -wrf_auxhist10out.o : wrf_auxhist10out.F -wrf_auxhist11in.o : wrf_auxhist11in.F -wrf_auxhist11out.o : wrf_auxhist11out.F -wrf_auxhist1in.o : wrf_auxhist1in.F -wrf_auxhist1out.o : wrf_auxhist1out.F -wrf_auxhist2in.o : wrf_auxhist2in.F -wrf_auxhist2out.o : wrf_auxhist2out.F -wrf_auxhist3in.o : wrf_auxhist3in.F -wrf_auxhist3out.o : wrf_auxhist3out.F -wrf_auxhist4in.o : wrf_auxhist4in.F -wrf_auxhist4out.o : wrf_auxhist4out.F -wrf_auxhist5in.o : wrf_auxhist5in.F -wrf_auxhist5out.o : wrf_auxhist5out.F -wrf_auxhist6in.o : wrf_auxhist6in.F -wrf_auxhist6out.o : wrf_auxhist6out.F -wrf_auxhist7in.o : wrf_auxhist7in.F -wrf_auxhist7out.o : wrf_auxhist7out.F -wrf_auxhist8in.o : wrf_auxhist8in.F -wrf_auxhist8out.o : wrf_auxhist8out.F -wrf_auxhist9in.o : wrf_auxhist9in.F -wrf_auxhist9out.o : wrf_auxhist9out.F -wrf_auxinput10in.o : wrf_auxinput10in.F -wrf_auxinput10out.o : wrf_auxinput10out.F -wrf_auxinput11in.o : wrf_auxinput11in.F -wrf_auxinput11out.o : wrf_auxinput11out.F -wrf_auxinput1in.o : wrf_auxinput1in.F -wrf_auxinput1out.o : wrf_auxinput1out.F -wrf_auxinput2in.o : wrf_auxinput2in.F -wrf_auxinput2out.o : wrf_auxinput2out.F -wrf_auxinput3in.o : wrf_auxinput3in.F -wrf_auxinput3out.o : wrf_auxinput3out.F -wrf_auxinput4in.o : wrf_auxinput4in.F -wrf_auxinput4out.o : wrf_auxinput4out.F -wrf_auxinput5in.o : wrf_auxinput5in.F -wrf_auxinput5out.o : wrf_auxinput5out.F -wrf_auxinput6in.o : wrf_auxinput6in.F -wrf_auxinput6out.o : wrf_auxinput6out.F -wrf_auxinput7in.o : wrf_auxinput7in.F -wrf_auxinput7out.o : wrf_auxinput7out.F -wrf_auxinput8in.o : wrf_auxinput8in.F -wrf_auxinput8out.o : wrf_auxinput8out.F -wrf_auxinput9in.o : wrf_auxinput9in.F -wrf_auxinput9out.o : wrf_auxinput9out.F wrf_bdyin.o : wrf_bdyin.F wrf_bdyout.o : wrf_bdyout.F wrf_ext_read_field.o : wrf_ext_read_field.F @@ -166,50 +136,6 @@ module_domain.o \ module_domain_type.o \ module_physics_init.o \ module_io.o \ -wrf_auxhist10in.o \ -wrf_auxhist10out.o \ -wrf_auxhist11in.o \ -wrf_auxhist11out.o \ -wrf_auxhist1in.o \ -wrf_auxhist1out.o \ -wrf_auxhist2in.o \ -wrf_auxhist2out.o \ -wrf_auxhist3in.o \ -wrf_auxhist3out.o \ -wrf_auxhist4in.o \ -wrf_auxhist4out.o \ -wrf_auxhist5in.o \ -wrf_auxhist5out.o \ -wrf_auxhist6in.o \ -wrf_auxhist6out.o \ -wrf_auxhist7in.o \ -wrf_auxhist7out.o \ -wrf_auxhist8in.o \ -wrf_auxhist8out.o \ -wrf_auxhist9in.o \ -wrf_auxhist9out.o \ -wrf_auxinput10in.o \ -wrf_auxinput10out.o \ -wrf_auxinput11in.o \ -wrf_auxinput11out.o \ -wrf_auxinput1in.o \ -wrf_auxinput1out.o \ -wrf_auxinput2in.o \ -wrf_auxinput2out.o \ -wrf_auxinput3in.o \ -wrf_auxinput3out.o \ -wrf_auxinput4in.o \ -wrf_auxinput4out.o \ -wrf_auxinput5in.o \ -wrf_auxinput5out.o \ -wrf_auxinput6in.o \ -wrf_auxinput6out.o \ -wrf_auxinput7in.o \ -wrf_auxinput7out.o \ -wrf_auxinput8in.o \ -wrf_auxinput8out.o \ -wrf_auxinput9in.o \ -wrf_auxinput9out.o \ wrf_bdyin.o \ wrf_bdyout.o \ wrf_ext_read_field.o \ @@ -221,12 +147,23 @@ wrf_inputout.o \ wrf_restartin.o \ wrf_restartout.o \ module_state_description.o \ -nl_set_0_routines.o \ -nl_set_1_routines.o \ -nl_get_0_routines.o \ -nl_get_1_routines.o \ module_alloc_space.o \ +module_alloc_space_0.o \ +module_alloc_space_1.o \ +module_alloc_space_2.o \ +module_alloc_space_3.o \ +module_alloc_space_4.o \ +module_alloc_space_5.o \ +module_alloc_space_6.o \ +module_alloc_space_7.o \ +module_alloc_space_8.o \ +module_alloc_space_9.o \ module_comm_dm.o \ +module_comm_dm_0.o \ +module_comm_dm_1.o \ +module_comm_dm_2.o \ +module_comm_dm_3.o \ +module_comm_nesting_dm.o \ module_configure.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb diff --git a/wrfv2_fire/arch/postamble_new b/wrfv2_fire/arch/postamble_new index 35f8b60f..f2efab73 100644 --- a/wrfv2_fire/arch/postamble_new +++ b/wrfv2_fire/arch/postamble_new @@ -1,8 +1,9 @@ ###################### +# POSTAMBLE FGREP = fgrep -iq -ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \ +ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \ $(ARCH_LOCAL) \ $(DA_ARCHFLAGS) \ CONFIGURE_DMPARALLEL \ @@ -19,11 +20,13 @@ ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORD -DLIMIT_ARGS \ -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \ -DMAX_DOMAINS_F=$(MAX_DOMAINS) \ + -DMAX_HISTORY=$(MAX_HISTORY) \ -DNMM_NEST=$(WRF_NMM_NEST) -CFLAGS = $(CFLAGS_LOCAL) CONFIGURE_DMPARALLEL CONFIGURE_STUBMPI +CFLAGS = $(CFLAGS_LOCAL) CONFIGURE_DMPARALLEL CONFIGURE_STUBMPI \ + -DMAX_HISTORY=$(MAX_HISTORY) FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) ESMF_LIB_FLAGS = ESMFLIBFLAG -ESMF_IO_LIB = ESMFIOLIB +#NOWIN ESMF_IO_LIB = ESMFIOLIB ESMF_IO_LIB_EXT = ESMFIOEXTLIB INCLUDE_MODULES = $(MODULE_SRCH_FLAG) \ $(ESMF_MOD_INC) $(ESMF_LIB_FLAGS) \ @@ -38,19 +41,18 @@ INCLUDE_MODULES = $(MODULE_SRCH_FLAG) \ CONFIGURE_RTTOV_INC REGISTRY = Registry -LIB_BUNDLED = \ - -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \ - -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \ - -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \ - -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \ - $(ESMF_IO_LIB) \ - $(ESMF_IO_LIB) \ - CONFIGURE_COMMS_LIB \ - $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \ - $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o - -LIB_EXTERNAL = \ - CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH CONFIGURE_GRIB2_LIB CONFIGURE_ATMPOM_LIB +#NOWIN LIB_BUNDLED = \ +#NOWIN $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \ +#NOWIN $(WRF_SRC_ROOT_DIR)/external/io_grib1/libio_grib1.a \ +#NOWIN $(WRF_SRC_ROOT_DIR)/external/io_grib_share/libio_grib_share.a \ +#NOWIN $(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \ +#NOWIN $(ESMF_IO_LIB) \ +#NOWIN CONFIGURE_COMMS_LIB \ +#NOWIN $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \ +#NOWIN $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o + +#NOWIN LIB_EXTERNAL = \ +#NOWIN CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH CONFIGURE_GRIB2_LIB CONFIGURE_ATMPOM_LIB LIB = $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL) LDFLAGS = $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) CONFIGURE_LDFLAGS diff --git a/wrfv2_fire/arch/preamble_new b/wrfv2_fire/arch/preamble_new index c7ecebd2..c50a4932 100644 --- a/wrfv2_fire/arch/preamble_new +++ b/wrfv2_fire/arch/preamble_new @@ -21,6 +21,7 @@ COREDEFS = CONFIGURE_EM_CORE \ CONFIGURE_NMM_CORE -DNMM_MAX_DIM=2600 \ CONFIGURE_COAMPS_CORE \ CONFIGURE_DA_CORE \ + CONFIGURE_DFI_RADAR \ CONFIGURE_EXP_CORE #### Single location for defining total number of domains. You need @@ -33,6 +34,13 @@ MAX_DOMAINS = 21 CONFIG_BUF_LEN = 32768 +#### Size of bitmasks (in 4byte integers) of stream masks for WRF I/O + +MAX_HISTORY = 25 + +IWORDSIZE = 4 +DWORDSIZE = 8 +LWORDSIZE = 4 ############################################################################## #### The settings in this section are defaults that may be overridden by the diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags index e5c77ec6..8d1c8b69 100644 --- a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags @@ -1 +1 @@ - -Aa + diff --git a/wrfv2_fire/chem/KPP/util/wkc/Makefile b/wrfv2_fire/chem/KPP/util/wkc/Makefile index 49031993..fb38d6f2 100644 --- a/wrfv2_fire/chem/KPP/util/wkc/Makefile +++ b/wrfv2_fire/chem/KPP/util/wkc/Makefile @@ -20,7 +20,7 @@ registry : $(OBJ) $(SCC) -o registry_kpp $(DEBUG) $(LDFLAGS) $(OBJ) .c.o : - $(SCC) $(CFLAGS) -c $(DEBUG) $< + $(SCC) -I../../../../inc $(CFLAGS) -c $(DEBUG) $< clean: /bin/rm -f $(OBJ) gen_comms.c diff --git a/wrfv2_fire/chem/Makefile b/wrfv2_fire/chem/Makefile index d189032e..118f4db7 100755 --- a/wrfv2_fire/chem/Makefile +++ b/wrfv2_fire/chem/Makefile @@ -9,11 +9,11 @@ MODULES = \ module_chem_utilities.o \ module_data_radm2.o \ module_data_sorgam.o \ - module_data_isrpia.o \ - module_isrpia.o \ - module_input_chem_emissopt3.o \ module_plumerise1.o \ + module_input_tracer.o \ + module_input_tracer_data.o \ module_add_emiss_burn.o \ + module_aer_opt_out.o \ module_zero_plumegen_coms.o \ module_chem_plumerise_scalar.o \ module_data_cbmz.o \ @@ -81,7 +81,10 @@ MODULES = \ module_cmu_bulkaqchem.o \ module_mosaic_cloudchem.o \ module_wetscav_driver.o \ - module_mixactivate_wrappers.o + module_lightning_driver.o \ + module_ltng_crm.o \ + module_mixactivate_wrappers.o \ + module_aer_drydep.o OBJS = \ @@ -108,6 +111,10 @@ clean: # DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) +module_lightning_driver.o: module_ltng_crm.o + +module_ltng_crm.o: + module_mixactivate_wrappers.o: ../phys/module_mixactivate.o module_data_radm2.o: @@ -170,9 +177,11 @@ module_ftuv_subs.o: module_wave_data.o: -module_input_chem_data.o: module_aerosols_sorgam.o +module_input_tracer.o: module_input_tracer_data.o module_input_chem_data.o -module_input_chem_emissopt3.o: +module_input_tracer_data.o: + +module_input_chem_data.o: module_aerosols_sorgam.o module_input_chem_bioemiss.o: @@ -184,6 +193,8 @@ module_dep_simple.o: module_bioemi_simple.o: +module_aer_opt_out.o: + module_data_megan2.o: module_data_mgn2mech.o: @@ -196,12 +207,6 @@ module_emissions_anthropogenics.o: module_data_sorgam.o: -module_data_isrpia.o: - -module_isrpia.o: module_data_isrpia.o module_mosaic_addemiss.o - -module_aerosols_sorgam.o: module_isrpia.o - module_cbmz_lsodes_solver.o: module_cbmz_rodas3_solver.o: @@ -216,7 +221,9 @@ module_data_mosaic_therm.o: module_mosaic_addemiss.o: module_data_mosaic_asect.o -module_aerosols_sorgam.o: module_mosaic_addemiss.F +module_mosaic_wetscav.o: module_dep_simple.o + +module_aerosols_sorgam.o: module_mosaic_addemiss.o module_radm.o module_mosaic_wetscav.o module_mosaic_drydep.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o @@ -250,6 +257,8 @@ module_ctrans_grell.o: module_convtrans_prep.o: +module_aer_drydep.o: module_aerosols_sorgam.o module_mosaic_drydep.o + chem_driver.o: module_radm.o module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o chemics_init.o: module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_mixactivate_wrappers.o @@ -262,9 +271,11 @@ photolysis_driver.o: module_phot_mad.o module_phot_fastj.o module_ftuv_driver.o mechanism_driver.o: module_data_radm2.o module_radm.o module_aerosols_sorgam.o module_data_cbmz.o module_cbmz.o -emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis313.o module_bioemi_megan2.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_mosaic_addemiss.o module_aerosols_sorgam.o module_plumerise1.o module_gocart_dust.o module_gocart_seasalt.o +optical_driver.o: module_optical_averaging.o + +emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis313.o module_bioemi_megan2.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_mosaic_addemiss.o module_aerosols_sorgam.o module_plumerise1.o module_gocart_dust.o module_gocart_seasalt.o module_lightning_driver.o -dry_dep_driver.o: module_data_radm2.o module_dep_simple.o module_aerosols_sorgam.o module_mosaic_drydep.o ../phys/module_mixactivate.o +dry_dep_driver.o: module_data_radm2.o module_aer_drydep.o module_dep_simple.o module_aerosols_sorgam.o module_mosaic_drydep.o ../phys/module_mixactivate.o convert_gocart : convert_gocart.o $(RANLIB) ../main/$(LIBWRFLIB) diff --git a/wrfv2_fire/chem/aerosol_driver.F b/wrfv2_fire/chem/aerosol_driver.F index 564b4a98..bdea28bb 100755 --- a/wrfv2_fire/chem/aerosol_driver.F +++ b/wrfv2_fire/chem/aerosol_driver.F @@ -168,7 +168,7 @@ ! cps_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) + CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2,MOZCART_KPP) call gocart_aerosols_driver(ktauc,dtstepc,config_flags,t_phy,moist, & chem,rho_phy,dz8w,p8w,dx,g, & ids,ide, jds,jde, kds,kde, & @@ -277,7 +277,7 @@ ! sum_pm_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) + CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2,MOZCART_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_gocart') CALL sum_pm_gocart ( & alt, chem,pm2_5_dry, pm2_5_dry_ec, pm10, & diff --git a/wrfv2_fire/chem/chem_driver.F b/wrfv2_fire/chem/chem_driver.F index c79106f5..6bfbfdb7 100755 --- a/wrfv2_fire/chem/chem_driver.F +++ b/wrfv2_fire/chem/chem_driver.F @@ -38,9 +38,11 @@ USE module_dep_simple USE module_bioemi_simple USE module_phot_mad +! USE module_ftuv_driver, only : ftuv_timestep_init USE module_aerosols_sorgam USE module_chem_utilities USE module_gocart_so2so4 + USE module_aer_opt_out,only: aer_opt_out USE module_ctrans_grell USE module_convtrans_prep USE module_dry_dep_driver @@ -50,7 +52,7 @@ #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) chem_dbg, & #endif - get_last_gas + get_last_gas,mozcart_lbc_set IMPLICIT NONE ! Input data. @@ -106,7 +108,7 @@ REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: & p_phy,u_phy,v_phy & ,t_phy,dz8w,t8w,p8w & - ,rho,rri,z_at_w,vvel,zmid + ,rho,rri,z_at_w,vvel,zmid,rh REAL,DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: pbl_h REAL,DIMENSION(grid%sm32:grid%em32-1) :: QL,TL REAL,DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: REXNSFC,FACTRS & @@ -281,6 +283,14 @@ ! !initialize ! + if (config_flags%lightning_opt > 0 ) then +! initialize lightning flash rates + IF ( ktau==1 ) then + grid%ic_flshrate(:,:) = 0. + grid%cg_flshrate(:,:) = 0. + ENDIF + ENDIF + #if ( NMM_CORE == 1 ) !*** IN NMM SET CONTROLS FOR TILES TO PATCHES ! @@ -383,6 +393,9 @@ CASE (CBMZ_BB) CALL wrf_debug(15,'calling cbmz_bb from chem_driver') haveaer = .false. + CASE (CBMZ_BB_KPP) + CALL wrf_debug(15,'calling cbmz_bb_kpp from chem_driver') + haveaer = .false. CASE (CBMZ_MOSAIC_4BIN) CALL wrf_debug(15,'calling cbmz_mosaic_4bin aerosols driver from chem_driver') haveaer = .true. @@ -395,11 +408,30 @@ CASE (CBMZ_MOSAIC_8BIN_AQ) CALL wrf_debug(15,'calling cbmz_mosaic_8bin_aq aerosols driver from chem_driver') haveaer = .true. + CASE (MOZART_KPP) + CALL wrf_debug(15,'calling mozart driver from chem_driver') + CASE (MOZCART_KPP) + CALL wrf_debug(15,'calling mozcart driver from chem_driver') CASE (CHEM_TRACER,CHEM_TRACE2) CALL wrf_debug(15,'tracer mode: only doing emissions and dry dep in chem_driver') CASE DEFAULT + if(config_flags%tracer_opt > 0 )then + CALL wrf_debug(15,'only doing tracer transport in chem_driver') + else CALL wrf_debug(15,'calling chem_opt=? from chem_driver') + endif END SELECT chem_select + tracer_select: SELECT CASE(config_flags%tracer_opt) + CASE (TRACER_SMOKE) + CALL wrf_debug(15,'tracer mode: 1 tracer for fires') + CASE (TRACER_ME) + CALL wrf_debug(15,'tracer mode: 8 tracers') + CASE (TRACER_SUS) + CALL wrf_debug(15,'tracer mode: ensemble of tracers') + CASE DEFAULT + CALL wrf_debug(15,'calling chem_opt=? from chem_driver') + END SELECT tracer_select + ! ! ! @@ -600,7 +632,7 @@ moist, num_3d_m, rho, & p_phy, u_phy, v_phy, & p8w, t_phy, t8w, grid%z, z_at_w, & - dz8w, grid%fnm, grid%fnp, & + dz8w, rh, grid%fnm, grid%fnp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its,ite,jts,jte, & @@ -638,22 +670,10 @@ #if (EM_CORE == 1 ) grid%gmt,grid%julday,rri,t_phy,moist,p8w,t8w,u_phy,v_phy,vvel, & #endif - grid%e_bio,p_phy,chem,rho,dz8w,grid%ne_area,emis_ant,grid%tsk,grid%erod,g,emis_seas,emis_dust, & - grid%ebu_no,grid%ebu_co,grid%ebu_co2,grid%ebu_eth,grid%ebu_hc3,grid%ebu_hc5, & - grid%ebu_hc8,grid%ebu_ete,grid%ebu_olt,grid%ebu_oli,grid%ebu_pm25, & - grid%ebu_pm10,grid%ebu_dien,grid%ebu_iso,grid%ebu_api,grid%ebu_lim, & - grid%ebu_tol,grid%ebu_xyl,grid%ebu_csl,grid%ebu_hcho,grid%ebu_ald, & - grid%ebu_ket,grid%ebu_macr,grid%ebu_ora1,grid%ebu_ora2,grid%ebu_bc, & - grid%ebu_oc,grid%ebu_so2,grid%ebu_dms,grid%ebu_sulf, & - grid%ebu_in_no,grid%ebu_in_co,grid%ebu_in_co2,grid%ebu_in_eth, & - grid%ebu_in_hc3,grid%ebu_in_hc5,grid%ebu_in_hc8,grid%ebu_in_ete, & - grid%ebu_in_olt,grid%ebu_in_oli,grid%ebu_in_pm25,grid%ebu_in_pm10, & - grid%ebu_in_dien,grid%ebu_in_iso,grid%ebu_in_api,grid%ebu_in_lim, & - grid%ebu_in_tol,grid%ebu_in_xyl,grid%ebu_in_csl,grid%ebu_in_hcho, & - grid%ebu_in_ald,grid%ebu_in_ket,grid%ebu_in_macr,grid%ebu_in_ora1, & - grid%ebu_in_ora2,grid%ebu_in_bc,grid%ebu_in_oc,grid%ebu_in_so2, & - grid%ebu_in_dms,grid%ebu_in_sulf, grid%mean_fct_agtf, & - grid%mean_fct_agef,grid%mean_fct_agsv,grid%mean_fct_aggr,grid%firesize_agtf, & + grid%e_bio,p_phy,chem,rho,dz8w,grid%ne_area,emis_ant,grid%tsk, & + grid%erod,g,emis_seas,emis_dust,tracer, & + ebu , ebu_in,grid%mean_fct_agtf,grid%mean_fct_agef,grid%mean_fct_agsv, & + grid%mean_fct_aggr,grid%firesize_agtf, & grid%firesize_agef,grid%firesize_agsv,grid%firesize_aggr, & grid%u10,grid%v10,grid%ivgtyp,grid%isltyp,grid%gsw,grid%vegfra,grid%rmol, & grid%ust,grid%znt,grid%dms_0, & @@ -667,7 +687,11 @@ grid%ebio_iso,grid%ebio_oli,grid%ebio_api,grid%ebio_lim,grid%ebio_xyl, & grid%ebio_hc3,grid%ebio_ete,grid%ebio_olt,grid%ebio_ket,grid%ebio_ald, & grid%ebio_hcho,grid%ebio_eth,grid%ebio_ora2,grid%ebio_co,grid%ebio_nr, & - grid%ebio_no, & + grid%ebio_no,grid%ebio_c10h16,grid%ebio_tol,grid%ebio_bigalk, & + grid%ebio_ch3oh,grid%ebio_acet,grid%ebio_nh3,grid%ebio_no2, & + grid%ebio_c2h5oh,grid%ebio_ch3cooh,grid%ebio_mek,grid%ebio_bigene, & + grid%ebio_c2h6,grid%ebio_c2h4,grid%ebio_c3h6,grid%ebio_c3h8,grid%ebio_so2, & + grid%ebio_dms, & #if (NMM_CORE == 1) grid%T2,grid%RSWIN, & #endif @@ -683,9 +707,22 @@ grid%mebio_isop,grid%mebio_apin,grid%mebio_bpin, grid%mebio_bcar, & grid%mebio_acet,grid%mebio_mbo,grid%mebio_no, & current_month, & + ! stuff for lightning NOx + grid%ht, grid%dy, & + grid%lightning_time_step, grid%lightning_start_seconds, grid%passive_ltng, & + grid%temp_upper, grid%temp_lower, grid%N_IC, grid%N_CG, & + grid%lflash_data, grid%ic_flshrate, grid%cg_flshrate, & + grid%flashrate_factor, grid%flashrate_method, grid%iccg_method, & + grid%cellcount_method, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte) + if( config_flags%chem_opt == MOZART_KPP .or. & + config_flags%chem_opt == MOZCART_KPP ) then + call mozcart_lbc_set( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + end if #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & @@ -710,7 +747,7 @@ config_flags%chem_opt /= CHEM_TRACE2 ) then call wrf_debug(15,'calling optical driver') call optical_driver (grid%id,curr_secs,grid%dt,config_flags,haveaer, & - chem,dz8w,rri, & + chem,dz8w,rri,rh, & grid%h2oai,grid%h2oaj, & grid%tauaer1,grid%tauaer2,grid%tauaer3,grid%tauaer4, & grid%gaer1,grid%gaer2,grid%gaer3,grid%gaer4, & @@ -745,13 +782,18 @@ grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & grid%ph_ch3coc2h5,grid%ph_hcocho,grid%ph_ch3cocho, & grid%ph_hcochest,grid%ph_ch3o2h,grid%ph_ch3coo2h,grid%ph_ch3ono2, & - grid%ph_hcochob,grid%ph_n2o5,grid%ph_o2, & + grid%ph_hcochob,grid%ph_n2o5,grid%ph_o2,grid%ph_n2o, & + grid%ph_pan,grid%ph_mpan,grid%ph_acetol,grid%ph_gly, & + grid%ph_open,grid%ph_mek,grid%ph_etooh,grid%ph_prooh,grid%ph_pooh, & + grid%ph_acetp,grid%ph_xooh,grid%ph_isooh,grid%ph_alkooh, & + grid%ph_mekooh,grid%ph_tolooh,grid%ph_terpooh,grid%ph_mvk, & + grid%ph_glyald,grid%ph_hyac, & grid%tauaer1,grid%tauaer2,grid%tauaer3,grid%tauaer4, & grid%gaer1,grid%gaer2,grid%gaer3,grid%gaer4, & grid%waer1,grid%waer2,grid%waer3,grid%waer4, & grid%bscoef1,grid%bscoef2,grid%bscoef3,grid%bscoef4, & grid%l2aer,grid%l3aer,grid%l4aer,grid%l5aer,grid%l6aer,grid%l7aer, & - grid%pm2_5_dry,grid%pm2_5_water,grid%uvrad, & + grid%pm2_5_dry,grid%pm2_5_water,grid%uvrad,grid%ivgtyp, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte) @@ -791,7 +833,7 @@ #if (EM_CORE == 1) grid%gmt,grid%julday,t_phy,moist,scalar,p8w,t8w,vvel, & #endif - rri,p_phy,chem,rho,dz8w,grid%exch_h,grid%hfx,grid%dx, & + rri,p_phy,chem,tracer,rho,dz8w,grid%exch_h,grid%hfx,grid%dx, & grid%cldfra, grid%cldfra_old,grid%raincv_b, & grid%ccn1, grid%ccn2, grid%ccn3, grid%ccn4, grid%ccn5, grid%ccn6, & grid%qndropsource,grid%ivgtyp,grid%tsk,grid%gsw,grid%vegfra,pbl_h, & @@ -801,10 +843,18 @@ grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2,grid%cvalk1,grid%cvole1,& grid%cvapi1,grid%cvapi2,grid%cvlim1,grid%cvlim2,grid%dep_vel_o3, & emis_ant(ims,kms,jms,p_e_co),config_flags%kemit, & - config_flags%sf_urban_physics,numgas, & + config_flags%sf_urban_physics,numgas,current_month, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte) + + if( config_flags%chem_opt == MOZART_KPP .or. & + config_flags%chem_opt == MOZCART_KPP ) then + call mozcart_lbc_set( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + end if + end if #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) @@ -831,8 +881,9 @@ ! ! if( config_flags%cu_physics>0 .and. config_flags%chem_conv_tr>0)then - call wrf_debug(15,'calling conv transport') - call grelldrvct(grid%DT,ktau,grid%DX,grid%id,config_flags, & + call wrf_debug(15,'calling conv transport for chemical species') + if(config_flags%chem_opt >0 )then + call grelldrvct(grid%DT,ktau,grid%DX, & rho,grid%RAINCV_B,chem, & #if (NMM_CORE == 1) U_phy,V_phy,t_phy,moist_trans,dz8w, & @@ -841,12 +892,37 @@ U_phy,V_phy,t_phy,moist,dz8w, & #endif p_phy,XLV,CP,G,r_v, & - z_at_w, & - grid%cu_co_ten, & - numgas,config_flags%chem_opt, & + z_at_w,grid%cu_co_ten, & + num_moist,numgas,num_chem,config_flags%chem_opt,0, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite,jts,jte,kts,k_end) + if( config_flags%chem_opt == MOZART_KPP .or. & + config_flags%chem_opt == MOZCART_KPP ) then + call mozcart_lbc_set( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + end if + endif + if (config_flags%tracer_opt > 0)then + call wrf_debug(15,'calling conv transport for tracers') + call grelldrvct(grid%DT,ktau,grid%DX, & + rho,grid%RAINCV_B,tracer, & +#if (NMM_CORE == 1) + U_phy,V_phy,t_phy,moist_trans,dz8w, & +#endif +#if (EM_CORE == 1) + U_phy,V_phy,t_phy,moist,dz8w, & +#endif + p_phy,XLV,CP,G,r_v, & + z_at_w, grid%cu_co_ten, & + num_moist,0,num_tracer,0,config_flags%tracer_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,k_end) + + + end if end if ! ! @@ -915,6 +991,12 @@ CALL kpp_mechanism_driver (chem, ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte) + if( config_flags%chem_opt == MOZART_KPP .or. & + config_flags%chem_opt == MOZCART_KPP ) then + call mozcart_lbc_set( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + end if if(config_flags%chem_opt == 301 ) then chem(its:ite,kts:kte,jts:jte,p_sulf)=vcsulf_old(its:ite,kts:kte,jts:jte) chem(its:ite,kts:kte,jts:jte,p_so2)=vcso2_old(its:ite,kts:kte,jts:jte) @@ -1094,6 +1176,21 @@ end if !Chemistry time step check enddo enddo call wrf_debug(15,'done tileloop in chem_driver') + if( grid%OPT_PARS_OUT == 1) then + write(0,*)'calculate optical output stuff' + call aer_opt_out(TAUAER300=grid%tauaer1, TAUAER400=grid%tauaer2 & + & ,TAUAER600=grid%tauaer3, TAUAER999=grid%tauaer4 & + & ,GAER300=grid%gaer1, GAER400=grid%gaer2, GAER600=grid%gaer3, GAER999=grid%gaer4 & + & ,WAER300=grid%waer1, WAER400=grid%waer2, WAER600=grid%waer3, WAER999=grid%waer4 & + ,ext_coeff=grid%ext_coef,bscat_coeff=grid%bscat_coef,asym_par=grid%asym_par & + ,num_ext_coef=num_ext_coef,num_bscat_coef=num_bscat_coef,num_asym_par=num_asym_par & + & ,dz8w=dz8w & + & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + & ,its=its,ite=ite,jts=jts,jte=jte,kts=kts, kte=kte) + + + endif # if ( EM_CORE == 1 ) END DO chem_tile_loop_1 diff --git a/wrfv2_fire/chem/chemics_init.F b/wrfv2_fire/chem/chemics_init.F index 532f8357..2f878db4 100755 --- a/wrfv2_fire/chem/chemics_init.F +++ b/wrfv2_fire/chem/chemics_init.F @@ -23,6 +23,8 @@ USE module_configure USE module_state_description USE module_phot_mad + +! USE module_ftuv_driver, only : ftuv_init USE module_aerosols_sorgam USE module_dep_simple USE module_data_gocart_dust @@ -35,6 +37,7 @@ USE module_mosaic_initmixrats, only: mosaic_init_wrf_mixrats USE module_input_chem_data, only: get_last_gas, & gasprofile_init_pnnl, & + mozcart_lbc_init, & last_chem_time, & setup_gasprofile_maps USE module_mixactivate_wrappers, only: mosaic_mixactivate_init @@ -90,6 +93,7 @@ ! ! local stuff ! + CHARACTER*256 :: mminlu_loc TYPE(WRFU_TimeInterval) :: tmpTimeInterval integer :: i,j,k,l,numgas,ixhour,n,ndystep,kk,nv real, DIMENSION (1,1) :: sza,cosszax @@ -99,7 +103,7 @@ #endif call wrf_message("*********************************************************************") -call wrf_message("* PROGRAM: WRF/CHEM VERSION 3.1 *") +call wrf_message("* PROGRAM: WRF/CHEM VERSION 3.1.1 *") call wrf_message("* *") call wrf_message("* PLEASE REPORT ANY BUGS TO WRF/CHEM HELP at *") call wrf_message("* *") @@ -155,6 +159,12 @@ call wrf_message("************************************************************** if ( config_flags%biomass_burn_opt == 1 ) then CALL wrf_debug(15,'calling biomass burning') endif + if( config_flags%chem_opt == MOZCART_KPP ) then + call wrf_message("chem_init: calling mozcart_lbc_init") + call mozcart_lbc_init( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + endif if ( config_flags%wetscav_onoff == 1 ) then if ( config_flags%chem_opt >= 13 .OR. config_flags%chem_opt <= 8) then @@ -183,6 +193,11 @@ call wrf_message("************************************************************** ! call wrf_error_fatal(" ERROR: USE dust_opt = 2 when using MADE/SORGAM aerosol option ") ! ENDIF + CALL nl_get_mminlu( 1, mminlu_loc ) + IF (mminlu_loc .NE. 'USGS') THEN + call wrf_error_fatal(" ERROR: CHEM_INIT: Chemistry routines function with USGS data. Need to change land use option. ") + ENDIF + if( .NOT. config_flags%restart ) then do j=jts,jte do k=kts,kte @@ -261,7 +276,8 @@ call wrf_message("************************************************************** stepbioe=nint(bioemdt*60./dt) stepphot=nint(photdt*60./dt) stepchem=nint(chemdt*60./dt) - stepfirepl=plumerisefire_frq*60/nint(dt) + ! stepfirepl=plumerisefire_frq*60/nint(dt) + stepfirepl=nint(plumerisefire_frq*60/dt) stepbioe=max(stepbioe,1) stepphot=max(stepphot,1) stepchem=max(stepchem,1) @@ -290,6 +306,11 @@ call wrf_message("************************************************************** ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) +! CASE (FTUV) +! CALL wrf_debug(00,'call ftuv phot initialization') +! call ftuv_init( its, ite, jts, jte, kte, & +! ide, jde, config_flags%chem_opt ) + END SELECT phot_select ! ! initialization for aerosols @@ -345,6 +366,16 @@ call wrf_message("************************************************************** enddo enddo endif + CASE (CBMZ_BB_KPP) + if(config_flags%chem_in_opt == 0 )then + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,p_ch4)=1.7 + enddo + enddo + enddo + endif END SELECT kpp_select endif aer_select: SELECT CASE(config_flags%chem_opt) @@ -445,6 +476,10 @@ call wrf_message("************************************************************** if(i.eq.19.and.j.eq.19)write(0,*)TCOSZ(i,j),ttday(i,j),julday, gmtp, sza, cosszax,xlonn,rlat enddo enddo + CASE (MOZCART_KPP) + CALL wrf_debug(15,'MOZCART dust initialization') + ch_dust(:,:) = 0.8e-9_8 + CASE (RADM2SORG, RADM2SORG_AQ, RACMSORG_AQ, RADM2SORG_KPP, RACMSORG_KPP) CALL wrf_debug(15,'call MADE/SORGAM aerosols initialization') @@ -505,7 +540,7 @@ call wrf_message("************************************************************** ! ! initialization for wesely (gas) dry deposition ! - drydep_select: SELECT CASE(config_flags%drydep_opt) + drydep_select: SELECT CASE(config_flags%gas_drydep_opt) CASE (WESELY) CALL wrf_debug(15,'initializing dry dep (wesely)') call dep_init(id,config_flags,numgas) @@ -515,7 +550,7 @@ call wrf_message("************************************************************** ! initialization for cbmz gas-phase chemistry ! cbmz_select: SELECT CASE(config_flags%chem_opt) - CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & + CASE (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) CALL wrf_debug(15,'initializing cbmz gas-phase chemistry') if(config_flags%chem_in_opt == 0 )then @@ -759,7 +794,7 @@ subroutine print_chem_species_index( chem_opt ) print*,p_ch3so2oo,"ch3so2oo" print*,p_ch3so2ch2oo,"ch3so2ch2oo" print*,p_mtf,"mtf" - case (CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + case (CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) print*,p_so2,"so2" print*,p_sulf,"sulf" print*,p_no2,"no2" @@ -782,6 +817,7 @@ subroutine print_chem_species_index( chem_opt ) print*,p_hc5,"hc5" print*,p_hc8,"hc8" print*,p_eth,"eth" + print*,p_ch4,"ch4" print*,p_co,"co" print*,p_ol2,"ol2" print*,p_olt,"olt" diff --git a/wrfv2_fire/chem/convert_emiss.F b/wrfv2_fire/chem/convert_emiss.F index fe403c02..7457601e 100644 --- a/wrfv2_fire/chem/convert_emiss.F +++ b/wrfv2_fire/chem/convert_emiss.F @@ -15,17 +15,15 @@ PROGRAM convert_emissions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! USE module_machine - USE module_domain - USE module_io USE module_wrf_error - USE module_io_wrf - USE module_integrate + USE module_integrate + USE module_domain, ONLY : domain + USE module_initialize_real, ONLY : wrfu_initialize, rebalance_driver USE module_driver_constants - USE module_state_description - USE module_configure + USE module_configure, ONLY : grid_config_rec_type, model_config_rec + USE module_io_domain USE module_timing USE module_utility - USE module_initialize_real #ifdef DM_PARALLEL USE module_dm #endif @@ -36,6 +34,13 @@ PROGRAM convert_emissions #if (EM_CORE ==1) USE module_big_step_utilities_em #endif +!#ifdef WRF_CHEM +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! for chemistry +! USE module_input_chem_data +!! USE module_input_chem_bioemiss +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT NONE @@ -283,7 +288,22 @@ PROGRAM convert_emissions end_minute = model_config_rec% end_minute(grid%id) end_second = model_config_rec% end_second(grid%id) - interval_seconds = config_flags%interval_seconds + interval_seconds = config_flags%auxinput5_interval + if ( interval_seconds == 0 ) then + interval_seconds = config_flags%auxinput5_interval_s + endif + if ( interval_seconds == 0 ) then + interval_seconds = 60 * config_flags%auxinput5_interval_m + endif + if ( interval_seconds == 0 ) then + interval_seconds = 3600 * config_flags%auxinput5_interval_h + endif + if ( interval_seconds == 0 ) then + interval_seconds = 86400 * config_flags%auxinput5_interval_d + endif + if ( interval_seconds == 0 ) then + interval_seconds = 2592000 * config_flags%auxinput5_interval_m + endif real_data_init_type = model_config_rec%real_data_init_type @@ -425,7 +445,7 @@ PROGRAM convert_emissions CALL wrf_message ( message ) IF ( ierr .NE. 0 ) THEN - CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' ) + CALL wrf_error_fatal( 'convert_emiss: error opening wrfchem emissions file for writing' ) ENDIF write(message,FMT='(A)') ' PAST OPEN GOCART BACKGROUND DATA WRF file ' @@ -924,7 +944,7 @@ PROGRAM convert_emissions write(message, FMT='(A)') ' put dumc1 into ebu_in_so2' call wrf_debug(100, TRIM( message ) ) - grid%ebu_in_so2(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_so2) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -934,7 +954,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_no(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_no) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -944,7 +964,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_ald(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_ald) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -954,7 +974,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_hcho(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_hcho) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -964,7 +984,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_ora2(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_ora2) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -974,7 +994,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - ! grid%ebu_in_nh3(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + ! grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_nh3) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -984,7 +1004,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_hc3(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_hc3) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -994,7 +1014,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_hc5(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_hc5) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1004,7 +1024,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_hc8(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_hc8) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1014,7 +1034,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_eth(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_eth) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1024,7 +1044,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_co(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_co) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1034,7 +1054,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - ! grid%ebu_in_ol2(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + ! grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_ol2) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1044,7 +1064,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_olt(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_olt) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1054,7 +1074,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_oli(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_oli) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1064,7 +1084,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_tol(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_tol) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1074,7 +1094,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_xyl(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_xyl) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1084,7 +1104,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_ket(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_ket) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1094,7 +1114,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_csl(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_csl) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1104,7 +1124,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_iso(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_iso) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1114,7 +1134,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_pm25(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_pm25) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1124,7 +1144,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_pm10(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_pm10) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1134,7 +1154,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_oc(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_oc) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1144,7 +1164,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_bc(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_bc) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1154,7 +1174,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_dms(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_dms) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1164,7 +1184,7 @@ PROGRAM convert_emissions #else read(93)dumc1(ids:ide ,jds:jde ) #endif - grid%ebu_in_sulf(ips:ipe ,jps:jpe )=dumc1(ips:ipe ,jps:jpe ) + grid%ebu_in(ips:ipe,1, jps:jpe ,p_ebu_in_sulf) =dumc1(ips:ipe ,jps:jpe ) #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN @@ -1268,7 +1288,7 @@ PROGRAM convert_emissions write(message, FMT='(A,I10)') ' convert_emiss: error: conversion for all CBMZ emission arrays not available ' CALL wrf_error_fatal( TRIM( message ) ) endif - if(CONFIG_FLAGS%EMISS_OPT == ERADM .or. CONFIG_FLAGS%EMISS_OPT == ERADMSORG .or. + if(CONFIG_FLAGS%EMISS_OPT == ERADM .or. CONFIG_FLAGS%EMISS_OPT == ERADMSORG .or. & CONFIG_FLAGS%EMISS_OPT == ECBMZ_MOSAIC ) then ! Figure out our loop count for the processing times. #ifdef DM_PARALLEL @@ -1656,7 +1676,12 @@ PROGRAM convert_emissions ! grid%input_from_file = .false. - CALL construct_filename1( inpname , 'wrfchemi' , grid%id , 2 ) + if (config_flags%io_style_emissions.eq.1)then + write(eminame,FMT='(A9,i2.2,a1)') 'wrfchemi_',ihour,'z' + CALL construct_filename1 ( inpname ,TRIM(eminame), grid%id , 2 ) + else + CALL construct_filename1( inpname , 'wrfchemi' , grid%id , 2 ) + endif write(message,FMT='(A,A,I10)') ' OPEN FILE ',TRIM(inpname),config_flags%io_form_auxinput5 CALL wrf_debug ( 100, message ) @@ -1664,7 +1689,7 @@ PROGRAM convert_emissions write(message,FMT='(A,A)') ' EMISSIONS OUTPUT file name: ',TRIM(inpname) CALL wrf_message ( message ) IF ( ierr .NE. 0 ) THEN - CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' ) + CALL wrf_error_fatal( 'convert_emiss: error opening wrfchem emissions file for writing' ) ENDIF CALL calc_current_date ( grid%id , 0. ) @@ -1716,18 +1741,33 @@ PROGRAM convert_emissions write(message,FMT='(A,I4)') ' Hour ',ihour CALL wrf_message ( message ) ihour = mod(ihour + 1,24) - if(ihour.eq.0)then - close(91) - CALL construct_filename1 ( bdyname , 'wrfem_00to12z' , grid%id , 2 ) - open (91,file=bdyname,form='unformatted') - endif - if(ihour.eq.12) then + +! Allow writing of both 12h files with 1 submission when io_style_emissions=1 (2 12h files) + if(ihour.eq.0 .or. ihour.eq.12)then +! Read from next binary emissions file close(91) - CALL construct_filename1 ( bdyname , 'wrfem_12to24z' , grid%id , 2 ) + if(ihour.eq.0) then + CALL construct_filename1 ( bdyname , 'wrfem_00to12z' , grid%id , 2 ) + elseif(ihour.eq.12) then + CALL construct_filename1 ( bdyname , 'wrfem_12to24z' , grid%id , 2 ) + endif open (91,file=bdyname,form='unformatted') +!Write a 2nd netcdf emiss file? + if (config_flags%io_style_emissions .eq.1) then + CALL close_dataset ( id1 , config_flags , "DATASET=AUXOUTPUT5" ) + write(eminame,FMT='(A9,i2.2,a1)') 'wrfchemi_',ihour,'z' + CALL construct_filename1 ( inpname ,TRIM(eminame), grid%id , 2 ) + write(message,FMT='(A,A,I10)') ' OPEN FILE ',TRIM(inpname),config_flags%io_form_auxinput5 + CALL wrf_debug ( 0, message ) + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input5 , "DATASET=AUXINPUT5", ierr ) + write(message,FMT='(A,A)') ' EMISSIONS OUTPUT file name: ',TRIM(inpname) + CALL wrf_message ( message ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'Error opening wrfchem emissions file for writing' ) + ENDIF + endif endif - ENDIF CALL wrf_dm_bcast_bytes ( ihour , rnum8 ) ! CALL wrf_dm_bcast_bytes ( bdyname , rnum8 ) @@ -1758,6 +1798,33 @@ PROGRAM convert_emissions CALL construct_filename1 ( bdyname , 'wrfem_12to24z' , grid%id , 2 ) open (91,file=bdyname,form='unformatted') endif +! Allow writing of both 12h files with 1 submission when io_style_emissions=1 (2 12h files) + if(ihour.eq.0 .or. ihour.eq.12)then +! Read from next emissions file + close(91) + if(ihour.eq.0) then + CALL construct_filename1 ( bdyname , 'wrfem_00to12z' , grid%id , 2 ) + elseif(ihour.eq.12) then + CALL construct_filename1 ( bdyname , 'wrfem_12to24z' , grid%id , 2 ) + endif + open (91,file=bdyname,form='unformatted') +!Write a 2nd netcdf emiss file? + if (config_flags%io_style_emissions .eq.1) then + CALL close_dataset ( id1 , config_flags , "DATASET=AUXOUTPUT5" ) + write(message,FMT='(A)') ' CLOSED FIRST FILE, OPENING SECOND FILE' + CALL wrf_message ( message ) + write(eminame,FMT='(A9,i2.2,a1)') 'wrfchemi_',ihour,'z' + CALL construct_filename1 ( inpname , TRIM(eminame) , grid%id , 2 ) + write(message,FMT='(A,A,I10)') ' OPEN FILE ',TRIM(inpname),config_flags%io_form_auxinput5 + CALL wrf_debug ( 0, message ) + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_aux_model_input5 , "DATASET=AUXINPUT5", ierr ) + write(message,FMT='(A,A)') ' EMISSIONS OUTPUT file name: ',TRIM(inpname) + CALL wrf_message ( message ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'Error opening wrfchem emissions file for writing' ) + ENDIF + endif + endif #endif write(message, '(A,A,I10)') ' USING FILE: ',TRIM(bdyname),ihour @@ -2348,7 +2415,7 @@ PROGRAM convert_emissions CALL wrf_message ( message ) IF ( ierr .NE. 0 ) THEN - CALL wrf_error_fatal( 'real: error opening wrfchem emissions file for writing' ) + CALL wrf_error_fatal( 'convert_emiss: error opening wrfchem emissions file for writing' ) ENDIF write(message,FMT='(A)') ' WRITE BIOGENIC EMISSIONS WRF file ' diff --git a/wrfv2_fire/chem/dry_dep_driver.F b/wrfv2_fire/chem/dry_dep_driver.F index bc352d79..ea7cfdae 100755 --- a/wrfv2_fire/chem/dry_dep_driver.F +++ b/wrfv2_fire/chem/dry_dep_driver.F @@ -1,13 +1,7 @@ ! -! WRF-chem V3.0 : Original version of dry_dep_driver written by Georg Grell (ESRL/GSD) -! VERTMX was originally developed by Mariusz Pagowski. It is written to -! conserve, it needs concentration as input, it will not keep a -! constant mixing ratio profile untouched. Further modifications -! by Richard C. Easter. In addition -! modifications by Richard C. Easter (PNNL) are available to -! use mixing ratio as input and keep the mixing ratio constant. -! -! !!!!!! Both versions are conserving. !!!!!!!!!! +! WRF-chem V3.2 : Original version of dry_dep_driver written by Georg Grell (ESRL/GSD) +! VERTMX was originally developed by Mariusz Pagowski and modified by +! Richard C. Easter (PNNL) ! !WRF:MODEL_LAYER:CHEMICS ! @@ -18,14 +12,14 @@ CONTAINS subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & gmt,julday,t_phy,moist,scalar,p8w,t8w,w,alt, & - p_phy,chem,rho_phy,dz8w,exch_h,hfx,dx, & + p_phy,chem,tracer,rho_phy,dz8w,exch_h,hfx,dx, & cldfra, cldfra_old,raincv, & ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& xland,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & anh3,cvaro1,cvaro2, & cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,dep_vel_o3, & - e_co,kemit,sf_urban_physics,numgas, & + e_co,kemit,sf_urban_physics,numgas,current_month, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -41,11 +35,13 @@ CONTAINS USE module_gocart_drydep USE module_mosaic_drydep, only: mosaic_drydep_driver USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate + USE module_aer_drydep, only: aer_drydep_driver IMPLICIT NONE INTEGER, INTENT(IN ) :: id,julday, & sf_urban_physics, & numgas, & + current_month, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -57,6 +53,8 @@ CONTAINS INTENT(INOUT ) :: scalar REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_tracer ), & + INTENT(INOUT ) :: tracer INTEGER, INTENT(IN ) :: kemit REAL, DIMENSION( ims:ime, kms:kemit, jms:jme ), & @@ -116,7 +114,7 @@ CONTAINS INTEGER :: iland, iprt, iseason, jce, jcs, & n, nr, ipr, jpr, nvr, & - idrydep_onoff + idrydep_onoff, aer_mech_id LOGICAL :: highnh3, rainflag, vegflag, wetflag ! .. @@ -133,7 +131,7 @@ CONTAINS ! ! necessary for aerosols (module dependent) ! - REAL, DIMENSION( its:ite, jts:jte ) :: aer_res + REAL, DIMENSION( its:ite, jts:jte ) :: aer_res, aer_res_def, aer_res_zcen TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -146,7 +144,7 @@ CONTAINS ! compute dry deposition velocities = ddvel ! ! 28-jun-2005 rce - initialize ddvel=0; call aerosol drydep routine -! only when drydep_opt == WESELY +! only when gas_drydep_opt == WESELY ! the wesely_driver routine computes aer_res, and currently ! you cannot compute aerosol drydep without it !! ! 08-jul-2005 rce - pass idrydep_onoff to mixactivate routines @@ -154,11 +152,11 @@ CONTAINS ddvel(:,:,:) = 0.0 idrydep_onoff = 0 - drydep_select: SELECT CASE(config_flags%drydep_opt) + drydep_select: SELECT CASE(config_flags%gas_drydep_opt) CASE ( WESELY ) ! -! drydep_opt == WESELY means +! gas_drydep_opt == WESELY means ! wesely for gases ! other (appropriate) routine for aerosols ! @@ -171,7 +169,7 @@ CONTAINS call wesely_driver(id,ktau,dtstep, & config_flags, & gmt,julday,t_phy,moist,p8w,t8w,raincv, & - p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& numgas, & ids,ide, jds,jde, kds,kde, & @@ -181,7 +179,7 @@ CONTAINS call wesely_driver(id,ktau,dtstep, & config_flags, & gmt,julday,t_phy,moist,p8w,t8w,raincv, & - p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& numgas, & ids,ide, jds,jde, kds,kde, & @@ -206,7 +204,7 @@ CONTAINS call wesely_driver(id,ktau,dtstep, & config_flags, & gmt,julday,t_phy,moist,p8w,t8w,raincv, & - p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& numgas, & ids,ide, jds,jde, kds,kde, & @@ -227,13 +225,44 @@ CONTAINS ddvel(:,:,:) = 0. END IF - idrydep_onoff = 1 + if (config_flags%aer_aerodynres_opt == 2) then + ! use aerodynamic resistance from center of layer kts to surface + aer_res(:,:) = aer_res_zcen(:,:) + else + ! this is the default -- use aerodynamic resistance from + ! "default reference height" (currently 2 m) to surface + aer_res(:,:) = aer_res_def(:,:) + end if + idrydep_onoff = 1 + aer_mech_id_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP) + aer_mech_id = 1 + CASE (RACMSORG_AQ,RACMSORG_KPP) + aer_mech_id = 2 + CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + aer_mech_id = 3 + CASE DEFAULT + aer_mech_id = 0 + END SELECT aer_mech_id_select +! config_flags%aer_drydep_opt <= 0 -- aerosol depositon velocities are set to zero +! config_flags%aer_drydep_opt >= 100 -- aerosol depvels are calculated in subr aer_depvel_driver +! (see module_aer_drydep.F for details) +! config_flags%aer_drydep_opt == 1 -- SORGAM chem packages use subr vdvg_2 of module_aerosols_sorgam.F +! MOSAIC chem packages subr aerosol_depvel_2 of module_mosaic_drydep.F +! config_flags%aer_drydep_opt == 11 -- SORGAM chem packages use subr vdvg of module_aerosols_sorgam.F + + + if ((config_flags%aer_drydep_opt <= 0) .or. (aer_mech_id <= 0)) then + CALL wrf_debug(15,'AEROSOL DRY DEP VELOCITIES = 0.0') + + + else if (config_flags%aer_drydep_opt <= 99) then adrydep_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP) CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/RADM') - call sorgam_depdriver (id,ktau,dtstep, & + call sorgam_depdriver (id,config_flags,ktau,dtstep, & ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & @@ -245,7 +274,7 @@ CONTAINS its,ite, jts,jte, kts,kte ) CASE (RACMSORG_AQ,RACMSORG_KPP) CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/RACM') - call sorgam_depdriver (id,ktau,dtstep, & + call sorgam_depdriver (id,config_flags,ktau,dtstep, & ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & @@ -268,7 +297,31 @@ CONTAINS its,ite, jts,jte, kts,kte ) CASE DEFAULT - END SELECT adrydep_select + END SELECT adrydep_select + else ! (config_flags%aer_drydep_opt > 99) + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES THRU AER_DRYDEP_DRIVER') + call aer_drydep_driver( & + id, ktau, dtstep, config_flags, aer_mech_id, & + gmt, julday, & + t_phy, rho_phy, p_phy, & + alt, p8w, t8w, dz8w, z, z_at_w, & + ust, aer_res, ivgtyp, vegfra, pbl, rmol, znt, & + moist, chem, ddvel, & + h2oai, h2oaj, numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + end if + if (config_flags%aer_drydep_opt > 0) then + if ((aer_mech_id > 0) .and. (aer_mech_id <= 3)) then + ! limit aerosol ddvels to <= 0.5 m/s + ! drydep routines occasionally produce unrealistically-large particle + ! diameter leading to unrealistically-large sedimentation velocity + ddvel(:,:,numgas+1:num_chem) = min( 0.50, ddvel(:,:,numgas+1:num_chem) ) + end if + end if + + CASE DEFAULT @@ -335,7 +388,6 @@ CONTAINS zzfull,zz,ddvel(i,j,nv),kts,kte) endif -! CASE (PRESCRIBE_AEROSOL) CASE DEFAULT call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & @@ -347,6 +399,27 @@ CONTAINS chem(i,k,j,nv)=max(epsilc,pblst(k)) enddo enddo + tracer_select: SELECT CASE(config_flags%tracer_opt) +! +! only mixing one fire(smoke) scalar array +! + CASE (TRACER_SMOKE) + CALL wrf_debug(15,'DOING TRACER MIXING, 1 SPECIE ONLY') + do nv=2,num_tracer + do k=kts,kte + pblst(k)=max(epsilc,tracer(i,k,j,nv)) + enddo + + call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & + zzfull,zz,0.,kts,kte) + do k=kts,kte-1 + tracer(i,k,j,nv)=max(epsilc,pblst(k)) + enddo + enddo + CASE DEFAULT + CALL wrf_debug(15,'NOT YET DEFINED') + END SELECT tracer_select + 100 continue ! ! vertical mixing and activation of aerosol diff --git a/wrfv2_fire/chem/emissions_driver.F b/wrfv2_fire/chem/emissions_driver.F index 9849ad3c..7c9a998c 100755 --- a/wrfv2_fire/chem/emissions_driver.F +++ b/wrfv2_fire/chem/emissions_driver.F @@ -15,21 +15,8 @@ CONTAINS bioemdt,stepbioe, & config_flags,gmt,julday,alt,t_phy,moist,p8w,t8w,u_phy, & v_phy,vvel,e_bio,p_phy,chem,rho_phy,dz8w,ne_area,emis_ant, & - tsk,erod,g,emis_seas,emis_dust, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5, & - ebu_hc8,ebu_ete,ebu_olt,ebu_oli,ebu_pm25, & - ebu_pm10,ebu_dien,ebu_iso,ebu_api,ebu_lim, & - ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc, & - ebu_oc,ebu_so2,ebu_dms,ebu_sulf, & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth, & - ebu_in_hc3,ebu_in_hc5,ebu_in_hc8,ebu_in_ete, & - ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim, & - ebu_in_tol,ebu_in_xyl,ebu_in_csl,ebu_in_hcho, & - ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2, & - ebu_in_dms,ebu_in_sulf,mean_fct_agtf,mean_fct_agef, & + tsk,erod,g,emis_seas,emis_dust,tracer, & + ebu, ebu_in,mean_fct_agtf,mean_fct_agef, & mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & firesize_agsv,firesize_aggr, & u10,v10,ivgtyp,isltyp,gsw,vegfra,rmol,ust,znt,dms_0, & @@ -41,6 +28,10 @@ CONTAINS ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ebio_c10h16,ebio_tol,ebio_bigalk,ebio_ch3oh,ebio_acet, & + ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & + ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8,ebio_so2, & + ebio_dms, & ! stuff for MEGAN v2.04 T2,swdown, & nmegan,EFmegan, & @@ -53,6 +44,14 @@ CONTAINS mebio_acet, mebio_mbo, mebio_no, & current_month, & ! end stuff for MEGAN v2.04 + ! stuff for lightning NOx + ter_ht, dy, & + ltng_timestep, ltng_startsec, passive_ltng, & + temp_upper, temp_lower, N_IC, N_CG, & + lflash_data, ic_fr, cg_fr, & + flashrate_factor, flashrate_method, iccg_method, & + cellcount_method, & + ! end suff for lightning ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -75,6 +74,7 @@ CONTAINS USE module_add_emis_cptec USE module_add_emiss_burn USE module_plumerise1 + USE module_lightning_driver IMPLICIT NONE TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -89,6 +89,12 @@ CONTAINS INTENT(IN ) :: moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_tracer ), & + INTENT(INOUT ) :: tracer + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_ebu ), & + INTENT(INOUT ) :: ebu + REAL, DIMENSION( ims:ime, 1, jms:jme, num_ebu_in ), & + INTENT(INOUT ) :: ebu_in REAL, DIMENSION( ims:ime, jms:jme, ne_area ), & INTENT(INOUT ) :: e_bio REAL, DIMENSION( ims:ime, 1:config_flags%kemit, jms:jme,num_emis_ant),& @@ -107,24 +113,6 @@ CONTAINS OPTIONAL, & INTENT(INOUT ) :: & emis_seas - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, & - INTENT(INOUT ) :: & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_dms,ebu_sulf - - REAL, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, & - INTENT(INOUT ) :: & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3, & - ebu_in_hc5,ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli, & - ebu_in_pm25,ebu_in_pm10,ebu_in_dien,ebu_in_iso,ebu_in_api, & - ebu_in_lim,ebu_in_tol,ebu_in_xyl,ebu_in_csl,ebu_in_hcho, & - ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1,ebu_in_ora2, & - ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_dms,ebu_in_sulf REAL, DIMENSION( ims:ime, jms:jme ), & OPTIONAL, & @@ -172,7 +160,12 @@ CONTAINS noag_grow,noag_nongrow,nononag,slai, & ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & - ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ebio_c10h16,ebio_tol,ebio_bigalk, ebio_ch3oh,ebio_acet, & + ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & + ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8, & + ebio_so2,ebio_dms + ! stuff for MEGAN v2.04...most of these arrays are optional and package dependent ! as declared in registry.chem @@ -208,6 +201,22 @@ CONTAINS integer, intent(in) :: current_month ! end stuff for MEGAN v2.04 +! stuff for lightning NO + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN) :: ter_ht ! terrain height + REAL, INTENT(IN ) :: dy + REAL, INTENT(IN ) :: temp_upper, temp_lower, N_IC, N_CG ! upper/lower T(K) modes of vert distrib, nbr of IC and CG flashes + INTEGER, INTENT(IN ) :: ltng_timestep, ltng_startsec, & ! timestep for ltng data, starting time for lightning data + passive_ltng, lflash_data ! flag for putting LNOx into only the scalar array, + ! flag to choose observed or simulated flash rate + REAL , DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: ic_fr, & ! cumulative number of intracloud flashes (diagnostic) + cg_fr ! cumulative number of cloud-to-ground flashes (diagnostic) + REAL, INTENT(IN ) :: flashrate_factor ! factor to adjust predicted flashrates -- for PR prediction + INTEGER, INTENT(IN ) :: flashrate_method ! flashrate calculation method + INTEGER, INTENT(IN ) :: iccg_method ! choosing ic to cg ratio method + INTEGER, INTENT(IN ) :: cellcount_method ! choosing tile_wide or domain_wide method +! end stuff for lightning NO REAL(KIND=8), INTENT(IN ) :: & curr_secs @@ -275,6 +284,42 @@ CONTAINS do_bioemiss = .true. ENDIF ! +! we are doing the plumerise/fire emissions first, they may be needed for chem and tracer arrays +! + if( do_plumerisefire )then + CALL wrf_debug(15,'fire emissions: calling biomassb') + write(0,*)ktau,stepfirepl + call plumerise_driver (id,ktau,dtstep, & + ebu,ebu_in, & + mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & + firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & + config_flags, t_phy,moist, & + rho_phy,vvel,u_phy,v_phy,p_phy, & + emis_ant,z_at_w,z, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif +! +! Only Scalar? +! + tracer_select: SELECT CASE(config_flags%tracer_opt) + CASE (TRACER_SMOKE) + CALL wrf_debug(15,'tracer fire emissions: calling biomassb, only CO') +! +! here for tracers only, set chem_opt to zero. Chem species are handled later! +! + call add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,tracer,& + julday,gmt,xlat,xlong,t_phy,p_phy, & + ebu,0,config_flags%tracer_opt,config_flags%biomass_burn_opt, & + num_tracer,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE DEFAULT + CALL wrf_debug(15,'No tracer option selected') + END SELECT tracer_select + +! ! Gocart emissions... ! seasalt_select: SELECT CASE(config_flags%seas_opt) @@ -326,43 +371,30 @@ CONTAINS END SELECT dms_select ksub=0 -!!! *********** FIRE!!!! **************************************** +!!! *********** FIRE AND CHEM **************************************** ! fire_select: SELECT CASE(config_flags%biomass_burn_opt) CASE (BIOMASSB) - if( do_plumerisefire )then - CALL wrf_debug(15,'fire emissions: calling biomassb') - write(0,*)ktau,stepfirepl - call plumerise_driver (id,ktau,dtstep, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_dms,ebu_sulf, & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5, & - ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_xyl, & - ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_dms,ebu_in_sulf, & - mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & - firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & - config_flags, t_phy,moist, & - chem,rho_phy,vvel,u_phy,v_phy,p_phy, & - emis_ant,z_at_w,z, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - endif +! if( do_plumerisefire )then +! CALL wrf_debug(15,'fire emissions: calling biomassb') +! write(0,*)ktau,stepfirepl +! call plumerise_driver (id,ktau,dtstep, & +! ebu,ebu_in, & +! mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & +! firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & +! config_flags, t_phy,moist, & +! chem,rho_phy,vvel,u_phy,v_phy,p_phy, & +! emis_ant,z_at_w,z, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + +! endif CALL wrf_debug(15,'fire emissions: adding biomassb emissions') call add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem,& julday,gmt,xlat,xlong,t_phy,p_phy, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_dms,ebu_sulf,config_flags%chem_opt, & - ids,ide, jds,jde, kds,kde, & + ebu,config_flags%chem_opt,0,config_flags%biomass_burn_opt, & + num_chem,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) CASE DEFAULT @@ -471,7 +503,7 @@ CONTAINS end if ! emiss_inpt_opt /= 3 - CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CASE (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) IF(config_flags%kemit .GT. kte-ksub) THEN message = ' EMISSIONS_DRIVER: KEMIT > KME ' CALL WRF_ERROR_FATAL (message) @@ -645,10 +677,12 @@ CONTAINS RACMSORG_AQ,RACMSORG_KPP) call wrf_debug(15,'emissions_driver calling sorgam_addemiss') call sorgam_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & + ebu, & slai,ust,smois,ivgtyp,isltyp, & emis_ant,dust_emiss_active, & seasalt_emiss_active,config_flags%kemit, & - config_flags%num_soil_layers, & + config_flags%biomass_burn_opt, & + config_flags%num_soil_layers,config_flags%emiss_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -667,6 +701,33 @@ CONTAINS call wrf_debug(15,'emissions_driver NOT CALLING aer add_... routines') END SELECT aer_addemiss_select +! +! production of NO from lightning +! code from Mary Barth with contributions from: +! Lesley Ott, Ken Pickering (crm_decaria scheme) +! Christelle Barthe (crm_barthe scheme) +! Regional-scale LNOx schemes from MOZART provided by Louisa Emmons +! + IF (config_flags%lightning_opt /= 0) then + + CALL lightning_driver(t_phy, p_phy, rho_phy, & + u_phy, v_phy, vvel, & + ter_ht,xlat,xlong,dx,dy,z, & + moist, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + chem(ims,kms,jms,p_no), & + config_flags%lightning_opt, ktau, & + dtstep, ltng_timestep, ltng_startsec, & + passive_ltng,temp_upper,temp_lower, & + N_IC,N_CG,lflash_data,flashrate_factor, & + flashrate_method,iccg_method, & + cellcount_method, & + ic_fr,cg_fr) + + END IF + END subroutine emissions_driver diff --git a/wrfv2_fire/chem/module_add_emiss_burn.F b/wrfv2_fire/chem/module_add_emiss_burn.F dissimilarity index 60% index 5a3b83d4..c0d17ddf 100644 --- a/wrfv2_fire/chem/module_add_emiss_burn.F +++ b/wrfv2_fire/chem/module_add_emiss_burn.F @@ -1,529 +1,381 @@ -Module module_add_emiss_burn -CONTAINS - subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & - julday,gmt,xlat,xlong,t_phy,p_phy, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_dms,ebu_sulf,chem_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - USE module_configure, only: grid_config_rec_type - USE module_state_description - IMPLICIT NONE - - -! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: id,julday,chem_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: & - ktau - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem -! -! -! - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: & - xlat,xlong - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - t_phy, & - p_phy, & - dz8w, & - rho_phy - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2,ebu_dms,ebu_sulf - - REAL, INTENT(IN ) :: & - dtstep,gmt - integer ::imonth1,idate1,iyear1,itime1 - integer :: i,j,k - real :: time,conv_rho - integer :: iweek,idays - real :: tign,timeq,r_q,r_antro - real, dimension(7) :: week_CYCLE - ! dia da semana: DOM SEG TER QUA QUI SEX SAB - ! iweek= 1 2 3 4 5 6 7 - !- dados cetesb/campinas/2005 - data (week_CYCLE(iweek),iweek=1,7) /0.67, 1.1, 1.1, 1.1, 1.1, 1.1, 0.83/ !total = 7 - real, parameter :: bx_bburn = 18.041288 * 3600., & !- peak at 18 UTC - cx = 2.184936 * 3600., & - rinti = 2.1813936e-8 , & - ax = 2000.6038 , & - bx_antro = 15.041288 * 3600. !- peak em 15 UTC - !itime1 : initial time of simulation (hour*100) - ! time : time elapsed in seconds - ! r_q : gaussian function in 1/sec - - !-------------biomass burning diurnal cycle -------------------- - !number of days of simulation - idays = int(( float(itime1)/100. + time/3600.)/24.+.00001) - tign = real(idays)*24.*3600. - ! Modulacao da queimada media durante o ciclo diurno(unidade: 1/s) - ! com a int( r_q dt) (0 - 24h)= 1. - timeq= ( time + float(itime1)*0.01*3600. - tign ) - timeq=gmt*3600.+float(ktau)*dtstep - timeq=mod(timeq,86400.) - r_q = rinti*( ax * exp( -(timeq-bx_bburn)**2/(2.*cx**2) ) + 100. - & - 5.6712963e-4*( timeq )) - - - !------------- anthropogenic diurnal cycle (industrial,residencial, ...) - ! weekly cycle - ! week day - iweek= int(((float(julday)/7. - & - int(julday/7))*7.)) + 1 - if(iweek.gt.7) iweek = iweek-7 - !- weekly + diurnal cycle - r_q=r_q*86400. - r_q=1. ! no diurnal cycle - emiss_select: SELECT CASE(chem_opt) - CASE (RACMPM_KPP) - do j=jts,jte - do i=its,ite - do k=kts+1,kte -! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60. - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - chem(i,k,j,p_pm_25) = chem(i,k,j,p_pm_25) & - +r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_pm_10) = chem(i,k,j,p_pm_10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - enddo - k=kts - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - chem(i,k,j,p_pm_25) = chem(i,k,j,p_pm_25) & - +r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)/dz8w(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_pm_10) = chem(i,k,j,p_pm_10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)/dz8w(i,k,j)*dtstep/dz8w(i,k,j) - enddo - enddo - CASE (RADM2SORG,RACMSORG_KPP, RADM2SORG_KPP) - do j=jts,jte - do i=its,ite - do k=kts+1,kte - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) - - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - chem(i,k,j,p_orgpai) = chem(i,k,j,p_orgpai) & - +.25*r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_orgpaj) = chem(i,k,j,p_orgpaj) & - +.75*r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_eci) = chem(i,k,j,p_eci) & - +.25*r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_ecj) = chem(i,k,j,p_ecj) & - +.75*r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25i) = chem(i,k,j,p_p25i) & - +.25*r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25j) = chem(i,k,j,p_p25j) & - +.75*r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_pm_10) = chem(i,k,j,p_pm_10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - enddo - k=kts - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - chem(i,k,j,p_orgpai) = chem(i,k,j,p_orgpai) & - +.25*r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_orgpaj) = chem(i,k,j,p_orgpaj) & - +.75*r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_eci) = chem(i,k,j,p_eci) & - +.25*r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_ecj) = chem(i,k,j,p_ecj) & - +.75*r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25i) = chem(i,k,j,p_p25i) & - +.25*r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25j) = chem(i,k,j,p_p25j) & - +.75*r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_pm_10) = chem(i,k,j,p_pm_10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)/dz8w(i,k,j)*dtstep/dz8w(i,k,j) - enddo - enddo - CASE (GOCART_SIMPLE) - do j=jts,jte - do i=its,ite - do k=kts+1,kte - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & - +ebu_dms(i,k,j)*conv_rho - chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & - +r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & - +r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & - +r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - enddo - k=kts - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & - +r_q*ebu_dms(i,k,j)/rho_phy(i,k,j)*dtstep - chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & - +r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & - +r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & - +r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - enddo - enddo - CASE (GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) - do j=jts,jte - do i=its,ite - do k=kts+1,kte -! conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60. - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & - +ebu_dms(i,k,j)*conv_rho - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & - +r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & - +r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & - +r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - enddo - k=kts - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & - +ebu_so2(i,k,j)*conv_rho - chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & - +ebu_sulf(i,k,j)*conv_rho - chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & - +ebu_dms(i,k,j)*conv_rho - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & - +r_q*ebu_oc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & - +r_q*ebu_bc(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & - +r_q*ebu_pm25(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & - +r_q*ebu_pm10(i,k,j)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) - enddo - enddo - CASE (RADM2,RACM_KPP,RACM_MIM_KPP) - do j=jts,jte - do i=its,ite - do k=kts+1,kte - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - enddo - k=kts - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +ebu_csl(i,k,j)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +ebu_iso(i,k,j)*conv_rho - chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +ebu_no(i,k,j)*conv_rho - chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & - +ebu_ald(i,k,j)*conv_rho - chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & - +ebu_hcho(i,k,j)*conv_rho - chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & - +ebu_ora2(i,k,j)*conv_rho - chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & - +ebu_hc3(i,k,j)*conv_rho - chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & - +ebu_hc5(i,k,j)*conv_rho - chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & - +ebu_hc8(i,k,j)*conv_rho - chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & - +ebu_eth(i,k,j)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +ebu_co(i,k,j)*conv_rho - chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & - +ebu_olt(i,k,j)*conv_rho - chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & - +ebu_oli(i,k,j)*conv_rho - chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & - +ebu_tol(i,k,j)*conv_rho - chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & - +ebu_xyl(i,k,j)*conv_rho - chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & - +ebu_ket(i,k,j)*conv_rho - enddo - enddo - CASE (CHEM_TRACE2) - do j=jts,jte - do i=its,ite - do k=kts+1,kte-1 - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) - chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) & - +ebu_co(i,k,j)*conv_rho - enddo - k=kts - conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) & - +ebu_co(i,k,j)*conv_rho - enddo - enddo - CASE DEFAULT - call wrf_debug(15,'nothing done with burn emissions') - END SELECT emiss_select - - - END subroutine add_emis_burn - -END Module module_add_emiss_burn +Module module_add_emiss_burn +CONTAINS + subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & + julday,gmt,xlat,xlong,t_phy,p_phy, & + ebu,chem_opt,tracer_opt,biomass_burn_opt, & + num_c,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure, only: grid_config_rec_type + USE module_state_description + IMPLICIT NONE + + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id,julday,chem_opt,biomass_burn_opt, & + num_c,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte,tracer_opt + INTEGER, INTENT(IN ) :: & + ktau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_c ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_ebu ), & + INTENT(IN ) :: ebu +! +! +! + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + xlat,xlong + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + t_phy, & + p_phy, & + dz8w, & + rho_phy + + REAL, INTENT(IN ) :: & + dtstep,gmt + integer ::imonth1,idate1,iyear1,itime1 + integer :: i,j,k + real :: time,conv_rho + integer :: iweek,idays + real :: tign,timeq,r_q,r_antro + real, dimension(7) :: week_CYCLE + ! dia da semana: DOM SEG TER QUA QUI SEX SAB + ! iweek= 1 2 3 4 5 6 7 + !- dados cetesb/campinas/2005 + data (week_CYCLE(iweek),iweek=1,7) /0.67, 1.1, 1.1, 1.1, 1.1, 1.1, 0.83/ !total = 7 + real, parameter :: bx_bburn = 18.041288 * 3600., & !- peak at 18 UTC + cx = 2.184936 * 3600., & + rinti = 2.1813936e-8 , & + ax = 2000.6038 , & + bx_antro = 15.041288 * 3600. !- peak em 15 UTC + !itime1 : initial time of simulation (hour*100) + ! time : time elapsed in seconds + ! r_q : gaussian function in 1/sec + + !-------------biomass burning diurnal cycle -------------------- + !number of days of simulation + itime1=0 + time=0. + idays = int(( float(itime1)/100. + time/3600.)/24.+.00001) + tign = real(idays)*24.*3600. + ! Modulacao da queimada media durante o ciclo diurno(unidade: 1/s) + ! com a int( r_q dt) (0 - 24h)= 1. + timeq= ( time + float(itime1)*0.01*3600. - tign ) + timeq=gmt*3600.+float(ktau)*dtstep + timeq=mod(timeq,86400.) + r_q = rinti*( ax * exp( -(timeq-bx_bburn)**2/(2.*cx**2) ) + 100. - & + 5.6712963e-4*( timeq )) + + + !------------- anthropogenic diurnal cycle (industrial,residencial, ...) + ! weekly cycle + ! week day + iweek= int(((float(julday)/7. - & + int(julday/7))*7.)) + 1 + if(iweek.gt.7) iweek = iweek-7 + !- weekly + diurnal cycle + r_q=r_q*86400. + r_q=1. ! no diurnal cycle +! +!tracer_opt has to come in as zero, if chem_opt is not =0! + temiss_select: SELECT CASE(tracer_opt) + CASE (TRACER_SMOKE) +! +! for smoke only +! + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke)+ebu(i,k,j,p_ebu_co)*conv_rho + enddo + enddo + enddo + CASE DEFAULT + call wrf_debug(15,'nothing done with burn emissions for tracers here') + END SELECT temiss_select + emiss_select: SELECT CASE(chem_opt) + CASE (RACMPM_KPP) + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +ebu(i,k,j,p_ebu_so2)*conv_rho + chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & + +ebu(i,k,j,p_ebu_sulf)*conv_rho + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +ebu(i,k,j,p_ebu_csl)*conv_rho + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & + +ebu(i,k,j,p_ebu_iso)*conv_rho + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +ebu(i,k,j,p_ebu_no)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +ebu(i,k,j,p_ebu_ald)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +ebu(i,k,j,p_ebu_hcho)*conv_rho + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +ebu(i,k,j,p_ebu_ora2)*conv_rho + chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & + +ebu(i,k,j,p_ebu_hc3)*conv_rho + chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & + +ebu(i,k,j,p_ebu_hc5)*conv_rho + chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & + +ebu(i,k,j,p_ebu_hc8)*conv_rho + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + +ebu(i,k,j,p_ebu_eth)*conv_rho + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +ebu(i,k,j,p_ebu_co)*conv_rho + chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & + +ebu(i,k,j,p_ebu_olt)*conv_rho + chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & + +ebu(i,k,j,p_ebu_oli)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + +ebu(i,k,j,p_ebu_tol)*conv_rho + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + +ebu(i,k,j,p_ebu_xyl)*conv_rho + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & + +ebu(i,k,j,p_ebu_ket)*conv_rho + chem(i,k,j,p_pm_25) = chem(i,k,j,p_pm_25) & + +r_q*ebu(i,k,j,p_ebu_pm25)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_pm_10) = chem(i,k,j,p_pm_10) & + +r_q*ebu(i,k,j,p_ebu_pm10)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + enddo + ; enddo + enddo + CASE (RADM2SORG,RACMSORG_KPP, RADM2SORG_KPP, RADM2SORG_AQ, RACMSORG_AQ) + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) + + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +ebu(i,k,j,p_ebu_so2)*conv_rho + chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & + +ebu(i,k,j,p_ebu_sulf)*conv_rho + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +ebu(i,k,j,p_ebu_csl)*conv_rho + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & + +ebu(i,k,j,p_ebu_iso)*conv_rho + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +ebu(i,k,j,p_ebu_no)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +ebu(i,k,j,p_ebu_ald)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +ebu(i,k,j,p_ebu_hcho)*conv_rho + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +ebu(i,k,j,p_ebu_ora2)*conv_rho + chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & + +ebu(i,k,j,p_ebu_hc3)*conv_rho + chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & + +ebu(i,k,j,p_ebu_hc5)*conv_rho + chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & + +ebu(i,k,j,p_ebu_hc8)*conv_rho + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + +ebu(i,k,j,p_ebu_eth)*conv_rho + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +ebu(i,k,j,p_ebu_co)*conv_rho + chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & + +ebu(i,k,j,p_ebu_olt)*conv_rho + chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & + +ebu(i,k,j,p_ebu_oli)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + +ebu(i,k,j,p_ebu_tol)*conv_rho + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + +ebu(i,k,j,p_ebu_xyl)*conv_rho + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & + +ebu(i,k,j,p_ebu_ket)*conv_rho + enddo + enddo + enddo + CASE (GOCART_SIMPLE) + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +ebu(i,k,j,p_ebu_so2)*conv_rho + chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & + +ebu(i,k,j,p_ebu_sulf)*conv_rho + chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & + +ebu(i,k,j,p_ebu_dms)*conv_rho + chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & + +r_q*ebu(i,k,j,p_ebu_oc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & + +r_q*ebu(i,k,j,p_ebu_bc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & + +r_q*ebu(i,k,j,p_ebu_pm25)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & + +r_q*ebu(i,k,j,p_ebu_pm10)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + enddo + k=kts + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +ebu(i,k,j,p_ebu_so2)*conv_rho + chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & + +ebu(i,k,j,p_ebu_sulf)*conv_rho + chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & + +r_q*ebu(i,k,j,p_ebu_dms)/rho_phy(i,k,j)*dtstep + chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & + +r_q*ebu(i,k,j,p_ebu_oc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & + +r_q*ebu(i,k,j,p_ebu_bc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & + +r_q*ebu(i,k,j,p_ebu_pm25)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & + +r_q*ebu(i,k,j,p_ebu_pm10)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + enddo + enddo + CASE (GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + +ebu(i,k,j,p_ebu_so2)*conv_rho + chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & + +ebu(i,k,j,p_ebu_sulf)*conv_rho + chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & + +ebu(i,k,j,p_ebu_dms)*conv_rho + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +ebu(i,k,j,p_ebu_csl)*conv_rho + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & + +ebu(i,k,j,p_ebu_iso)*conv_rho + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +ebu(i,k,j,p_ebu_no)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +ebu(i,k,j,p_ebu_ald)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +ebu(i,k,j,p_ebu_hcho)*conv_rho + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +ebu(i,k,j,p_ebu_ora2)*conv_rho + chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & + +ebu(i,k,j,p_ebu_hc3)*conv_rho + chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & + +ebu(i,k,j,p_ebu_hc5)*conv_rho + chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & + +ebu(i,k,j,p_ebu_hc8)*conv_rho + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + +ebu(i,k,j,p_ebu_eth)*conv_rho + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +ebu(i,k,j,p_ebu_co)*conv_rho + chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & + +ebu(i,k,j,p_ebu_olt)*conv_rho + chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & + +ebu(i,k,j,p_ebu_oli)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + +ebu(i,k,j,p_ebu_tol)*conv_rho + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + +ebu(i,k,j,p_ebu_xyl)*conv_rho + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & + +ebu(i,k,j,p_ebu_ket)*conv_rho + chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & + +r_q*ebu(i,k,j,p_ebu_oc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & + +r_q*ebu(i,k,j,p_ebu_bc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & + +r_q*ebu(i,k,j,p_ebu_pm25)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p10) = chem(i,k,j,p_p10) & + +r_q*ebu(i,k,j,p_ebu_pm10)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + enddo + enddo + enddo + CASE (RADM2,RACM_KPP,RACM_MIM_KPP) + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +ebu(i,k,j,p_ebu_csl)*conv_rho + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & + +ebu(i,k,j,p_ebu_iso)*conv_rho + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + +ebu(i,k,j,p_ebu_no)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & + +ebu(i,k,j,p_ebu_ald)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & + +ebu(i,k,j,p_ebu_hcho)*conv_rho + chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & + +ebu(i,k,j,p_ebu_ora2)*conv_rho + chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & + +ebu(i,k,j,p_ebu_hc3)*conv_rho + chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & + +ebu(i,k,j,p_ebu_hc5)*conv_rho + chem(i,k,j,p_hc8) = chem(i,k,j,p_hc8) & + +ebu(i,k,j,p_ebu_hc8)*conv_rho + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + +ebu(i,k,j,p_ebu_eth)*conv_rho + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +ebu(i,k,j,p_ebu_co)*conv_rho + chem(i,k,j,p_olt) = chem(i,k,j,p_olt) & + +ebu(i,k,j,p_ebu_olt)*conv_rho + chem(i,k,j,p_oli) = chem(i,k,j,p_oli) & + +ebu(i,k,j,p_ebu_oli)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + +ebu(i,k,j,p_ebu_tol)*conv_rho + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + +ebu(i,k,j,p_ebu_xyl)*conv_rho + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & + +ebu(i,k,j,p_ebu_ket)*conv_rho + enddo + enddo + enddo + CASE (MOZCART_KPP) + do j=jts,jte + do i=its,ite + do k=kts,kte + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) + chem(i,k,j,p_co) = chem(i,k,j,p_co) +ebu(i,k,j,p_ebu_co)*conv_rho + chem(i,k,j,p_no) = chem(i,k,j,p_no) +ebu(i,k,j,p_ebu_no)*conv_rho + chem(i,k,j,p_bigalk) = chem(i,k,j,p_bigalk) + ebu(i,k,j,p_ebu_bigalk)*conv_rho + chem(i,k,j,p_bigene) = chem(i,k,j,p_bigene) + ebu(i,k,j,p_ebu_bigene)*conv_rho + chem(i,k,j,p_c2h4) = chem(i,k,j,p_c2h4) + ebu(i,k,j,p_ebu_c2h4)*conv_rho + chem(i,k,j,p_c2h5oh) = chem(i,k,j,p_c2h5oh) + ebu(i,k,j,p_ebu_c2h5oh)*conv_rho + chem(i,k,j,p_c2h6) = chem(i,k,j,p_c2h6) + ebu(i,k,j,p_ebu_c2h6)*conv_rho + chem(i,k,j,p_c3h6) = chem(i,k,j,p_c3h6) + ebu(i,k,j,p_ebu_c3h6)*conv_rho + chem(i,k,j,p_c3h8) = chem(i,k,j,p_c3h8) + ebu(i,k,j,p_ebu_c3h8)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) +ebu(i,k,j,p_ebu_hcho)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) +ebu(i,k,j,p_ebu_ald)*conv_rho + + chem(i,k,j,p_acet) = chem(i,k,j,p_acet) + ebu(i,k,j,p_ebu_ch3coch3)*conv_rho + chem(i,k,j,p_ch3oh) = chem(i,k,j,p_ch3oh) + ebu(i,k,j,p_ebu_ch3oh)*conv_rho + chem(i,k,j,p_mek) = chem(i,k,j,p_mek) + ebu(i,k,j,p_ebu_mek)*conv_rho + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) +ebu(i,k,j,p_ebu_so2)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) +ebu(i,k,j,p_ebu_tol)*conv_rho + chem(i,k,j,p_nh3) = chem(i,k,j,p_nh3) + ebu(i,k,j,p_ebu_nh3)*conv_rho + chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) & + +r_q*ebu(i,k,j,p_ebu_oc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) & + +r_q*ebu(i,k,j,p_ebu_bc)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p25) = chem(i,k,j,p_p25) & + +r_q*ebu(i,k,j,p_ebu_pm25)/rho_phy(i,k,j)*dtstep/dz8w(i,k,j) + enddo + enddo + enddo + CASE (CHEM_TRACE2) + do j=jts,jte + do i=its,ite + do k=kts+1,kte-1 + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/60./dz8w(i,k,j) + chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) & + +ebu(i,k,j,p_ebu_co)*conv_rho + enddo + k=kts + conv_rho=r_q*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + chem(i,k,j,p_tracer_1) = chem(i,k,j,p_tracer_1) & + +ebu(i,k,j,p_ebu_co)*conv_rho + enddo + enddo + CASE DEFAULT + call wrf_debug(15,'nothing done with burn emissions for chem array') + END SELECT emiss_select + + + END subroutine add_emis_burn + +END Module module_add_emiss_burn diff --git a/wrfv2_fire/chem/module_aerosols_sorgam.F b/wrfv2_fire/chem/module_aerosols_sorgam.F index 7bb7c33b..2573b302 100644 --- a/wrfv2_fire/chem/module_aerosols_sorgam.F +++ b/wrfv2_fire/chem/module_aerosols_sorgam.F @@ -4,7 +4,7 @@ MODULE module_aerosols_sorgam USE module_data_radm2 USE module_data_sorgam USE module_radm - USE module_isrpia, only: isoropia +! USE module_isrpia, only: isoropia ! IMPLICIT NONE #define cw_species_are_in_registry @@ -211,7 +211,6 @@ CONTAINS (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))) ) rh(k)=max(.1,0.01*rh(k)) -! rh(k) = .10 enddo do k=kts,kte ! if(timer.gt.2.)then @@ -544,7 +543,7 @@ CONTAINS enddo END SUBROUTINE sum_pm_sorgam ! /////////////////////////////////////////////////// - SUBROUTINE sorgam_depdriver (id,ktau,dtstep, & + SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & @@ -554,6 +553,9 @@ CONTAINS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + + USE module_configure,only: grid_config_rec_type + TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags INTEGER, INTENT(IN ) :: & numaer, & ids,ide, jds,jde, kds,kde, & @@ -801,6 +803,14 @@ CONTAINS cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2) cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2) cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2) + if (p_naai >= param_first_scalar) & + cblk(1,VNAAI ) = max(epsilc,chem(i,k,j,p_naai)*convfac2) + if (p_naaj >= param_first_scalar) & + cblk(1,VNAAJ ) = max(epsilc,chem(i,k,j,p_naaj)*convfac2) + if (p_clai >= param_first_scalar) & + cblk(1,VCLAI ) = max(epsilc,chem(i,k,j,p_clai)*convfac2) + if (p_claj >= param_first_scalar) & + cblk(1,VCLAJ ) = max(epsilc,chem(i,k,j,p_claj)*convfac2) cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2) cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2) cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2) @@ -869,24 +879,32 @@ CONTAINS DGNUC, DGACC, DGCOR, & KNNUC, KNACC,KNCOR ) ! print *,'out modpar ',i,j -! CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, & -! BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, & -! DGNUC, DGACC, DGCOR, & -! KNNUC, KNACC,KNCOR, & -! PDENSN, PDENSA, PDENSC, & -! VSED, VDEP ) + if (config_flags%aer_drydep_opt == 11) then + CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, & + BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP ) + else CALL VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, & BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,& ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,& KNNUC, KNACC,KNCOR, & PDENSN, PDENSA, PDENSC, & VSED, VDEP ) + endif + VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC ) VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC ) VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ ) VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI ) VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ ) VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI ) + if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI ) = VGSA(i, j, VSO4AI ) + if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ ) = VGSA(i, j, VSO4AJ ) + if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI ) = VGSA(i, j, VSO4AI ) + if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ ) = VGSA(i, j, VSO4AJ ) VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ ) VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI ) VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ ) @@ -1463,11 +1481,11 @@ END SUBROUTINE sorgam_depdriver ! for now, don't call if temp is below -40C (humidity ! for this wrf version is already limited to 10 percent) - if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then - CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) - else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then +! if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then +! CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) +! else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh) - endif +! endif ! *** get size distribution information: @@ -2873,7 +2891,7 @@ END SUBROUTINE sorgam_depdriver print *,wi(1),wi(2),wi(3),wi(4),wi(5) endif - call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other) +! call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other) ! *** the following is an interim procedure. Assume the i-mode has the @@ -7084,6 +7102,7 @@ END SUBROUTINE VDVG RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982) vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor vdplim=min(vdplim,.02) + vdplim=max(vdplim,1e-35) !wig: add check since occasionally a lg particle causes overflow of rsurfq RSURFQ=RA(LCELL)+1./vdplim ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence ! @@ -8035,11 +8054,13 @@ END SUBROUTINE VDVG_2 END SUBROUTINE sorgam_init_aer_ic_pnnl !------------------------------------------------------------------------ + SUBROUTINE sorgam_addemiss( & id, dtstep, u10, v10, alt, dz8w, xland, chem, & + ebu, & slai,ust,smois,ivgtyp,isltyp, & emis_ant,dust_emiss_active, & - seasalt_emiss_active,kemit,num_soil_layers, & + seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -8052,9 +8073,9 @@ SUBROUTINE sorgam_addemiss( & USE module_state_description, only: num_chem - INTEGER, INTENT(IN ) :: seasalt_emiss_active, kemit, & + INTEGER, INTENT(IN ) :: seasalt_emiss_active, kemit,emissopt, & dust_emiss_active,num_soil_layers,id, & - ids,ide, jds,jde, kds,kde, & + biom,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -8066,9 +8087,15 @@ SUBROUTINE sorgam_addemiss( & ! ! aerosol emissions arrays ((ug/m3)*m/s) ! - REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), & + REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), & INTENT(IN ) :: & emis_ant +! +! biomass burning aerosol emissions arrays ((ug/m3)*m/s) +! + REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_ebu ), & + INTENT(IN ) :: & + ebu ! 1/(dry air density) and layer thickness (m) REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & @@ -8084,15 +8111,16 @@ SUBROUTINE sorgam_addemiss( & INTENT(INOUT) :: smois ! Local variables... - real, dimension(its:ite,kts:kemit,jts:jte) :: factor + real, dimension(its:ite,kts:kte,jts:jte) :: factor ! ! Get the emissions unit conversion factor including the time step. ! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep] ! - factor(its:ite,kts:kemit,jts:jte) = alt(its:ite,kts:kemit,jts:jte)*dtstep/ & - dz8w(its:ite,kts:kemit,jts:jte) + factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ & + dz8w(its:ite,kts:kte,jts:jte) ! ! Increment the aerosol numbers... + if(emissopt .lt. 5 )then ! ! Aitken mode first... @@ -8164,6 +8192,105 @@ SUBROUTINE sorgam_addemiss( & chem(its:ite,kts:kemit,jts:jte,p_no3ai) = & chem(its:ite,kts:kemit,jts:jte,p_no3ai) + & emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte) + elseif(emissopt == 5)then +! +! Aitken mode first... + + chem(its:ite,kts:kemit,jts:jte,p_nu0) = & + chem(its:ite,kts:kemit,jts:jte,p_nu0) + & + factor(its:ite,kts:kemit,jts:jte)*factnumn*( & + anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + & + orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) ) + +! Accumulation mode next... + + chem(its:ite,kts:kemit,jts:jte,p_ac0) = & + chem(its:ite,kts:kemit,jts:jte,p_ac0) + & + factor(its:ite,kts:kemit,jts:jte)*factnuma*( & + anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + & + orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) ) + +! +! Increment the aerosol masses... +! + + chem(its:ite,kts:kemit,jts:jte,p_ecj) = & + chem(its:ite,kts:kemit,jts:jte,p_ecj) + & + .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_eci) = & + chem(its:ite,kts:kemit,jts:jte,p_eci) + & + .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = & + chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + & + .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_orgpai) = & + chem(its:ite,kts:kemit,jts:jte,p_orgpai) + & + .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte) + + endif +! add biomass burning emissions if present +! + if(biom == 1 )then +! +! Aitken mode first... + + chem(its:ite,kts:kte,jts:jte,p_nu0) = & + chem(its:ite,kts:kte,jts:jte,p_nu0) + & + factor(its:ite,kts:kte,jts:jte)*factnumn*( & + anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + & + orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) ) + +! Accumulation mode next... + + chem(its:ite,kts:kte,jts:jte,p_ac0) = & + chem(its:ite,kts:kte,jts:jte,p_ac0) + & + factor(its:ite,kts:kte,jts:jte)*factnuma*( & + anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + & + orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) ) +! coarse + chem(its:ite,kts:kte,jts:jte,p_corn) = & + chem(its:ite,kts:kte,jts:jte,p_corn) + & + factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac* & + ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10) + +! +! Increment the aerosol masses... +! + + chem(its:ite,kts:kte,jts:jte,p_ecj) = & + chem(its:ite,kts:kte,jts:jte,p_ecj) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_eci) = & + chem(its:ite,kts:kte,jts:jte,p_eci) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_orgpaj) = & + chem(its:ite,kts:kte,jts:jte,p_orgpaj) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_orgpai) = & + chem(its:ite,kts:kte,jts:jte,p_orgpai) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_antha) = & + chem(its:ite,kts:kte,jts:jte,p_antha) + & + ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_p25j) = & + chem(its:ite,kts:kte,jts:jte,p_p25j) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_p25i) = & + chem(its:ite,kts:kte,jts:jte,p_p25i) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte) + + endif !end biomass burning ! ! Get the sea salt emissions... ! @@ -8193,7 +8320,6 @@ SUBROUTINE sorgam_addemiss( & END SUBROUTINE sorgam_addemiss - !------------------------------------------------------------------------ SUBROUTINE sorgam_seasalt_emiss( & dtstep, u10, v10, alt, dz8w, xland, chem, & diff --git a/wrfv2_fire/chem/module_bioemi_megan2.F b/wrfv2_fire/chem/module_bioemi_megan2.F index 4249f7c8..6ad13a57 100644 --- a/wrfv2_fire/chem/module_bioemi_megan2.F +++ b/wrfv2_fire/chem/module_bioemi_megan2.F @@ -396,7 +396,7 @@ CONTAINS ! get p_of_megan2racm(:), p_of_racm(:), and racm_per_megan(:) CALL get_megan2racm_table - CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CASE (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) ! get p_of_megan2cbmz(:), p_of_cbmz(:), and cbmz_per_megan(:) CALL get_megan2cbmz_table @@ -844,7 +844,7 @@ CONTAINS END DO - CASE (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) + CASE (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) DO icount = 1, n_megan2cbmz diff --git a/wrfv2_fire/chem/module_chem_utilities.F b/wrfv2_fire/chem/module_chem_utilities.F index aeb731fa..b6958e34 100644 --- a/wrfv2_fire/chem/module_chem_utilities.F +++ b/wrfv2_fire/chem/module_chem_utilities.F @@ -10,7 +10,7 @@ CONTAINS phb, t, moist, n_moist, & ! input rho, p_phy , & ! output u_phy, v_phy, p8w, t_phy, t8w, & ! output - z, z_at_w, dz8w, & ! output + z, z_at_w, dz8w,rh, & ! output fzm, fzp, & ! params ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -39,7 +39,7 @@ CONTAINS rho, & z, & dz8w, & - z_at_w + rh, z_at_w REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(IN ) :: pb, & @@ -127,10 +127,15 @@ CONTAINS do k = k_start, k_end do i = i_start, i_end z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) ) + rh(i,k,j) = max(.1,MIN( .95, moist(i,k,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))))) +! rh(i,k,j)=max(.1,rh(i,k,j)) enddo enddo enddo + ! interp t and p at w points do j = j_start,j_end diff --git a/wrfv2_fire/chem/module_ctrans_grell.F b/wrfv2_fire/chem/module_ctrans_grell.F index e637f2d7..fcf59eee 100755 --- a/wrfv2_fire/chem/module_ctrans_grell.F +++ b/wrfv2_fire/chem/module_ctrans_grell.F @@ -4,28 +4,31 @@ MODULE module_ctrans_grell USE module_cu_gd USE module_dep_simple +USE module_state_description, only:p_co,p_qv,p_so2,p_o3,p_sulf,p_nh3,p_h2o2, & + p_paa,p_hno3,p_n2o5,p_so4aj,p_nh4aj,p_no3aj CONTAINS !------------------------------------------------------------- SUBROUTINE GRELLDRVCT(DT,itimestep,DX, & - id,config_flags,rho_phy,RAINCV,chem, & + rho_phy,RAINCV,chem, & U,V,t_phy,moist,dz8w,p_phy, & XLV,CP,G,r_v,z,cu_co_ten, & - numgas,chemopt, & + num_moist,numgas,num_chem,chemopt,scalaropt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - USE module_configure - USE module_state_description +! USE module_configure +! USE module_state_description !------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------- INTEGER, INTENT(IN ) :: & - id, numgas,chemopt, & + numgas,chemopt,scalaropt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte + its,ite, jts,jte, kts,kte, & + num_chem,num_moist INTEGER, INTENT(IN ) :: ITIMESTEP @@ -82,7 +85,6 @@ CONTAINS Z1,PSUR,AAEQ integer, dimension (its:ite) :: & ktop - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER :: nv,i,j,k,ICLDCK,ipr,jpr,npr REAL :: tcrit,dp,dq,epsilc @@ -97,7 +99,8 @@ CONTAINS ! jpr=60 ipr=0 jpr=0 - npr=p_co + npr=1 + if(p_co.gt.1)npr=p_co tcrit=258. iopt=0 itf=MIN(ite,ide-1) @@ -130,7 +133,7 @@ CONTAINS IF(Q(I,K).LT.1.E-08)Q(I,K)=1.E-08 ENDDO ENDDO - do nv=1,num_chem + do nv=2,num_chem DO K=kts,ktf DO I=ITS,ITF tracer(i,k,nv)=max(epsilc,chem(i,k,j,nv)) @@ -153,12 +156,12 @@ CONTAINS ! CALL CUP_ct(ktop,tracer,j,AAEQ,T,Q,TER11,PRET,P,tracert, & hstary,DT,PSUR,US,VS,tcrit, & - xlv,r_v,cp,g,ipr,jpr,npr,num_chem,chemopt, & + xlv,r_v,cp,g,ipr,jpr,npr,num_chem,chemopt,scalaropt,& numgas,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - do nv=1,num_chem + do nv=2,num_chem DO I=its,itf if(pret(i).le.0.)then DO K=kts,ktf @@ -169,7 +172,7 @@ CONTAINS enddo CALL neg_check_ct(pret,ktop,epsilc,dt,tracer,tracert,iopt,num_chem, & its,ite,kts,kte,itf,ktf,ipr,jpr,npr,j) - do nv=1,num_chem + do nv=2,num_chem DO I=its,itf if(pret(i).gt.0.)then DO K=kts,ktf @@ -196,7 +199,7 @@ CONTAINS SUBROUTINE CUP_ct(ktop,tracer,J,AAEQ,T,Q,Z1, & PRE,P,tracert,hstary,DTIME,PSUR,US,VS,TCRIT, & - xl,rv,cp,g,ipr,jpr,npr,num_chem,chemopt, & + xl,rv,cp,g,ipr,jpr,npr,num_chem,chemopt,scalaropt, & numgas,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -206,7 +209,7 @@ CONTAINS integer & ,intent (in ) :: & num_chem,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + ims,ime, jms,jme, kms,kme,scalaropt, & its,ite, jts,jte, kts,kte,ipr,jpr,npr,chemopt,numgas integer, intent (in ) :: & j @@ -539,6 +542,10 @@ CONTAINS its,ite, jts,jte, kts,kte) DO 100 i=its,ite IF(ierr(I).eq.0.)THEN + if(jmin(i).le.3)then + ierr(i)=9 + go to 100 + endif ! !--- check whether it would have buoyancy, if there where !--- no entrainment/detrainment @@ -579,6 +586,9 @@ CONTAINS ! do i=its,itf IF(ierr(I).eq.0.)THEN + if(jmin(i).le.3)then + ierr(i)=9 + endif IF(-z_cup(I,KBCON(I))+z_cup(I,KTOP(I)).LT.depth_min)then ierr(i)=6 endif @@ -675,9 +685,9 @@ CONTAINS if(j.eq.jpr)print *,'calling up_tracer' call cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up,tr_pw, & tr_c,hstary,pw,clw_all,kbcon,ktop,cd,mentr_rate,zu,k22,& - numgas,chemopt,ids,ide, jds,jde, kds,kde, & + numgas,chemopt,scalaropt,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,ipr,jpr,j,npr) + its,ite, jts,jte, kts,kte,ipr,jpr,j,npr,num_chem) if(j.eq.jpr)print *,'called up_tracer' call cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & tr_pw,tr_pwd,jmin,cdd,mentrd_rate,zd,pwdper,k22, & @@ -805,7 +815,7 @@ CONTAINS entdo=edt(i)*zd(i,2)*mentrd_rate*dz subin=-EDT(I)*zd(i,2) detdo=detdo1+detdo2-entdo+subin - do nv=1,num_chem + do nv=2,num_chem tracert(I,1,nv)=(detdo1*.5*(tr_dd(i,1,nv)+tr_dd(i,2,nv)) & +detdo2*tr_dd(i,1,nv) & +subin*tre_cup(i,2,nv) & @@ -880,7 +890,7 @@ CONTAINS print *,'in dellas kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i)' print *,kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i) endif - do nv=1,num_chem + do nv=2,num_chem DO K=kts+1,kte do i=its,itf tracert(i,k,nv)=0. @@ -951,7 +961,7 @@ CONTAINS CALL wrf_error_fatal ( 'cup_dellas_tr: TOTMAS > CRITICAL VALUE') endif dp=100.*(p_cup(i,k-1)-p_cup(i,k)) - do nv=1,num_chem + do nv=2,num_chem ! tracert(i,k,nv)=(subin*tre_cup(i,k+1,nv) & ! -subdown*tre_cup(i,k,nv) & tracert(i,k,nv)=(subin*tracer(i,k+1,nv) & @@ -1004,7 +1014,7 @@ CONTAINS i,k,nv,itf,ktf itf=MIN(ite,ide-1) ktf=MIN(kte,kde-1) - do nv=1,num_chem + do nv=2,num_chem do k=kts+1,ktf do i=its,ite if(ierr(i).eq.0)then @@ -1013,7 +1023,7 @@ CONTAINS enddo enddo enddo - do nv=1,num_chem + do nv=2,num_chem do i=its,ite if(ierr(i).eq.0)then tre_cup(i,kts,nv)=tracer(i,kts,nv) @@ -1027,11 +1037,11 @@ END subroutine cup_env_clev_tr SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & tr_pw,tr_c,hstary,cupclw,clw_all,kbcon,ktop,cd,mentr_rate,zu,k22, & - numgas,chemopt,ids,ide, jds,jde, kds,kde, & + numgas,chemopt,scalaropt,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte,ipr,jpr,j,npr) - USE module_configure - USE module_state_description + its,ite, jts,jte, kts,kte,ipr,jpr,j,npr,num_chem) +! USE module_configure +! USE module_state_description USE module_ctrans_aqchem implicit none ! Aqeuous species pointers INCLUDE File @@ -1158,8 +1168,8 @@ END subroutine cup_env_clev_tr integer & ,intent (in ) :: & - numgas,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme,chemopt, & + numgas,ids,ide, jds,jde, kds,kde,scalaropt, & + num_chem,ims,ime, jms,jme, kms,kme,chemopt, & its,ite, jts,jte, kts,kte,ipr,jpr,j,npr real, dimension (its:ite,kts:kte) & ,intent (in ) :: & @@ -1229,7 +1239,7 @@ END subroutine cup_env_clev_tr if(radius.lt.900.)c0=0. ! if(radius.lt.900.)iall=0 endif - do nv=1,num_chem + do nv=2,num_chem do k=kts,ktf do i=its,itf tr_pw(i,k,nv)=0. @@ -1238,7 +1248,7 @@ END subroutine cup_env_clev_tr enddo enddo enddo - do nv=1,num_chem + do nv=2,num_chem do i=its,itf if(ierr(i).eq.0.)then do k=k22(i),kbcon(i)-1 @@ -1264,7 +1274,7 @@ END subroutine cup_env_clev_tr !------ tr_up would be the concentration if tr would be conserved ! ! - do nv=1,num_chem + do nv=2,num_chem if(i.eq.ipr.and.j.eq.jpr.and.nv.eq.npr)print *,k,tr_up(i,K-1,nv),tr_up(i,K,nv),tr_pw(i,k-1,nv),clw_all(i,k),cupclw(i,k) tr_up(i,K,nv)=(tr_up(i,K-1,nv)*(1.-.5*CD(i,K)*DZ)+mentr_rate* & DZ*tracer(i,K-1,nv))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz) @@ -1358,7 +1368,7 @@ END subroutine cup_env_clev_tr ! FOLLOWING FOR WET DEPOSITION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - do nv=1,num_chem + do nv=2,num_chem tr_c(i,k,nv)=0. tr_pw(i,k,nv)=c0*dz*tr_C(I,K,nv)*zu(i,k) if(tr_c(i,k,nv).le.0.)then @@ -1406,7 +1416,7 @@ END subroutine cup_env_clev_tr write(6,*)'a',tr_up(i,k,npr),tracer(i,K-1,npr),tr_pw(i,k,npr) endif else ! NOT MADE SORGAM - do nv=1,num_chem + do nv=2,num_chem ! we definitely need wet deposition for sulf ! tr_c would be conc_mxr for other tracers, like: ! partialp=1.e-6*qc(i,k)*29./wtm(name)*p(i,k)/1013. @@ -1463,11 +1473,11 @@ END subroutine cup_up_tracer SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & tr_pw,tr_pwd,jmin,cdd,entr,zd,pwdper,k22, & - numch,ids,ide, jds,jde, kds,kde, & + num_chem,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) - USE module_configure - USE module_state_description +! USE module_configure +! USE module_state_description implicit none ! ! on input @@ -1477,7 +1487,7 @@ END subroutine cup_up_tracer integer & ,intent (in ) :: & - numch,ids,ide, jds,jde, kds,kde, & + num_chem,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte real, dimension (its:ite,kts:kte) & @@ -1523,8 +1533,8 @@ END subroutine cup_up_tracer ktf=MIN(kte,kde-1) ! qrch=0. - do nv=1,num_chem - do k=kts+1,kte + do nv=2,num_chem + do k=kts+0,kte do i=its,ite tr_dd(i,k,nv)=0. tr_pwd(i,k,nv)=0. @@ -1551,12 +1561,13 @@ END subroutine cup_up_tracer !--- for now ! ! - do nv=1,num_chem + if(jmin(i).lt.3)write(0,*)i,jmin(i) + do nv=2,num_chem tr_dd(i,jmin(i),nv)=tre_cup(i,jmin(i),nv) enddo do ki=jmin(i)-1,1,-1 DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki) - do nv=1,num_chem + do nv=2,num_chem tr_pwd(i,jmin(i),nv)=0. tr_dd(i,Ki,nv)=(tr_dd(i,Ki+1,nv)*(1.-.5*CDD(i,Ki)*DZ) & +entr*DZ*tracer(i,Ki,nv) & @@ -1618,7 +1629,7 @@ END subroutine cup_dd_tracer thresh=epsilc ! thresh=1.e-30 if(iopt.eq.0)then - do nv=1,num_chem + do nv=2,num_chem do 100 i=its,itf if(pret(i).le.0.)go to 100 tracermin=q(i,kts,nv) @@ -1701,7 +1712,7 @@ END subroutine cup_dd_tracer do i=its,itf qmemf=1. do k=kts,ktop(i) - do nv=1,num_chem + do nv=2,num_chem ! ! tracer tendency ! @@ -1723,7 +1734,7 @@ END subroutine cup_dd_tracer endif enddo enddo - do nv=1,num_chem + do nv=2,num_chem do k=kts,ktop(i) outq(i,k,nv)=outq(i,k,nv)*qmemf enddo diff --git a/wrfv2_fire/chem/module_data_mgn2mech.F b/wrfv2_fire/chem/module_data_mgn2mech.F index bf974d58..0886e4ba 100644 --- a/wrfv2_fire/chem/module_data_mgn2mech.F +++ b/wrfv2_fire/chem/module_data_mgn2mech.F @@ -1,28 +1,33 @@ MODULE module_data_mgn2mech - - ! This module contains speciation to convert MEGAN emissions - ! species to various gas-phase mechanism species - ! - ! August, 2007 - ! - ! Serena H. Chung Washington State University - ! Tan Sakulyanontvittaya University of Colorado - ! Christine Wiedinmyer National Center for Atmospheric Research - - - - ! - ! provides p_iso, p_par, etc +!--------------------------------------------------------------- +! This module contains speciation to convert MEGAN emissions +! species to various gas-phase mechanism species +! +! August, 2007 +! +! Serena H. Chung Washington State University +! Tan Sakulyanontvittaya University of Colorado +! Christine Wiedinmyer National Center for Atmospheric Research +!--------------------------------------------------------------- + +!--------------------------------------------------------------- +! provides p_iso, p_par, etc +!--------------------------------------------------------------- USE module_state_description - ! provides is_soprene, is_myrcene, etc +!--------------------------------------------------------------- +! provides is_soprene, is_myrcene, etc +!--------------------------------------------------------------- USE module_data_megan2 IMPLICIT NONE + SAVE - ! for MEGAN species not in the reaction mechanisms +!--------------------------------------------------------------- +! for MEGAN species not in the reaction mechanisms +!--------------------------------------------------------------- INTEGER, PARAMETER :: non_react = 9999 INTEGER, PARAMETER :: n_megan2cbmz = 173 @@ -41,35 +46,191 @@ MODULE module_data_mgn2mech REAL, DIMENSION (n_megan2racm) :: racm_per_megan DATA p_of_racm / n_megan2racm*non_react / - - - !-------------------------------------------------------------------- - ! Some naming convention in denoting MEGAN species - ! _a = alpha , _b = beta , _c = cis , _al = allo , - ! _g = gamma , _d = delta , _t = trans , _m = methyl , - ! _p = para , _o = ortho , _e = ene , _ol = ol , - ! met = methyl , 2met= dimethyl , MBO = methylbutenol , - ! 2s = disulfide , s = sulfide , OXD = oxide , ACT = acetate , - ! PPPP= propenylpropyl , DCTT= decatetraene , - ! CCO = acetaldehyde - + INTEGER, PARAMETER :: n_megan2mozcart = 142 + INTEGER, DIMENSION (n_megan2mozcart) :: p_of_megan2mozcart, p_of_mozcart + REAL, DIMENSION (n_megan2mozcart) :: mozcart_per_megan + DATA p_of_mozcart / n_megan2mozcart*non_react / + +!-------------------------------------------------------------------- +! Some naming convention in denoting MEGAN species +! _a = alpha , _b = beta , _c = cis , _al = allo , +! _g = gamma , _d = delta , _t = trans , _m = methyl , +! _p = para , _o = ortho , _e = ene , _ol = ol , +! met = methyl , 2met= dimethyl , MBO = methylbutenol , +! 2s = disulfide , s = sulfide , OXD = oxide , ACT = acetate , +! PPPP= propenylpropyl , DCTT= decatetraene , +! CCO = acetaldehyde +!-------------------------------------------------------------------- CONTAINS - - !-------------------------------------------------------------------- + SUBROUTINE get_megan2mozcart_table +!-------------------------------------------------------------------- +! For MEGAN v2.04 species conversion to CBMZ species +! Based on Tan's MAP_CV2CBMZ.EXT; updated on 08/03/2007 +! based on Rahul A. Zaveri's suggestions. +!-------------------------------------------------------------------- + +!----------------------------------------------------------------------------------------------------------- +! Index of Index of Molar ratio +! MEGAN species MOZCART Species +!----------------------------------------------------------------------------------------------------------- + p_of_megan2mozcart( 1) = is_isoprene ; p_of_mozcart( 1) = p_isopr ; mozcart_per_megan( 1) = 1. + p_of_megan2mozcart( 2) = is_myrcene ; p_of_mozcart( 2) = p_c10h16 ; mozcart_per_megan( 2) = 1. + p_of_megan2mozcart( 3) = is_sabinene ; p_of_mozcart( 3) = p_c10h16 ; mozcart_per_megan( 3) = 1. + p_of_megan2mozcart( 4) = is_limonene ; p_of_mozcart( 4) = p_c10h16 ; mozcart_per_megan( 4) = 1. + p_of_megan2mozcart( 5) = is_carene_3 ; p_of_mozcart( 5) = p_c10h16 ; mozcart_per_megan( 5) = 1. + p_of_megan2mozcart( 6) = is_ocimene_t_b ; p_of_mozcart( 6) = p_c10h16 ; mozcart_per_megan( 6) = 1. + p_of_megan2mozcart( 7) = is_pinene_b ; p_of_mozcart( 7) = p_c10h16 ; mozcart_per_megan( 7) = 1. + p_of_megan2mozcart( 8) = is_pinene_a ; p_of_mozcart( 8) = p_c10h16 ; mozcart_per_megan( 8) = 1. + p_of_megan2mozcart( 9) = is_2met_styrene ; p_of_mozcart( 9) = p_c10h16 ; mozcart_per_megan( 9) = 1. + p_of_megan2mozcart( 10) = is_cymene_p ; p_of_mozcart( 10) = p_tol ; mozcart_per_megan( 10) = 1.5 + p_of_megan2mozcart( 11) = is_cymene_o ; p_of_mozcart( 11) = p_tol ; mozcart_per_megan( 11) = 1.5 + p_of_megan2mozcart( 12) = is_phellandrene_a ; p_of_mozcart( 12) = p_c10h16 ; mozcart_per_megan( 12) = 1. + p_of_megan2mozcart( 13) = is_thujene_a ; p_of_mozcart( 13) = p_c10h16 ; mozcart_per_megan( 13) = 1. + p_of_megan2mozcart( 14) = is_terpinene_a ; p_of_mozcart( 14) = p_c10h16 ; mozcart_per_megan( 14) = 1. + p_of_megan2mozcart( 15) = is_terpinene_g ; p_of_mozcart( 15) = p_c10h16 ; mozcart_per_megan( 15) = 1. + p_of_megan2mozcart( 16) = is_terpinolene ; p_of_mozcart( 16) = p_c10h16 ; mozcart_per_megan( 16) = 1. + p_of_megan2mozcart( 17) = is_phellandrene_b ; p_of_mozcart( 17) = p_c10h16 ; mozcart_per_megan( 17) = 1. + p_of_megan2mozcart( 18) = is_camphene ; p_of_mozcart( 18) = p_c10h16 ; mozcart_per_megan( 18) = 1. + p_of_megan2mozcart( 19) = is_bornene ; p_of_mozcart( 19) = p_c10h16 ; mozcart_per_megan( 19) = 1. + p_of_megan2mozcart( 20) = is_fenchene_a ; p_of_mozcart( 20) = p_c10h16 ; mozcart_per_megan( 20) = 1. + p_of_megan2mozcart( 21) = is_ocimene_al ; p_of_mozcart( 21) = p_c10h16 ; mozcart_per_megan( 21) = 1. + p_of_megan2mozcart( 22) = is_ocimene_c_b ; p_of_mozcart( 22) = p_c10h16 ; mozcart_per_megan( 22) = 1. + p_of_megan2mozcart( 23) = is_tricyclene ; p_of_mozcart( 23) = p_c10h16 ; mozcart_per_megan( 23) = 1. + p_of_megan2mozcart( 24) = is_estragole ; p_of_mozcart( 24) = p_c10h16 ; mozcart_per_megan( 24) = 1. + p_of_megan2mozcart( 25) = is_camphor ; p_of_mozcart( 25) = p_bigalk ; mozcart_per_megan( 25) = 2. + p_of_megan2mozcart( 26) = is_fenchone ; p_of_mozcart( 26) = p_bigalk ; mozcart_per_megan( 26) = 2. + p_of_megan2mozcart( 27) = is_piperitone ; p_of_mozcart( 27) = p_c10h16 ; mozcart_per_megan( 27) = 1. + p_of_megan2mozcart( 28) = is_thujone_a ; p_of_mozcart( 28) = p_bigalk ; mozcart_per_megan( 28) = 2. + p_of_megan2mozcart( 29) = is_thujone_b ; p_of_mozcart( 29) = p_bigalk ; mozcart_per_megan( 29) = 2. + p_of_megan2mozcart( 30) = is_cineole_1_8 ; p_of_mozcart( 30) = p_bigalk ; mozcart_per_megan( 30) = 2. + p_of_megan2mozcart( 31) = is_borneol ; p_of_mozcart( 31) = p_bigalk ; mozcart_per_megan( 31) = 2. + p_of_megan2mozcart( 32) = is_linalool ; p_of_mozcart( 32) = p_c10h16 ; mozcart_per_megan( 32) = 1. + p_of_megan2mozcart( 33) = is_terpineol_4 ; p_of_mozcart( 33) = p_c10h16 ; mozcart_per_megan( 33) = 1. + p_of_megan2mozcart( 34) = is_terpineol_a ; p_of_mozcart( 34) = p_c10h16 ; mozcart_per_megan( 34) = 1. + p_of_megan2mozcart( 35) = is_linalool_oxd_c ; p_of_mozcart( 35) = p_c10h16 ; mozcart_per_megan( 35) = 1.25 + p_of_megan2mozcart( 36) = is_linalool_oxd_t ; p_of_mozcart( 36) = p_c10h16 ; mozcart_per_megan( 36) = 1.25 + p_of_megan2mozcart( 37) = is_ionone_b ; p_of_mozcart( 37) = p_c10h16 ; mozcart_per_megan( 37) = 1.4 + p_of_megan2mozcart( 38) = is_bornyl_act ; p_of_mozcart( 38) = p_bigalk ; mozcart_per_megan( 38) = 2.7 + p_of_megan2mozcart( 39) = is_farnescene_a ; p_of_mozcart( 39) = p_c10h16 ; mozcart_per_megan( 39) = 1.5 + p_of_megan2mozcart( 40) = is_caryophyllene_b ; p_of_mozcart( 40) = p_c10h16 ; mozcart_per_megan( 40) = 1.5 + p_of_megan2mozcart( 41) = is_acoradiene ; p_of_mozcart( 41) = p_c10h16 ; mozcart_per_megan( 41) = 1.5 + p_of_megan2mozcart( 42) = is_aromadendrene ; p_of_mozcart( 42) = p_c10h16 ; mozcart_per_megan( 42) = 1.5 + p_of_megan2mozcart( 43) = is_bergamotene_a ; p_of_mozcart( 43) = p_c10h16 ; mozcart_per_megan( 43) = 1.5 + p_of_megan2mozcart( 44) = is_bergamotene_b ; p_of_mozcart( 44) = p_c10h16 ; mozcart_per_megan( 44) = 1.5 + p_of_megan2mozcart( 45) = is_bisabolene_a ; p_of_mozcart( 45) = p_c10h16 ; mozcart_per_megan( 45) = 1.5 + p_of_megan2mozcart( 46) = is_bisabolene_b ; p_of_mozcart( 46) = p_c10h16 ; mozcart_per_megan( 46) = 1.5 + p_of_megan2mozcart( 47) = is_bourbonene_b ; p_of_mozcart( 47) = p_c10h16 ; mozcart_per_megan( 47) = 1.5 + p_of_megan2mozcart( 48) = is_cadinene_d ; p_of_mozcart( 48) = p_c10h16 ; mozcart_per_megan( 48) = 1.5 + p_of_megan2mozcart( 49) = is_cadinene_g ; p_of_mozcart( 49) = p_c10h16 ; mozcart_per_megan( 49) = 1.5 + p_of_megan2mozcart( 50) = is_cedrene_a ; p_of_mozcart( 50) = p_c10h16 ; mozcart_per_megan( 50) = 1.5 + p_of_megan2mozcart( 51) = is_copaene_a ; p_of_mozcart( 51) = p_c10h16 ; mozcart_per_megan( 51) = 1.5 + p_of_megan2mozcart( 52) = is_cubebene_a ; p_of_mozcart( 52) = p_c10h16 ; mozcart_per_megan( 52) = 1.5 + p_of_megan2mozcart( 53) = is_cubebene_b ; p_of_mozcart( 53) = p_c10h16 ; mozcart_per_megan( 53) = 1.5 + p_of_megan2mozcart( 54) = is_elemene_b ; p_of_mozcart( 54) = p_c10h16 ; mozcart_per_megan( 54) = 1.5 + p_of_megan2mozcart( 55) = is_farnescene_b ; p_of_mozcart( 55) = p_c10h16 ; mozcart_per_megan( 55) = 1.5 + p_of_megan2mozcart( 56) = is_germacrene_B ; p_of_mozcart( 56) = p_c10h16 ; mozcart_per_megan( 56) = 1.5 + p_of_megan2mozcart( 57) = is_germacrene_D ; p_of_mozcart( 57) = p_c10h16 ; mozcart_per_megan( 57) = 1.5 + p_of_megan2mozcart( 58) = is_gurjunene_b ; p_of_mozcart( 58) = p_c10h16 ; mozcart_per_megan( 58) = 1.5 + p_of_megan2mozcart( 59) = is_humulene_a ; p_of_mozcart( 59) = p_c10h16 ; mozcart_per_megan( 59) = 1.5 + p_of_megan2mozcart( 60) = is_humulene_g ; p_of_mozcart( 60) = p_c10h16 ; mozcart_per_megan( 60) = 1.5 + p_of_megan2mozcart( 61) = is_isolongifolene ; p_of_mozcart( 61) = p_c10h16 ; mozcart_per_megan( 61) = 1.5 + p_of_megan2mozcart( 62) = is_longifolene ; p_of_mozcart( 62) = p_c10h16 ; mozcart_per_megan( 62) = 1.5 + p_of_megan2mozcart( 63) = is_longipinene ; p_of_mozcart( 63) = p_c10h16 ; mozcart_per_megan( 63) = 1.5 + p_of_megan2mozcart( 64) = is_muurolene_a ; p_of_mozcart( 64) = p_c10h16 ; mozcart_per_megan( 64) = 1.5 + p_of_megan2mozcart( 65) = is_muurolene_g ; p_of_mozcart( 65) = p_c10h16 ; mozcart_per_megan( 65) = 1.5 + p_of_megan2mozcart( 66) = is_selinene_b ; p_of_mozcart( 66) = p_c10h16 ; mozcart_per_megan( 66) = 1.5 + p_of_megan2mozcart( 67) = is_selinene_d ; p_of_mozcart( 67) = p_c10h16 ; mozcart_per_megan( 67) = 1.5 + p_of_megan2mozcart( 68) = is_nerolidol_c ; p_of_mozcart( 68) = p_c10h16 ; mozcart_per_megan( 68) = 1.5 + p_of_megan2mozcart( 69) = is_nerolidol_t ; p_of_mozcart( 69) = p_c10h16 ; mozcart_per_megan( 69) = 1.5 + p_of_megan2mozcart( 70) = is_cedrol ; p_of_mozcart( 70) = p_bigalk ; mozcart_per_megan( 70) = 3. + p_of_megan2mozcart( 71) = is_mbo_2m3e2ol ; p_of_mozcart( 71) = p_isopr ; mozcart_per_megan( 71) = 2.4 + p_of_megan2mozcart( 72) = is_methanol ; p_of_mozcart( 72) = p_ch3oh ; mozcart_per_megan( 72) = 1. + p_of_megan2mozcart( 73) = is_acetone ; p_of_mozcart( 73) = p_acet ; mozcart_per_megan( 73) = 1. + p_of_megan2mozcart( 74) = is_methane ; p_of_mozcart( 74) = non_react ; mozcart_per_megan( 74) = 1. + p_of_megan2mozcart( 75) = is_ammonia ; p_of_mozcart( 75) = p_nh3 ; mozcart_per_megan( 75) = 1. + p_of_megan2mozcart( 76) = is_nitrous_oxd ; p_of_mozcart( 76) = non_react ; mozcart_per_megan( 76) = 1. + p_of_megan2mozcart( 77) = is_nitric_oxd ; p_of_mozcart( 77) = p_no ; mozcart_per_megan( 77) = 1. + p_of_megan2mozcart( 78) = is_acetaldehyde ; p_of_mozcart( 78) = p_ald ; mozcart_per_megan( 78) = 1. + p_of_megan2mozcart( 79) = is_ethanol ; p_of_mozcart( 79) = p_c2h5oh ; mozcart_per_megan( 79) = 1. + p_of_megan2mozcart( 80) = is_formic_acid ; p_of_mozcart( 80) = non_react ; mozcart_per_megan( 80) = 1. + p_of_megan2mozcart( 81) = is_formaldehyde ; p_of_mozcart( 81) = p_hcho ; mozcart_per_megan( 81) = 1. + p_of_megan2mozcart( 82) = is_acetic_acid ; p_of_mozcart( 82) = p_ch3cooh ; mozcart_per_megan( 82) = 1. + p_of_megan2mozcart( 83) = is_mbo_3m2e1ol ; p_of_mozcart( 83) = p_isopr ; mozcart_per_megan( 83) = 1.25 + p_of_megan2mozcart( 84) = is_benzaldehyde ; p_of_mozcart( 84) = p_tol ; mozcart_per_megan( 84) = 1.1 + p_of_megan2mozcart( 85) = is_butanone_2 ; p_of_mozcart( 85) = p_mek ; mozcart_per_megan( 85) = 1. + p_of_megan2mozcart( 86) = is_decanal ; p_of_mozcart( 86) = p_bigalk ; mozcart_per_megan( 86) = 3. + p_of_megan2mozcart( 87) = is_dodecene_1 ; p_of_mozcart( 87) = p_bigene ; mozcart_per_megan( 87) = 2.25 + p_of_megan2mozcart( 88) = is_geranyl_acetone ; p_of_mozcart( 88) = p_c10h16 ; mozcart_per_megan( 88) = 1.4 + p_of_megan2mozcart( 89) = is_heptanal ; p_of_mozcart( 89) = p_bigalk ; mozcart_per_megan( 89) = 2. + p_of_megan2mozcart( 90) = is_heptane ; p_of_mozcart( 90) = p_bigalk ; mozcart_per_megan( 90) = 2. + p_of_megan2mozcart( 91) = is_hexane ; p_of_mozcart( 91) = p_bigalk ; mozcart_per_megan( 91) = 1.5 + p_of_megan2mozcart( 92) = is_met_benzoate ; p_of_mozcart( 92) = p_tol ; mozcart_per_megan( 92) = 1.5 + p_of_megan2mozcart( 93) = is_met_heptenone ; p_of_mozcart( 93) = p_bigene ; mozcart_per_megan( 93) = 1.75 + p_of_megan2mozcart( 94) = is_neryl_acetone ; p_of_mozcart( 94) = p_bigene ; mozcart_per_megan( 94) = 2.7 + p_of_megan2mozcart( 95) = is_nonanal ; p_of_mozcart( 95) = p_bigalk ; mozcart_per_megan( 95) = 2.5 + p_of_megan2mozcart( 96) = is_nonenal ; p_of_mozcart( 96) = p_bigene ; mozcart_per_megan( 96) = 2. + p_of_megan2mozcart( 97) = is_octanal ; p_of_mozcart( 97) = p_bigalk ; mozcart_per_megan( 97) = 2.3 + p_of_megan2mozcart( 98) = is_octanol ; p_of_mozcart( 98) = p_bigalk ; mozcart_per_megan( 98) = 2.3 + p_of_megan2mozcart( 99) = is_octenol_1e3ol ; p_of_mozcart( 99) = p_bigene ; mozcart_per_megan( 99) = 1.7 + p_of_megan2mozcart(100) = is_oxopentanal ; p_of_mozcart(100) = p_mek ; mozcart_per_megan(100) = 1.4 + p_of_megan2mozcart(101) = is_pentane ; p_of_mozcart(101) = p_bigalk ; mozcart_per_megan(101) = 1.25 + p_of_megan2mozcart(102) = is_phenyl_cco ; p_of_mozcart(102) = p_tol ; mozcart_per_megan(102) = 1.3 + p_of_megan2mozcart(103) = is_pyruvic_acid ; p_of_mozcart(103) = non_react ; mozcart_per_megan(103) = 1. + p_of_megan2mozcart(104) = is_terpinyl_act_a ; p_of_mozcart(104) = p_c10h16 ; mozcart_per_megan(104) = 1.4 + p_of_megan2mozcart(105) = is_tetradecene_1 ; p_of_mozcart(105) = p_bigene ; mozcart_per_megan(105) = 3.5 + p_of_megan2mozcart(106) = is_toluene ; p_of_mozcart(106) = p_tol ; mozcart_per_megan(106) = 1. + p_of_megan2mozcart(107) = is_carbon_monoxide ; p_of_mozcart(107) = p_co ; mozcart_per_megan(107) = 1. + p_of_megan2mozcart(108) = is_butene ; p_of_mozcart(108) = p_bigene ; mozcart_per_megan(108) = .8 + p_of_megan2mozcart(109) = is_ethane ; p_of_mozcart(109) = p_c2h6 ; mozcart_per_megan(109) = 1. + p_of_megan2mozcart(110) = is_ethene ; p_of_mozcart(110) = p_c2h4 ; mozcart_per_megan(110) = 1. + p_of_megan2mozcart(111) = is_hydrogen_cyanide ; p_of_mozcart(111) = non_react ; mozcart_per_megan(111) = 1. + p_of_megan2mozcart(112) = is_propane ; p_of_mozcart(112) = p_c3h8 ; mozcart_per_megan(112) = 1. + p_of_megan2mozcart(113) = is_propene ; p_of_mozcart(113) = p_c3h6 ; mozcart_per_megan(113) = 1. + p_of_megan2mozcart(114) = is_carbon_2s ; p_of_mozcart(114) = non_react ; mozcart_per_megan(114) = 1. + p_of_megan2mozcart(115) = is_carbonyl_s ; p_of_mozcart(115) = non_react ; mozcart_per_megan(115) = 1. + p_of_megan2mozcart(116) = is_diallyl_2s ; p_of_mozcart(116) = p_bigene ; mozcart_per_megan(116) = .66 + p_of_megan2mozcart(117) = is_diallyl_2s ; p_of_mozcart(117) = p_so2 ; mozcart_per_megan(117) = 1.53 + p_of_megan2mozcart(118) = is_2met_2s ; p_of_mozcart(118) = p_c2h6 ; mozcart_per_megan(118) = 1. + p_of_megan2mozcart(119) = is_2met_2s ; p_of_mozcart(119) = p_so2 ; mozcart_per_megan(119) = 1. + p_of_megan2mozcart(120) = is_met_chloride ; p_of_mozcart(120) = non_react ; mozcart_per_megan(120) = 1. + p_of_megan2mozcart(121) = is_met_bromide ; p_of_mozcart(121) = non_react ; mozcart_per_megan(121) = 1. + p_of_megan2mozcart(122) = is_met_iodide ; p_of_mozcart(122) = non_react ; mozcart_per_megan(122) = 1. + p_of_megan2mozcart(123) = is_hydrogen_s ; p_of_mozcart(123) = p_so2 ; mozcart_per_megan(123) = .5 + p_of_megan2mozcart(124) = is_met_mercaptan ; p_of_mozcart(124) = p_so2 ; mozcart_per_megan(124) = .75 + p_of_megan2mozcart(125) = is_met_propenyl_2s ; p_of_mozcart(125) = p_c3h6 ; mozcart_per_megan(125) = 2.8 + p_of_megan2mozcart(126) = is_met_propenyl_2s ; p_of_mozcart(126) = p_so2 ; mozcart_per_megan(126) = 1.8 + p_of_megan2mozcart(127) = is_pppp_2s ; p_of_mozcart(127) = p_c3h6 ; mozcart_per_megan(127) = 3.5 + p_of_megan2mozcart(128) = is_pppp_2s ; p_of_mozcart(128) = p_so2 ; mozcart_per_megan(128) = 2.3 + p_of_megan2mozcart(129) = is_2met_nonatriene ; p_of_mozcart(129) = p_c10h16 ; mozcart_per_megan(129) = 1.1 + p_of_megan2mozcart(130) = is_met_salicylate ; p_of_mozcart(130) = p_tol ; mozcart_per_megan(130) = 1.6 + p_of_megan2mozcart(131) = is_indole ; p_of_mozcart(131) = non_react ; mozcart_per_megan(131) = 1. + p_of_megan2mozcart(132) = is_jasmone ; p_of_mozcart(132) = p_c10h16 ; mozcart_per_megan(132) = 1.2 + p_of_megan2mozcart(133) = is_met_jasmonate ; p_of_mozcart(133) = p_c10h16 ; mozcart_per_megan(133) = 1.6 + p_of_megan2mozcart(134) = is_3met_3dctt ; p_of_mozcart(134) = p_bigene ; mozcart_per_megan(134) = 3. + p_of_megan2mozcart(135) = is_hexanal ; p_of_mozcart(135) = p_bigalk ; mozcart_per_megan(135) = 1.8 + p_of_megan2mozcart(136) = is_hexanol_1 ; p_of_mozcart(136) = p_bigalk ; mozcart_per_megan(136) = 1.8 + p_of_megan2mozcart(137) = is_hexenal_c3 ; p_of_mozcart(137) = p_bigene ; mozcart_per_megan(137) = 1.4 + p_of_megan2mozcart(138) = is_hexenal_t2 ; p_of_mozcart(138) = p_bigene ; mozcart_per_megan(138) = 1.4 + p_of_megan2mozcart(139) = is_hexenol_c3 ; p_of_mozcart(139) = p_bigene ; mozcart_per_megan(139) = 1.4 + p_of_megan2mozcart(140) = is_hexenyl_act_c3 ; p_of_mozcart(140) = p_bigene ; mozcart_per_megan(140) = 2. + p_of_megan2mozcart(141) = is_mbo_3m3e1ol ; p_of_mozcart(141) = p_isopr ; mozcart_per_megan(141) = 1.25 + p_of_megan2mozcart(142) = is_2met_s ; p_of_mozcart(142) = p_dms ; mozcart_per_megan(142) = 1. + + END SUBROUTINE get_megan2mozcart_table SUBROUTINE get_megan2cbmz_table - - ! For MEGAN v2.04 species conversion to CBMZ species - ! Based on Tan's MAP_CV2CBMZ.EXT; updated on 08/03/2007 - ! based on Rahul A. Zaveri's suggestions. - - - ! - ! Index of Index of Molar ratio - ! MEGAN species CMBZ Species - ! +!-------------------------------------------------------------------- +! For MEGAN v2.04 species conversion to CBMZ species +! Based on Tan's MAP_CV2CBMZ.EXT; updated on 08/03/2007 +! based on Rahul A. Zaveri's suggestions. +!-------------------------------------------------------------------- + +!----------------------------------------------------------------------------------------------------------- +! Index of Index of Molar ratio +! MEGAN species CMBZ Species +!----------------------------------------------------------------------------------------------------------- p_of_megan2cbmz( 1) = is_isoprene ; p_of_cbmz( 1) = p_iso ; cbmz_per_megan( 1) = 1. p_of_megan2cbmz( 2) = is_myrcene ; p_of_cbmz( 2) = p_iso ; cbmz_per_megan( 2) = 2. p_of_megan2cbmz( 3) = is_sabinene ; p_of_cbmz( 3) = p_iso ; cbmz_per_megan( 3) = 2. diff --git a/wrfv2_fire/chem/module_dep_simple.F b/wrfv2_fire/chem/module_dep_simple.F index c24fbf58..10d64e0c 100755 --- a/wrfv2_fire/chem/module_dep_simple.F +++ b/wrfv2_fire/chem/module_dep_simple.F @@ -30,7 +30,7 @@ subroutine wesely_driver(id,ktau,dtstep, & config_flags, & gmt,julday,t_phy,moist,p8w,t8w,raincv, & - p_phy,chem,rho_phy,dz8w,ddvel,aer_res, & + p_phy,chem,rho_phy,dz8w,ddvel,aer_res_def,aer_res_zcen, & ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& numgas, & ids,ide, jds,jde, kds,kde, & @@ -105,7 +105,8 @@ ! ! necessary for aerosols (module dependent) ! - real :: aer_res(its:ite,jts:jte),rcx(numgas) + real :: aer_res_def(its:ite,jts:jte), aer_res_zcen(its:ite,jts:jte) + real :: rcx(numgas) TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -161,13 +162,20 @@ END DO CALL deppart(rmol(i,j),ustar,rhchem,clwchem,iland,dvpart,dvfog) ddvel0d=0. - aer_res(i,j)=0. + aer_res_def(i,j)=0. + aer_res_zcen(i,j)=0. CALL landusevg(ddvel0d,ustar,rmol(i,j),zntt,z1,dvpart,iland, & - numgas,srfres,aer_res(i,j),p_sulf) + numgas,srfres,aer_res_def(i,j),aer_res_zcen(i,j),p_sulf) !wig: CMBZ does not have HO and HO2 last so need to copy all species ! ddvel(i,j,1:numgas-2)=ddvel0d(1:numgas-2) ddvel(i,j,1:numgas)=ddvel0d(1:numgas) + if ( (config_flags%chem_opt == RADM2 ) .or. & + (config_flags%chem_opt == RADM2SORG ) .or. & + (config_flags%chem_opt == RADM2SORG_AQ) ) then + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + end if + 100 continue ! @@ -177,6 +185,7 @@ ! if ( (config_flags%chem_opt == CBMZ ) .or. & (config_flags%chem_opt == CBMZ_BB ) .or. & + (config_flags%chem_opt == CBMZ_BB_KPP ) .or. & (config_flags%chem_opt == CBMZ_MOSAIC_4BIN_AQ) .or. & (config_flags%chem_opt == CBMZ_MOSAIC_8BIN_AQ) .or. & (config_flags%chem_opt == CBMZ_MOSAIC_4BIN) .or. & @@ -185,7 +194,6 @@ do i=its,ite ddvel(i,j,p_sulf) = ddvel(i,j,p_hno3) ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) - ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) ddvel(i,j,p_ch3o2) = 0 ddvel(i,j,p_ethp) = 0 ddvel(i,j,p_ch3oh) = ddvel(i,j,p_hcho) @@ -248,6 +256,9 @@ ddvel(i,j,p_sulf) = 0. ddvel(i,j,p_dms) = 0. ddvel(i,j,p_msa) = ddvel(i,j,p_hno3) + if( config_flags%chem_opt == GOCARTRADM2 ) then + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + end if end do end do end if @@ -601,7 +612,7 @@ END SUBROUTINE wesely_driver END SUBROUTINE deppart SUBROUTINE landusevg(vgs,ustar,rmol,z0,zz,dvparx,iland,numgas, & - srfres,aer_res,p_sulf) + srfres,aer_res_def,aer_res_zcen,p_sulf) ! This subroutine calculates the species specific deposition velocit ! as a function of the local meteorology and land use. The depositi ! Velocity is also landuse specific. @@ -637,26 +648,30 @@ END SUBROUTINE wesely_driver ! Local Variables ! .. Scalar Arguments .. REAL :: dvparx, rmol, ustar, z0, zz - real :: aer_res, polint + real :: aer_res_def, aer_res_zcen, polint INTEGER :: iland, numgas, p_sulf ! .. ! .. Array Arguments .. REAL :: srfres(numgas), vgs(numgas) ! .. ! .. Local Scalars .. - REAL :: vgp, vgpart, zr + REAL :: rmol_tmp, vgp, vgpart, zr INTEGER :: jspec ! .. ! .. Local Arrays .. REAL :: vgspec(numgas) ! .. +! Calculate aerodynamic resistance for reference height = layer center + zr = zz*0.5 + rmol_tmp = rmol + CALL depvel(numgas,rmol_tmp,zr,z0,ustar,vgspec,vgpart,aer_res_zcen) ! Set the reference height (10.0 m) ! zr = 10.0 zr = 2.0 ! CALCULATE THE DEPOSITION VELOCITY without any surface ! resistance term, i.e. 1 / (ra + rb) - CALL depvel(numgas,rmol,zr,z0,ustar,vgspec,vgpart,aer_res) + CALL depvel(numgas,rmol,zr,z0,ustar,vgspec,vgpart,aer_res_def) ! Calculate the deposition velocity for each species ! and grid cell by looping through all the possibile combinations @@ -1159,8 +1174,20 @@ END SUBROUTINE wesely_driver hstar(p_ora2) = 9.63E+5 hstar(p_nh3) = 1.04E+4 hstar(p_n2o5) = 1.00E+10 - if(p_ol2.gt.1)hstar(p_ol2) = 4.67E-3 - hstar(p_par) = 1.13E-3 !wig, 1-May-2007: for CBMZ + if(p_ol2.gt.1) hstar(p_ol2) = 4.67E-3 + if(p_par.gt.1) hstar(p_par) = 1.13E-3 !wig, 1-May-2007: for CBMZ + if(p_ch4.gt.1) then + hstar(p_ch4) = 1.50E-3 + dhr(p_ch4)= 0. + f0(p_ch4)=0. + dvj(p_ch4)=0.250 + end if + if(p_co2.gt.1) then + hstar(p_co2) = 1.86E-1 + dhr(p_co2)= 1636. + f0(p_co2)=0. + dvj(p_co2)=0.151 + end if ! ! FOLLOWING FOR RACM ! @@ -1169,8 +1196,6 @@ END SUBROUTINE wesely_driver HSTAR(p_API )=4.76E-3 HSTAR(p_LIM )=4.76E-3 HSTAR(p_DIEN)=4.76E-3 - HSTAR(p_CH4 )=1.50E-3 - HSTAR(p_CO2 )=1.86E-1 HSTAR(p_MACR)=1.14E+1 HSTAR(p_UDD )=1.40E+6 HSTAR(p_HKET)=7.80E+3 @@ -1178,8 +1203,6 @@ END SUBROUTINE wesely_driver DHR(p_API )= 0. DHR(p_LIM )= 0. DHR(p_DIEN)= 0. - DHR(p_CH4 )= 0. - DHR(p_CO2 )= 1636. DHR(p_MACR)= 6266. DHR(p_UDD )= 0. DHR(p_HKET)= 0. @@ -1187,8 +1210,6 @@ END SUBROUTINE wesely_driver F0(p_API )=0. F0(p_LIM )=0. F0(p_DIEN)=0. - F0(p_CH4 )=0. - F0(p_CO2 )=0. F0(p_MACR)=0. F0(p_UDD )=0. F0(p_HKET)=0. @@ -1196,8 +1217,6 @@ END SUBROUTINE wesely_driver DVJ(p_API )=0.086 DVJ(p_LIM )=0.086 DVJ(p_DIEN)=0.136 - DVJ(p_CH4 )=0.250 - DVJ(p_CO2 )=0.151 DVJ(p_MACR)=0.120 DVJ(p_UDD )=0.092 DVJ(p_HKET)=0.116 @@ -1243,7 +1262,7 @@ END SUBROUTINE wesely_driver dhr(p_nh3) = 3660. dhr(p_n2o5) = 0. if(p_ol2.gt.1)dhr(p_ol2) = 0. - dhr(p_par) = 0. !wig, 1-May-2007: for CBMZ + if(p_par.gt.1)dhr(p_par) = 0. !wig, 1-May-2007: for CBMZ ! REACTIVITY FACTORS ! [f0]=1 @@ -1285,7 +1304,7 @@ END SUBROUTINE wesely_driver f0(p_nh3) = 0. f0(p_n2o5) = 1. if(p_ol2.gt.1)f0(p_ol2) = 0. - f0(p_par) = 0. !wig, 1-May-2007: for CBMZ + if(p_par.gt.1)f0(p_par) = 0. !wig, 1-May-2007: for CBMZ ! DIFFUSION COEFFICIENTS ! [DV]=cm2/s (assumed: 1/SQRT(molar mass) when not known) @@ -1329,7 +1348,7 @@ END SUBROUTINE wesely_driver dvj(p_ho) = 0.243 dvj(p_ho2) = 0.174 if(p_ol2.gt.1)dvj(p_ol2) = 0.189 - dvj(p_par) = 0.118 !wig, 1-May-2007: for CBMZ + if(p_par.gt.1)dvj(p_par) = 0.118 !wig, 1-May-2007: for CBMZ DO l = 1, numgas hstar4(l) = hstar(l) ! preliminary ! Correction of diff. coeff diff --git a/wrfv2_fire/chem/module_emissions_anthropogenics.F b/wrfv2_fire/chem/module_emissions_anthropogenics.F index b4f40c41..10611a48 100755 --- a/wrfv2_fire/chem/module_emissions_anthropogenics.F +++ b/wrfv2_fire/chem/module_emissions_anthropogenics.F @@ -95,22 +95,42 @@ CONTAINS end if #endif - chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & - +emis_ant(i,k,j,p_e_csl)*conv_rho - chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & - +emis_ant(i,k,j,p_e_iso)*conv_rho chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & +emis_ant(i,k,j,p_e_so2)*conv_rho + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + +emis_ant(i,k,j,p_e_co)*conv_rho chem(i,k,j,p_no) = chem(i,k,j,p_no) & +emis_ant(i,k,j,p_e_no)*conv_rho + chem(i,k,j,p_nh3) = chem(i,k,j,p_nh3) & + +emis_ant(i,k,j,p_e_nh3)*conv_rho + if( config_flags%chem_opt == MOZART_KPP .or. config_flags%chem_opt == MOZCART_KPP ) then + chem(i,k,j,p_bigalk) = chem(i,k,j,p_bigalk) + emis_ant(i,k,j,p_e_bigalk)*conv_rho + chem(i,k,j,p_bigene) = chem(i,k,j,p_bigene) + emis_ant(i,k,j,p_e_bigene)*conv_rho + chem(i,k,j,p_c2h4) = chem(i,k,j,p_c2h4) + emis_ant(i,k,j,p_e_c2h4)*conv_rho + chem(i,k,j,p_c2h5oh) = chem(i,k,j,p_c2h5oh) + emis_ant(i,k,j,p_e_c2h5oh)*conv_rho + chem(i,k,j,p_c2h6) = chem(i,k,j,p_c2h6) + emis_ant(i,k,j,p_e_c2h6)*conv_rho + chem(i,k,j,p_c3h6) = chem(i,k,j,p_c3h6) + emis_ant(i,k,j,p_e_c3h6)*conv_rho + chem(i,k,j,p_c3h8) = chem(i,k,j,p_c3h8) + emis_ant(i,k,j,p_e_c3h8)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) + emis_ant(i,k,j,p_e_ch2o)*conv_rho + chem(i,k,j,p_ald) = chem(i,k,j,p_ald) + emis_ant(i,k,j,p_e_ch3cho)*conv_rho + chem(i,k,j,p_acet) = chem(i,k,j,p_acet) + emis_ant(i,k,j,p_e_ch3coch3)*conv_rho + chem(i,k,j,p_ch3oh) = chem(i,k,j,p_ch3oh) + emis_ant(i,k,j,p_e_ch3oh)*conv_rho + chem(i,k,j,p_mek) = chem(i,k,j,p_mek) + emis_ant(i,k,j,p_e_mek)*conv_rho + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) + emis_ant(i,k,j,p_e_toluene)*conv_rho + chem(i,k,j,p_isopr) = chem(i,k,j,p_isopr) + emis_ant(i,k,j,p_e_isop)*conv_rho + chem(i,k,j,p_c10h16) = chem(i,k,j,p_c10h16) + emis_ant(i,k,j,p_e_c10h16)*conv_rho + chem(i,k,j,p_no2) = chem(i,k,j,p_no2) + emis_ant(i,k,j,p_e_no2)*conv_rho + else + chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & + +emis_ant(i,k,j,p_e_csl)*conv_rho + chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & + +emis_ant(i,k,j,p_e_iso)*conv_rho chem(i,k,j,p_ald) = chem(i,k,j,p_ald) & +emis_ant(i,k,j,p_e_ald)*conv_rho chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & +emis_ant(i,k,j,p_e_hcho)*conv_rho chem(i,k,j,p_ora2) = chem(i,k,j,p_ora2) & +emis_ant(i,k,j,p_e_ora2)*conv_rho - chem(i,k,j,p_nh3) = chem(i,k,j,p_nh3) & - +emis_ant(i,k,j,p_e_nh3)*conv_rho chem(i,k,j,p_hc3) = chem(i,k,j,p_hc3) & +emis_ant(i,k,j,p_e_hc3)*conv_rho chem(i,k,j,p_hc5) = chem(i,k,j,p_hc5) & @@ -119,8 +139,6 @@ CONTAINS +emis_ant(i,k,j,p_e_hc8)*conv_rho chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & +emis_ant(i,k,j,p_e_eth)*conv_rho - chem(i,k,j,p_co) = chem(i,k,j,p_co) & - +emis_ant(i,k,j,p_e_co)*conv_rho if(p_ol2.gt.1)chem(i,k,j,p_ol2) = chem(i,k,j,p_ol2) & +emis_ant(i,k,j,p_e_ol2)*conv_rho if(p_ete.gt.1)chem(i,k,j,p_ete) = chem(i,k,j,p_ete) & @@ -135,6 +153,7 @@ CONTAINS +emis_ant(i,k,j,p_e_xyl)*conv_rho chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & +emis_ant(i,k,j,p_e_ket)*conv_rho + endif END DO 100 continue diff --git a/wrfv2_fire/chem/module_ftuv_driver.F b/wrfv2_fire/chem/module_ftuv_driver.F index 9271bf19..4ab5c0a0 100644 --- a/wrfv2_fire/chem/module_ftuv_driver.F +++ b/wrfv2_fire/chem/module_ftuv_driver.F @@ -215,6 +215,8 @@ ! set total ozone and land use type dobson = 265.0; lu = 1 + xlwc(:) = 0. !initialize in case no cloud water is present + ! get photolysis rates J_TILE_LOOP : do j = jts, jte I_TILE_LOOP : do i = its, ite diff --git a/wrfv2_fire/chem/module_gocart_dust.F b/wrfv2_fire/chem/module_gocart_dust.F index bdc5e615..7ed7b373 100644 --- a/wrfv2_fire/chem/module_gocart_dust.F +++ b/wrfv2_fire/chem/module_gocart_dust.F @@ -93,9 +93,9 @@ CONTAINS ! we donṫ trust the u10,v10 values, is model layers are very thin near surface ! if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) - erodin(1,1,1,1)=erod(i,j,1)/dx/dx - erodin(1,1,2,1)=erod(i,j,2)/dx/dx - erodin(1,1,3,1)=erod(i,j,3)/dx/dx + erodin(1,1,1,1)=erod(i,j,1)!/dx/dx + erodin(1,1,2,1)=erod(i,j,2)!/dx/dx + erodin(1,1,3,1)=erod(i,j,3)!/dx/dx ! ! volumetric soil moisture over porosity ! diff --git a/wrfv2_fire/chem/module_input_chem_data.F b/wrfv2_fire/chem/module_input_chem_data.F index 03f47edd..2fb98e93 100755 --- a/wrfv2_fire/chem/module_input_chem_data.F +++ b/wrfv2_fire/chem/module_input_chem_data.F @@ -77,6 +77,9 @@ MODULE module_input_chem_data INTEGER, DIMENSION(logg) :: iref + real, allocatable :: ch4_lbc(:,:) + real, allocatable :: n2o_lbc(:,:) + real, allocatable :: h2_lbc(:,:) REAL, DIMENSION(logg) :: fracref REAL, DIMENSION(kx) :: dens REAL, DIMENSION(kx+1) :: zfa @@ -333,7 +336,7 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) GOCARTRACM_KPP, GOCARTRADM2,GOCARTRADM2_KPP,CHEM_TRACER, CHEM_TRACE2) call setup_gasprofile_map_radm_racm - case (CBMZ, CBMZ_BB, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & + case (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ) call setup_gasprofile_map_cbmz(numgas) @@ -342,6 +345,13 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) case (GOCART_SIMPLE) call wrf_debug("setup_profile_maps: nothing done for gocart simple") + + case (MOZART_KPP) + call wrf_debug("setup_profile_maps: nothing done for mozart_kpp") + + case (MOZCART_KPP) + call wrf_debug("setup_profile_maps: nothing done for mozcart_kpp") + case default call wrf_error_fatal("setup_profile_maps: could not decipher chem_opt value") @@ -1279,7 +1289,7 @@ SUBROUTINE input_chem_profile (si_grid) ! we have to treat it separately. (wig, 2-May-2007) ! SELECT CASE(chem_opt) - CASE (CBMZ,CBMZ_BB,CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN, & + CASE (CBMZ,CBMZ_BB,CBMZ_BB_KPP,CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN, & CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ) do j = ny1,ny2 do k = nz1,nz2 @@ -2782,7 +2792,7 @@ SUBROUTINE input_chem_profile (si_grid) case (CBMZ) get_last_gas = p_mtf - case (CBMZ_BB,CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ) + case (CBMZ_BB,CBMZ_BB_KPP,CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ) get_last_gas = p_isopo2 case (CHEM_TRACER) @@ -2797,6 +2807,12 @@ SUBROUTINE input_chem_profile (si_grid) case (CBM4_KPP) get_last_gas = p_ho2 + case (MOZART_KPP) + get_last_gas = p_meko2 + + case (MOZCART_KPP) + get_last_gas = p_meko2 + case default call wrf_error_fatal("get_last_gas: could not decipher chem_opt value") @@ -3747,6 +3763,65 @@ SUBROUTINE med_read_bin_chem_fireemiss ( grid , config_flags ,intime, itime_max) RETURN END SUBROUTINE med_read_bin_chem_fireemiss +SUBROUTINE mozcart_lbc_init( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + + USE module_state_description, only : p_ch4, p_n2o, p_h2 + +integer, intent(in) :: num_chem +integer, intent(in) :: ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts +real, intent(in) :: chem(ims:ime,kms:kme,jms:jme,num_chem) + + integer :: astat + + if( p_ch4 > 1 ) then + allocate( ch4_lbc(its:ite,jts:jte),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal("mozcart_lbc_init: failed to allocate ch4 lbc") + end if + ch4_lbc(its:ite,jts:jte) = chem(its:ite,kts,jts:jte,p_ch4) + end if + if( p_n2o > 1 ) then + allocate( n2o_lbc(its:ite,jts:jte),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal("mozcart_lbc_init: failed to allocate n2o lbc") + end if + n2o_lbc(its:ite,jts:jte) = chem(its:ite,kts,jts:jte,p_n2o) + end if + if( p_h2 > 1 ) then + allocate( h2_lbc(its:ite,jts:jte),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal("mozcart_lbc_init: failed to allocate h2 lbc") + end if + end if + h2_lbc(its:ite,jts:jte) = chem(its:ite,kts,jts:jte,p_h2) + +END SUBROUTINE mozcart_lbc_init + +SUBROUTINE mozcart_lbc_set( chem, num_chem, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts ) + + USE module_state_description, only : p_ch4, p_n2o, p_h2 + +integer, intent(in) :: num_chem +integer, intent(in) :: ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts +real, intent(inout) :: chem(ims:ime,kms:kme,jms:jme,num_chem) + + if( p_ch4 > 1 ) then + chem(its:ite,kts,jts:jte,p_ch4) = ch4_lbc(its:ite,jts:jte) + end if + if( p_n2o > 1 ) then + chem(its:ite,kts,jts:jte,p_n2o) = n2o_lbc(its:ite,jts:jte) + end if + if( p_h2 > 1 ) then + chem(its:ite,kts,jts:jte,p_h2) = h2_lbc(its:ite,jts:jte) + end if + +END SUBROUTINE mozcart_lbc_set + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! END MODULE module_input_chem_data - diff --git a/wrfv2_fire/chem/module_isrpia.F b/wrfv2_fire/chem/module_isrpia.F index ea4e848f..432ab5aa 100644 --- a/wrfv2_fire/chem/module_isrpia.F +++ b/wrfv2_fire/chem/module_isrpia.F @@ -4512,7 +4512,7 @@ CONTAINS ! SUBROUTINE ISERRINF (ERRSTKI, ERRMSGI, NOFERI, STKOFLI) implicit none - CHARACTER ERRMSGI*40(NERRMX) + CHARACTER(len=40) :: ERRMSGI(NERRMX) INTEGER ERRSTKI(NERRMX) LOGICAL STKOFLI INTEGER NOFERI diff --git a/wrfv2_fire/chem/module_mosaic_driver.F b/wrfv2_fire/chem/module_mosaic_driver.F index 8a323b19..89cc222f 100644 --- a/wrfv2_fire/chem/module_mosaic_driver.F +++ b/wrfv2_fire/chem/module_mosaic_driver.F @@ -389,10 +389,10 @@ ! note units for aerosol is now ug/m3 call wrf_debug(300,"mosaic_aerchem_driver: back from aerchemistry") - if ((it .eq.45) .and. (jt .eq.71) & - .and. (ktau.eq.240)) then - call aerchem_debug_dump( 3, it, jt, dtchem ) - end if +! if ((it .eq.45) .and. (jt .eq.71) & +! .and. (ktau.eq.240)) then +! call aerchem_debug_dump( 3, it, jt, dtchem ) +! end if if (i_force_dump > 0) call aerchem_debug_dump( 3, it, jt, dtchem ) @@ -542,7 +542,7 @@ end subroutine sum_pm_mosaic -! ---------------------------------------------------------------------- +!----------------------------------------------------------------------- subroutine mapaer_tofrom_host( imap, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -2232,6 +2232,13 @@ !----------------------------------------------------------------------- +! aerchem_debug_dump is used to generate input for testing with Rahul's +! offline MOSAIC box model. To use it, first determine which cell and +! time is crashing. Then, turn on the calls to this routine for that +! cell and time only. The routine is called once before aerchemistry +! with iflag=1, and then again after with iflag=3, if the model makes it +! that far. ;-) +!----------------------------------------------------------------------- subroutine aerchem_debug_dump( & iflag, iclm, jclm, dtchem ) diff --git a/wrfv2_fire/chem/module_mosaic_therm.F b/wrfv2_fire/chem/module_mosaic_therm.F index 21e004d5..1f6debd1 100644 --- a/wrfv2_fire/chem/module_mosaic_therm.F +++ b/wrfv2_fire/chem/module_mosaic_therm.F @@ -1864,8 +1864,7 @@ integer iaer, iconverge, iconverge_flux, iconverge_mass, & idissolved, itdum, js, je, jp ! raz update 11/13/2008 real(kind=8) tau_p(nsalt), tau_d(nsalt) - real(kind=8) frac_solid, sumflux, hsalt_min, alpha, xt, dumdum, & - h_ion + real(kind=8) hsalt_min real(kind=8) phi_prod, alpha_fac, sum_dum ! raz update 11/13/2008 real(kind=8) aer_H ! function @@ -2869,6 +2868,7 @@ ! ! author: rahul a. zaveri ! update: jan 2005 +! Oct 2009: William.Gustafson@pnl.gov - zero salt bug fixed !----------------------------------------------------------------------- subroutine mesa_convergence_criterion(ibin, & ! touch iconverge_mass, & @@ -2906,14 +2906,26 @@ ! frac_solid = mass_solid/mass_dry_a(ibin) - frac_solid = mass_solid_salt/mass_dry_salt(ibin) - - if(frac_solid .ge. 0.98)then - iconverge_mass = myes - return - endif - - +!!$ frac_solid = mass_solid_salt/mass_dry_salt(ibin) +!!$ +!!$ if(frac_solid .ge. 0.98)then +!!$ iconverge_mass = myes +!!$ return +!!$ endif +!beg: Modified above logic to handle zero salts, wig 28-Oct-2009 +! If mass of salts is zero, then this will force jaerosolstate to solid +! in mesa_ptc. + if( mass_dry_salt(ibin) < 1e-30 ) then + iconverge_mass = myes + return + else + frac_solid = mass_solid_salt/mass_dry_salt(ibin) + if(frac_solid .ge. 0.98)then + iconverge_mass = myes + return + endif + end if +!end wig ! check relative driving force convergence iconverge_flux = myes diff --git a/wrfv2_fire/chem/module_optical_averaging.F b/wrfv2_fire/chem/module_optical_averaging.F index 1c53040c..30e465c2 100644 --- a/wrfv2_fire/chem/module_optical_averaging.F +++ b/wrfv2_fire/chem/module_optical_averaging.F @@ -102,7 +102,7 @@ ! subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & nbin_o,haveaer,option_method,option_mie,chem,dz8w,alt, & - h2oai,h2oaj, & + relhum,h2oai,h2oaj, & tauaer1,tauaer2,tauaer3,tauaer4, & gaer1,gaer2,gaer3,gaer4, & waer1,waer2,waer3,waer4, & @@ -131,7 +131,7 @@ INTENT(IN ) :: chem ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: dz8w, alt, h2oai, h2oaj + INTENT(IN ) :: relhum,dz8w, alt, h2oai, h2oaj ! ! arrays that hold the aerosol optical properties ! @@ -195,6 +195,13 @@ ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (GOCART_SIMPLE) + call optical_prep_gocart(nbin_o, chem, alt,relhum, & + refindx, radius_wet, number_bin, & + radius_core, refindx_core, refindx_shell, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) END SELECT chem_select do jclm = jts, jte do iclm = its, ite @@ -1092,19 +1099,19 @@ ss1=alog(sginin) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 - dgnum_um=max(dgmin,ss3)*1.0e+04 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_secti,xmas_secti) ss1=alog(sginia) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 - dgnum_um=max(dgmin,ss3)*1.0e+04 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_sectj,xmas_sectj) ss1=alog(sginic) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 - dgnum_um=max(dgmin,ss3)*1.0e+04 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_sectc,xmas_sectc) @@ -1210,6 +1217,571 @@ end subroutine optical_prep_modal ! +!---------------------------------------------------------------------------------- +! 9/21/09, SAM a modification of optical_prep_modal subroutine for GOCART aerosol model - +! SAM 7/18/09 - Modal parameters for OC1 (hydrophobic) OC2 (hydrophylic), BC1,BC2, +! and sulfate - just use dginia (meters) and sginia from module_data_sorgam. +! Not using accumulation mode from d'Almedia 1991 Table 7.1 and 7.2 global model +! +! This subroutine computes volume-averaged refractive index and wet radius needed +! by the mie calculations. Aerosol number is also passed into the mie calculations +! in terms of other units. +! + subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & + refindx, radius_wet, number_bin, & + radius_core, refindx_core, refindx_shell, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! + USE module_configure + USE module_model_constants + USE module_data_sorgam + USE module_data_gocart_seas + USE module_data_mosaic_asect, only: hygro_msa_aer +! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/) +! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/) +! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/) +! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) + USE module_data_gocart_dust, only: ndust, reff_dust, den_dust +! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) +! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) + +! + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte, nbin_o + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt,relhum + REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & + INTENT(OUT ) :: & + radius_wet, number_bin, radius_core + COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & + INTENT(OUT ) :: & + refindx, refindx_core, refindx_shell +! +! local variables +! + integer i, j, k, l, m, n, isize, itype, iphase + complex ref_index_nh4so4 , ref_index_lvcite , ref_index_nh4hso4, & + ref_index_nh4msa , ref_index_nh4no3 , ref_index_nh4cl , & + ref_index_nacl , ref_index_nano3 , ref_index_na2so4, & + ref_index_na3hso4, ref_index_nahso4 , ref_index_namsa, & + ref_index_caso4 , ref_index_camsa2 , ref_index_cano3, & + ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4, & + ref_index_hhso4 , ref_index_hno3 , ref_index_hcl, & + ref_index_msa , ref_index_oc , ref_index_bc, & + ref_index_oin , ref_index_aro1 , ref_index_aro2, & + ref_index_alk1 , ref_index_ole1 , ref_index_api1, & + ref_index_api2 , ref_index_im1 , ref_index_im2, & + ref_index_h2o , ri_dum , ri_ave_a + real dens_so4 , dens_no3 , dens_cl , dens_msa , dens_co3 , & + dens_nh4 , dens_na , dens_ca , dens_oin , dens_oc , & + dens_bc , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1, & + dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o + real mass_so4 , mass_no3 , mass_cl , mass_msa , mass_co3 , & + mass_nh4 , mass_na , mass_ca , mass_oin , mass_oc , & + mass_bc , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1, & + mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o + real mass_so4i , mass_no3i , mass_cli , mass_msai , mass_co3i, & + mass_nh4i , mass_nai , mass_cai , mass_oini , mass_oci , & + mass_bci , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, & + mass_ba1i , mass_ba2i, mass_ba3i , mass_ba4i , mass_pai, & + mass_h2oi + real mass_so4j , mass_no3j , mass_clj , mass_msaj , mass_co3j, & + mass_nh4j , mass_naj , mass_caj , mass_oinj , mass_ocj , & + mass_bcj , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, & + mass_ba1j , mass_ba2j, mass_ba3j , mass_ba4j , mass_paj, & + mass_h2oj + real mass_antha, mass_seas, mass_soil + real num_ai, num_aj, num_ac, vol_ai, vol_aj, vol_ac + real vol_so4 , vol_no3 , vol_cl , vol_msa , vol_co3 , & + vol_nh4 , vol_na , vol_ca , vol_oin , vol_oc , & + vol_bc , vol_aro1 , vol_aro2 , vol_alk1 , vol_ole1 , & + vol_api1 , vol_api2 , vol_lim1 , vol_lim2 , vol_h2o + real conv1a, conv1b, conv1sulf + real mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell, & + dp_dry_a , dp_wet_a , num_a , dp_bc_a + real ifac, jfac, cfac + real refr + real dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp + integer iflag + real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc + real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc + real, dimension(1:nbin_o) :: xdia_um, xdia_cm + REAL, PARAMETER :: FRAC2Aitken=0.25 ! Fraction of modal mass in Aitken mode - applied globally to each species + +! 7/21/09 SAM variables needed to convert GOCART sectional dust and seasalt to MOZAIC sections + real dgnum, dhi, dlo, xlo, xhi, dxbin, relh_frc + real dlo_sectm(nbin_o), dhi_sectm(nbin_o) + integer, parameter :: nbin_omoz=8 + real, save :: seasfrc_goc8bin(4,nbin_omoz) ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins + real, save :: dustfrc_goc8bin(ndust,nbin_omoz) ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins + real mass_bc1 , mass_bc2 , vol_bc2 , mass_bc1j , mass_bc2j, & + mass_bc1i , mass_bc2i , vol_soil + real*8 dlogoc, dhigoc + integer istop + integer, save :: kcall + data kcall / 0 / + +! +! real sginin,sginia,sginic from module_data_sorgam.F +! +! Mass from modal distribution is divided into individual sections before +! being passed back into the Mie routine. +! * currently use the same size bins as 8 default MOSAIC size bins +! * dlo_um and dhi_um define the lower and upper bounds of individual sections +! used to compute optical properties +! * sigmas for 3 modes taken from module_sorgam_data.F +! * these parameters are needed by sect02 that is called later +! * sginin=1.7, sginia=2.0, sginic=2.5 +! + sixpi=6.0/3.14159265359 + dlo_um=0.0390625 + dhi_um=10.0 + drydens=1.8 + iflag=2 + duma=1.0 + dgmin=1.0e-07 ! in (cm) + dtemp=dlo_um + do isize=1,nbin_o + xdia_um(isize)=(dtemp+dtemp*2.0)/2.0 + dtemp=dtemp*2.0 + enddo + if (kcall .eq. 0) then +! 7/21/09 SAM calculate sectional contributions from GOCART seasalt and dust + dlo = dlo_um*1.0e-6 + dhi = dhi_um*1.0e-6 + xlo = log( dlo ) + xhi = log( dhi ) + dxbin = (xhi - xlo)/nbin_o + do n = 1, nbin_o + dlo_sectm(n) = exp( xlo + dxbin*(n-1) ) + dhi_sectm(n) = exp( xlo + dxbin*n ) + end do +! real, save :: seasfrc_goc8bin(4,nbin_o) ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins +! real, save :: dustfrc_goc8bin(ndust,nbin_o) ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins +! USE module_data_gocart_seas +! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/) +! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/) +! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/) +! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) +! USE module_data_gocart_dust, only: ndust, reff_dust, den_dust +! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) +! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) +! Seasalt bin mass fractions + seasfrc_goc8bin=0. +! WRITE(*,*)'Seasalt mass fractions' +! WRITE(*,*)' ',' ',(dlo_sectm(n),n=1,nbin_o) +! WRITE(*,*)' ',' ',(dhi_sectm(n),n=1,nbin_o) + do m =1, 4 ! loop over seasalt size bins + dlogoc = ra(m)*2.E-6 ! low diameter limit (m) + dhigoc = rb(m)*2.E-6 ! hi diameter limit (m) + do n = 1, nbin_o + seasfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(dhi_sectm(n)),dhigoc)- & + max(dlogoc,DBLE(dlo_sectm(n))) )/(dhigoc-dlogoc) + end do +! WRITE(*,*)m,dlogoc,dhigoc,(seasfrc_goc8bin(m,n),n=1,nbin_o) + end do +! Dust bin mass fractions +! WRITE(*,*)'Dust mass fractions' +! WRITE(*,*)' ',' ',(dlo_sectm(n),n=1,nbin_o) +! WRITE(*,*)' ',' ',(dhi_sectm(n),n=1,nbin_o) + dustfrc_goc8bin=0. + dlogoc=0.46*2.E-6 ! Begin lower dust bin, makes upper limit diam 20 micron diameter + do m =1, ndust ! loop over dust size bins + dhigoc = 2.*2.*reff_dust(m)-dlogoc ! hi diameter limit (m) + do n = 1, nbin_o + dustfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(dhi_sectm(n)),dhigoc)- & + max(dlogoc,DBLE(dlo_sectm(n))) )/(dhigoc-dlogoc) + end do +! WRITE(*,*)m,dlogoc,dhigoc,(dustfrc_goc8bin(m,n),n=1,nbin_o) + dlogoc=dhigoc + end do + kcall=kcall+1 +! ISTOP=1 +! IF(ISTOP.EQ.1)THEN +! STOP +! ENDIF + endif +! +! Define refractive indicies +! * assume na and cl are the same as nacl +! * assume so4, no3, and nh4 are the same as nh4no3 +! * assume ca and co3 are the same as caco3 +! * assume msa is just msa +! Further work: +! * to be more precise, need to compute electrolytes to apportion +! so4, no3, nh4, na, cl, msa, ca, co3 among various componds +! as was done previously in module_mosaic_therm.F +! + ref_index_nh4so4 = cmplx(1.52,0.) + ref_index_lvcite = cmplx(1.50,0.) + ref_index_nh4hso4= cmplx(1.47,0.) + ref_index_nh4msa = cmplx(1.50,0.) ! assumed + ref_index_nh4no3 = cmplx(1.50,0.) + ref_index_nh4cl = cmplx(1.50,0.) + ref_index_nacl = cmplx(1.45,0.) + ref_index_nano3 = cmplx(1.50,0.) + ref_index_na2so4 = cmplx(1.50,0.) + ref_index_na3hso4= cmplx(1.50,0.) + ref_index_nahso4 = cmplx(1.50,0.) + ref_index_namsa = cmplx(1.50,0.) ! assumed + ref_index_caso4 = cmplx(1.56,0.006) + ref_index_camsa2 = cmplx(1.56,0.006) ! assumed + ref_index_cano3 = cmplx(1.56,0.006) + ref_index_cacl2 = cmplx(1.52,0.006) + ref_index_caco3 = cmplx(1.68,0.006) + ref_index_h2so4 = cmplx(1.43,0.) + ref_index_hhso4 = cmplx(1.43,0.) + ref_index_hno3 = cmplx(1.50,0.) + ref_index_hcl = cmplx(1.50,0.) + ref_index_msa = cmplx(1.43,0.) ! assumed + ref_index_oc = cmplx(1.45,0.) ! JCB, Feb. 20, 2008: no complex part? +! JCB, Feb. 20, 2008: set the refractive index of BC equal to the +! midpoint of ranges given in Bond and Bergstrom, Light absorption by +! carboneceous particles: an investigative review 2006, Aerosol Sci. +! and Tech., 40:27-67. +! ref_index_bc = cmplx(1.82,0.74) old value + ref_index_bc = cmplx(1.85,0.71) + ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: if "other inorganics" includes dust, then this refractive index should be wavelength depedent + ref_index_aro1 = cmplx(1.45,0.) + ref_index_aro2 = cmplx(1.45,0.) + ref_index_alk1 = cmplx(1.45,0.) + ref_index_ole1 = cmplx(1.45,0.) + ref_index_api1 = cmplx(1.45,0.) + ref_index_api2 = cmplx(1.45,0.) + ref_index_im1 = cmplx(1.45,0.) + ref_index_im2 = cmplx(1.45,0.) + ref_index_h2o = cmplx(1.33,0.) +! +! densities in g/cc +! + dens_so4 = 1.8 ! used + dens_no3 = 1.8 ! used + dens_cl = 2.2 ! used + dens_msa = 1.8 ! used + dens_co3 = 2.6 ! used + dens_nh4 = 1.8 ! used + dens_na = 2.2 ! used + dens_ca = 2.6 ! used + dens_oin = 2.6 ! used + dens_oc = 1.0 ! used +! JCB, Feb. 20, 2008: the density of BC is updated to reflect values +! published by Bond and Bergstrom, Light absorption by carboneceous +! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. +! dens_bc = 1.7 ! used, old value + dens_bc = 1.8 ! midpoint of Bond and Bergstrom value + dens_aro1 = 1.0 + dens_aro2 = 1.0 + dens_alk1 = 1.0 + dens_ole1 = 1.0 + dens_api1 = 1.0 + dens_api2 = 1.0 + dens_lim1 = 1.0 + dens_lim2 = 1.0 + dens_h2o = 1.0 +! + do isize = 1, nbin_o + do j = jts, jte + do k = kts, kte + do i = its, ite + refindx(i,k,j,isize)=0.0 + radius_wet(i,k,j,isize)=0.0 + number_bin(i,k,j,isize)=0.0 + radius_core(i,k,j,isize)=0.0 + refindx_core(i,k,j,isize)=0.0 + refindx_shell(i,k,j,isize)=0.0 + enddo + enddo + enddo + enddo +! +! units: +! * mass - g/cc(air) +! * number - #/cc(air) +! * volume - cc(air)/cc(air) +! * diameter - cm +! + do j = jts, jte + do k = kts, kte + do i = its, ite + mass_so4i = 0.0 + mass_so4j = 0.0 + mass_no3i = 0.0 + mass_no3j = 0.0 + mass_nh4i = 0.0 + mass_nh4j = 0.0 + mass_oini = 0.0 + mass_oinj = 0.0 + mass_aro1i = 0.0 + mass_aro1j = 0.0 + mass_aro2i = 0.0 + mass_aro2j = 0.0 + mass_alk1i = 0.0 + mass_alk1j = 0.0 + mass_ole1i = 0.0 + mass_ole1j = 0.0 + mass_ba1i = 0.0 + mass_ba1j = 0.0 + mass_ba2i = 0.0 + mass_ba2j = 0.0 + mass_ba3i = 0.0 + mass_ba3j = 0.0 + mass_ba4i = 0.0 + mass_ba4j = 0.0 + mass_pai = 0.0 + mass_paj = 0.0 + mass_oci = 0.0 + mass_ocj = 0.0 + mass_bci = 0.0 + mass_bcj = 0.0 + mass_bc1i = 0.0 + mass_bc1j = 0.0 + mass_bc2i = 0.0 + mass_bc2j = 0.0 + mass_cai = 0.0 + mass_caj = 0.0 + mass_co3i = 0.0 + mass_co3j = 0.0 + mass_nai = 0.0 + mass_naj = 0.0 + mass_cli = 0.0 + mass_clj = 0.0 + mass_msai = 0.0 + mass_msaj = 0.0 + mass_nai = 0.0 + mass_naj = 0.0 + mass_cli = 0.0 + mass_clj = 0.0 + mass_h2oi = 0.0 + mass_h2oj = 0.0 + mass_antha = 0.0 + mass_seas = 0.0 + mass_soil = 0.0 + mass_cl = 0.0 + mass_na = 0.0 + mass_msa = 0.0 + vol_aj = 0.0 + vol_ai = 0.0 + vol_ac = 0.0 + num_aj = 0.0 + num_ai = 0.0 + num_ac = 0.0 + +! convert ug / kg dry air to g / cc air + conv1a = (1.0/alt(i,k,j)) * 1.0e-12 +! convert # / kg dry air to # / cc air + conv1b = (1.0/alt(i,k,j)) * 1.0e-6 +! convert ppmv sulfate (and coincidentally MSA) to g / cc air + conv1sulf = (1.0/alt(i,k,j)) * 1.0e-9 * 96./28.97 + +! Accumulation mode... +! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal accumulation mode + mass_oinj = (1.-FRAC2Aitken)*chem(i,k,j,p_p25)*conv1a + mass_so4j= (1.-FRAC2Aitken)*chem(i,k,j,p_sulf)*conv1sulf + mass_aro1j= (1.-FRAC2Aitken)*chem(i,k,j,p_oc1)*conv1a + mass_aro2j= (1.-FRAC2Aitken)*chem(i,k,j,p_oc2)*conv1a + mass_bc1j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc1)*conv1a + mass_bc2j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc2)*conv1a + mass_bcj= mass_bc1j + mass_bc2j + mass_msaj= (1.-FRAC2Aitken)*chem(i,k,j,p_msa)*conv1sulf + +! Aitken mode... +! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal Aitken mode + mass_oini = FRAC2Aitken*chem(i,k,j,p_p25)*conv1a + mass_so4i= FRAC2Aitken*chem(i,k,j,p_sulf)*conv1sulf + mass_aro1i= FRAC2Aitken*chem(i,k,j,p_oc1)*conv1a + mass_aro2i= FRAC2Aitken*chem(i,k,j,p_oc2)*conv1a + mass_bc1i= FRAC2Aitken*chem(i,k,j,p_bc1)*conv1a + mass_bc2i= FRAC2Aitken*chem(i,k,j,p_bc2)*conv1a + mass_bci= mass_bc1i + mass_bc2i + mass_msai= FRAC2Aitken*chem(i,k,j,p_msa)*conv1sulf + + vol_ai = (mass_so4i/dens_so4)+(mass_no3i/dens_no3)+ & + (mass_nh4i/dens_nh4)+(mass_oini/dens_oin)+ & + (mass_aro1i/dens_oc)+(mass_alk1i/dens_oc)+ & + (mass_ole1i/dens_oc)+(mass_ba1i/dens_oc)+ & + (mass_ba2i/dens_oc)+(mass_ba3i/dens_oc)+ & + (mass_ba4i/dens_oc)+(mass_pai/dens_oc)+ & + (mass_aro2i/dens_oc)+(mass_bci/dens_bc)+ & + (mass_nai/dens_na)+(mass_cli/dens_cl)+ & + (mass_msai/dens_msa) + vol_aj = (mass_so4j/dens_so4)+(mass_no3j/dens_no3)+ & + (mass_nh4j/dens_nh4)+(mass_oinj/dens_oin)+ & + (mass_aro1j/dens_oc)+(mass_alk1j/dens_oc)+ & + (mass_ole1j/dens_oc)+(mass_ba1j/dens_oc)+ & + (mass_ba2j/dens_oc)+(mass_ba3j/dens_oc)+ & + (mass_ba4j/dens_oc)+(mass_paj/dens_oc)+ & + (mass_aro2j/dens_oc)+(mass_bcj/dens_bc)+ & + (mass_naj/dens_na)+(mass_clj/dens_cl)+ & + (mass_msaj/dens_msa) +! +! Now divide mass into sections which is done by sect02: +! * xmas_secti is for aiken mode +! * xmas_sectj is for accumulation mode +! * xmas_sectc is for coarse mode +! * sect02 expects input in um +! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins +! +!! ss1=alog(sginin) +!! ss2=exp(ss1*ss1*36.0/8.0) +!! ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 +!! dgnum_um=amax1(dgmin,ss3)*1.0e+04 + dgnum_um=dginin*1.E6 + call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_secti,xmas_secti) +!! ss1=alog(sginia) +!! ss2=exp(ss1*ss1*36.0/8.0) +!! ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 +!! dgnum_um=amax1(dgmin,ss3)*1.0e+04 + dgnum_um=dginia*1.E6 + call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_sectj,xmas_sectj) +!! ss1=alog(sginic) +!! ss2=exp(ss1*ss1*36.0/8.0) +!! ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 + dgnum_um=dginic*1.E6 + call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_sectc,xmas_sectc) + + do isize = 1, nbin_o + xdia_cm(isize)=xdia_um(isize)*1.0e-04 + mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize) + mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize) + mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize) + mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + & + mass_soil*xmas_sectc(isize) + mass_antha*xmas_sectc(isize) +! GOCART OC mass_aero1 is hydrophobic, mass_aero2 is hydrophylic + mass_aro1 = mass_aro1j*xmas_sectj(isize) + mass_aro1i*xmas_secti(isize) + mass_aro2 = mass_aro2j*xmas_sectj(isize) + mass_aro2i*xmas_secti(isize) + mass_oc = mass_aro1 + mass_aro2 +! GOCART BC mass_bc1 is hydrophobic, mass_bc2 is hydrophylic + mass_bc1 = mass_bc1i*xmas_secti(isize) + mass_bc1j*xmas_sectj(isize) + mass_bc2 = mass_bc2i*xmas_secti(isize) + mass_bc2j*xmas_sectj(isize) + mass_bc = mass_bc1 + mass_bc2 +! Add in seasalt and dust from GOCART sectional distributions + n = 0 + mass_seas = 0.0 + do m =p_seas_1, p_seas_3 ! loop over seasalt size bins less than 10 um diam + n = n+1 + mass_seas=mass_seas+seasfrc_goc8bin(n,isize)*chem(i,k,j,m) + end do + n = 0 + mass_soil = 0.0 + do m =p_dust_1, p_dust_1+ndust-2 ! loop over dust size bins less than 10 um diam + n = n+1 + mass_soil=mass_soil+dustfrc_goc8bin(n,isize)*chem(i,k,j,m) + end do + mass_cl=mass_seas*conv1a*22.9897/58.4428 + mass_na=mass_seas*conv1a*35.4270/58.4428 + mass_soil=mass_soil*conv1a +! mass_h2o = 0.0 ! testing purposes only + vol_so4 = mass_so4 / dens_so4 + vol_no3 = mass_no3 / dens_no3 + vol_nh4 = mass_nh4 / dens_nh4 + vol_oin = mass_oin / dens_oin + vol_oc = mass_oc / dens_oc + vol_aro2 = mass_aro2 / dens_oc + vol_bc = mass_bc / dens_bc + vol_bc2 = mass_bc2 / dens_bc + vol_na = mass_na / dens_na + vol_cl = mass_cl / dens_cl + vol_soil = mass_soil / dens_oin +! vol_h2o = mass_h2o / dens_h2o +! 7/23/09 SAM calculate vol_h2o from kappas in Petters and Kreidenweis ACP, 2007, vol. 7, 1961-1971. +! Their kappas are the hygroscopicities used in Abdul-Razzak and Ghan, 2004, JGR, V105, p. 6837-6844. +! These kappas are defined in module_data_sorgam and module_data_mosaic_asect. +! Note that hygroscopicities are at 298K and specific surface tension - further refinement could +! include temperature dependence in Petters and Kreidenweis +! Also, for hygroscopic BC part, assume kappa of OC (how can BC be hydrophylic?) + relh_frc=amin1(.9,relhum(i,k,j)) !0.8 ! Put in fractional relative humidity, max of .9, here + vol_h2o = vol_so4*hygro_so4_aer + vol_aro2*hygro_oc_aer + & + vol_cl*hygro_cl_aer + vol_na*hygro_na_aer + vol_msa*hygro_msa_aer + & + vol_oin*hygro_oin_aer + vol_bc2*hygro_oc_aer + vol_soil*hygro_dust_aer + vol_h2o = relh_frc*vol_h2o/(1.-relh_frc) + mass_h2o = vol_h2o*dens_h2o + mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + & + mass_oc + mass_bc + mass_na + mass_cl + mass_wet_a = mass_dry_a + mass_h2o + vol_dry_a = vol_so4 + vol_no3 + vol_nh4 + vol_oin + & + vol_oc + vol_bc + vol_na + vol_cl + vol_wet_a = vol_dry_a + vol_h2o + vol_shell = vol_wet_a - vol_bc + num_a = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize)) + ri_dum = (0.0,0.0) + ri_dum = (ref_index_nh4so4 * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & + (ref_index_oin * mass_oin / dens_oin) + & + (ref_index_oc * mass_oc / dens_oc) + & + (ref_index_bc * mass_bc / dens_bc) + & + (ref_index_nacl * mass_na / dens_na) + & + (ref_index_nacl * mass_cl / dens_cl) + & + (ref_index_msa * mass_msa / dens_msa) + & + (ref_index_h2o * mass_h2o / dens_h2o) +! +! for some reason MADE/SORGAM occasionally produces zero aerosols so +! need to add a check here to avoid divide by zero +! + IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then + dp_dry_a = 0.0 + dp_wet_a = 0.0 + dp_bc_a = 0.0 + ri_ave_a = 0.0 + ri_dum = 0.0 + else + dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 + dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 + dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 + ri_ave_a = ri_dum/vol_wet_a + ri_dum = (ref_index_nh4so4 * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & + (ref_index_oin * mass_oin / dens_oin) + & + (ref_index_oc * mass_oc / dens_oc) + & + (ref_index_nacl * mass_na / dens_na) + & + (ref_index_nacl * mass_cl / dens_cl) + & + (ref_index_msa * mass_msa / dens_msa) + & + (ref_index_h2o * mass_h2o / dens_h2o) + endif + if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then + refindx(i,k,j,isize) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + refindx_core(i,k,j,isize) = ref_index_bc + refindx_shell(i,k,j,isize) = ref_index_oin + elseif(vol_shell .lt. 1.0e-20) then + refindx(i,k,j,isize) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + refindx_core(i,k,j,isize) = ref_index_bc + refindx_shell(i,k,j,isize) = ref_index_oin + else + refindx(i,k,j,isize) =ri_ave_a + radius_wet(i,k,j,isize) =dp_wet_a/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =dp_bc_a/2.0 + refindx_core(i,k,j,isize) =ref_index_bc + refindx_shell(i,k,j,isize) =ri_dum/vol_shell + endif +! + refr=real(refindx(i,k,j,isize)) + enddo + enddo + enddo + enddo + + return + + end subroutine optical_prep_gocart + +! !*********************************************************************** ! <1.> subr mieaer ! Purpose: calculate aerosol optical depth, single scattering albedo, @@ -1282,7 +1854,8 @@ real x real thesum ! for normalizing things real sizem ! size in microns - integer kcallmieaer + integer, save :: kcallmieaer + data kcallmieaer / 0 / ! integer m, j, nc, klevel real pext ! parameterized specific extinction (cm2/g) @@ -1390,7 +1963,8 @@ integer irams, jrams ! diagnostic declarations - integer kcallmieaer2 + integer, save :: kcallmieaer2 + data kcallmieaer2 / 0 / integer ibin character*150 msg @@ -3883,6 +4457,8 @@ real*8 qextc,qscatc,qbackc,extc,scatc,backc,gscac real*8 vlambc integer n,kkk,jjj + integer, save :: kcallmieaer + data kcallmieaer / 0 / real*8 pmom(0:7,1) real weighte, weights, pscat real pie,sizem @@ -3894,7 +4470,8 @@ data rmin /0.010e-04/ ! rmin in cm, 5e-3 microns min allowable size data rmax /7.0e-04/ ! rmax in cm. 50 microns, big particle, max allowable size ! diagnostic declarations - integer kcallmieaer2 + integer, save :: kcallmieaer2 + data kcallmieaer2 / 0 / integer ibin character*150 msg diff --git a/wrfv2_fire/chem/module_phot_fastj.F b/wrfv2_fire/chem/module_phot_fastj.F index c83a9785..c2d5d815 100644 --- a/wrfv2_fire/chem/module_phot_fastj.F +++ b/wrfv2_fire/chem/module_phot_fastj.F @@ -736,7 +736,8 @@ iozone1,tauaer_550,jvalue,sza,lpar,jpnl, & sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7) - cos_sza = cosd(sza) + !cos_sza = cosd(sza) + cos_sza = cos(sza*3.141592653/180.) ! array jvalue (real*8) is returned from fastj. array valuej(unspecified diff --git a/wrfv2_fire/chem/module_plumerise1.F b/wrfv2_fire/chem/module_plumerise1.F index a08fc923..cb2e6f10 100644 --- a/wrfv2_fire/chem/module_plumerise1.F +++ b/wrfv2_fire/chem/module_plumerise1.F @@ -21,20 +21,10 @@ Module module_plumerise1 CONTAINS subroutine plumerise_driver (id,ktau,dtstep, & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_dms,ebu_sulf, & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5, & - ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_xyl, & - ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_dms,ebu_in_sulf, & - mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & + ebu,ebu_in,mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr, & firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr, & config_flags, t_phy,moist, & - chem,rho_phy,vvel,u_phy,v_phy,p_phy, & + rho_phy,vvel,u_phy,v_phy,p_phy, & emis_ant,z_at_w,z, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -60,25 +50,10 @@ subroutine plumerise_driver (id,ktau,dtstep, & its,ite, jts,jte, kts,kte REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(INOUT ) :: & - ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & - ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & - ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & - ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_bc,ebu_oc,ebu_so2, & - ebu_dms,ebu_sulf - - REAL, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, & - INTENT(IN ) :: & - ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5, & - ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10, & - ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_xyl, & - ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1, & - ebu_in_ora2,ebu_in_bc,ebu_in_oc,ebu_in_so2,ebu_in_dms,ebu_in_sulf - + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_ebu ), & + INTENT(INOUT ) :: ebu + REAL, DIMENSION( ims:ime, 1, jms:jme, num_ebu_in ), & + INTENT(INOUT ) :: ebu_in REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN ) :: & mean_fct_agtf,mean_fct_agef,& @@ -100,12 +75,12 @@ subroutine plumerise_driver (id,ktau,dtstep, & ! ! Local variables... ! - INTEGER :: i, j, k, ksub + INTEGER :: nv, i, j, k, ksub, nspecies - integer, parameter :: nspecies=30 - real, dimension (nspecies) :: eburn_in - real, dimension (kte,nspecies) :: eburn_out +! integer, parameter :: nspecies=num_ebu + real, dimension (num_ebu) :: eburn_in + real, dimension (kte,num_ebu) :: eburn_out real, dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in & ,rho_phyin ,qv_in ,zmid & ,z_lev @@ -113,70 +88,45 @@ subroutine plumerise_driver (id,ktau,dtstep, & real :: sum, ffirs ! real,save,dimension(its:ite,jts:jte) :: ffirs ffirs=0. + nspecies=num_ebu ! write(0,*)'plumerise' do j=jts,jte do i=its,ite - ebu_no(i,kts,j)=ebu_in_no(i,j) - ebu_co(i,kts,j)=ebu_in_co(i,j) - ebu_co2(i,kts,j)=ebu_in_co2(i,j) - ebu_eth(i,kts,j)=ebu_in_eth(i,j) - ebu_hc3(i,kts,j)=ebu_in_hc3(i,j) - ebu_hc5(i,kts,j)=ebu_in_hc5(i,j) - ebu_hc8(i,kts,j)=ebu_in_hc8(i,j) - ebu_ete(i,kts,j)=ebu_in_ete(i,j) - ebu_olt(i,kts,j)=ebu_in_olt(i,j) - ebu_oli(i,kts,j)=ebu_in_oli(i,j) - ebu_pm25(i,kts,j)=ebu_in_pm25(i,j) - ebu_pm10(i,kts,j)=ebu_in_pm10(i,j) - ebu_dien(i,kts,j)=ebu_in_dien(i,j) - ebu_iso(i,kts,j)=ebu_in_iso(i,j) - ebu_api(i,kts,j)=ebu_in_api(i,j) - ebu_lim(i,kts,j)=ebu_in_lim(i,j) - ebu_tol(i,kts,j)=ebu_in_tol(i,j) - ebu_xyl(i,kts,j)=ebu_in_xyl(i,j) - ebu_csl(i,kts,j)=ebu_in_csl(i,j) - ebu_hcho(i,kts,j)=ebu_in_hcho(i,j) - ebu_ald(i,kts,j)=ebu_in_ald(i,j) - ebu_ket(i,kts,j)=ebu_in_ket(i,j) - ebu_macr(i,kts,j)=ebu_in_macr(i,j) - ebu_ora1(i,kts,j)=ebu_in_ora1(i,j) - ebu_ora2(i,kts,j)=ebu_in_ora2(i,j) - ebu_sulf(i,kts,j)=ebu_in_sulf(i,j) - ebu_bc(i,kts,j)=ebu_in_bc(i,j) - ebu_oc(i,kts,j)=ebu_in_oc(i,j) - ebu_so2(i,kts,j)=ebu_in_so2(i,j) - ebu_dms(i,kts,j)=ebu_in_dms(i,j) - do k=kts+1,kte - ebu_co(i,k,j)=0. - ebu_co2(i,k,j)=0. - ebu_eth(i,k,j)=0. - ebu_hc3(i,k,j)=0. - ebu_hc5(i,k,j)=0. - ebu_hc8(i,k,j)=0. - ebu_ete(i,k,j)=0. - ebu_olt(i,k,j)=0. - ebu_oli(i,k,j)=0. - ebu_pm25(i,k,j)=0. - ebu_pm10(i,k,j)=0. - ebu_dien(i,k,j)=0. - ebu_iso(i,k,j)=0. - ebu_api(i,k,j)=0. - ebu_lim(i,k,j)=0. - ebu_tol(i,k,j)=0. - ebu_xyl(i,k,j)=0. - ebu_csl(i,k,j)=0. - ebu_hcho(i,k,j)=0. - ebu_ald(i,k,j)=0. - ebu_ket(i,k,j)=0. - ebu_macr(i,k,j)=0. - ebu_ora1(i,k,j)=0. - ebu_ora2(i,k,j)=0. - ebu_sulf(i,k,j)=0. - ebu_bc(i,k,j)=0. - ebu_oc(i,k,j)=0. - ebu_so2(i,k,j)=0. - ebu_dms(i,k,j)=0. + ebu(i,kts,j,p_ebu_no)=ebu_in(i,1,j,p_ebu_in_no) + ebu(i,kts,j,p_ebu_co)=ebu_in(i,1,j,p_ebu_in_co) + ebu(i,kts,j,p_ebu_co2)=ebu_in(i,1,j,p_ebu_in_co2) + ebu(i,kts,j,p_ebu_eth)=ebu_in(i,1,j,p_ebu_in_eth) + ebu(i,kts,j,p_ebu_hc3)=ebu_in(i,1,j,p_ebu_in_hc3) + ebu(i,kts,j,p_ebu_hc5)=ebu_in(i,1,j,p_ebu_in_hc5) + ebu(i,kts,j,p_ebu_hc8)=ebu_in(i,1,j,p_ebu_in_hc8) + ebu(i,kts,j,p_ebu_ete)=ebu_in(i,1,j,p_ebu_in_ete) + ebu(i,kts,j,p_ebu_olt)=ebu_in(i,1,j,p_ebu_in_olt) + ebu(i,kts,j,p_ebu_oli)=ebu_in(i,1,j,p_ebu_in_oli) + ebu(i,kts,j,p_ebu_pm25)=ebu_in(i,1,j,p_ebu_in_pm25) + ebu(i,kts,j,p_ebu_pm10)=ebu_in(i,1,j,p_ebu_in_pm10) + ebu(i,kts,j,p_ebu_dien)=ebu_in(i,1,j,p_ebu_in_dien) + ebu(i,kts,j,p_ebu_iso)=ebu_in(i,1,j,p_ebu_in_iso) + ebu(i,kts,j,p_ebu_api)=ebu_in(i,1,j,p_ebu_in_api) + ebu(i,kts,j,p_ebu_lim)=ebu_in(i,1,j,p_ebu_in_lim) + ebu(i,kts,j,p_ebu_tol)=ebu_in(i,1,j,p_ebu_in_tol) + ebu(i,kts,j,p_ebu_xyl)=ebu_in(i,1,j,p_ebu_in_xyl) + ebu(i,kts,j,p_ebu_csl)=ebu_in(i,1,j,p_ebu_in_csl) + ebu(i,kts,j,p_ebu_hcho)=ebu_in(i,1,j,p_ebu_in_hcho) + ebu(i,kts,j,p_ebu_ald)=ebu_in(i,1,j,p_ebu_in_ald) + ebu(i,kts,j,p_ebu_ket)=ebu_in(i,1,j,p_ebu_in_ket) + ebu(i,kts,j,p_ebu_macr)=ebu_in(i,1,j,p_ebu_in_macr) + ebu(i,kts,j,p_ebu_ora1)=ebu_in(i,1,j,p_ebu_in_ora1) + ebu(i,kts,j,p_ebu_ora2)=ebu_in(i,1,j,p_ebu_in_ora2) + ebu(i,kts,j,p_ebu_sulf)=ebu_in(i,1,j,p_ebu_in_sulf) + ebu(i,kts,j,p_ebu_bc)=ebu_in(i,1,j,p_ebu_in_bc) + ebu(i,kts,j,p_ebu_oc)=ebu_in(i,1,j,p_ebu_in_oc) + ebu(i,kts,j,p_ebu_so2)=ebu_in(i,1,j,p_ebu_in_so2) + ebu(i,kts,j,p_ebu_dms)=ebu_in(i,1,j,p_ebu_in_dms) + do nv=1,num_ebu + do k=kts+1,kte + ebu(i,k,j,nv)=0. + enddo enddo enddo enddo @@ -196,36 +146,9 @@ subroutine plumerise_driver (id,ktau,dtstep, & firesize(2)=firesize_agef(i,j) firesize(3)=firesize_agsv(i,j) firesize(4)=firesize_aggr(i,j) - eburn_in(1)=ebu_no(i,kts,j) - eburn_in(2)=ebu_co(i,kts,j) - eburn_in(3)=ebu_co2(i,kts,j) - eburn_in(4)=ebu_eth(i,kts,j) - eburn_in(5)=ebu_hc3(i,kts,j) - eburn_in(6)=ebu_hc5(i,kts,j) - eburn_in(7)=ebu_hc8(i,kts,j) - eburn_in(8)=ebu_ete(i,kts,j) - eburn_in(9)=ebu_olt(i,kts,j) - eburn_in(10)=ebu_oli(i,kts,j) - eburn_in(11)=ebu_pm25(i,kts,j) - eburn_in(12)=ebu_pm10(i,kts,j) - eburn_in(13)=ebu_dien(i,kts,j) - eburn_in(14)=ebu_iso(i,kts,j) - eburn_in(15)=ebu_api(i,kts,j) - eburn_in(16)=ebu_lim(i,kts,j) - eburn_in(17)=ebu_tol(i,kts,j) - eburn_in(18)=ebu_xyl(i,kts,j) - eburn_in(19)=ebu_csl(i,kts,j) - eburn_in(20)=ebu_hcho(i,kts,j) - eburn_in(21)=ebu_ald(i,kts,j) - eburn_in(22)=ebu_ket(i,kts,j) - eburn_in(23)=ebu_macr(i,kts,j) - eburn_in(24)=ebu_ora1(i,kts,j) - eburn_in(25)=ebu_ora2(i,kts,j) - eburn_in(26)=ebu_sulf(i,kts,j) - eburn_in(27)=ebu_oc(i,kts,j) - eburn_in(28)=ebu_bc(i,kts,j) - eburn_in(29)=ebu_so2(i,kts,j) - eburn_in(30)=ebu_dms(i,kts,j) + do nv=1,num_ebu + eburn_in(nv)=ebu(i,kts,j,nv) + enddo do k=kts,kte u_in(k)=u_phy(i,k,j) v_in(k)=v_phy(i,k,j) @@ -266,38 +189,10 @@ subroutine plumerise_driver (id,ktau,dtstep, & ! write(0,*)'eburn_out ',k,i,j,eburn_out(k,1) ! enddo ! endif + do nv=1,num_ebu do k=kts+1,kte - ebu_no(i,k,j)=eburn_out(k,1)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_co(i,k,j)=eburn_out(k,2)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) -! write(0,*)'after',k,ebu_co(i,k,j) - ebu_co2(i,k,j)=eburn_out(k,3)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_eth(i,k,j)=eburn_out(k,4)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hc3(i,k,j)=eburn_out(k,5)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hc5(i,k,j)=eburn_out(k,6)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hc8(i,k,j)=eburn_out(k,7)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ete(i,k,j)=eburn_out(k,8)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_olt(i,k,j)=eburn_out(k,9)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_oli(i,k,j)=eburn_out(k,10)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_pm25(i,k,j)=eburn_out(k,11)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_pm10(i,k,j)=eburn_out(k,12)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_dien(i,k,j)=eburn_out(k,13)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_iso(i,k,j)=eburn_out(k,14)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_api(i,k,j)=eburn_out(k,15)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_lim(i,k,j)=eburn_out(k,16)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_tol(i,k,j)=eburn_out(k,17)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_xyl(i,k,j)=eburn_out(k,18)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_csl(i,k,j)=eburn_out(k,19)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_hcho(i,k,j)=eburn_out(k,20)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ald(i,k,j)=eburn_out(k,21)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ket(i,k,j)=eburn_out(k,22)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_macr(i,k,j)=eburn_out(k,23)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ora1(i,k,j)=eburn_out(k,24)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_ora2(i,k,j)=eburn_out(k,25)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_sulf(i,k,j)=eburn_out(k,26)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_oc(i,k,j)=eburn_out(k,27)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_bc(i,k,j)=eburn_out(k,28)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_so2(i,k,j)=eburn_out(k,29)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) - ebu_dms(i,k,j)=eburn_out(k,30)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) + ebu(i,k,j,nv)=eburn_out(k,nv)*(z_at_w(i,k+1,j)-z_at_w(i,k,j)) + enddo enddo enddo diff --git a/wrfv2_fire/chem/optical_driver.F b/wrfv2_fire/chem/optical_driver.F index 11cc67e9..0bcb2d88 100755 --- a/wrfv2_fire/chem/optical_driver.F +++ b/wrfv2_fire/chem/optical_driver.F @@ -13,7 +13,7 @@ !WRF:MODEL_LAYER:CHEMISTRY ! SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& - chem,dz8w,alt, & + chem,dz8w,alt,relhum, & h2oai,h2oaj, & tauaer1,tauaer2,tauaer3,tauaer4, & gaer1,gaer2,gaer3,gaer4, & @@ -43,7 +43,7 @@ INTENT(IN ) :: chem ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: dz8w, alt, h2oai, h2oaj + INTENT(IN ) :: relhum, dz8w, alt, h2oai, h2oaj ! ! arrays that hold the aerosol optical properties ! @@ -76,7 +76,7 @@ ENDIF select case (config_flags%chem_opt) case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, & - RACMSORG_KPP, RACMSORG_AQ, & + GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, & CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) processingAerosols = .true. @@ -95,7 +95,7 @@ ! select case (config_flags%chem_opt) case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, & - RACMSORG_KPP, RACMSORG_AQ ) + GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ ) nbin_o = 8 case (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) @@ -131,7 +131,7 @@ call wrf_debug(15,'optical driver: call optical averaging') call optical_averaging(id,curr_secs,dtstep,config_flags, & nbin_o,haveaer,option_method,option_mie,chem,dz8w,alt, & - h2oai,h2oaj, & + relhum,h2oai,h2oaj, & tauaer1,tauaer2,tauaer3,tauaer4, & gaer1,gaer2,gaer3,gaer4, & waer1,waer2,waer3,waer4, & diff --git a/wrfv2_fire/chem/photolysis_driver.F b/wrfv2_fire/chem/photolysis_driver.F index f03326a0..8cd7937e 100755 --- a/wrfv2_fire/chem/photolysis_driver.F +++ b/wrfv2_fire/chem/photolysis_driver.F @@ -4,17 +4,23 @@ config_flags,haveaer, & gmt,julday,t_phy,moist,aerwrf,p8w,t8w,p_phy, & chem,rho_phy,dz8w,xlat,xlong,z_at_w,gd_cloud,gd_cloud2, & - ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & - ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & - ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & - ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & - ph_n2o5,ph_o2, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2, & + ph_no3o,ph_hno2,ph_hno3,ph_hno4,ph_h2o2, & + ph_ch2or,ph_ch2om,ph_ch3cho,ph_ch3coch3, & + ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2, & + ph_hcochob, ph_n2o5,ph_o2,ph_n2o, & + ph_pan,ph_mpan,ph_acetol,ph_gly, & + ph_bigald,ph_mek,ph_c2h5ooh,ph_c3h7ooh,ph_pooh, & + ph_rooh,ph_xooh,ph_isopooh,ph_alkooh, & + ph_mekooh,ph_tolooh,ph_terpooh,ph_mvk, & + ph_glyald,ph_hyac, & tauaer1,tauaer2,tauaer3,tauaer4, & gaer1,gaer2,gaer3,gaer4, & waer1,waer2,waer3,waer4, & bscoef1,bscoef2,bscoef3,bscoef4, & l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & - pm2_5_dry,pm2_5_water,uvrad, & + pm2_5_dry,pm2_5_water,uvrad,ivgtyp, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -55,7 +61,11 @@ ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & - ph_n2o5,ph_o2 + ph_n2o5,ph_o2,ph_n2o,ph_pan,ph_mpan,ph_acetol,ph_gly, & + ph_bigald,ph_mek,ph_c2h5ooh,ph_c3h7ooh,ph_pooh,ph_rooh, & + ph_xooh,ph_isopooh,ph_alkooh,ph_mekooh,ph_tolooh, & + ph_terpooh,ph_mvk,ph_glyald,ph_hyac + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT ) :: & gd_cloud,gd_cloud2 @@ -95,6 +105,7 @@ TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags LOGICAL, INTENT(IN) :: haveaer + integer, INTENT(IN ) :: ivgtyp(ims:ime,jms:jme) ! ! ! LOCAL VAR @@ -141,8 +152,7 @@ its,ite, jts,jte, kts,kte ) CASE (FTUV) call wrf_debug(15,'calling ftuv_driver') - call ftuv_radm2_driver( & - id, curr_secs, dtstep, config_flags, & + call ftuv_radm2_driver( id, curr_secs, dtstep, config_flags, & gmt, julday, & p_phy, t_phy, rho_phy, p8w, t8w, & xlat, xlong, z_at_w, & diff --git a/wrfv2_fire/clean b/wrfv2_fire/clean index 443ff38a..5c3b6754 100755 --- a/wrfv2_fire/clean +++ b/wrfv2_fire/clean @@ -37,6 +37,7 @@ if ( "$1" == '-a' ) then /bin/rm -fr tools/code_dbase ( cd external ; make -i superclean ) ( cd external/io_grib1/WGRIB ; make clean ) + ( cd external/atm_pom ; make clean ) ( cd tools ; /bin/rm -f registry gen_comms.c fseeko_test fseeko64_test ) ( cd inc; /bin/rm -f dm_comm_cpp_flags wrf_io_flags.h wrf_status_codes.h ) ( cd run ; /bin/rm -f gm* out* fort* ideal* *.exe ; \ @@ -44,10 +45,10 @@ if ( "$1" == '-a' ) then /bin/rm -f namelist.input ) >& /dev/null ( cd test/exp_real ; /bin/rm -f gm* out* fort* real* ) ( cd test ; rm -f */*.exe */ETAMPNEW_DATA */GENPARM.TBL */LANDUSE.TBL */README.namelist \ - */RRTM_DATA */SOILPARM.TBL */VEGPARM.TBL */urban_param.tbl */grib2map.tbl \ + */RRTM_DATA */SOILPARM.TBL */VEGPARM.TBL */URBPARM.TBL */grib2map.tbl \ */CAM_ABS_DATA */CAM_AEROPT_DATA */RRTMG_LW_DATA */RRTMG_SW_DATA \ */ozone.formatted */ozone_lat.formatted */ozone_plev.formatted \ - */gribmap.txt */tr??t?? ) >& /dev/null + */gribmap.txt */tr??t?? */co2_trans) >& /dev/null endif #cms++ diff --git a/wrfv2_fire/compile b/wrfv2_fire/compile index b5fd936b..3b68b95b 100755 --- a/wrfv2_fire/compile +++ b/wrfv2_fire/compile @@ -67,7 +67,7 @@ foreach a ( $argv ) endif end -if ( $arglist == "" ) then +if ( "$arglist" == "" ) then goto hlp else unsetenv A2DCASE @@ -88,6 +88,7 @@ else # calls to Make if ( ! $?WRF_DA_CORE ) setenv WRF_DA_CORE 0 if ( ! $?WRF_EM_CORE ) setenv WRF_EM_CORE 0 + if ( ! $?WRF_DFI_RADAR ) setenv WRF_DFI_RADAR 0 if ( ! $?WRF_NMM_CORE ) setenv WRF_NMM_CORE 0 if ( ! $?WRF_NMM_NEST ) setenv WRF_NMM_NEST 0 if ( ! $?WRF_COAMPS_CORE ) setenv WRF_COAMPS_CORE 0 @@ -154,7 +155,7 @@ else echo "Cannot compile because both EM and NMM cores are set to 0." exit 2 endif - if ($arglist == 'nmm_real' && $WRF_NMM_CORE == 0) then + if ("$arglist" == 'nmm_real' && $WRF_NMM_CORE == 0) then echo WRF_NMM_CORE must be set to 1 in order to compile nmm_real exit 2 endif @@ -312,7 +313,7 @@ else endif echo " " - echo -n "**** Compiling: " + echo -n "Compiling: " if ( $WRF_DA_CORE ) echo -n "WRF_DA_CORE " if ( $WRF_EM_CORE ) echo -n "WRF_EM_CORE " if ( $WRF_NMM_CORE ) echo -n "WRF_NMM_CORE " @@ -322,6 +323,18 @@ else echo " " if ( ! $?WRF_SRC_ROOT_DIR ) setenv WRF_SRC_ROOT_DIR `pwd` + +# new dec 2009. check to see if make supports parallel -j option + make -j 6 >& /dev/null + if ( $status == 0 ) then + if ( ! $?J ) then + echo setting parallel make -j 6 + setenv J "-j 6" + endif + else + echo not setting parallel make + endif + make $arglist A2DCASE="$A2DCASE" WRF_SRC_ROOT_DIR="$WRF_SRC_ROOT_DIR" endif diff --git a/wrfv2_fire/configure b/wrfv2_fire/configure index 26ce4191..8dcdd6dd 100755 --- a/wrfv2_fire/configure +++ b/wrfv2_fire/configure @@ -321,7 +321,11 @@ else if [ "$os" = "AIX" -o "$os" = "IRIX" -o "$os" = "IRIX64" -o "$os" = "SunOS" -o "$os" = "HP-UX" -o "$os" = "Darwin" -o "$os" = "Interix" ] ; then mach="ARCH" else - if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o "$os" = "CYGWIN_NT-5.1" ] ; then + xxx=`expr "$os" : '\(.........\).*'` + if [ "$xxx" = "CYGWIN_NT" ] ; then + os=$xxx + fi + if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o "$os" = "CYGWIN_NT" ] ; then mach=`uname -m` if [ "$mach" = "ia64" -a -f /etc/sgi-release ] ; then mach="Altix" @@ -369,13 +373,15 @@ if [ -n "$WRF_VENUS" ] ; then compileflags="${compileflags}!-DPLANET!-DVENUS" fi fi -if [ $WRF_NMM_CORE = 1 ]; then -if [ -n "$HWRF" ]; then - if [ $HWRF = 1 ]; then - echo building WRF with HWRF option - compileflags="${compileflags}!-DHWRF=1" +if [ -n "$WRF_NMM_CORE" ]; then + if [ $WRF_NMM_CORE = 1 ]; then + if [ -n "$HWRF" ]; then + if [ $HWRF = 1 ]; then + echo building WRF with HWRF option + compileflags="${compileflags}!-DHWRF=1" + fi fi -fi + fi fi if [ -n "$WRF_CHEM" ] ; then if [ $WRF_CHEM = 1 ] ; then @@ -394,6 +400,10 @@ else compileflags="${compileflags} " fi +if [ `which timex` ] ; then + FORTRAN_COMPILER_TIMER=timex +fi + # Found perl, so proceed with configuration if test -n "$PERL" ; then srch=`grep -i "^#ARCH.*$os" arch/configure_new.defaults | grep -i "$mach"` @@ -434,6 +444,9 @@ if test -f configure.wrf ; then if test -e tools/mpi2_test.o ; then echo " " MPI_Comm_f2c and MPI_Comm_c2f are supported sed '/^DM_CC.*=/s/$/ -DMPI2_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + if [ `hostname | cut -c 1-2` = "be" ] ; then + sed '/^ARCH_LOCAL.*=/s/$/ -DUSE_MPI_IN_PLACE/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + fi else echo " " MPI_Comm_f2c and MPI_Comm_c2f are not supported fi diff --git a/wrfv2_fire/dyn_em/Makefile b/wrfv2_fire/dyn_em/Makefile index ae839ee4..5aea79c6 100644 --- a/wrfv2_fire/dyn_em/Makefile +++ b/wrfv2_fire/dyn_em/Makefile @@ -16,8 +16,12 @@ MODULES = \ module_init_utilities.o \ module_damping_em.o \ module_polarfft.o \ + module_force_scm.o \ module_first_rk_step_part1.o \ module_first_rk_step_part2.o \ + module_avgflx_em.o \ + module_sfs_nba.o \ + module_sfs_driver.o \ $(CASE_MODULE) # possible CASE_MODULE settings @@ -102,6 +106,16 @@ module_em.o: module_big_step_utilities_em.o module_advect_em.o \ module_polarfft.o: ../share/module_model_constants.o \ ../frame/module_wrf_error.o +module_sfs_driver.o: \ + module_sfs_nba.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_tiles.o \ + ../frame/module_dm.o \ + ../frame/module_machine.o \ + ../share/module_bc.o + module_small_step_em.o: \ ../frame/module_configure.o \ ../share/module_model_constants.o @@ -117,6 +131,8 @@ module_initialize_b_wave.o : \ ../share/module_bc.o \ module_init_utilities.o +module_force_scm.o: module_init_utilities.o + module_initialize_grav2d_x.o: \ ../frame/module_domain.o \ ../frame/module_configure.o \ @@ -245,12 +261,14 @@ nest_init_utils.o: \ ../frame/module_domain.o \ ../frame/module_configure.o -start_em.o: module_bc_em.o \ +start_em.o: module_bc_em.o \ + module_avgflx_em.o \ ../frame/module_domain.o \ ../frame/module_configure.o \ ../frame/module_state_description.o \ ../frame/module_timing.o \ ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ ../share/module_io_domain.o \ ../share/module_model_constants.o \ ../share/module_bc.o \ @@ -265,6 +283,7 @@ solve_em.o: module_small_step_em.o \ module_big_step_utilities_em.o \ module_first_rk_step_part1.o \ module_first_rk_step_part2.o \ + module_avgflx_em.o \ ../frame/module_domain.o \ ../frame/module_configure.o \ ../frame/module_driver_constants.o \ @@ -272,6 +291,7 @@ solve_em.o: module_small_step_em.o \ ../frame/module_machine.o \ ../frame/module_tiles.o \ ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ ../share/module_llxy.o \ ../share/module_model_constants.o \ ../share/module_bc.o \ @@ -280,21 +300,29 @@ solve_em.o: module_small_step_em.o \ ../phys/module_physics_addtendc.o module_first_rk_step_part1.o : \ + module_force_scm.o \ + module_big_step_utilities_em.o \ + module_em.o \ ../phys/module_radiation_driver.o \ ../phys/module_surface_driver.o \ ../phys/module_cumulus_driver.o \ ../phys/module_pbl_driver.o \ + ../frame/module_comm_dm.o \ ../phys/module_fddagd_driver.o module_first_rk_step_part2.o : \ + module_em.o \ module_diffusion_em.o \ module_bc_em.o \ + module_sfs_driver.o \ ../frame/module_domain.o \ ../frame/module_state_description.o \ ../frame/module_driver_constants.o \ ../frame/module_configure.o \ ../frame/module_dm.o \ ../share/module_bc.o \ + ../frame/module_comm_dm.o \ + ../phys/module_fddaobs_driver.o \ ../phys/module_fddaobs_driver.o adapt_timestep_em.o: \ diff --git a/wrfv2_fire/dyn_em/adapt_timestep_em.F b/wrfv2_fire/dyn_em/adapt_timestep_em.F index 5d3edfc5..dd0b493b 100644 --- a/wrfv2_fire/dyn_em/adapt_timestep_em.F +++ b/wrfv2_fire/dyn_em/adapt_timestep_em.F @@ -1,4 +1,4 @@ -SUBROUTINE adapt_timestep(grid, config_flags) +RECURSIVE SUBROUTINE adapt_timestep(grid, config_flags) !-------------------------------------------------------------------------- ! @@ -17,7 +17,7 @@ SUBROUTINE adapt_timestep(grid, config_flags) ! Driver layer modules USE module_domain USE module_configure - USE module_dm + USE module_dm, ONLY : wrf_dm_maxval, wrf_dm_minval, wrf_dm_mintile_double, wrf_dm_tile_val_int, wrf_dm_maxtile_real USE module_bc_em IMPLICIT NONE @@ -33,11 +33,12 @@ SUBROUTINE adapt_timestep(grid, config_flags) INTEGER :: idex=0, jdex=0 INTEGER :: rc TYPE(WRFU_TimeInterval) :: tmpTimeInterval, dtInterval + TYPE(WRFU_TimeInterval) :: parent_dtInterval INTEGER :: num_small_steps integer :: tile LOGICAL :: stepping_to_bc INTEGER :: bc_time, output_time - double precision :: dt + double precision :: dt = 0 INTEGER, PARAMETER :: precision = 100 INTEGER :: dt_num, dt_den, dt_whole REAL :: factor @@ -53,16 +54,37 @@ SUBROUTINE adapt_timestep(grid, config_flags) use_last2 = .FALSE. ! - ! For nests, we only want to change nests' time steps when the time is - ! conincident with the parent's time. So, if dtbc is not - ! zero, simply return and leave the last time step in place. + ! If this step has already been adapted, no need to do it again. + ! time step can already be adapted when adaptation_domain is + ! enabled. ! - if (config_flags%nested) then - if (abs(grid%dtbc) > 0.0001) then - return - endif + + if (grid%last_step_updated == grid%itimestep) then + return + else + grid%last_step_updated = grid%itimestep endif + ! + ! For nests, set adapt_this_step_using_child to parent's value + ! + if (grid%id .ne. 1) then + grid%adapt_this_step_using_child = grid%parents(1)%ptr%adapt_this_step_using_child; + endif + + ! + ! For nests, if we're not adapting using child nest, we only want to change + ! nests' time steps when the time is conincident with the parent's time. + ! So, if dtbc is not zero, simply return and leave the last time step in + ! place. + ! + +! if ((grid%id .ne. 1) .and. (.not. grid%adapt_this_step_using_child)) then +! if (abs(grid%dtbc) > 0.0001) then +! return +! endif +! endif + last_dtInterval = grid%last_dtInterval ! @@ -84,12 +106,7 @@ SUBROUTINE adapt_timestep(grid, config_flags) ! Calculate the maximum allowable increase in the time step given ! the user input max_step_increase_pct value and the nest ratio. ! - if (config_flags%nested) then - max_increase_factor = 1. + & - grid%parent_time_step_ratio * grid%max_step_increase_pct / 100. - else - max_increase_factor = 1. + grid%max_step_increase_pct / 100. - endif + max_increase_factor = 1. + grid%max_step_increase_pct / 100. ! ! If this is the first time step of the model run (indicated by current_time @@ -121,13 +138,12 @@ SUBROUTINE adapt_timestep(grid, config_flags) if (grid%max_cfl_val .gt. grid%target_cfl) then ! ! If we are reducing the time step, we go below target cfl by half the - ! difference between max and target (or 75% of the last time step, - ! which ever is greater). + ! difference between max and target ! This tends to keep the model more stable. ! - factor = MAX ( 0.75 , ( (grid%target_cfl - 0.5 * & - (grid%max_cfl_val - grid%target_cfl) ) / grid%max_cfl_val ) ) + factor = ( (grid%target_cfl - 0.5 * & + (grid%max_cfl_val - grid%target_cfl) ) / grid%max_cfl_val ) num = INT(factor * precision + 0.5) den = precision @@ -182,23 +198,43 @@ SUBROUTINE adapt_timestep(grid, config_flags) endif ! - ! Now, if this is a nest, we round down the time step to the nearest + ! Now, if this is a nest, and we are adapting based upon parent, + ! we round down the time step to the nearest ! value that divides evenly into the parent time step. + ! If this is a nest, and we are adapting based upon the child (i.e., the + ! nest), we update the parent timestep to the next smallest multiple + ! timestep. ! - if (config_flags%nested) then - ! We'll calculate real numbers to get the number of small steps: - + if (grid%nested) then + dt = real_time(dtInterval) + + if (.not. grid%adapt_this_step_using_child) then - num_small_steps = CEILING( grid%parents(1)%ptr%dt / dt ) + ! We'll calculate real numbers to get the number of small steps: + + num_small_steps = CEILING( grid%parents(1)%ptr%dt / dt ) #ifdef DM_PARALLEL - call wrf_dm_maxval(num_small_steps, idex, jdex) + call wrf_dm_maxval(num_small_steps, idex, jdex) #endif - dtInterval = domain_get_time_step(grid%parents(1)%ptr) / & - num_small_steps + dtInterval = domain_get_time_step(grid%parents(1)%ptr) / & + num_small_steps + else + + num_small_steps = FLOOR( grid%parents(1)%ptr%dt / dt ) + +#ifdef DM_PARALLEL + call wrf_dm_minval(num_small_steps, idex, jdex) +#endif + if (num_small_steps < 1) then + num_small_steps = 1 + endif + + endif endif + ! ! Setup the values for several variables from the tile with the ! minimum dt. @@ -218,41 +254,57 @@ SUBROUTINE adapt_timestep(grid, config_flags) call wrf_dm_maxtile_real(grid%max_horiz_cfl, tile) #endif + if ((grid%nested) .and. (grid%adapt_this_step_using_child)) then + + grid%dt = real_time(dtInterval) + + ! Set parent step here. + grid%parents(1)%ptr%dt = grid%dt * num_small_steps + parent_dtInterval = dtInterval * num_small_steps + + ! + ! Update the parent clock based on the new time step + ! + CALL WRFU_ClockSet ( grid%parents(1)%ptr%domain_clock, & + timeStep=parent_dtInterval, & + rc=rc ) + + endif + + ! ! Assure that we fall on a BC time. Due to a bug in WRF, the time ! step must fall on the boundary times. Only modify the dtInterval ! when this is not the first time step on this domain. ! - if ( real_time(domain_get_current_time(grid) - domain_get_start_time(grid)) .GT. 0.01 ) THEN - time_to_bc = grid%interval_seconds - grid%dtbc - num = INT(time_to_bc * precision + 0.5) - den = precision - CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=num, Sd=den) - - if ( ( tmpTimeInterval .LT. dtInterval * 2 ) .and. & - ( tmpTimeInterval .GT. dtInterval ) ) then - dtInterval = tmpTimeInterval / 2 - - use_last2 = .TRUE. - stepping_to_bc = .true. - - elseif (tmpTimeInterval .LE. dtInterval) then - - bc_time = NINT ( (curr_secs + time_to_bc) / ( grid%interval_seconds ) ) & - * ( grid%interval_seconds ) - CALL WRFU_TimeIntervalSet(tmpTimeInterval, S=bc_time) - dtInterval = tmpTimeInterval - & - (domain_get_current_time(grid) - domain_get_start_time(grid)) - - use_last2 = .TRUE. - stepping_to_bc = .true. - else - stepping_to_bc = .false. - endif + grid%stepping_to_time = .FALSE. + time_to_bc = grid%interval_seconds - grid%dtbc + num = INT(time_to_bc * precision + 0.5) + den = precision + CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=num, Sd=den) + + if ( ( tmpTimeInterval .LT. dtInterval * 2 ) .and. & + ( tmpTimeInterval .GT. dtInterval ) ) then + dtInterval = tmpTimeInterval / 2 + + use_last2 = .TRUE. + stepping_to_bc = .true. + grid%stepping_to_time = .TRUE. + + elseif (tmpTimeInterval .LE. dtInterval) then + + bc_time = NINT ( (curr_secs + time_to_bc) / ( grid%interval_seconds ) ) & + * ( grid%interval_seconds ) + CALL WRFU_TimeIntervalSet(tmpTimeInterval, S=bc_time) + dtInterval = tmpTimeInterval - & + (domain_get_current_time(grid) - domain_get_start_time(grid)) + + use_last2 = .TRUE. + stepping_to_bc = .true. + grid%stepping_to_time = .TRUE. else stepping_to_bc = .false. - tmpTimeInterval = dtInterval endif ! @@ -263,7 +315,7 @@ SUBROUTINE adapt_timestep(grid, config_flags) ! if ((grid%step_to_output_time) .and. (.not. stepping_to_bc) .and. & - (.not. config_flags%nested)) then + (.not. grid%nested)) then time_to_output = grid%history_interval*60 - & mod(curr_secs, grid%history_interval*60.0) @@ -275,6 +327,7 @@ SUBROUTINE adapt_timestep(grid, config_flags) ( tmpTimeInterval .GT. dtInterval ) ) then dtInterval = tmpTimeInterval / 2 use_last2 = .TRUE. + grid%stepping_to_time = .TRUE. elseif (tmpTimeInterval .LE. dtInterval) then ! @@ -293,9 +346,32 @@ SUBROUTINE adapt_timestep(grid, config_flags) (domain_get_current_time(grid) - domain_get_start_time(grid)) use_last2 = .TRUE. + grid%stepping_to_time = .TRUE. + endif + endif + + ! + ! Now, set adapt_this_step_using_child only if we are not stepping to an + ! output time, or, it's not the start of the model run. + ! Note: adapt_this_step_using_child is updated just before recursive call to + ! adapt_timestep--see end of this function. + ! + + if (grid%id == 1) then + if ((grid%adaptation_domain > 1) .and. & + (grid%max_dom == 2) .and. & + (.not. grid%stepping_to_time) .and. & + (domain_get_current_time(grid) .ne. & + domain_get_start_time(grid)) & + ) then + + grid%adapt_this_step_using_child = .TRUE. + else + grid%adapt_this_step_using_child = .FALSE. endif endif + if (use_last2) then grid%last_dtInterval = last_dtInterval else @@ -314,11 +390,34 @@ SUBROUTINE adapt_timestep(grid, config_flags) rc=rc ) ! + ! If we're are adapting based on the child time step, + ! we call the child from here. This assures that + ! child and parent are updated in sync. + ! Note: This is not necessary when we are adapting based + ! upon parent. + ! + if ((grid%id == 1) .and. (grid%adapt_this_step_using_child)) then + ! + ! Finally, check if we can adapt using child. If we are + ! stepping to an output time, we cannot adapt based upon + ! child. So, we reset the variable before calling the child. + ! This covers the case that, within this parent time-step that + ! we just calculated, we are stepping to an output time. + ! + if (grid%stepping_to_time) then + grid%adapt_this_step_using_child = .FALSE. + endif + call adapt_timestep(grid%nests(1)%ptr, config_flags) + endif + + ! ! Lateral boundary weight recomputation based on time step. ! - CALL lbc_fcx_gcx ( grid%fcx , grid%gcx , grid%spec_bdy_width , & - grid%spec_zone , grid%relax_zone , grid%dt , config_flags%spec_exp , & - config_flags%specified , config_flags%nested ) + if (grid%id == 1) then + CALL lbc_fcx_gcx ( grid%fcx , grid%gcx , grid%spec_bdy_width , & + grid%spec_zone , grid%relax_zone , grid%dt , config_flags%spec_exp , & + config_flags%specified , config_flags%nested ) + endif END SUBROUTINE adapt_timestep diff --git a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F index 8c21569a..aec50aa8 100644 --- a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F +++ b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F @@ -15,7 +15,12 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & USE module_driver_constants USE module_machine USE module_tiles +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic + USE module_comm_dm, ONLY : halo_em_couple_a_sub,halo_em_couple_b_sub,period_em_couple_a_sub,period_em_couple_b_sub +#else USE module_dm +#endif USE module_bc ! Mediation layer modules ! Registry generated module diff --git a/wrfv2_fire/dyn_em/module_advect_em.F b/wrfv2_fire/dyn_em/module_advect_em.F index c1c14bb6..a9b92d79 100644 --- a/wrfv2_fire/dyn_em/module_advect_em.F +++ b/wrfv2_fire/dyn_em/module_advect_em.F @@ -5940,7 +5940,7 @@ END SUBROUTINE advect_w SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & ru, rv, rom, & mut, mub, mu_old, & - config_flags, & + time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & fzm, fzp, & @@ -5993,6 +5993,7 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & REAL , INTENT(IN ) :: rdx, & rdy, & dt + INTEGER , INTENT(IN ) :: time_step ! Local data @@ -6029,7 +6030,7 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & - sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) + sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & @@ -6037,7 +6038,7 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & - -sign(1.,ua)*(1./60.)*( & + -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 & diff --git a/wrfv2_fire/dyn_em/module_bc_em.F b/wrfv2_fire/dyn_em/module_bc_em.F index ca1ee844..ec993d2b 100644 --- a/wrfv2_fire/dyn_em/module_bc_em.F +++ b/wrfv2_fire/dyn_em/module_bc_em.F @@ -972,40 +972,40 @@ CONTAINS !--------------------------------------------------------------------- - SUBROUTINE set_w_surface( config_flags, znw, & + SUBROUTINE set_w_surface( config_flags, znw, fill_w_flag, & w, ht, u, v, cf1, cf2, cf3, rdx, rdy, & msftx, msfty, & ids, ide, jds, jde, kds, kde, & - ips, ipe, jps, jpe, kps, kpe, & - its, ite, jts, jte, kts, kte, & - ims, ime, jms, jme, kms, kme ) - implicit none - - TYPE( grid_config_rec_type ) config_flags + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + implicit none - INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte, & - ips, ipe, jps, jpe, kps, kpe + TYPE( grid_config_rec_type ) config_flags - REAL :: rdx, rdy, cf1, cf2, cf3 + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL :: rdx, rdy, cf1, cf2, cf3 - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & - INTENT(IN ) :: u, & - v + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: u, & + v - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & - INTENT(INOUT) :: w + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(INOUT) :: w - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: ht, & - msftx, & - msfty - REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: znw + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: ht, & + msftx, & + msfty + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: znw + + LOGICAL, INTENT(IN ) :: fill_w_flag - INTEGER :: i,j,k - INTEGER :: ip1,im1,jp1,jm1 + INTEGER :: i,j,k + INTEGER :: ip1,im1,jp1,jm1 + INTEGER :: ip1_limit,im1_limit,jp1_limit,jm1_limit ! set kinematic lower boundary condition on W @@ -1020,12 +1020,29 @@ CONTAINS ! [NB - cf1, cf2 and cf3 do vertical weighting of u or v values ! nearest the surface] +! get indices for points next to edge of domain + + jm1_limit = jds ! No periodic BC's + jp1_limit = jde-1 + im1_limit = ids + ip1_limit = ide-1 + + IF ( config_flags%periodic_x ) THEN + im1_limit = ids-1 + ip1_limit = ide + ENDIF + + IF ( config_flags%periodic_y ) THEN + jm1_limit = jds-1 + jp1_limit = jde + ENDIF + DO j = jts,min(jte,jde-1) - jm1 = max(j-1,jds) - jp1 = min(j+1,jde-1) + jm1 = max(j-1, jm1_limit) + jp1 = min(j+1, jp1_limit) DO i = its,min(ite,ide-1) - im1 = max(i-1,ids) - ip1 = min(i+1,ide-1) + im1 = max(i-1, im1_limit) + ip1 = min(i+1, ip1_limit) w(i,1,j)= msfty(i,j)* & .5*rdy*( & @@ -1044,14 +1061,15 @@ CONTAINS ENDDO ! Fill the atmospheric w field with smoothly decaying values - - DO j = jts,min(jte,jde-1) - DO k = kts+1,kte - DO i = its,min(ite,ide-1) - w(i,k,j) = w(i,1,j)*znw(k)*znw(k) - ENDDO - ENDDO - ENDDO + IF (fill_w_flag) THEN + DO j = jts,min(jte,jde-1) + DO k = kts+1,kte + DO i = its,min(ite,ide-1) + w(i,k,j) = w(i,1,j)*znw(k)*znw(k) + ENDDO + ENDDO + ENDDO + ENDIF END SUBROUTINE set_w_surface @@ -1100,74 +1118,5 @@ CONTAINS ENDIF END SUBROUTINE lbc_fcx_gcx - - SUBROUTINE set_w_surface2( & - w, ht, u, v, cf1, cf2, cf3, rdx, rdy, & - msftx, msfty, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - implicit none - -! TYPE( grid_config_rec_type ) config_flags - - INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - - REAL :: rdx, rdy, cf1, cf2, cf3 - - - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & - INTENT(IN ) :: u, & - v - - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & - INTENT(INOUT) :: w - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: ht, & - msftx, & - msfty - - INTEGER :: i,j,k - INTEGER :: ip1,im1,jp1,jm1 - -! set kinematic lower boundary condition on W - -! Comments on directional map scale factors: -! Chain rule: if Z=Z(X,Y) [true at the surface] then -! dZ/dt = dZ/dX * dX/dt + dZ/dY * dY/dt, U=dX/dt, V=dY/dt -! using capitals to denote actual values -! in mapped values, u=U, v=V, z=Z, 1/dX=mx/dx, 1/dY=my/dy -! => w = dz/dt = mx u dz/dx + my v dz/dy -! [where dz/dx is just the surface height change between x -! gridpoints, and dz/dy is the change between y gridpoints] -! [NB - cf1, cf2 and cf3 do vertical weighting of u or v values -! nearest the surface] - - DO j = jts,min(jte,jde-1) - jm1 = max(j-1,jds) - jp1 = min(j+1,jde-1) - DO i = its,min(ite,ide-1) - im1 = max(i-1,ids) - ip1 = min(i+1,ide-1) - - w(i,1,j)= msfty(i,j)* & - .5*rdy*( & - (ht(i,jp1)-ht(i,j )) & - *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1)) & - +(ht(i,j )-ht(i,jm1)) & - *(cf1*v(i,1,j )+cf2*v(i,2,j )+cf3*v(i,3,j )) ) & - +msftx(i,j)* & - .5*rdx*( & - (ht(ip1,j)-ht(i,j )) & - *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j)) & - +(ht(i ,j)-ht(im1,j)) & - *(cf1*u(i ,1,j)+cf2*u(i ,2,j)+cf3*u(i ,3,j)) ) - - ENDDO - ENDDO - - END SUBROUTINE set_w_surface2 END MODULE module_bc_em diff --git a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F index b52a8140..789ce9af 100644 --- a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F +++ b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F @@ -4547,10 +4547,11 @@ END SUBROUTINE pole_point_bc SUBROUTINE phy_prep ( config_flags, & ! input mu, muu, muv, u, v, p, pb, alt, ph, & ! input phb, t, tsk, moist, n_moist, & ! input - mu_3d, rho, th_phy, p_phy , pi_phy , & ! output + rho, th_phy, p_phy , pi_phy , & ! output u_phy, v_phy, p8w, t_phy, t8w, & ! output z, z_at_w, dz8w, & ! output - fzm, fzp, & ! params + p_hyd, p_hyd_w, & ! output + fzm, fzp, znw, p_top, & ! params RTHRATEN, & RTHBLTEN, RUBLTEN, RVBLTEN, & RQVBLTEN, RQCBLTEN, RQIBLTEN, & @@ -4587,13 +4588,18 @@ END SUBROUTINE pole_point_bc t_phy, & th_phy, & t8w, & - mu_3d, & rho, & z, & dz8w, & z_at_w REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT( OUT) :: p_hyd, & + p_hyd_w + + REAL , INTENT(IN ) :: p_top + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(IN ) :: pb, & p, & u, & @@ -4607,6 +4613,8 @@ END SUBROUTINE pole_point_bc REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: znw + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & INTENT(INOUT) :: RTHRATEN @@ -4643,6 +4651,7 @@ END SUBROUTINE pole_point_bc INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, j_startv INTEGER :: i, j, k REAL :: w1, w2, z0, z1, z2 + REAL :: e_vapor !----------------------------------------------------------------------- @@ -4665,7 +4674,7 @@ END SUBROUTINE pole_point_bc k_start = kts k_end = min( kte, kde-1 ) -! compute thermodynamics and velocities at pressure points +! compute thermodynamics and velocities at pressure points (or half levels) do j = j_start,j_end do k = k_start, k_end @@ -4676,7 +4685,6 @@ END SUBROUTINE pole_point_bc pi_phy(i,k,j) = (p_phy(i,k,j)/p1000mb)**rcp t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) rho(i,k,j) = 1./alt(i,k,j)*(1.+moist(i,k,j,P_QV)) - mu_3d(i,k,j) = mu(i,j) u_phy(i,k,j) = 0.5*(u(i,k,j)+u(i+1,k,j)) v_phy(i,k,j) = 0.5*(v(i,k,j)+v(i,k,j+1)) @@ -4708,7 +4716,7 @@ END SUBROUTINE pole_point_bc enddo enddo -! compute z at p points (average of z at w points) +! compute z at p points or half levels (average of z at full levels) do j = j_start,j_end do k = k_start, k_end @@ -4718,7 +4726,7 @@ END SUBROUTINE pole_point_bc enddo enddo -! interp t and p at w points +! interp t and p to full levels do j = j_start,j_end do k = 2, k_end @@ -4761,6 +4769,36 @@ END SUBROUTINE pole_point_bc enddo enddo +! calculate hydrostatic pressure at both full and half levels +! first, full level p: assuming dry over model top + + do j = j_start,j_end + do i = i_start, i_end + p_hyd_w(i,kte,j) = p_top + enddo + enddo + + e_vapor = 0. + do j = j_start,j_end + do k = kte-1, k_start, -1 + do i = i_start, i_end +! e_vapor = 1./alt(i,k,j)*moist(i,k,j,P_QV)*g*dz8w(i,k,j) +! p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+e_vapor + p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))*g*dz8w(i,k,j) + enddo + enddo + enddo + +! now calculate hydrostatic pressure at half levels + + do j = j_start,j_end + do k = k_start, k_end + do i = i_start, i_end + p_hyd(i,k,j) = 0.5*(p_hyd_w(i,k,j)+p_hyd_w(i,k+1,j)) + enddo + enddo + enddo + ! decouple all physics tendencies IF (config_flags%ra_lw_physics .gt. 0 .or. config_flags%ra_sw_physics .gt. 0) THEN @@ -5133,6 +5171,9 @@ END SUBROUTINE phy_prep SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & th_phy, h_diabatic, dt, & config_flags, & +#if ( WRF_DFI_RADAR == 1 ) + dfi_tten_rad,dfi_stage, & +#endif ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -5153,6 +5194,14 @@ END SUBROUTINE phy_prep t_old, & th_phy, & h_diabatic +#if ( WRF_DFI_RADAR == 1 ) + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(IN), OPTIONAL :: dfi_tten_rad + INTEGER, INTENT(IN ) ,OPTIONAL :: dfi_stage +! REAL :: dfi_tten_max, old_max +#endif + + REAL mpten, mptenmax, mptenmin REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: mut @@ -5160,7 +5209,7 @@ END SUBROUTINE phy_prep REAL, INTENT(IN ) :: t0, dt INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end - INTEGER :: i, j, k + INTEGER :: i, j, k, imax, jmax, imin, jmin !-------------------------------------------------------------------- @@ -5173,23 +5222,60 @@ END SUBROUTINE phy_prep ! set up loop bounds for this grid's boundary conditions - i_start = its i_end = min( ite,ide-1 ) j_start = jts j_end = min( jte,jde-1 ) +! i_start=max(its,ids+4) +! i_end=min(ite,ide-5) +! j_start=max(jts,jds+4) +! j_end=min(jte,jde-5) k_start = kts k_end = min( kte, kde-1 ) +#if ( WRF_DFI_RADAR == 1 ) + if (config_flags%dfi_radar == 1 .and. PRESENT(dfi_stage) .and. dfi_stage ==DFI_FWD & + .and. PRESENT(dfi_tten_rad) ) then + WRITE(wrf_err_message,*)'Add radar tendency: i_start,j_start: ', i_start, j_start + CALL wrf_debug ( 50 , TRIM(wrf_err_message) ) + endif + dfi_tten_max=-999 + old_max=-999 +#endif + ! add microphysics theta diff to perturbation theta, set h_diabatic IF ( config_flags%no_mp_heating .eq. 0 ) THEN DO j = j_start, j_end DO k = k_start, k_end DO i = i_start, i_end +#if ( WRF_DFI_RADAR == 1 ) + mpten = th_phy(i,k,j)-h_diabatic(i,k,j) + + mpten=min(config_flags%mp_tend_lim*dt, mpten) + mpten=max(-config_flags%mp_tend_lim*dt, mpten) + + if (config_flags%dfi_radar == 1 .and. PRESENT(dfi_stage) .and. & + dfi_stage == DFI_FWD .and. PRESENT(dfi_tten_rad) .and. & + dfi_tten_rad(i,k,j) >= 1.0e-7 .and. dfi_tten_rad(i,k,j) <= 10. & + .and. k < k_end ) then +! add radar temp tendency +!tgs if(dfi_tten_rad(i,k,j) > th_phy(i,k,j)-h_diabatic(i,k,j) ) then + if(dfi_tten_rad(i,k,j) > mpten ) then + t_new(i,k,j) = t_new(i,k,j) + (dfi_tten_rad(i,k,j)) + else +!tgs t_new(i,k,j) = t_new(i,k,j) + (th_phy(i,k,j)-h_diabatic(i,k,j)) + t_new(i,k,j) = t_new(i,k,j) + mpten + endif + else +!tgs t_new(i,k,j) = t_new(i,k,j) + (th_phy(i,k,j)-h_diabatic(i,k,j)) + t_new(i,k,j) = t_new(i,k,j) + mpten + endif +#else t_new(i,k,j) = t_new(i,k,j) + (th_phy(i,k,j)-h_diabatic(i,k,j)) - h_diabatic(i,k,j) = (th_phy(i,k,j)-h_diabatic(i,k,j))/dt +#endif + h_diabatic(i,k,j) = (th_phy(i,k,j)-h_diabatic(i,k,j))/dt ENDDO ENDDO ENDDO diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F index cdf59206..015cc2ed 100644 --- a/wrfv2_fire/dyn_em/module_diffusion_em.F +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -17,6 +17,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & defor11, defor22, defor33, & defor12, defor13, defor23, & + nba_rij, n_nba_rij, & !JDM u_base, v_base, msfux, msfuy, & msfvx, msfvy, msftx, msfty, & rdx, rdy, dn, dnw, rdz, rdzw, & @@ -75,6 +76,12 @@ REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: defor11, defor22, defor33, defor12, defor13, defor23, div + INTEGER, INTENT( IN ) :: n_nba_rij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_rij), INTENT(INOUT) & !JDM + :: nba_rij + + ! Local variables. INTEGER & @@ -593,6 +600,79 @@ ! Here adding v^ terms: ! m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi) + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA-- + +!JDM____________________________________________________________________ +! +! s12 = du/dy + dv/dx +! = (du/dy - dz/dy*du/dz) + (dv/dx - dz/dx*dv/dz) +! ______defor12______ ___tmp1___ +! +! r12 = du/dy - dv/dx +! = (du/dy - dz/dy*du/dz) - (dv/dx - dz/dx*dv/dz) +! ______defor12______ ___tmp1___ +!_______________________________________________________________________ + + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + nba_rij(i,k,j,P_r12) = defor12(i,k,j) - & + mm(i,j) * ( & + rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) + + defor12(i,k,j) = defor12(i,k,j) + & + mm(i,j) * ( & + rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) + END DO + END DO + END DO + +! End addition of the second term to defor12. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Update the boundary for defor12 (might need to change later). + + IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN + DO j = jts, jte + DO k = kts, kte + defor12(ids,k,j) = defor12(ids+1,k,j) + nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN + DO k = kts, kte + DO i = its, ite + defor12(i,k,jds) = defor12(i,k,jds+1) + nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN + DO j = jts, jte + DO k = kts, kte + defor12(ide,k,j) = defor12(ide-1,k,j) + nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN + DO k = kts, kte + DO i = its, ite + defor12(i,k,jde) = defor12(i,k,jde-1) + nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12) + END DO + END DO + END IF + + ELSE ! NOT NBA-------------------------------------------------------- + DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end @@ -641,6 +721,8 @@ END DO END IF + ENDIF ! NBA----------------------------------------------------------- + ! End update of boundary for defor12. !----------------------------------------------------------------------- @@ -782,6 +864,38 @@ ! Add the second term (du/dz) to defor13 (dw/dx+du/dz) at vorticity ! points. + + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA-- + +!JDM____________________________________________________________________ +! +! s13 = du/dz + dw/dx +! = du/dz + (dw/dx - dz/dx*dw/dz) +! = tmp1 + ______defor13______ +! +! r13 = du/dz - dw/dx +! = du/dz - (dw/dx - dz/dx*dw/dz) +! = tmp1 - ______defor13______ +!_______________________________________________________________________ + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + nba_rij(i,k,j,P_r13) = tmp1(i,k,j) - defor13(i,k,j) + defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end !change for different surface B. C. + DO i = i_start, i_end + nba_rij(i,kts ,j,P_r13) = 0.0 + nba_rij(i,ktf+1,j,P_r13) = 0.0 + END DO + END DO + + ELSE ! NOT NBA-------------------------------------------------------- + DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end @@ -790,6 +904,8 @@ END DO END DO + ENDIF ! NBA----------------------------------------------------------- + ! End addition of the second term to defor13. !----------------------------------------------------------------------- @@ -926,6 +1042,89 @@ ! Add the second term (dv/dz) to defor23 (dw/dy+dv/dz) at vorticity ! points. + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA-- + +!JDM___________________________________________________________________ +! +! s23 = dv/dz + dw/dy +! = dv/dz + (dw/dy - dz/dy*dw/dz) +! tmp1 + ______defor23______ +! +! r23 = dv/dz - dw/dy +! = dv/dz - (dw/dy - dz/dy*dw/dz) +! = tmp1 - ______defor23______ + +! Add tmp1 to defor23. + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j) + defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j) + END DO + END DO + END DO + + DO j = j_start, j_end + DO i = i_start, i_end + nba_rij(i,kts ,j,P_r23) = 0.0 + nba_rij(i,ktf+1,j,P_r23) = 0.0 + END DO + END DO + +! End addition of the second term to defor23. +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! Update the boundary for defor13 and defor23 (might need to change +! later). + + IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1) THEN + DO j = jts, jte + DO k = kts, kte + defor13(ids,k,j) = defor13(ids+1,k,j) + defor23(ids,k,j) = defor23(ids+1,k,j) + nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13) + nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN + DO k = kts, kte + DO i = its, ite + defor13(i,k,jds) = defor13(i,k,jds+1) + defor23(i,k,jds) = defor23(i,k,jds+1) + nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13) + nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_x .AND. i_end .EQ. ide-1) THEN + DO j = jts, jte + DO k = kts, kte + defor13(ide,k,j) = defor13(ide-1,k,j) + defor23(ide,k,j) = defor23(ide-1,k,j) + nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13) + nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23) + END DO + END DO + END IF + + IF ( .NOT. config_flags%periodic_y .AND. j_end .EQ. jde-1) THEN + DO k = kts, kte + DO i = its, ite + defor13(i,k,jde) = defor13(i,k,jde-1) + defor23(i,k,jde) = defor23(i,k,jde-1) + nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13) + nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23) + END DO + END DO + END IF + + ELSE ! NOT NBA-------------------------------------------------------- + ! Add tmp1 to defor23. DO j = j_start, j_end @@ -979,6 +1178,8 @@ END DO END IF + ENDIF ! NBA----------------------------------------------------------- + ! End update of boundary for defor13 and defor23. !----------------------------------------------------------------------- @@ -2060,10 +2261,13 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & moist_tendf, n_moist, & chem_tendf, n_chem, & scalar_tendf, n_scalar, & + tracer_tendf, n_tracer, & thp, theta, mu, tke, config_flags, & defor11, defor22, defor12, & - defor13, defor23, div, & - moist, chem, scalar, & + defor13, defor23, & + nba_mij, n_nba_mij, & !JDM + div, & + moist, chem, scalar,tracer, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, xkmh, xkhh,km_opt, & rdx, rdy, rdz, rdzw, fnm, fnp, & @@ -2083,7 +2287,7 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN ) :: n_moist, n_chem, n_scalar, km_opt + INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,km_opt REAL , INTENT(IN ) :: cf1, cf2, cf3 @@ -2115,6 +2319,9 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar), & INTENT(INOUT) :: scalar_tendf + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer), & + INTENT(INOUT) :: tracer_tendf + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(IN ) :: moist @@ -2124,6 +2331,9 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(IN ) :: scalar + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & + INTENT(IN ) :: tracer + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & defor22, & defor12, & @@ -2143,6 +2353,10 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & REAL , INTENT(IN ) :: rdx, & rdy + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij ! LOCAL VARS @@ -2158,6 +2372,7 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & CALL horizontal_diffusion_u_2( ru_tendf, mu, config_flags, & defor11, defor12, div, & + nba_mij, n_nba_mij, & !JDM tke(ims,kms,jms), & msfux, msfuy, xkmh, rdx, rdy, fnm, fnp, & zx, zy, rdzw, & @@ -2167,6 +2382,7 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & CALL horizontal_diffusion_v_2( rv_tendf, mu, config_flags, & defor12, defor22, div, & + nba_mij, n_nba_mij, & !JDM tke(ims,kms,jms), & msfvx, msfvy, xkmh, rdx, rdy, fnm, fnp, & zx, zy, rdzw, & @@ -2176,6 +2392,7 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & CALL horizontal_diffusion_w_2( rw_tendf, mu, config_flags, & defor13, defor23, div, & + nba_mij, n_nba_mij, & !JDM tke(ims,kms,jms), & msftx, msfty, xkmh, rdx, rdy, fnm, fnp, & zx, zy, rdz, & @@ -2245,6 +2462,26 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & ENDDO chem_loop ENDIF + + IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN + + tracer_loop: do ic = PARAM_FIRST_SCALAR, n_tracer + + CALL horizontal_diffusion_s( tracer_tendf(ims,kms,jms,ic), & + mu, config_flags, & + tracer(ims,kms,jms,ic), & + msftx, msfty, msfux, msfuy, & + msfvx, msfvy, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + ENDDO tracer_loop + + ENDIF IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN scalar_loop: do is = PARAM_FIRST_SCALAR, n_scalar @@ -2271,7 +2508,9 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & !======================================================================= SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & - defor11, defor12, div, tke, & + defor11, defor12, div, & + nba_mij, n_nba_mij, & !JDM + tke, & msfux, msfuy, & xkmh, rdx, rdy, fnm, fnp, & zx, zy, rdzw, & @@ -2310,6 +2549,11 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & zx, & zy + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , INTENT(IN ) :: rdx, & rdy ! Local data @@ -2380,6 +2624,7 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & je_ext=0 CALL cal_titau_11_22_33( config_flags, titau1, & mu, tke, xkmh, defor11, & + nba_mij(ims,kms,jms,P_m11), & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2392,6 +2637,7 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & je_ext=1 CALL cal_titau_12_21( config_flags, titau2, & mu, xkmh, defor12, & + nba_mij(ims,kms,jms,P_m12), & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2451,7 +2697,9 @@ END SUBROUTINE horizontal_diffusion_u_2 !======================================================================= SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & - defor12, defor22, div, tke, & + defor12, defor22, div, & + nba_mij, n_nba_mij, & !JDM + tke, & msfvx, msfvy, & xkmh, rdx, rdy, fnm, fnp, & zx, zy, rdzw, & @@ -2488,6 +2736,11 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & zy, & rdzw + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , INTENT(IN ) :: rdx, & rdy @@ -2558,6 +2811,7 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & je_ext=0 CALL cal_titau_12_21( config_flags, titau1, & mu, xkmh, defor12, & + nba_mij(ims,kms,jms,P_m12), & !JDM is_ext,ie_ext,js_ext,je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2570,6 +2824,7 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & je_ext=0 CALL cal_titau_11_22_33( config_flags, titau2, & mu, tke, xkmh, defor22, & + nba_mij(ims,kms,jms,P_m22), & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2628,7 +2883,9 @@ END SUBROUTINE horizontal_diffusion_v_2 !======================================================================= SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & - defor13, defor23, div, tke, & + defor13, defor23, div, & + nba_mij, n_nba_mij, & !JDM + tke, & msftx, msfty, & xkmh, rdx, rdy, fnm, fnp, & zx, zy, rdz, & @@ -2665,6 +2922,11 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & zy, & rdz + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , INTENT(IN ) :: rdx, & rdy @@ -2733,6 +2995,7 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & js_ext=0 je_ext=0 CALL cal_titau_13_31( config_flags, titau1, defor13, & + nba_mij(ims,kms,jms,P_m13), & !JDM mu, xkmh, fnm, fnp, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & @@ -2745,6 +3008,7 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & js_ext=0 je_ext=1 CALL cal_titau_23_32( config_flags, titau2, defor23, & + nba_mij(ims,kms,jms,P_m23), & !JDM mu, xkmh, fnm, fnp, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & @@ -3119,10 +3383,13 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & tke_tendf, moist_tendf, n_moist, & chem_tendf, n_chem, & scalar_tendf, n_scalar, & + tracer_tendf, n_tracer, & u_2, v_2, & thp,u_base,v_base,t_base,qv_base,mu,tke, & - config_flags,defor13,defor23,defor33,div, & - moist, chem, scalar, xkmv, xkhv,km_opt, & + config_flags,defor13,defor23,defor33, & + nba_mij, n_nba_mij, & !JDM + div, & + moist,chem,scalar,tracer,xkmv,xkhv,km_opt,& fnm, fnp, dn, dnw, rdz, rdzw, & hfx, qfx, ust, rho, & ids, ide, jds, jde, kds, kde, & @@ -3140,7 +3407,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN ) :: n_moist, n_chem, n_scalar, km_opt + INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,km_opt REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp @@ -3167,6 +3434,8 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(INOUT) :: scalar_tendf + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & + INTENT(INOUT) :: tracer_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist @@ -3176,6 +3445,8 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & INTENT(IN ) :: scalar + REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & + INTENT(IN ) :: tracer REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor13, & defor23, & @@ -3189,6 +3460,11 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & v_2, & rdzw + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rho REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: hfx, & qfx @@ -3229,6 +3505,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & CALL vertical_diffusion_u_2( ru_tendf, config_flags, mu, & defor13, xkmv, & + nba_mij, n_nba_mij, & !JDM dnw, rdzw, fnm, fnp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3237,6 +3514,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & CALL vertical_diffusion_v_2( rv_tendf, config_flags, mu, & defor23, xkmv, & + nba_mij, n_nba_mij, & !JDM dnw, rdzw, fnm, fnp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3244,6 +3522,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & CALL vertical_diffusion_w_2( rw_tendf, config_flags, mu, & defor33, tke(ims,kms,jms), & + nba_mij, n_nba_mij, & !JDM div, xkmv, & dn, rdz, & ids, ide, jds, jde, kds, kde, & @@ -3493,6 +3772,22 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & ENDIF + IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN + + tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer + + CALL vertical_diffusion_s( tracer_tendf(ims,kms,jms,im), & + config_flags, tracer(ims,kms,jms,im), & + mu, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO tracer_loop + + ENDIF + IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN @@ -3517,6 +3812,7 @@ END SUBROUTINE vertical_diffusion_2 SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & defor13, xkmv, & + nba_mij, n_nba_mij, & !JDM dnw, rdzw, fnm, fnp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3544,6 +3840,12 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & INTENT(IN ) ::defor13, & xkmv, & rdzw + + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu ! LOCAL VARS @@ -3586,6 +3888,7 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & js_ext=0 je_ext=0 CALL cal_titau_13_31( config_flags, titau3, defor13, & + nba_mij(ims,kms,jms,P_m13), & !JDM mu, xkmv, fnm, fnp, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & @@ -3623,6 +3926,7 @@ END SUBROUTINE vertical_diffusion_u_2 SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & defor23, xkmv, & + nba_mij, n_nba_mij, & !JDM dnw, rdzw, fnm, fnp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3649,6 +3953,11 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & xkmv, & rdzw + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu ! LOCAL VARS @@ -3691,6 +4000,7 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & js_ext=0 je_ext=0 CALL cal_titau_23_32( config_flags, titau3, defor23, & + nba_mij(ims,kms,jms,P_m23), & !JDM mu, xkmv, fnm, fnp, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & @@ -3728,7 +4038,9 @@ END SUBROUTINE vertical_diffusion_v_2 !======================================================================= SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & - defor33, tke, div, xkmv, & + defor33, tke, & + nba_mij, n_nba_mij, & !JDM + div, xkmv, & dn, rdz, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3756,6 +4068,11 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & xkmv, & rdz + INTEGER, INTENT( IN ) :: n_nba_mij !JDM + + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + :: nba_mij + REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: mu ! LOCAL VARS @@ -3795,6 +4112,7 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & je_ext=0 CALL cal_titau_11_22_33( config_flags, titau3, & mu, tke, xkmv, defor33, & + nba_mij(ims,kms,jms,P_m33), & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3950,6 +4268,7 @@ END SUBROUTINE vertical_diffusion_s SUBROUTINE cal_titau_11_22_33( config_flags, titau, & mu, tke, xkx, defor, & + mtau, & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3990,6 +4309,9 @@ END SUBROUTINE vertical_diffusion_s REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor, xkx, tke + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM + :: mtau + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu @@ -4024,23 +4346,48 @@ END SUBROUTINE vertical_diffusion_s j_start = j_start - js_ext j_end = j_end + je_ext - IF ( config_flags%km_opt .EQ. 2) THEN - DO j = j_start,j_end - DO k = kts,ktf - DO i = i_start,i_end - titau(i,k,j) = mu(i,j) * ( - xkx(i,k,j) * ( defor(i,k,j) ) ) - END DO - END DO - END DO - ELSE + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES + DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end - titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j) - END DO + + titau(i,k,j) = mu(i,j) * mtau(i,k,j) + END DO END DO - END IF + END DO + + ELSE !NOT NBA + + IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j) + + END DO + END DO + END DO + + ELSE !NO STRESS OUTPUT + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j) + + END DO + END DO + END DO + + ENDIF + + ENDIF END SUBROUTINE cal_titau_11_22_33 @@ -4049,6 +4396,7 @@ END SUBROUTINE vertical_diffusion_s SUBROUTINE cal_titau_12_21( config_flags, titau, & mu, xkx, defor, & + mtau, & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4089,6 +4437,9 @@ END SUBROUTINE vertical_diffusion_s REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor, xkx + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM + :: mtau + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu @@ -4149,20 +4500,57 @@ END SUBROUTINE vertical_diffusion_s ! titau12 or titau21 - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) - END DO - END DO - END DO + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + titau(i,k,j) = muavg(i,j) * mtau(i,k,j) + + END DO + END DO + END DO + + ELSE ! NOT NBA + + IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + + END DO + END DO + END DO + + ELSE ! NO STRESS OUTPUT + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + + END DO + END DO + END DO + + ENDIF + + ENDIF END SUBROUTINE cal_titau_12_21 !======================================================================= SUBROUTINE cal_titau_13_31( config_flags, titau, & - defor, mu, xkx, fnm, fnp, & + defor, & + mtau, & !JDM + mu, xkx, fnm, fnp, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4206,6 +4594,9 @@ END SUBROUTINE vertical_diffusion_s REAL, DIMENSION( ims:ime, kms:kme, jms:jme), INTENT( IN ) & :: defor, xkx + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM + :: mtau + REAL, DIMENSION( ims:ime, jms:jme), INTENT( IN ) & :: mu @@ -4263,13 +4654,46 @@ END SUBROUTINE vertical_diffusion_s END DO END DO - DO j = j_start, j_end - DO k = kts+1, ktf - DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) - ENDDO - ENDDO - ENDDO + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + titau(i,k,j) = muavg(i,j) * mtau(i,k,j) + ENDDO + ENDDO + ENDDO + + ELSE ! NOT NBA + + IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + + ENDDO + ENDDO + ENDDO + + ELSE ! NO STRESS OUTPUT + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + + ENDDO + ENDDO + ENDDO + + ENDIF + + ENDIF DO j = j_start, j_end DO i = i_start, i_end @@ -4284,6 +4708,7 @@ END SUBROUTINE vertical_diffusion_s !======================================================================= SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & + mtau, & !JDM mu, xkx, fnm, fnp, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & @@ -4328,6 +4753,9 @@ END SUBROUTINE vertical_diffusion_s REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor, xkx + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM + :: mtau + REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu @@ -4385,13 +4813,48 @@ END SUBROUTINE vertical_diffusion_s END DO END DO - DO j = j_start, j_end - DO k = kts+1, ktf - DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) - END DO - END DO - END DO + IF ( config_flags%sfs_opt .EQ. 1 ) THEN ! USE NBA MODEL SFS STRESSES + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + + titau(i,k,j) = muavg(i,j) * mtau(i,k,j) + + END DO + END DO + END DO + + ELSE ! NOT NBA + + IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + + END DO + END DO + END DO + + ELSE ! NO STRESS OUTPUT + + DO j = j_start, j_end + DO k = kts+1, ktf + DO i = i_start, i_end + + titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + + END DO + END DO + END DO + + ENDIF + + ENDIF DO j = j_start, j_end DO i = i_start, i_end diff --git a/wrfv2_fire/dyn_em/module_em.F b/wrfv2_fire/dyn_em/module_em.F index 04223f69..f4785fe8 100644 --- a/wrfv2_fire/dyn_em/module_em.F +++ b/wrfv2_fire/dyn_em/module_em.F @@ -903,7 +903,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & scalar_old(ims,kms,jms,im), & advect_tend(ims,kms,jms), & ru, rv, ww, mut, mub, mu_old, & - config_flags, & + time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & rdx, rdy, rdnw,dt, & @@ -1316,6 +1316,7 @@ END SUBROUTINE rk_update_scalar_pd SUBROUTINE init_zero_tendency(ru_tendf, rv_tendf, rw_tendf, ph_tendf, & t_tendf, tke_tendf, mu_tendf, & moist_tendf,chem_tendf,scalar_tendf, & + tracer_tendf,n_tracer, & n_moist,n_chem,n_scalar,rk_step, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1328,7 +1329,7 @@ SUBROUTINE init_zero_tendency(ru_tendf, rv_tendf, rw_tendf, ph_tendf, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,rk_step + INTEGER , INTENT(IN ) :: n_moist,n_chem,n_scalar,n_tracer,rk_step REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: & ru_tendf, & @@ -1345,6 +1346,8 @@ SUBROUTINE init_zero_tendency(ru_tendf, rv_tendf, rw_tendf, ph_tendf, & REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_chem ),INTENT(INOUT)::& chem_tendf + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_tracer ),INTENT(INOUT)::& + tracer_tendf REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar ),INTENT(INOUT)::& scalar_tendf @@ -1412,6 +1415,14 @@ SUBROUTINE init_zero_tendency(ru_tendf, rv_tendf, rw_tendf, ph_tendf, & its, ite, jts, jte, kts, kte ) ENDDO +! DO ic=PARAM_FIRST_SCALAR,n_tracer + DO ic=1,n_tracer ! make sure first one is zero too + CALL zero_tend ( tracer_tendf(ims,kms,jms,ic), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDDO + ! DO ic=PARAM_FIRST_SCALAR,n_scalar DO ic=1,n_scalar ! make sure first one is zero too CALL zero_tend ( scalar_tendf(ims,kms,jms,ic), & diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F index 3e209521..7971ca8b 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F @@ -10,6 +10,7 @@ CONTAINS SUBROUTINE first_rk_step_part1 ( grid , config_flags & , moist , moist_tend & , chem , chem_tend & + , tracer, tracer_tend & , scalar , scalar_tend & , fdda3d, fdda2d & , ru_tendf, rv_tendf & @@ -21,7 +22,6 @@ CONTAINS , cu_act_flag , hol , th_phy & , pi_phy , p_phy , t_phy , u_phy , v_phy & , dz8w , p8w , t8w , rho_phy , rho & - , mu_3d & , ids, ide, jds, jde, kds, kde & , ims, ime, jms, jme, kms, kme & , ips, ipe, jps, jpe, kps, kpe & @@ -30,6 +30,7 @@ CONTAINS , imsy,imey,jmsy,jmey,kmsy,kmey & , ipsy,ipey,jpsy,jpey,kpsy,kpey & , k_start , k_end & + , f_flux & ) USE module_state_description USE module_model_constants @@ -46,10 +47,8 @@ CONTAINS USE module_big_step_utilities_em, ONLY : phy_prep #ifdef DM_PARALLEL USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval -#else - USE module_dm + USE module_comm_dm, ONLY : halo_em_phys_a_sub,halo_em_fdda_sfc_sub #endif - USE module_comm_dm USE module_utility ! jm debug USE module_fr_sfire_util @@ -75,6 +74,8 @@ CONTAINS REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT) :: moist_tend REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT) :: chem REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT) :: chem_tend + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer_tend REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar_tend REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_fdda3d),INTENT(INOUT) :: fdda3d @@ -99,7 +100,6 @@ CONTAINS REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: mu_3d REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf @@ -110,17 +110,18 @@ CONTAINS REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: mu_tendf - INTEGER , INTENT(IN) :: k_start, k_end + INTEGER, INTENT(IN) :: k_start, k_end + LOGICAL, INTENT(IN), OPTIONAL :: f_flux ! Local REAL, DIMENSION( ims:ime, jms:jme ) :: ht_loc, mixht - INTEGER, DIMENSION( ims:ime, jms:jme ) :: shadowmask INTEGER :: ij INTEGER num_roof_layers INTEGER num_wall_layers INTEGER num_road_layers INTEGER iswater + LOGICAL :: l_flux INTEGER :: isurban INTEGER rk_step INTEGER :: yr, month, day, hr, minute, sec, rc @@ -132,6 +133,10 @@ CONTAINS CHARACTER (LEN=256) :: mminlu +#if ( WRF_DFI_RADAR == 1 ) + INTEGER do_capsupress ! =1 do CAP supress, other = don't +#endif + CALL get_ijk_from_subgrid ( grid , & sids, side, sjds, sjde, skds, skde, & sims, sime, sjms, sjme, skms, skme, & @@ -140,6 +145,9 @@ CONTAINS ! initialize all tendencies to zero in order to update physics ! tendencies first (separate from dry dynamics). + l_flux=.FALSE. + if (present(f_flux)) l_flux=f_flux + rk_step = 1 BENCH_START(init_zero_tend_tim) @@ -153,7 +161,8 @@ BENCH_START(init_zero_tend_tim) ph_tendf, t_tendf, tke_tend, & mu_tendf, & moist_tend,chem_tend,scalar_tend, & - num_moist,num_chem,num_scalar, & + tracer_tend,num_tracer, & + num_moist,num_chem,num_scalar, & rk_step, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -178,11 +187,11 @@ BENCH_END(init_zero_tend_tim) grid%mut, grid%muu, grid%muv, grid%u_2, & grid%v_2, grid%p, grid%pb, grid%alt, & grid%ph_2, grid%phb, grid%t_2, grid%tsk, moist, num_moist, & - mu_3d, rho, & - th_phy, p_phy, pi_phy, u_phy, v_phy, & - p8w, t_phy, t8w, grid%z, grid%z_at_w, & - dz8w, grid%fnm, grid%fnp, & - grid%rthraten, & + rho,th_phy, p_phy, pi_phy, u_phy, v_phy, & + p8w, t_phy, t8w, grid%z, grid%z_at_w, dz8w, & + grid%p_hyd, grid%p_hyd_w, & + grid%fnm, grid%fnp, grid%znw, grid%p_top, & + grid%rthraten, & grid%rthblten, grid%rublten, grid%rvblten, & grid%rqvblten, grid%rqcblten, grid%rqiblten, & grid%rthcuten, grid%rqvcuten, grid%rqccuten, & @@ -215,7 +224,7 @@ BENCH_END(phy_prep_tim) & ,julian=grid%julian, xtime=grid%xtime, RADT=grid%radt & & ,STEPRA=grid%stepra & & ,ht=grid%ht,dx=grid%dx,dy=grid%dy,sina=grid%sina,cosa=grid%cosa & - & ,shadowmask=shadowmask,slope_rad=config_flags%slope_rad & + & ,shadowmask=grid%shadowmask,slope_rad=config_flags%slope_rad & & ,topo_shading=config_flags%topo_shading & & ,shadlen=config_flags%shadlen,ht_shad=grid%ht_shad,ht_loc=ht_loc & & ,ht_shad_bxs=grid%ht_shad_bxs, ht_shad_bxe=grid%ht_shad_bxe & @@ -245,7 +254,7 @@ BENCH_START(rad_driver_tim) & ,ITIMESTEP=grid%itimestep,JULDAY=grid%julday , JULIAN=grid%julian & & ,JULYR=grid%julyr ,LW_PHYSICS=config_flags%ra_lw_physics & & ,NCFRCV=grid%ncfrcv ,NCFRST=grid%ncfrst ,NPHS=1 & - & ,P8W=p8w ,P=p_phy ,PI=pi_phy & + & ,P8W=grid%p_hyd_w ,P=grid%p_hyd ,PI=pi_phy & & ,RADT=grid%radt ,RA_CALL_OFFSET=grid%ra_call_offset & & ,RHO=rho ,RLWTOA=grid%rlwtoa & & ,RSWTOA=grid%rswtoa ,RTHRATEN=grid%rthraten & @@ -256,9 +265,8 @@ BENCH_START(rad_driver_tim) & ,TAUCLDI=grid%taucldi ,TSK=grid%tsk ,VEGFRA=grid%vegfra & & ,WARM_RAIN=grid%warm_rain ,XICE=grid%xice ,XLAND=grid%xland & & ,XLAT=grid%xlat ,XLONG=grid%xlong ,YR=yr & -!Optional urban - & ,DECLIN_URB=grid%declin_urb ,COSZ_URB2D=grid%cosz_urb2d & - & ,OMG_URB2D=grid%omg_urb2d & +!Optional solar variables + & ,DECLINX=grid%declin ,SOLCONX=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang & ! & ,Z=grid%z & & ,LEVSIZ=grid%levsiz, N_OZMIXM=num_ozmixm & @@ -321,7 +329,7 @@ BENCH_START(rad_driver_tim) & ,WAER300=grid%waer1, WAER400=grid%waer2, WAER600=grid%waer3, WAER999=grid%waer4 & ! jcb #endif & ,slope_rad=config_flags%slope_rad,topo_shading=config_flags%topo_shading & - & ,shadowmask=shadowmask,ht=grid%ht,dx=grid%dx,dy=grid%dy,sina=grid%sina,cosa=grid%cosa ) + & ,shadowmask=grid%shadowmask,ht=grid%ht,dx=grid%dx,dy=grid%dy ) BENCH_END(rad_driver_tim) @@ -357,10 +365,10 @@ BENCH_START(surf_driver_tim) & ,ISLTYP=grid%isltyp ,ITIMESTEP=grid%itimestep, JULIAN_IN=grid%julian & & ,IVGTYP=grid%ivgtyp ,LH=grid%lh ,LOWLYR=grid%lowlyr & & ,MAVAIL=grid%mavail ,NUM_SOIL_LAYERS=config_flags%num_soil_layers & - & ,P8W=p8w ,PBLH=grid%pblh ,PI_PHY=pi_phy & + & ,P8W=grid%p_hyd_w ,PBLH=grid%pblh ,PI_PHY=pi_phy & & ,PSFC=grid%psfc ,PSHLTR=grid%pshltr ,PSIH=psih & & ,BLDT=grid%bldt ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & - & ,PSIM=psim ,P_PHY=p_phy ,Q10=grid%q10 & + & ,PSIM=psim ,P_PHY=grid%p_hyd ,Q10=grid%q10 & & ,Q2=grid%q2 ,QFX=grid%qfx ,QSFC=grid%qsfc & & ,QSHLTR=grid%qshltr ,QZ0=grid%qz0 ,RAINCV=grid%raincv & & ,RA_LW_PHYSICS=config_flags%ra_lw_physics ,RHO=rho & @@ -390,12 +398,15 @@ BENCH_START(surf_driver_tim) & ,ZS=grid%zs ,XICEM=grid%xicem ,ISICE=grid%landuse_isice& & ,USTM=grid%ustm ,CK=grid%ck ,CKA=grid%cka & & ,CD=grid%cd ,CDA=grid%cda & - & ,ISFTCFLX=config_flags%isftcflx & + & ,ISFTCFLX=config_flags%isftcflx, IZ0TLND=config_flags%iz0tlnd & & ,OMLCALL=config_flags%omlcall ,OML_HML0=config_flags%oml_hml0 ,OML_GAMMA=config_flags%oml_gamma & & ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml, HUML=grid%huml, HVML=grid%hvml, F=grid%f & & ,ISWATER=iswater & - & ,DECLIN_URB=grid%declin_urb ,COSZ_URB2D=grid%cosz_urb2d & !I urban - & ,OMG_URB2D=grid%omg_urb2d ,xlat_urb2d=grid%XLAT & !I urban + & ,SLOPE_RAD=config_flags%slope_rad,TOPO_SHADING=config_flags%topo_shading & ! solar + & ,SHADOWMASK=grid%shadowmask & ! solar + & ,SLOPE=grid%slope, SLP_AZI=grid%slp_azi, SWNORM=grid%swnorm & ! solar + & ,DECLIN=grid%declin ,SOLCON=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang & + & ,xlat_urb2d=grid%XLAT & !I urban & ,NUM_ROOF_LAYERS=num_roof_layers & !I urban & ,NUM_WALL_LAYERS=num_wall_layers & !I urban & ,NUM_ROAD_LAYERS=num_road_layers & @@ -418,8 +429,21 @@ BENCH_START(surf_driver_tim) ! Optional urban for BEP scheme & ,SF_URBAN_PHYSICS=config_flags%sf_urban_physics & & ,NUM_URBAN_LAYERS=config_flags%num_urban_layers & !multi-layer urban - & ,TRB_URB4D=grid%trb_urb4d,TW1_URB4D=grid%tw1_urb4d & !multi-layer urban - & ,TW2_URB4D=grid%tw2_urb4d,TGB_URB4D=grid%tgb_urb4d & !multi-layer urban + & ,TRB_URB4D=grid%trb_urb4d,TW1_URB4D=grid%tw1_urb4d & !multi-layer urban + & ,TW2_URB4D=grid%tw2_urb4d,TGB_URB4D=grid%tgb_urb4d & !multi-layer urban + & ,TLEV_URB3D=grid%tlev_urb3d & !multi-layer urban + & ,QLEV_URB3D=grid%qlev_urb3d & !multi-layer urban + & ,TW1LEV_URB3D=grid%tw1lev_urb3d & !multi-layer urban + & ,TW2LEV_URB3D=grid%tw2lev_urb3d & !multi-layer urban + & ,TGLEV_URB3D=grid%tglev_urb3d & !multi-layer urban + & ,TFLEV_URB3D=grid%tflev_urb3d & !multi-layer urban + & ,SF_AC_URB3D=grid%sf_ac_urb3d & !multi-layer urban + & ,LF_AC_URB3D=grid%lf_ac_urb3d & !multi-layer urban + & ,CM_AC_URB3D=grid%cm_ac_urb3d & !multi-layer urban + & ,SFVENT_URB3D=grid%sfvent_urb3d & !multi-layer urban + & ,LFVENT_URB3D=grid%lfvent_urb3d & !multi-layer urban + & ,SFWIN1_URB3D=grid%sfwin1_urb3d & !multi-layer urban + & ,SFWIN2_URB3D=grid%sfwin2_urb3d & !multi-layer urban & ,SFW1_URB3D=grid%sfw1_urb3d,SFW2_URB3D=grid%sfw2_urb3d & !multi-layer urban & ,SFR_URB3D=grid%sfr_urb3d,SFG_URB3D=grid%sfg_urb3d & !multi-layer urban & ,GMT=grid%gmt,XLAT=grid%xlat,XLONG=grid%xlong,JULDAY=grid%julday & @@ -430,13 +454,15 @@ BENCH_START(surf_driver_tim) & ,SF_BEP=grid%sf_bep,VL_BEP=grid%vl_bep & & ,A_E_BEP=grid%a_e_bep,B_E_BEP=grid%b_e_bep,DLG_BEP=grid%dlg_bep & & ,DL_U_BEP=grid%dl_u_bep & + & ,CMR_SFCDIF=grid%cmr_sfcdif, CHR_SFCDIF=grid%chr_sfcdif & !I/O urban + & ,CMC_SFCDIF=grid%cmc_sfcdif, CHC_SFCDIF=grid%chc_sfcdif & !I/O urban ! P-X LSM Variables & ,LANDUSEF=grid%landusef, SOILCTOP=grid%soilctop & ! P-X LSM & ,SOILCBOT=grid%soilcbot & ! P-X LSM & ,RA=grid%ra, RS=grid%rs, LAI=grid%lai & ! P-X LSM & ,NLCAT=grid%num_land_cat, NSCAT=grid%num_soil_cat & ! P-X LSM & ,VEGF_PX=grid%vegf_px, SNOWNCV=grid%snowncv & ! P-X LSM - & ,ANAL_INTERVAL=config_flags%sgfdda_interval_s & ! P-X LSM + & ,ANAL_INTERVAL=config_flags%auxinput9_interval_s & ! P-X LSM & ,PXLSM_SMOIS_INIT=config_flags%pxlsm_smois_init & ! P-X LSM & ,PXLSM_SOIL_NUDGE=config_flags%grid_sfdda & ! P-X LSM ! Optional PX LSM nudging @@ -460,16 +486,16 @@ BENCH_START(surf_driver_tim) & ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI & & ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS & & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG & - & ,CAPG=grid%capg, EMISS=grid%emiss, HOL=hol,MOL=grid%mol & + & ,CAPG=grid%capg, EMISS=grid%emiss, HOL=hol,MOL=grid%mol & & ,T2OBS=grid%t2obs, Q2OBS=grid%q2obs & & ,RAINBL=grid%rainbl,SR=grid%sr & - & ,RAINNCV=grid%rainncv,REGIME=grid%regime,T2=grid%t2,THC=grid%thc & - & ,QSG=grid%qsg,QVG=grid%qvg,QCG=grid%qcg,SOILT1=grid%soilt1,TSNAV=grid%tsnav & ! ruc lsm - & ,SMFR3D=grid%smfr3d,KEEPFR3DFLAG=grid%keepfr3dflag & ! ruc lsm - & ,POTEVP=grid%POTEVP, SNOPCX=grid%SNOPCX, SOILTB=grid%SOILTB & ! ruc lsm + & ,RAINNCV=grid%rainncv,REGIME=grid%regime,T2=grid%t2,THC=grid%thc & + & ,QSG=grid%qsg,QVG=grid%qvg,QCG=grid%qcg,SOILT1=grid%soilt1,TSNAV=grid%tsnav & ! ruc lsm + & ,SMFR3D=grid%smfr3d,KEEPFR3DFLAG=grid%keepfr3dflag,DEW=grid%dew & ! ruc lsm + & ,POTEVP=grid%POTEVP, SNOPCX=grid%SNOPCX, SOILTB=grid%SOILTB & ! ruc lsm & ,ISURBAN=isurban, MMINLU=TRIM(mminlu) & - & ,SNOTIME = grid%SNOTIME & - & ,RDLAI2D=config_flags%rdlai2d & + & ,SNOTIME = grid%SNOTIME & + & ,RDLAI2D=config_flags%rdlai2d & & ,usemonalb=config_flags%usemonalb & & ,NOAHRES=grid%noahres & !mynn mp@ @@ -492,9 +518,9 @@ BENCH_START(pbl_driver_tim) & ,F=grid%f ,GRDFLX=grid%grdflx & & ,GZ1OZ0=gz1oz0 ,HFX=grid%hfx ,HT=grid%ht & & ,ITIMESTEP=grid%itimestep ,KPBL=grid%kpbl & - & ,LH=grid%lh ,LOWLYR=grid%lowlyr ,P8W=p8w & + & ,LH=grid%lh ,LOWLYR=grid%lowlyr ,P8W=grid%p_hyd_w & & ,PBLH=grid%pblh ,PI_PHY=pi_phy ,PSIH=psih & - & ,PSIM=psim ,P_PHY=p_phy ,QFX=grid%qfx & + & ,PSIM=psim ,P_PHY=grid%p_hyd ,QFX=grid%qfx & & ,QSFC=grid%qsfc ,QZ0=grid%qz0 ,MIXHT=mixht & & ,RA_LW_PHYSICS=config_flags%ra_lw_physics & & ,RHO=rho ,RQCBLTEN=grid%rqcblten ,RQIBLTEN=grid%rqiblten & @@ -580,19 +606,26 @@ BENCH_END(fire_driver_tim) CALL wrf_debug ( 200 , ' call cumulus_driver' ) +#if ( WRF_DFI_RADAR == 1 ) + do_capsupress=0 + if (config_flags%dfi_radar == 1) then + if(grid%dfi_stage == DFI_FWD ) do_capsupress=1 + if(grid%itimestep <= 31 .and. grid%dfi_stage == DFI_FST ) do_capsupress=1 + endif +#endif BENCH_START(cu_driver_tim) CALL cumulus_driver(grid & ! Prognostic variables & ,U=u_phy ,V=v_phy ,TH=th_phy ,T=t_phy & - & ,W=grid%w_2 ,P=p_phy ,PI=pi_phy ,RHO=rho & + & ,W=grid%w_2 ,P=grid%p_hyd ,PI=pi_phy ,RHO=rho & ! Other arguments & ,ITIMESTEP=grid%itimestep ,DT=grid%dt ,DX=grid%dx & & ,CUDT=grid%cudt,CURR_SECS=curr_secs,ADAPT_STEP_FLAG=adapt_step_flag & & ,RAINC=grid%rainc ,RAINCV=grid%raincv ,PRATEC=grid%pratec & & , NCA=grid%nca & & ,HTOP=grid%cutop ,HBOT=grid%cubot ,KPBL=grid%kpbl & - & ,DZ8W=dz8w ,P8W=p8w & + & ,DZ8W=dz8w ,P8W=grid%p_hyd_w & & ,W0AVG=grid%w0avg ,STEPCU=grid%stepcu & & ,CLDEFI=grid%cldefi ,LOWLYR=grid%lowlyr ,XLAND=grid%xland & & ,APR_GR=grid%apr_gr ,APR_W=grid%apr_w ,APR_MC=grid%apr_mc & @@ -601,12 +634,15 @@ BENCH_START(cu_driver_tim) & ,MASS_FLUX=grid%mass_flux ,XF_ENS=grid%xf_ens & & ,PR_ENS=grid%pr_ens ,HT=grid%ht,EDT_OUT=grid%edt_out & & ,imomentum=grid%imomentum,clos_choice=grid%clos_choice & + & ,ishallow=config_flags%ishallow & & ,cugd_tten=grid%cugd_tten,cugd_qvten=grid%cugd_qvten,cugd_qcten=grid%cugd_qcten & & ,cugd_ttens=grid%cugd_ttens,cugd_qvtens=grid%cugd_qvtens & & ,ENSDIM=config_flags%ensdim ,MAXIENS=config_flags%maxiens ,MAXENS=config_flags%maxens & & ,MAXENS2=config_flags%maxens2 ,MAXENS3=config_flags%maxens3 & & ,CU_ACT_FLAG=cu_act_flag ,WARM_RAIN=grid%warm_rain & & ,GSW=grid%gsw,cugd_avedx=config_flags%cugd_avedx & + & ,k22_shallow=grid%k22_shallow,kbcon_shallow=grid%kbcon_shallow & + & ,ktop_shallow=grid%ktop_shallow,xmb_shallow=grid%xmb_shallow & & ,PERIODIC_X=(config_flags%polar .OR. config_flags%periodic_x) & & ,PERIODIC_Y=config_flags%periodic_y & ! Selection flag @@ -635,9 +671,12 @@ BENCH_START(cu_driver_tim) & ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS & & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG & #ifdef WRF_CHEM - & ,GD_CLOUD=grid%GD_CLOUD,GD_CLOUD2=grid%GD_CLOUD2 & + & ,GD_CLOUD=grid%GD_CLOUD,GD_CLOUD2=grid%GD_CLOUD2 & #endif - & ) +#if ( WRF_DFI_RADAR == 1 ) + & ,DO_CAPSUPPRESS=do_capsupress & +#endif + & ,cfu1=grid%cfu1,cfd1=grid%cfd1,dfu1=grid%dfu1,efu1=grid%efu1,dfd1=grid%dfd1,efd1=grid%efd1,f_flux=l_flux) BENCH_END(cu_driver_tim) ! JPH call force_scm to update bl tendencies diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F index 0a4c862f..fbe8dbe5 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F @@ -10,6 +10,7 @@ CONTAINS SUBROUTINE first_rk_step_part2 ( grid , config_flags & , moist , moist_tend & , chem , chem_tend & + , tracer, tracer_tend & , scalar , scalar_tend & , fdda3d, fdda2d & , ru_tendf, rv_tendf & @@ -21,7 +22,8 @@ CONTAINS , cu_act_flag , hol , th_phy & , pi_phy , p_phy , t_phy , u_phy , v_phy & , dz8w , p8w , t8w , rho_phy , rho & - , mu_3d & + , nba_mij, n_nba_mij & !JDM + , nba_rij, n_nba_rij & !JDM , ids, ide, jds, jde, kds, kde & , ims, ime, jms, jme, kms, kme & , ips, ipe, jps, jpe, kps, kpe & @@ -33,10 +35,11 @@ CONTAINS USE module_configure, ONLY : grid_config_rec_type, model_config_rec #ifdef DM_PARALLEL USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval, wrf_err_message -#else - USE module_dm + USE module_comm_dm, ONLY : halo_em_tke_c_sub,halo_em_tke_d_sub,halo_em_tke_e_sub & + ,halo_em_phys_pbl_sub,halo_em_fdda_sub,halo_em_phys_diffusion_sub,halo_em_tke_3_sub & + ,halo_em_tke_5_sub,halo_obs_nudge_sub,period_bdy_em_a1_sub,period_bdy_em_phy_bc_sub & + ,period_bdy_em_fdda_bc_sub,period_bdy_em_chem_sub #endif - USE module_comm_dm USE module_diffusion_em, ONLY : phy_bc, cal_deform_and_div, compute_diff_metrics, & vertical_diffusion_2, horizontal_diffusion_2, calculate_km_kh, & tke_rhs @@ -45,6 +48,8 @@ CONTAINS USE module_bc, ONLY : set_physical_bc3d, set_physical_bc2d USE module_physics_addtendc, ONLY : update_phy_ten + USE module_sfs_driver !JDM + IMPLICIT NONE TYPE ( domain ), INTENT(INOUT) :: grid @@ -61,6 +66,8 @@ CONTAINS REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT) :: moist_tend REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT) :: chem REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT) :: chem_tend + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer_tend REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar_tend REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_fdda3d),INTENT(INOUT) :: fdda3d @@ -85,7 +92,6 @@ CONTAINS REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: mu_3d REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf @@ -98,6 +104,15 @@ CONTAINS INTEGER , INTENT(IN) :: k_start, k_end +!JDM + INTEGER, INTENT( IN ) :: n_nba_mij, n_nba_rij + + REAL ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,n_nba_mij) & + :: nba_mij + + REAL ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,n_nba_rij) & + :: nba_rij + ! Local REAL, DIMENSION( ims:ime, jms:jme ) :: ht_loc @@ -108,6 +123,9 @@ CONTAINS INTEGER num_road_layers INTEGER iswater INTEGER rk_step +#if ( WRF_DFI_RADAR == 1 ) + INTEGER i_start,i_end,j_start,j_end,i,j,k +#endif ! initialize all tendencies to zero in order to update physics ! tendencies first (separate from dry dynamics). @@ -230,6 +248,7 @@ BENCH_START(deform_div_tim) CALL cal_deform_and_div ( config_flags,grid%u_2,grid%v_2,grid%w_2,grid%div, & grid%defor11,grid%defor22,grid%defor33, & grid%defor12,grid%defor13,grid%defor23, & + nba_rij, n_nba_rij, & !JDM grid%u_base, grid%v_base,grid%msfux,grid%msfuy, & grid%msfvx,grid%msfvy,grid%msftx,grid%msfty, & grid%rdx, grid%rdy, grid%dn, grid%dnw, grid%rdz, & @@ -314,6 +333,15 @@ BENCH_START(phy_bc_tim) !$OMP END PARALLEL DO BENCH_END(phy_bc_tim) +!JDM +IF ( ( config_flags%sfs_opt .GT. 0 ) .AND. ( config_flags%diff_opt .eq. 2 ) ) THEN + + CALL sfs_driver( grid, config_flags, & + nba_mij, n_nba_mij, & + nba_rij, n_nba_rij ) + +ENDIF + #ifdef DM_PARALLEL !----------------------------------------------------------------------- ! @@ -381,6 +409,28 @@ BENCH_START(update_phy_ten_tim) DO ij = 1 , grid%num_tiles CALL wrf_debug ( 200 , ' call update_phy_ten' ) +#if ( WRF_DFI_RADAR == 1 ) + if (config_flags%cu_physics .gt. 0) then + i_start = grid%i_start(ij) + i_end = min( grid%i_end(ij),ide-1 ) + j_start = grid%j_start(ij) + j_end = min( grid%j_end(ij),jde-1 ) + if (config_flags%dfi_radar == 1 .and. grid%dfi_stage == DFI_FWD ) & + CALL wrf_debug ( 200 , ' Zero out cu_physics' ) + DO j = j_start, j_end + DO k = k_start, min( k_end,kde-1 ) - 1 + DO i = i_start, i_end + if (config_flags%dfi_radar == 1 .and. grid%dfi_stage ==DFI_FWD & + .and. grid%dfi_tten_rad(i,k,j) >= 1.0e-7 .and. & + grid%dfi_tten_rad(i,k,j) <= 10.) then +! zero out cu-param temp tendency + grid%rthcuten(i,k,j) = 0.0 + endif + ENDDO + ENDDO + ENDDO + ENDIF +#endif CALL update_phy_ten(ph_tendf,t_tendf, ru_tendf, rv_tendf,moist_tend ,& scalar_tend, mu_tendf, & grid%rthraten,grid%rthblten,grid%rthcuten, & @@ -478,11 +528,13 @@ BENCH_START(vert_diff_tim) moist_tend, num_moist, & chem_tend, num_chem, & scalar_tend, num_scalar, & + tracer_tend, num_tracer, & grid%u_2, grid%v_2, & grid%t_2,grid%u_base,grid%v_base,grid%t_base,grid%qv_base, & grid%mut,grid%tke_2,config_flags, & grid%defor13,grid%defor23,grid%defor33, & - grid%div, moist, chem, scalar, & + nba_mij, num_nba_mij, & !JDM + grid%div, moist, chem, scalar,tracer, & grid%xkmv, grid%xkhv, config_flags%km_opt, & grid%fnm, grid%fnp, grid%dn, grid%dnw, grid%rdz, grid%rdzw, & grid%hfx, grid%qfx, grid%ustm, rho, & @@ -509,11 +561,14 @@ BENCH_START(hor_diff_tim) moist_tend, num_moist, & chem_tend, num_chem, & scalar_tend, num_scalar, & + tracer_tend, num_tracer, & grid%t_2, th_phy, & grid%mut, grid%tke_2, config_flags, & grid%defor11, grid%defor22, grid%defor12, & - grid%defor13, grid%defor23, grid%div, & - moist, chem, scalar, & + grid%defor13, grid%defor23, & + nba_mij, num_nba_mij, & !JDM + grid%div, & + moist, chem, scalar,tracer, & grid%msfux,grid%msfuy, grid%msfvx,grid%msfvy, grid%msftx, & grid%msfty, grid%xkmh, grid%xkhh, config_flags%km_opt, & grid%rdx, grid%rdy, grid%rdz, grid%rdzw, & @@ -542,6 +597,7 @@ BENCH_END(hor_diff_tim) CALL fddaobs_driver (grid%grid_id, model_config_rec%grid_id, & model_config_rec%parent_id, config_flags%restart, & + config_flags, & grid%obs_nudge_opt, & grid%obs_ipf_errob, & grid%obs_ipf_nudob, & @@ -565,21 +621,23 @@ BENCH_END(hor_diff_tim) grid%obs_dtramp, & grid%parent_grid_ratio, & grid%max_dom, grid%itimestep, & + grid%xtime, & grid%dt, grid%gmt, grid%julday, grid%fdob, & grid%max_obs, & model_config_rec%nobs_ndg_vars, & model_config_rec%nobs_err_flds, & grid%fdob%nstat, grid%fdob%varobs, grid%fdob%errf, & grid%dx, grid%KPBL,grid%HT, & - grid%mut, grid%muu, grid%muv, & + grid%mut, grid%muu, grid%muv, & grid%msftx, grid%msfty, grid%msfux, grid%msfuy, grid%msfvx, grid%msfvy, & p_phy, t_tendf, t0, & - grid%u_2, grid%v_2, grid%t_2, & - moist(ims,kms,jms,P_QV), & + grid%u_2, grid%v_2, grid%t_2, & + moist(ims,kms,jms,P_QV), & grid%pb, grid%p_top, grid%p, grid%phb, grid%ph_2, & grid%uratx, grid%vratx, grid%tratx, & ru_tendf, rv_tendf, & - moist_tend(ims,kms,jms,P_QV), grid%obs_savwt, & + moist_tend(ims,kms,jms,P_QV), grid%obs_savwt, & + grid%regime, grid%pblh, grid%z_at_w, grid%z, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & grid%i_start(ij), min(grid%i_end(ij),ide-1), & diff --git a/wrfv2_fire/dyn_em/module_initialize_real.F b/wrfv2_fire/dyn_em/module_initialize_real.F index ef410cf4..64c27956 100644 --- a/wrfv2_fire/dyn_em/module_initialize_real.F +++ b/wrfv2_fire/dyn_em/module_initialize_real.F @@ -20,6 +20,13 @@ MODULE module_initialize_real USE module_llxy #ifdef DM_PARALLEL USE module_dm + USE module_comm_dm, ONLY : & + HALO_EM_INIT_1_sub & + ,HALO_EM_INIT_2_sub & + ,HALO_EM_INIT_3_sub & + ,HALO_EM_INIT_4_sub & + ,HALO_EM_INIT_5_sub & + ,HALO_EM_VINTERP_UV_1_sub #endif REAL , SAVE :: p_top_save @@ -1374,6 +1381,7 @@ integer::oops1,oops2 grid%soilcbot , grid%tmn , grid%vegfra , & grid%tslb , grid%smois , grid%sh2o , & grid%seaice_threshold , & + grid%sst,flag_sst, & config_flags%fractional_seaice, & num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & model_config_rec%num_soil_layers , & @@ -1433,6 +1441,14 @@ endif ENDIF END DO END DO +!tgs set snoalb to land value if the water point is covered with ice + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( grid%ivgtyp(i,j) .EQ. config_flags%isice) THEN + grid%snoalb(i,j) = 0.75 + ENDIF + END DO + END DO ! From the full level data, we can get the half levels, reciprocals, and layer ! thicknesses. These are all defined at half level locations, so one less level. diff --git a/wrfv2_fire/dyn_em/module_polarfft.F b/wrfv2_fire/dyn_em/module_polarfft.F index f3385956..28c6dc35 100644 --- a/wrfv2_fire/dyn_em/module_polarfft.F +++ b/wrfv2_fire/dyn_em/module_polarfft.F @@ -61,10 +61,11 @@ SUBROUTINE pxft ( grid & ,flag_mu,flag_mut & ,flag_moist & ,flag_chem & + ,flag_tracer & ,flag_scalar & - ,fft_filter_lat, dclat & + ,fft_filter_lat, dclat & ,positive_definite & - ,moist,chem,scalar & + ,moist,chem,tracer,scalar & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,ips,ipe,jps,jpe,kps,kpe & @@ -72,7 +73,41 @@ SUBROUTINE pxft ( grid & ,ipsx,ipex,jpsx,jpex,kpsx,kpex ) USE module_state_description USE module_domain, ONLY : domain +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y & + , local_communicator_periodic, itrace & + , local_communicator_x + USE module_driver_constants +#if 0 + USE module_comm_dm, ONLY : & + XPOSE_POLAR_FILTER_V_z2x_sub & + ,XPOSE_POLAR_FILTER_V_x2z_sub & + ,XPOSE_POLAR_FILTER_U_z2x_sub & + ,XPOSE_POLAR_FILTER_U_x2z_sub & + ,XPOSE_POLAR_FILTER_T_z2x_sub & + ,XPOSE_POLAR_FILTER_T_x2z_sub & + ,XPOSE_POLAR_FILTER_W_z2x_sub & + ,XPOSE_POLAR_FILTER_W_x2z_sub & + ,XPOSE_POLAR_FILTER_PH_z2x_sub & + ,XPOSE_POLAR_FILTER_PH_x2z_sub & + ,XPOSE_POLAR_FILTER_WW_z2x_sub & + ,XPOSE_POLAR_FILTER_WW_x2z_sub & + ,XPOSE_POLAR_FILTER_RV_z2x_sub & + ,XPOSE_POLAR_FILTER_RV_x2z_sub & + ,XPOSE_POLAR_FILTER_RU_z2x_sub & + ,XPOSE_POLAR_FILTER_RU_x2z_sub & + ,XPOSE_POLAR_FILTER_MOIST_z2x_sub & + ,XPOSE_POLAR_FILTER_MOIST_x2z_sub & + ,XPOSE_POLAR_FILTER_CHEM_z2x_sub & + ,XPOSE_POLAR_FILTER_MOIST_x2z_sub & + ,XPOSE_POLAR_FILTER_TRACER_z2x_sub & + ,XPOSE_POLAR_FILTER_TRACER_x2z_sub & + ,XPOSE_POLAR_FILTER_SCALAR_z2x_sub & + ,XPOSE_POLAR_FILTER_SCALAR_x2z_sub +#endif +#else USE module_dm +#endif IMPLICIT NONE ! Input data. TYPE(domain) , TARGET :: grid @@ -93,8 +128,9 @@ integer myproc, i, j, k ,flag_mu,flag_mut & ,flag_moist & ,flag_chem & + ,flag_tracer & ,flag_scalar - REAL, DIMENSION(ims:ime,kms:kme,jms:jme,*) , INTENT(INOUT) :: moist, chem, scalar + REAL, DIMENSION(ims:ime,kms:kme,jms:jme,*) , INTENT(INOUT) :: moist, chem, scalar,tracer ! Local LOGICAL piggyback_mu, piggyback_mut @@ -364,6 +400,28 @@ call wrf_get_myproc(myproc) #endif ENDIF +! tracer + IF ( flag_tracer .GE. PARAM_FIRST_SCALAR ) THEN + itrace = flag_tracer +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +# include "XPOSE_POLAR_FILTER_TRACER_z2x.inc" + CALL polar_filter_3d( grid%fourd_xxx, grid%clat_xxx, .false. , & + fft_filter_lat, 0., & + ids, ide, jds, jde, kds, kde, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), & + positive_definite = positive_definite ) +# include "XPOSE_POLAR_FILTER_TRACER_x2z.inc" +#else + CALL polar_filter_3d( tracer(ims,kms,jms,itrace), grid%clat, .false. , & + fft_filter_lat, 0., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), & + positive_definite = positive_definite ) +#endif + ENDIF + !!!!!!!!!!!!!!!!!!!!!!! ! SCALAR IF ( flag_scalar .GE. PARAM_FIRST_SCALAR ) THEN diff --git a/wrfv2_fire/dyn_em/nest_init_utils.F b/wrfv2_fire/dyn_em/nest_init_utils.F index 111b3756..dce3fd9d 100644 --- a/wrfv2_fire/dyn_em/nest_init_utils.F +++ b/wrfv2_fire/dyn_em/nest_init_utils.F @@ -351,7 +351,12 @@ SUBROUTINE update_after_feedback_em ( grid & USE module_driver_constants USE module_machine USE module_tiles +#ifdef DM_PARALLEL + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask + USE module_comm_dm, ONLY : HALO_EM_FEEDBACK_sub +#else USE module_dm +#endif USE module_bc ! Mediation layer modules ! Registry generated module diff --git a/wrfv2_fire/dyn_em/shift_domain_em.F b/wrfv2_fire/dyn_em/shift_domain_em.F index 82032767..b8e9a672 100644 --- a/wrfv2_fire/dyn_em/shift_domain_em.F +++ b/wrfv2_fire/dyn_em/shift_domain_em.F @@ -7,7 +7,12 @@ SUBROUTINE shift_domain_em ( grid , disp_x, disp_y & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_timing USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, itrace + USE module_comm_dm, ONLY : SHIFT_HALO_X_HALO_sub +#else USE module_dm +#endif IMPLICIT NONE ! Arguments INTEGER disp_x, disp_y ! number of parent domain points to move @@ -90,7 +95,12 @@ SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_timing USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, itrace + USE module_comm_dm, ONLY : SHIFT_HALO_Y_HALO_sub +#else USE module_dm +#endif IMPLICIT NONE ! Arguments INTEGER disp_x, disp_y ! number of parent domain points to move diff --git a/wrfv2_fire/dyn_em/solve_em.F b/wrfv2_fire/dyn_em/solve_em.F index 4938fc43..a192de1c 100644 --- a/wrfv2_fire/dyn_em/solve_em.F +++ b/wrfv2_fire/dyn_em/solve_em.F @@ -7,17 +7,42 @@ SUBROUTINE solve_em ( grid , config_flags & ) ! Driver layer modules USE module_state_description - USE module_domain, ONLY : domain, get_ijk_from_grid, get_ijk_from_subgrid, domain_get_current_time, domain_get_start_time + USE module_domain, ONLY : & + domain, get_ijk_from_grid, get_ijk_from_subgrid & + ,domain_get_current_time, domain_get_start_time, domain_clock_get + USE module_domain_type, ONLY : history_alarm USE module_configure, ONLY : grid_config_rec_type USE module_driver_constants USE module_machine USE module_tiles, ONLY : set_tiles #ifdef DM_PARALLEL - USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval -#else - USE module_dm + USE module_dm, ONLY : & + local_communicator, mytask, ntasks, ntasks_x, ntasks_y & + ,local_communicator_periodic, wrf_dm_maxval + USE module_comm_dm, ONLY : & + halo_em_a_sub,halo_em_b_sub,halo_em_c2_sub,halo_em_chem_e_3_sub & + ,halo_em_chem_e_5_sub,halo_em_chem_e_7_sub,halo_em_chem_old_e_5_sub & + ,halo_em_chem_old_e_7_sub,halo_em_c_sub,halo_em_d2_3_sub & + ,halo_em_d2_5_sub,halo_em_d3_3_sub,halo_em_d3_5_sub,halo_em_d_sub & + ,halo_em_e_3_sub,halo_em_e_5_sub,halo_em_hydro_uv_sub & + ,halo_em_moist_e_3_sub,halo_em_moist_e_5_sub,halo_em_moist_e_7_sub & + ,halo_em_moist_old_e_5_sub,halo_em_moist_old_e_7_sub & + ,halo_em_scalar_e_3_sub,halo_em_scalar_e_5_sub,halo_em_scalar_e_7_sub & + ,halo_em_scalar_old_e_5_sub,halo_em_scalar_old_e_7_sub,halo_em_tke_3_sub & + ,halo_em_tke_5_sub,halo_em_tke_7_sub,halo_em_tke_advect_3_sub & + ,halo_em_tke_advect_5_sub,halo_em_tke_old_e_5_sub & + ,halo_em_tke_old_e_7_sub,halo_em_tracer_e_3_sub,halo_em_tracer_e_5_sub & + ,halo_em_tracer_e_7_sub,halo_em_tracer_old_e_5_sub & + ,halo_em_tracer_old_e_7_sub,period_bdy_em_a_sub & + ,period_bdy_em_b3_sub,period_bdy_em_b_sub,period_bdy_em_chem2_sub & + ,period_bdy_em_chem_old_sub,period_bdy_em_chem_sub,period_bdy_em_d3_sub & + ,period_bdy_em_d_sub,period_bdy_em_e_sub,period_bdy_em_moist2_sub & + ,period_bdy_em_moist_old_sub,period_bdy_em_moist_sub & + ,period_bdy_em_scalar2_sub,period_bdy_em_scalar_old_sub & + ,period_bdy_em_scalar_sub,period_bdy_em_tke_old_sub & + ,period_bdy_em_tracer2_sub,period_bdy_em_tracer_old_sub & + ,period_bdy_em_tracer_sub,period_em_da_sub,period_em_hydro_uv_sub #endif - USE module_comm_dm USE module_utility ! Mediation layer modules ! Model layer modules @@ -37,11 +62,13 @@ SUBROUTINE solve_em ( grid , config_flags & USE module_diagnostics #ifdef WRF_CHEM USE module_input_chem_data + USE module_input_tracer USE module_chem_utilities #endif USE module_first_rk_step_part1 USE module_first_rk_step_part2 USE module_llxy, ONLY : proj_cassini + USE module_avgflx_em, ONLY : zero_avgflx, upd_avgflx IMPLICIT NONE @@ -101,7 +128,8 @@ SUBROUTINE solve_em ( grid , config_flags & REAL , ALLOCATABLE , DIMENSION(:) :: max_vert_cfl_tmp, max_horiz_cfl_tmp LOGICAL :: leapfrog INTEGER :: l,kte,kk - REAL :: curr_secs + LOGICAL :: f_flux ! flag for computing averaged fluxes in cu_gd + REAL :: curr_secs INTEGER :: num_sound_steps INTEGER :: idex, jdex REAL :: max_msft @@ -117,6 +145,15 @@ SUBROUTINE solve_em ( grid , config_flags & TYPE(WRFU_TimeInterval) :: tmpTimeInterval REAL :: real_time LOGICAL :: adapt_step_flag + LOGICAL :: fill_w_flag + +! variables for flux-averaging code 20091223 + CHARACTER*256 :: message, message2 + REAL :: old_dt + TYPE(WRFU_Time) :: temp_time, CurrTime + INTEGER, PARAMETER :: precision = 100 + INTEGER :: num, den + TYPE(WRFU_TimeInterval) :: dtInterval ! Define benchmarking timers if -DBENCH is compiled #include @@ -185,6 +222,7 @@ SUBROUTINE solve_em ( grid , config_flags & num_3d_c = num_chem num_3d_s = num_scalar + f_flux = config_flags%do_avgflx_cugd .EQ. 1 ! Compute these starting and stopping locations for each tile and number of tiles. ! See: http://www.mmm.ucar.edu/wrf/WG2/topics/settiles @@ -195,6 +233,32 @@ SUBROUTINE solve_em ( grid , config_flags & ALLOCATE (max_vert_cfl_tmp(grid%num_tiles)) ALLOCATE (max_horiz_cfl_tmp(grid%num_tiles)) + ! + ! Calculate current time in seconds since beginning of model run. + ! Unfortunately, ESMF does not seem to have a way to return + ! floating point seconds based on a TimeInterval. So, we will + ! calculate it here--but, this is not clean!! + ! + tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_start_time ( grid ) + curr_secs = real_time(tmpTimeInterval) + + old_dt = grid%dt ! store old time step for flux averaging code at end of RK loop +!----------------------------------------------------------------------------- +! Adaptive time step: Added by T. Hutchinson, WSI 3/5/07 +! In this call, we do the time-step adaptation and set time-dependent lateral +! boundary condition nudging weights. +! + IF ( (config_flags%use_adaptive_time_step) .and. & + ( (.not. grid%nested) .or. & + ( (grid%nested) .and. (abs(grid%dtbc) < 0.0001) ) ) )THEN + CALL adapt_timestep(grid, config_flags) + adapt_step_flag = .TRUE. + ELSE + adapt_step_flag = .FALSE. + ENDIF +! End of adaptive time step modifications +!----------------------------------------------------------------------------- + grid%itimestep = grid%itimestep + 1 IF (config_flags%polar) dclat = 90./REAL(jde-jds) !(0.5 * 180/ny) @@ -227,8 +291,6 @@ SUBROUTINE solve_em ( grid , config_flags & #ifdef WRF_CHEM ! -! prepare chem aerosols for advection before communication -! kte=min(k_end,kde-1) # ifdef DM_PARALLEL @@ -252,6 +314,20 @@ SUBROUTINE solve_em ( grid , config_flags & CALL wrf_error_fatal(TRIM(wrf_err_message)) ENDIF ENDIF + if ( num_tracer >= PARAM_FIRST_SCALAR ) then +!----------------------------------------------------------------------- +! see matching halo calls below for stencils +!-------------------------------------------------------------- + CALL wrf_debug ( 200 , ' call HALO_RK_tracer' ) + IF ( config_flags%h_mom_adv_order <= 4 ) THEN +# include "HALO_EM_TRACER_E_3.inc" + ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN +# include "HALO_EM_TRACER_E_5.inc" + ELSE + WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ENDIF + ENDIF # endif !-------------------------------------------------------------- #endif @@ -259,29 +335,6 @@ SUBROUTINE solve_em ( grid , config_flags & rk_order = config_flags%rk_ord - ! - ! Calculate current time in seconds since beginning of model run. - ! Unfortunately, ESMF does not seem to have a way to return - ! floating point seconds based on a TimeInterval. So, we will - ! calculate it here--but, this is not clean!! - ! - tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_start_time ( grid ) - curr_secs = real_time(tmpTimeInterval) - -!----------------------------------------------------------------------------- -! Adaptive time step: Added by T. Hutchinson, WSI 3/5/07 -! In this call, we do the time-step adaptation and set time-dependent lateral -! boundary condition nudging weights. -! - IF (config_flags%use_adaptive_time_step) THEN - CALL adapt_timestep(grid, config_flags) - adapt_step_flag = .TRUE. - ELSE - adapt_step_flag = .FALSE. - ENDIF -! End of adaptive time step modifications -!----------------------------------------------------------------------------- - IF ( grid%time_step_sound == 0 ) THEN ! This function will give 4 for 6*dx and 6 for 10*dx and returns even numbers only spacing = min(grid%dx, grid%dy) @@ -541,6 +594,7 @@ BENCH_END(set_phys_bc_tim) CALL first_rk_step_part1 ( grid, config_flags & , moist , moist_tend & , chem , chem_tend & + , tracer, tracer_tend & , scalar , scalar_tend & , fdda3d, fdda2d & , ru_tendf, rv_tendf & @@ -554,7 +608,6 @@ BENCH_END(set_phys_bc_tim) , pi_phy , p_phy , t_phy & , u_phy , v_phy & , dz8w , p8w , t8w , rho_phy , rho & - , mu_3d & , ids, ide, jds, jde, kds, kde & , ims, ime, jms, jme, kms, kme & , ips, ipe, jps, jpe, kps, kpe & @@ -563,11 +616,13 @@ BENCH_END(set_phys_bc_tim) , imsy, imey, jmsy, jmey, kmsy, kmey & , ipsy, ipey, jpsy, jpey, kpsy, kpey & , k_start , k_end & + , f_flux & ) CALL first_rk_step_part2 ( grid, config_flags & , moist , moist_tend & , chem , chem_tend & + , tracer, tracer_tend & , scalar , scalar_tend & , fdda3d, fdda2d & , ru_tendf, rv_tendf & @@ -581,7 +636,8 @@ BENCH_END(set_phys_bc_tim) , pi_phy , p_phy , t_phy & , u_phy , v_phy & , dz8w , p8w , t8w , rho_phy , rho & - , mu_3d & + , nba_mij, num_nba_mij & !JDM + , nba_rij, num_nba_rij & !JDM , ids, ide, jds, jde, kds, kde & , ims, ime, jms, jme, kms, kme & , ips, ipe, jps, jpe, kps, kpe & @@ -983,9 +1039,10 @@ BENCH_END(advance_uv_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite = .FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -1089,9 +1146,10 @@ BENCH_END(advance_mu_t_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite = .FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -1194,9 +1252,10 @@ BENCH_END(advance_w_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite = .FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -1466,9 +1525,10 @@ BENCH_END(small_step_finish_tim) ,flag_mut = 1 & ,flag_moist = 0 & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite = .FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -1675,6 +1735,67 @@ BENCH_END(small_step_finish_tim) ENDIF ! end if for chem_adv_opt +! tracer + + IF ((config_flags%tracer_adv_opt /= ORIGINAL) .and. (rk_step == rk_order)) THEN + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + CALL wrf_debug ( 200 , ' call rk_update_scalar_pd' ) + DO im = PARAM_FIRST_SCALAR, num_tracer + CALL rk_update_scalar_pd( im, im, & + tracer_old(ims,kms,jms,im), & + tracer_tend(ims,kms,jms,im), & + grid%mu_1, grid%mu_1, grid%mub, & + rk_step, dt_rk, grid%spec_zone, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDDO + END DO + !$OMP END PARALLEL DO + +!---------------------- positive definite bc call +#ifdef DM_PARALLEL + IF (config_flags%tracer_adv_opt /= ORIGINAL) THEN + IF ( config_flags%h_sca_adv_order <= 4 ) THEN +# include "HALO_EM_TRACER_OLD_E_5.inc" + ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN +# include "HALO_EM_TRACER_OLD_E_7.inc" + ELSE + WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ENDIF + ENDIF +#endif + +#ifdef DM_PARALLEL +# include "PERIOD_BDY_EM_TRACER_OLD.inc" +#endif + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + IF (num_tracer >= PARAM_FIRST_SCALAR) THEN + DO im = PARAM_FIRST_SCALAR , num_tracer + CALL set_physical_bc3d( tracer_old(ims,kms,jms,im), 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + END DO + ENDIF + END DO + !$OMP END PARALLEL DO + + ENDIF ! end if for tracer_adv_opt + ! tke IF ((config_flags%tke_adv_opt /= ORIGINAL) .and. (rk_step == rk_order) & @@ -2101,6 +2222,124 @@ BENCH_START(chem_adv_tim) ENDDO chem_variable_loop ENDIF chem_scalar_advance BENCH_END(chem_adv_tim) +! next the chemical species +BENCH_START(tracer_adv_tim) + tracer_advance: IF (num_tracer >= PARAM_FIRST_SCALAR) THEN + + tracer_variable_loop: DO ic = PARAM_FIRST_SCALAR, num_tracer + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + tracer_tile_loop_1: DO ij = 1 , grid%num_tiles + + CALL wrf_debug ( 15 , ' call rk_scalar_tend in tracer_tile_loop_1' ) + CALL rk_scalar_tend ( ic, ic, config_flags, & + rk_step, dt_rk, & + grid%ru_m, grid%rv_m, grid%ww_m, & + grid%muts, grid%mub, grid%mu_1, & + grid%alt, & + tracer_old(ims,kms,jms,ic), & + tracer(ims,kms,jms,ic), & + tracer_tend(ims,kms,jms,ic), & + advect_tend,grid%rqvften, & + grid%qv_base, .false., grid%fnm, grid%fnp, & + grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, & + grid%msfvy, grid%msftx,grid%msfty, & + grid%rdx, grid%rdy, grid%rdn, grid%rdnw, & + grid%khdif, grid%kvdif, grid%xkhh, & + grid%diff_6th_opt, grid%diff_6th_factor, & + config_flags%tracer_adv_opt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) +! +! Currently, chemistry species with specified boundaries (i.e. the mother +! domain) are being over written by flow_dep_bdy_chem. So, relax_bdy and +! spec_bdy are only called for nests. For boundary conditions from global model or larger domain, +! chem is uncoupled, and only used for one row/column on inflow (if have_bcs_chem=.true.) +! + IF( ( config_flags%nested ) .and. rk_step == 1 ) THEN + IF(ic.eq.1)CALL wrf_debug ( 10 , ' have_bcs_tracer' ) + CALL relax_bdy_scalar ( tracer_tend(ims,kms,jms,ic), & + tracer(ims,kms,jms,ic), grid%mut, & + tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic), & + tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic), & + tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic), & + tracer_btys(ims,kms,1,ic),tracer_btye(ims,kms,1,ic), & + config_flags%spec_bdy_width, grid%spec_zone, grid%relax_zone, & + grid%dtbc, grid%fcx, grid%gcx, & + config_flags, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + CALL spec_bdy_scalar ( tracer_tend(ims,kms,jms,ic), & + tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic), & + tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic), & + tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic), & + tracer_btys(ims,kms,1,ic),tracer_btye(ims,kms,1,ic), & + config_flags%spec_bdy_width, grid%spec_zone, & + config_flags, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + ENDIF + + ENDDO tracer_tile_loop_1 + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + + tracer_tile_loop_2: DO ij = 1 , grid%num_tiles + + CALL wrf_debug ( 200 , ' call rk_update_scalar' ) + CALL rk_update_scalar( ic, ic, & + tracer_old(ims,kms,jms,ic), & + tracer(ims,kms,jms,ic), & + tracer_tend(ims,kms,jms,ic), & + advect_tend, grid%msftx, grid%msfty, & + grid%mu_1, grid%mu_2, grid%mub, & + rk_step, dt_rk, grid%spec_zone, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + + IF( config_flags%specified ) THEN + CALL flow_dep_bdy_tracer( tracer(ims,kms,jms,ic), & + tracer_bxs(jms,kms,1,ic), tracer_btxs(jms,kms,1,ic), & + tracer_bxe(jms,kms,1,ic), tracer_btxe(jms,kms,1,ic), & + tracer_bys(ims,kms,1,ic), tracer_btys(ims,kms,1,ic), & + tracer_bye(ims,kms,1,ic), tracer_btye(ims,kms,1,ic), & + dt_rk+grid%dtbc, & + config_flags%spec_bdy_width,grid%z, & + grid%have_bcs_tracer, & + grid%ru_m, grid%rv_m, config_flags%tracer_opt,grid%alt, & + grid%t_1,grid%pb,grid%p,t0,p1000mb,rcp,grid%ph_2,grid%phb,g, & + grid%spec_zone,ic, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + ENDIF + ENDDO tracer_tile_loop_2 + !$OMP END PARALLEL DO + + ENDDO tracer_variable_loop + ENDIF tracer_advance +BENCH_END(tracer_adv_tim) #endif ! next the other scalar species @@ -2140,7 +2379,13 @@ BENCH_END(chem_adv_tim) .OR. is .EQ. P_QNS & .OR. is .EQ. P_QNR & .OR. is .EQ. P_QNG & + .OR. is .EQ. P_QNH & .OR. is .EQ. P_QNN & +! .OR. is .EQ. P_QZR & +! .OR. is .EQ. P_QZI & +! .OR. is .EQ. P_QZS & +! .OR. is .EQ. P_QZG & +! .OR. is .EQ. P_QZH & .OR. is .EQ. P_QNC) THEN CALL relax_bdy_scalar ( scalar_tend(ims,kms,jms,is), & @@ -2201,22 +2446,6 @@ BENCH_END(chem_adv_tim) IF( config_flags%specified ) THEN -#ifdef WRF_CHEM - IF( ((is .EQ. p_tr17_1) .AND. (config_flags%scalar_opt .EQ. 2)) .OR. & - ((is .EQ. p_tr17_2) .AND. (config_flags%scalar_opt .EQ. 2)) ) THEN - - CALL flow_dep_bdy_s1( scalar(ims,kms,jms,is), & - grid%ru_m, grid%rv_m, config_flags, & - grid%spec_zone, & - ids,ide, jds,jde, kds,kde, & ! domain dims - ims,ime, jms,jme, kms,kme, & ! memory dims - ips,ipe, jps,jpe, kps,kpe, & ! patch dims - grid%i_start(ij), grid%i_end(ij), & - grid%j_start(ij), grid%j_end(ij), & - k_start, k_end ) - - ELSE -#endif CALL flow_dep_bdy ( scalar(ims,kms,jms,is), & grid%ru_m, grid%rv_m, config_flags, & @@ -2227,9 +2456,6 @@ BENCH_END(chem_adv_tim) grid%i_start(ij), grid%i_end(ij), & grid%j_start(ij), grid%j_end(ij), & k_start, k_end ) -#ifdef WRF_CHEM - ENDIF -#endif ENDIF ENDDO scalar_tile_loop_2 @@ -2294,8 +2520,9 @@ BENCH_END(calc_p_rho_tim) ,flag_moist = im & ,flag_chem = 0 & ,flag_scalar = 0 & + ,flag_tracer = 0 & ,positive_definite=.FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -2330,9 +2557,10 @@ BENCH_END(calc_p_rho_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = im & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite=.FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -2347,6 +2575,43 @@ BENCH_END(calc_p_rho_tim) ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) END DO END IF + IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN + CALL wrf_debug ( 200 , ' call filter tracer ' ) + DO im = PARAM_FIRST_SCALAR, num_tracer + CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & + ,MU=grid%mu_2 , MUB=grid%mub & + ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & + ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & + ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + CALL pxft ( grid=grid & + ,lineno=__LINE__ & + ,flag_uv = 0 & + ,flag_rurv = 0 & + ,flag_wph = 0 & + ,flag_ww = 0 & + ,flag_t = 0 & + ,flag_mu = 0 & + ,flag_mut = 0 & + ,flag_moist = 0 & + ,flag_chem = 0 & + ,flag_tracer = im & + ,flag_scalar = 0 & + ,positive_definite=.FALSE. & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & + ,fft_filter_lat = config_flags%fft_filter_lat & + ,dclat = dclat & + ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & + ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & + ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & + ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & + ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & + ,MU=grid%mu_2 , MUB=grid%mub & + ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & + ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & + ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END DO + END IF IF ( num_3d_s >= PARAM_FIRST_SCALAR ) THEN CALL wrf_debug ( 200 , ' call filter scalar ' ) @@ -2367,9 +2632,10 @@ BENCH_END(calc_p_rho_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = im & ,positive_definite=.FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -2442,6 +2708,7 @@ BENCH_END(calc_p_rho_tim) # include "PERIOD_BDY_EM_D.inc" # include "PERIOD_BDY_EM_MOIST2.inc" # include "PERIOD_BDY_EM_CHEM2.inc" +# include "PERIOD_BDY_EM_TRACER2.inc" # include "PERIOD_BDY_EM_SCALAR2.inc" #endif @@ -2505,6 +2772,22 @@ BENCH_END(diag_w_tim) END IF + IF (num_tracer >= PARAM_FIRST_SCALAR) THEN + + tracer_species_bdy_loop_1 : DO ic = PARAM_FIRST_SCALAR , num_tracer + + CALL set_physical_bc3d( tracer(ims,kms,jms,ic), 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end-1 ) + + END DO tracer_species_bdy_loop_1 + + END IF + IF (num_3d_s >= PARAM_FIRST_SCALAR) THEN scalar_species_bdy_loop_1 : DO is = PARAM_FIRST_SCALAR , num_3d_s @@ -2601,6 +2884,24 @@ BENCH_END(bc_end_tim) CALL wrf_error_fatal(TRIM(wrf_err_message)) ENDIF ENDIF + IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN + IF ( config_flags%h_sca_adv_order <= 4 ) THEN + IF ( (config_flags%tracer_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN +# include "HALO_EM_TRACER_E_5.inc" + ELSE +# include "HALO_EM_TRACER_E_3.inc" + ENDIF + ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN + IF ( (config_flags%tracer_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN +# include "HALO_EM_TRACER_E_7.inc" + ELSE +# include "HALO_EM_TRACER_E_5.inc" + ENDIF + ELSE + WRITE(wrf_err_message,*)'solve_em: invalid h_sca_adv_order = ',config_flags%h_sca_adv_order + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ENDIF + ENDIF IF ( num_scalar >= PARAM_FIRST_SCALAR ) THEN IF ( config_flags%h_sca_adv_order <= 4 ) THEN IF ( (config_flags%scalar_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN @@ -2632,6 +2933,65 @@ BENCH_END(bc_end_tim) END DO Runge_Kutta_loop + IF (config_flags%do_avgflx_em .EQ. 1) THEN +! Reinitialize time-averaged fluxes if history output was written after the previous time step: + CALL WRFU_ALARMGET(grid%alarms( HISTORY_ALARM ),temp_time) + CALL domain_clock_get ( grid, current_time=CurrTime, & + current_timestr=message2 ) +! use overloaded -, .LT. operator to check whether to initialize avgflx: +! reinitialize after each history output (detect this here by comparing current time +! against last history time and time step - this code follows what's done in adapt_timestep_em): + WRITE ( message , FMT = '("solve_em: old_dt =",g15.6,", dt=",g15.6," on domain ",I3)' ) & + & old_dt,grid%dt,grid%id + CALL wrf_debug(200,message) + old_dt=min(old_dt,grid%dt) + num = INT(old_dt * precision) + den = precision + CALL WRFU_TimeIntervalSet(dtInterval, Sn=num, Sd=den) + IF (CurrTime .lt. temp_time + dtInterval) THEN + WRITE ( message , FMT = '("solve_em: initializing avgflx at time ",A," on domain ",I3)' ) & + & TRIM(message2), grid%id + CALL wrf_message(trim(message)) + grid%avgflx_count = 0 +!tile-loop for zero_avgflx + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + + DO ij = 1 , grid%num_tiles + CALL wrf_debug(200,'In solve_em, before zero_avgflx call') + CALL zero_avgflx(grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, & + & ids, ide, jds, jde, kds, kde, & + & ims, ime, jms, jme, kms, kme, & + & grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), & + & k_start , k_end, f_flux, & + & grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, & + & grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 ) + CALL wrf_debug(200,'In solve_em, after zero_avgflx call') + ENDDO + ENDIF + +! Update avgflx quantities +!tile-loop for upd_avgflx + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + + DO ij = 1 , grid%num_tiles + CALL wrf_debug(200,'In solve_em, before upd_avgflx call') + CALL upd_avgflx(grid%avgflx_count,grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, & + & grid%ru_m, grid%rv_m, grid%ww_m, & + & ids, ide, jds, jde, kds, kde, & + & ims, ime, jms, jme, kms, kme, & + & grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), & + & k_start , k_end, f_flux, & + & grid%cfu1,grid%cfd1,grid%dfu1,grid%efu1,grid%dfd1,grid%efd1, & + & grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, & + & grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 ) + CALL wrf_debug(200,'In solve_em, after upd_avgflx call') + + ENDDO + grid%avgflx_count = grid%avgflx_count + 1 + ENDIF +! !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ) DO ij = 1 , grid%num_tiles @@ -2720,6 +3080,7 @@ BENCH_START(micro_driver_tim) & ,P8W=p8w ,P=p_phy ,PI_PHY=pi_phy & & ,RHO=rho ,SPEC_ZONE=grid%spec_zone & & ,SR=grid%sr ,TH=th_phy & + & ,refl_10cm=grid%refl_10cm & ! hm, 9/22/09 for refl & ,WARM_RAIN=grid%warm_rain & & ,T8W=t8w & & ,CLDFRA=grid%cldfra, EXCH_H=grid%exch_h & @@ -2748,7 +3109,8 @@ BENCH_START(micro_driver_tim) ! Optional & , RAINNC=grid%rainnc, RAINNCV=grid%rainncv & & , SNOWNC=grid%snownc, SNOWNCV=grid%snowncv & - & , GRAUPELNC=grid%graupelnc, GRAUPELNCV=grid%graupelncv & + & , GRAUPELNC=grid%graupelnc, GRAUPELNCV=grid%graupelncv & ! for milbrandt2mom + & , HAILNC=grid%hailnc, HAILNCV=grid%hailncv & & , W=grid%w_2, Z=grid%z, HT=grid%ht & & , MP_RESTART_STATE=grid%mp_restart_state & & , TBPVS_STATE=grid%tbpvs_state & ! etampnew @@ -2759,18 +3121,26 @@ BENCH_START(micro_driver_tim) & , QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI & & , QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS & & , QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG & + & , QH_CURR=moist(ims,kms,jms,P_QH), F_QH=F_QH & ! for milbrandt2mom & , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP & - & , QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=F_QNI & & , QT_CURR=scalar(ims,kms,jms,P_QT), F_QT=F_QT & - & , QNS_CURR=scalar(ims,kms,jms,P_QNS), F_QNS=F_QNS & - & , QNR_CURR=scalar(ims,kms,jms,P_QNR), F_QNR=F_QNR & - & , QNG_CURR=scalar(ims,kms,jms,P_QNG), F_QNG=F_QNG & & , QNN_CURR=scalar(ims,kms,jms,P_QNN), F_QNN=F_QNN & + & , QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=F_QNI & & , QNC_CURR=scalar(ims,kms,jms,P_QNC), F_QNC=F_QNC & - & , qrcuten=grid%rqrcuten, qscuten=grid%rqscuten & - & , qicuten=grid%rqicuten,mu=grid%mut & + & , QNR_CURR=scalar(ims,kms,jms,P_QNR), F_QNR=F_QNR & + & , QNS_CURR=scalar(ims,kms,jms,P_QNS), F_QNS=F_QNS & + & , QNG_CURR=scalar(ims,kms,jms,P_QNG), F_QNG=F_QNG & + & , QNH_CURR=scalar(ims,kms,jms,P_QNH), F_QNH=F_QNH & ! for milbrandt2mom +! & , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR & ! for milbrandt3mom +! & , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI & ! " +! & , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS & ! " +! & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! " +! & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! " + & , qrcuten=grid%rqrcuten, qscuten=grid%rqscuten & + & , qicuten=grid%rqicuten,mu=grid%mut & & , HAIL=config_flags%gsfcgce_hail & ! for gsfcgce & , ICE2=config_flags%gsfcgce_2ice & ! for gsfcgce +! & , ccntype=config_flags%milbrandt_ccntype & ! for milbrandt (2mom) ) BENCH_END(micro_driver_tim) @@ -2818,6 +3188,12 @@ BENCH_START(moist_phys_end_tim) ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & k_start , k_end ) + CALL microphysics_zero_outb ( & + tracer , num_tracer , config_flags , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, & + k_start , k_end ) IF ( config_flags%periodic_x ) THEN its = max(grid%i_start(ij),ids) @@ -2850,9 +3226,18 @@ BENCH_START(moist_phys_end_tim) its, ite, jts, jte, & k_start , k_end ) + CALL microphysics_zero_outa ( & + tracer , num_tracer , config_flags , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, & + k_start , k_end ) CALL moist_physics_finish_em( grid%t_2, grid%t_1, t0, grid%muts, th_phy, & grid%h_diabatic, dtm, config_flags, & +#if ( WRF_DFI_RADAR == 1 ) + grid%dfi_tten_rad,grid%dfi_stage, & +#endif ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, & @@ -2890,9 +3275,10 @@ BENCH_START(moist_phys_end_tim) ,flag_mut = 0 & ,flag_moist = im & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite=.FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -2995,9 +3381,10 @@ BENCH_END(moist_phys_end_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = im & + ,flag_tracer = 0 & ,flag_scalar = 0 & ,positive_definite=.FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -3015,6 +3402,48 @@ BENCH_END(moist_phys_end_tim) ENDDO ENDDO chem_filter_loop ENDIF + IF ( num_tracer >= PARAM_FIRST_SCALAR ) then + tracer_filter_loop: DO im = PARAM_FIRST_SCALAR, num_tracer + DO jj = jps, MIN(jpe,jde-1) + DO kk = kps, MIN(kpe,kde-1) + DO ii = ips, MIN(ipe,ide-1) + tracer(ii,kk,jj,im)=tracer(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj)) + ENDDO + ENDDO + ENDDO + + CALL pxft ( grid=grid & + ,lineno=__LINE__ & + ,flag_uv = 0 & + ,flag_rurv = 0 & + ,flag_wph = 0 & + ,flag_ww = 0 & + ,flag_t = 0 & + ,flag_mu = 0 & + ,flag_mut = 0 & + ,flag_moist = 0 & + ,flag_chem = 0 & + ,flag_tracer = im & + ,flag_scalar = 0 & + ,positive_definite=.FALSE. & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & + ,fft_filter_lat = config_flags%fft_filter_lat & + ,dclat = dclat & + ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & + ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & + ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & + ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & + ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + + DO jj = jps, MIN(jpe,jde-1) + DO kk = kps, MIN(kpe,kde-1) + DO ii = ips, MIN(ipe,ide-1) + tracer(ii,kk,jj,im)=tracer(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj)) + ENDDO + ENDDO + ENDDO + ENDDO tracer_filter_loop + ENDIF IF ( num_3d_s >= PARAM_FIRST_SCALAR ) then scalar_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_s @@ -3037,9 +3466,10 @@ BENCH_END(moist_phys_end_tim) ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & + ,flag_tracer = 0 & ,flag_scalar = im & ,positive_definite=.FALSE. & - ,moist=moist,chem=chem,scalar=scalar & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & @@ -3124,6 +3554,7 @@ BENCH_END(moist_phys_end_tim) # include "PERIOD_BDY_EM_D3.inc" # include "PERIOD_BDY_EM_MOIST.inc" # include "PERIOD_BDY_EM_CHEM.inc" +# include "PERIOD_BDY_EM_TRACER.inc" # include "PERIOD_BDY_EM_SCALAR.inc" #endif @@ -3187,6 +3618,18 @@ BENCH_START(bc_2d_tim) END DO chem_species_bdy_loop_2 + tracer_species_bdy_loop_2 : DO ic = PARAM_FIRST_SCALAR , num_tracer + + CALL set_physical_bc3d( tracer(ims,kms,jms,ic) , 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + + END DO tracer_species_bdy_loop_2 + scalar_species_bdy_loop_2 : DO is = PARAM_FIRST_SCALAR , num_3d_s CALL set_physical_bc3d( scalar(ims,kms,jms,is) , 'p', config_flags, & @@ -3211,14 +3654,16 @@ BENCH_END(bc_2d_tim) #ifdef DM_PARALLEL # include "HALO_EM_C.inc" +# include "PERIOD_BDY_EM_E.inc" #endif - CALL wrf_debug ( 10 , ' call set_w_surface2' ) + CALL wrf_debug ( 10 , ' call set_w_surface' ) + fill_w_flag = .false. !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ) DO ij = 1 , grid%num_tiles - CALL set_w_surface2( & + CALL set_w_surface( config_flags, grid%znw, fill_w_flag, & grid%w_2, grid%ht, grid%u_2, grid%v_2, & grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy,& grid%msftx, grid%msfty, & @@ -3321,6 +3766,20 @@ BENCH_END(bc_2d_tim) CALL wrf_error_fatal(TRIM(wrf_err_message)) ENDIF ENDIF + IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN +!----------------------------------------------------------------------- +! see above +!-------------------------------------------------------------- + CALL wrf_debug ( 200 , ' call HALO_RK_TRACER' ) + IF ( config_flags%h_mom_adv_order <= 4 ) THEN +# include "HALO_EM_TRACER_E_3.inc" + ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN +# include "HALO_EM_TRACER_E_5.inc" + ELSE + WRITE(wrf_err_message,*)'solve_em: invalid h_mom_adv_order = ',config_flags%h_mom_adv_order + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ENDIF + ENDIF IF ( num_scalar >= PARAM_FIRST_SCALAR ) THEN !----------------------------------------------------------------------- ! see above diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F index bc24a44a..737022c5 100644 --- a/wrfv2_fire/dyn_em/start_em.F +++ b/wrfv2_fire/dyn_em/start_em.F @@ -27,12 +27,15 @@ USE module_aerosols_sorgam, ONLY: sum_pm_sorgam USE module_gocart_aerosols, ONLY: sum_pm_gocart USE module_mosaic_driver, ONLY: sum_pm_mosaic + USE module_input_tracer, ONLY: initialize_tracer #endif !!debug !USE module_compute_geop USE module_model_constants + USE module_avgflx_em, ONLY : zero_avgflx + IMPLICIT NONE ! Input data. TYPE (domain) :: grid @@ -72,7 +75,7 @@ REAL :: qvf1, qvf2, qvf REAL :: MPDT REAL :: spongeweight - LOGICAL :: first_trip_for_this_domain, start_of_simulation + LOGICAL :: first_trip_for_this_domain, start_of_simulation, fill_w_flag #ifndef WRF_CHEM REAL,ALLOCATABLE,DIMENSION(:,:,:) :: cldfra_old #endif @@ -83,10 +86,13 @@ CHARACTER (LEN=132) :: message TYPE(WRFU_TimeInterval) :: stepTime REAL, DIMENSION(:,:), ALLOCATABLE :: clat_glob + logical :: f_flux ! flag for computing averaged fluxes in cu_gd INTEGER :: idex, jdex + INTEGER :: im1,ip1,jm1,jp1 + REAL :: hx,hy,pi - CALL get_ijk_from_grid ( grid , & + CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & @@ -568,6 +574,21 @@ ! DO ij = 1, grid%num_tiles +!tgs do not need physics initialization for backward DFI integration + IF ( grid%dfi_opt .NE. DFI_NODFI .and. grid%dfi_stage .EQ. DFI_FST) THEN !tgs + grid%stepra=nint(grid%RADT*60./grid%DT) + grid%stepra=max(grid%stepra,1) + grid%stepbl=nint(grid%BLDT*60./grid%DT) + grid%stepbl=max(grid%stepbl,1) + grid%stepcu=nint(grid%CUDT*60./grid%DT) + grid%stepcu=max(grid%stepcu,1) + grid%stepfg=nint(grid%FGDT*60./grid%DT) + grid%stepfg=max(grid%stepfg,1) + ENDIF + + IF ( ( grid%dfi_opt .NE. DFI_NODFI .and. grid%dfi_stage .EQ. DFI_FWD) .or. & + ( grid%dfi_opt .EQ. DFI_NODFI)) THEN + CALL phy_init ( grid%id , config_flags, grid%DT, grid%RESTART, grid%znw, grid%znu, & grid%p_top, grid%tsk, grid%RADT,grid%BLDT,grid%CUDT, MPDT, & grid%rthcuten, grid%rqvcuten, grid%rqrcuten, & @@ -629,7 +650,11 @@ grid%TRL_URB3D, grid%TBL_URB3D, grid%TGL_URB3D, & !Optional urban grid%SH_URB2D, grid%LH_URB2D, grid%G_URB2D, grid%RN_URB2D, & !Optional urban grid%TS_URB2D, grid%FRC_URB2D, grid%UTYPE_URB2D, & !Optional urban - grid%TRB_URB4D,grid%TW1_URB4D,grid%TW2_URB4D,grid%TGB_URB4D, & !multi-layer urban + grid%TRB_URB4D,grid%TW1_URB4D,grid%TW2_URB4D,grid%TGB_URB4D,grid%TLEV_URB3D, & !multi-layer urban + grid%QLEV_URB3D,grid%TW1LEV_URB3D,grid%TW2LEV_URB3D, & !multi-layer urban + grid%TGLEV_URB3D,grid%TFLEV_URB3D,grid%SF_AC_URB3D, & !multi-layer urban + grid%LF_AC_URB3D,grid%CM_AC_URB3D,grid%SFVENT_URB3D,grid%LFVENT_URB3D, & !multi-layer urban + grid%SFWIN1_URB3D,grid%SFWIN2_URB3D, & !multi-layer urban grid%SFW1_URB3D,grid%SFW2_URB3D,grid%SFR_URB3D,grid%SFG_URB3D, & !multi-layer urban grid%A_U_BEP,grid%A_V_BEP,grid%A_T_BEP,grid%A_Q_BEP, & !multi-layer urban grid%A_E_BEP,grid%B_U_BEP,grid%B_V_BEP,grid%B_T_BEP, & !multi-layer urban @@ -641,13 +666,29 @@ grid%TYR, grid%TYRA, grid%TDLY, grid%TLAG, grid%NYEAR, grid%NDAY,grid%tmn_update, & grid%achfx, grid%aclhf, grid%acgrdflx & ) + ENDIF !tgs ENDDO - - CALL wrf_debug ( 100 , 'start_domain_em: After call to phy_init' ) + IF (config_flags%do_avgflx_em .EQ. 1) THEN + WRITE ( message , FMT = '("start_em: initializing avgflx on domain ",I3)' ) & + & grid%id + CALL wrf_message(trim(message)) + grid%avgflx_count = 0 + DO ij = 1, grid%num_tiles + call wrf_debug(200,'In start_em, before zero_avgflx call') + if (.not. grid%restart) call zero_avgflx(grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, & + & ids, ide, jds, jde, kds, kde, & + & ims, ime, jms, jme, kms, kme, & + & grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), kts, kte, f_flux, & + & grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, & + & grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 ) + call wrf_debug(200,'In start_em, after zero_avgflx call') + ENDDO + ENDIF + #ifdef MCELIO grid%LU_MASK = 0. WHERE ( grid%lu_index .EQ. 16 ) grid%LU_MASK = 1. @@ -775,20 +816,47 @@ ! above that. IF ( ( start_of_simulation .OR. config_flags%cycling ) .AND. ( .NOT. config_flags%restart ) ) THEN - CALL set_w_surface( config_flags, grid%znw, & + fill_w_flag = .true. + CALL set_w_surface( config_flags, grid%znw, fill_w_flag, & grid%w_1, grid%ht, grid%u_1, grid%v_1, grid%cf1, & grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, & - ids, ide, jds, jde, kds, kde, & - ips, ipe, jps, jpe, kps, kpe, & - its, ite, jts, jte, kts, kte, & - ims, ime, jms, jme, kms, kme ) - CALL set_w_surface( config_flags, grid%znw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CALL set_w_surface( config_flags, grid%znw, fill_w_flag, & grid%w_2, grid%ht, grid%u_2, grid%v_2, grid%cf1, & grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, & - ids, ide, jds, jde, kds, kde, & - ips, ipe, jps, jpe, kps, kpe, & - its, ite, jts, jte, kts, kte, & - ims, ime, jms, jme, kms, kme ) + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +! set up slope-radiation constant arrays based on topography + DO j = jts,min(jte,jde-1) + DO i = its, min(ite,ide-1) + im1 = max(i-1,ids) + ip1 = min(i+1,ide-1) + jm1 = max(j-1,jds) + jp1 = min(j+1,jde-1) + grid%toposlpx(i,j)=(grid%ht(ip1,j)-grid%ht(im1,j))*grid%msftx(i,j)*grid%rdx/(ip1-im1) + grid%toposlpy(i,j)=(grid%ht(i,jp1)-grid%ht(i,jm1))*grid%msfty(i,j)*grid%rdy/(jp1-jm1) + hx = grid%toposlpx(i,j) + hy = grid%toposlpy(i,j) + pi = 4.*atan(1.) + grid%slope(i,j) = atan((hx**2+hy**2)**.5) + if (grid%slope(i,j).lt.1.e-4) then + grid%slope(i,j) = 0. + grid%slp_azi(i,j) = 0. + else + grid%slp_azi(i,j) = atan2(hx,hy)+pi + +! Rotate slope azimuth to lat-lon grid + if (grid%cosa(i,j).ge.0) then + grid%slp_azi(i,j) = grid%slp_azi(i,j) - asin(grid%sina(i,j)) + else + grid%slp_azi(i,j) = grid%slp_azi(i,j) - (pi - asin(grid%sina(i,j))) + endif + endif + ENDDO + ENDDO END IF ! finished setting kinematic condition for w at the surface @@ -927,6 +995,15 @@ #ifdef WRF_CHEM + if(config_flags%tracer_opt > 0 )then + call initialize_tracer (tracer,config_flags%chem_in_opt, & + config_flags%tracer_opt,num_tracer, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + endif ! ! we do this here, so we only have one chem_init routine for either core.... ! diff --git a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F index 1d4869d3..137e3b1e 100644 --- a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F +++ b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F @@ -125,9 +125,16 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) ! soil configuration +#ifdef HWRF +!zhang + if ( .not.nest%analysis ) then +#endif nest%sldpth = parent%sldpth nest%dzsoil = parent%dzsoil nest%rtdpth = parent%rtdpth +#ifdef HWRF + endif +#endif ! numerical set up @@ -168,16 +175,26 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) CALL nl_get_truelat1 (parent%id, parent%truelat1 ) CALL nl_get_truelat2 (parent%id, parent%truelat2 ) +#ifdef HWRF +! bao : to make the restart output identical at the restart initial time for stand_lon + CALL nl_get_stand_lon (parent%id, parent%stand_lon ) +#endif CALL nl_get_map_proj (parent%id, parent%map_proj ) CALL nl_get_iswater (parent%id, parent%iswater ) nest%truelat1=parent%truelat1 nest%truelat2=parent%truelat2 +!bao + nest%stand_lon=parent%stand_lon +!bao nest%map_proj=parent%map_proj nest%iswater=parent%iswater CALL nl_set_truelat1(nest%id, nest%truelat1) CALL nl_set_truelat2(nest%id, nest%truelat2) +!bao + CALL nl_set_stand_lon(nest%id, nest%stand_lon) +!bao CALL nl_set_map_proj(nest%id, nest%map_proj) CALL nl_set_iswater(nest%id, nest%iswater) @@ -302,7 +319,7 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) nest%HLAT,nest%HLON, & ! target (nest) input lat lon in degrees parent_DLMD,parent_DPHD,parent_WBD,parent_SBD, & ! parent res, western and south boundaries parent_CLAT,parent_CLON, & ! parent central lat,lon, all in degrees - parent%ed31,parent%ed33, & ! parent imax and jmax + parent%ed31,parent%ed32, & ! parent imax and jmax IDS,IDE,JDS,JDE,KDS,KDE, & ! IMS,IME,JMS,JME,KMS,KME, & ! nested grid configuration ITS,ITE,JTS,JTE,KTS,KTE ) ! @@ -316,7 +333,7 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) nest%VLAT,nest%VLON, & ! target (nest) input lat lon in degrees parent_DLMD,parent_DPHD,parent_WBD,parent_SBD, & ! parent res, western and south boundaries parent_CLAT,parent_CLON, & ! parent central lat,lon, all in degrees - parent%ed31,parent%ed33, & ! parent imax and jmax + parent%ed31,parent%ed32, & ! parent imax and jmax IDS,IDE,JDS,JDE,KDS,KDE, & ! IMS,IME,JMS,JME,KMS,KME, & ! nested grid configuration ITS,ITE,JTS,JTE,KTS,KTE ) ! @@ -558,7 +575,7 @@ END SUBROUTINE EARTH_LATLON !*** V H !*** !*** -!*** h +!*** H !*** H V !*** !*** THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID @@ -588,7 +605,7 @@ END SUBROUTINE EARTH_LATLON !*** H V !*** !*** -!*** h +!*** H !*** V H !*** !*** THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID @@ -634,7 +651,7 @@ END SUBROUTINE EARTH_LATLON !*** H V H !*** !*** -!*** h +!*** H !*** H V H V H !*** !*** @@ -710,7 +727,7 @@ END SUBROUTINE EARTH_LATLON !*** !*** 4 !*** -!*** h +!*** H !*** 1 2 !*** !*** 3 @@ -834,7 +851,7 @@ END SUBROUTINE EARTH_LATLON !*** !*** !*** -!*** h +!*** H !*** 1 2 !*** !*** @@ -933,9 +950,9 @@ END SUBROUTINE EARTH_LATLON !*** Gopal - Revised Version for WRF (includes coincIDEnt grid points) !*** !*** GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY, -!*** AND THE NESTED GRID LAT-LONS AT v POINTS, THIS ROUTINE FIRST LOCATES THE -!*** INDICES,IIV,JJV, OF THE PARENT DOMAIN'S v POINTS THAT LIES CLOSEST TO THE -!*** v POINTS OF THE NESTED DOMAIN +!*** AND THE NESTED GRID LAT-LONS AT V POINTS, THIS ROUTINE FIRST LOCATES THE +!*** INDICES,IIV,JJV, OF THE PARENT DOMAIN'S V POINTS THAT LIES CLOSEST TO THE +!*** V POINTS OF THE NESTED DOMAIN ! !============================================================================ @@ -986,9 +1003,9 @@ END SUBROUTINE EARTH_LATLON DO J = JTS,MIN(JTE,JDE-1) DO I = ITS,MIN(ITE,IDE-1) !*** -!*** LOCATE TARGET v POINTS (VLAT AND VLON) ON THE PARENT DOMAIN AND +!*** LOCATE TARGET V POINTS (VLAT AND VLON) ON THE PARENT DOMAIN AND !*** DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST -!*** CONVERT NESTED GRID v POINTS FROM GEODETIC TO TRANSFORMED +!*** CONVERT NESTED GRID V POINTS FROM GEODETIC TO TRANSFORMED !*** COORDINATE ON THE PARENT GRID ! @@ -1013,12 +1030,12 @@ END SUBROUTINE EARTH_LATLON !*** !*** -!*** FIRST CONSIDER THE SITUATION WHERE THE POINT v IS AT +!*** FIRST CONSIDER THE SITUATION WHERE THE POINT V IS AT !*** !*** H V !*** !*** -!*** v +!*** V !*** V H !*** !*** THEN LOCATE THE NEAREST V POINT ON THE PARENT GRID @@ -1045,12 +1062,12 @@ END SUBROUTINE EARTH_LATLON ELSE !*** -!*** NOW CONSIDER THE SITUATION WHERE THE POINT v IS AT +!*** NOW CONSIDER THE SITUATION WHERE THE POINT V IS AT !*** !*** V H !*** !*** -!*** v +!*** V !*** H V !*** !*** THEN LOCATE THE NEAREST V POINT ON THE PARENT GRID @@ -1085,8 +1102,8 @@ END SUBROUTINE EARTH_LATLON !*** !*** WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS !*** NEAREST TO THE CENTER K AS SEEN BELOW. WE MUST FIND -!*** WHICH OF THE FOUR V-BOXES (OF WHICH THIS V POINT IS -!*** A VERTEX) SURROUNDS THE INNER GRID v POINT IN QUESTION. +!*** WHICH OF THE FOUR v-BOXES (OF WHICH THIS V POINT IS +!*** A VERTEX) SURROUNDS THE INNER GRID V POINT IN QUESTION. !*** !*** !*** V @@ -1096,7 +1113,7 @@ END SUBROUTINE EARTH_LATLON !*** V H V !*** !*** -!*** v +!*** V !*** V H V H V !*** !*** @@ -1108,7 +1125,7 @@ END SUBROUTINE EARTH_LATLON !*** V !*** !*** -!*** FIND THE SLOPE OF THE LINE CONNECTING v AND THE CENTER V. +!*** FIND THE SLOPE OF THE LINE CONNECTING V AND THE CENTER v. !*** N2R=K/IMT MK=MOD(K,IMT) @@ -1172,7 +1189,7 @@ END SUBROUTINE EARTH_LATLON !*** !*** 4 !*** -!*** v +!*** V !*** 1 2 !*** !*** 3 @@ -1292,7 +1309,7 @@ END SUBROUTINE EARTH_LATLON !*** !*** !*** -!*** v +!*** V !*** 1 2 !*** !*** @@ -1302,7 +1319,7 @@ END SUBROUTINE EARTH_LATLON !*** !*** !*** -!*** DL 1-4 ARE THE ANGULAR DISTANCES FROM v TO EACH VERTEX +!*** DL 1-4 ARE THE ANGULAR DISTANCES FROM V TO EACH VERTEX TLATO=TLATVX(I,J) TLONO=TLONVX(I,J) @@ -1878,13 +1895,15 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) real, allocatable, dimension(:,:,:) :: real_domain - character (len=10), dimension(8) :: name = (/ "XLAT_M ", & + character (len=10), dimension(10) :: name = (/ "XLAT_M ", & "XLONG_M ", & "XLAT_V ", & "XLONG_V ", & "E ", & "F ", & "LANDMASK ", & + "LANDUSEF ", & + "LU_INDEX ", & "HGT_M " /) integer, parameter :: IO_BIN=1, IO_NET=2 @@ -1954,7 +1973,7 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) if (input_type == 1) then ! -! SI version of the static file +! si version of the static file ! CALL get_wrfsi_static_dims(nestpath, im_big, jm_big) ALLOCATE (avc_big(im_big,jm_big)) @@ -1992,7 +2011,7 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) if (istatus /= 0) CALL wrf_error_fatal('NEST_TERRAIN error after ext_XXX_open_for_read '//trim(input_fname)) - do n=1,8 + do n=1,10 cname = name(n) @@ -2006,6 +2025,7 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) if (io_form_input == IO_NET) & call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) #endif + print *, "cname=", cname print *, "istatus=", istatus print *, "ndim=", ndim print *, "memorder=", memorder @@ -2112,14 +2132,14 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) WRITE(message,*)'SOME MATCHING TEST i_parent_start, j_parent_start',i_parent_start,j_parent_start CALL wrf_message(trim(message)) CALL wrf_message('WRFSI LAT COMPUTED LAT') - WRITE(message,*)lah_nest(1,1),nest%hlat(1,1) + WRITE(message,*)lah_nest(1,1),nest%HLAT(1,1) CALL wrf_message(trim(message)) CALL wrf_message('WRFSI LON COMPUTED LON') - WRITE(message,*)loh_nest(1,1),nest%hlon(1,1) + WRITE(message,*)loh_nest(1,1),nest%HLON(1,1) CALL wrf_message(trim(message)) - IF(ABS(lah_nest(1,1)-nest%hlat(1,1)) .GE. 0.5 .OR. & - ABS(loh_nest(1,1)-nest%hlon(1,1)) .GE. 0.5)THEN + IF(ABS(lah_nest(1,1)-nest%HLAT(1,1)) .GE. 0.5 .OR. & + ABS(loh_nest(1,1)-nest%HLON(1,1)) .GE. 0.5)THEN CALL wrf_message('CHECK WRFSI CONFIGURATION AND INPUT HIGH RESOLUTION TOPOGRAPHY AND/OR GRID RATIO') CALL wrf_error_fatal('LATLON MISMATCH: ERROR READING static FILE FOR THE NEST') ENDIF @@ -2188,7 +2208,7 @@ SUBROUTINE med_init_domain_constants_nmm ( parent, nest) !, config_flags) INTERFACE SUBROUTINE med_initialize_nest_nmm ( grid & ! -# include +# include ! ) USE module_domain @@ -2196,14 +2216,14 @@ SUBROUTINE med_init_domain_constants_nmm ( parent, nest) !, config_flags) USE module_timing IMPLICIT NONE TYPE(domain) , POINTER :: grid -#include +#include END SUBROUTINE med_initialize_nest_nmm END INTERFACE !------------------------------------------------------------------------------ ! PURPOSE: ! - initialize some data, mainly 2D & 3D nmm arrays very similar to -! those done in ./dyn_nmm/module_initialize_real.F +! those done in ./dyn_nmm/module_initialize_real.f !----------------------------------------------------------------------------- ! @@ -2211,7 +2231,7 @@ SUBROUTINE med_init_domain_constants_nmm ( parent, nest) !, config_flags) CALL med_initialize_nest_nmm( grid & ! -# include +# include ! ) @@ -2219,7 +2239,7 @@ END SUBROUTINE med_init_domain_constants_nmm SUBROUTINE med_initialize_nest_nmm( grid & ! -# include +# include ! ) @@ -2284,10 +2304,10 @@ SUBROUTINE med_initialize_nest_nmm( grid & CHARACTER(LEN=255) :: message ! Definitions of dummy arguments to solve -#include +#include -#define COPY_IN -#include +!#define COPY_IN +!#include #ifdef DM_PARALLEL # include #endif @@ -2310,6 +2330,8 @@ SUBROUTINE med_initialize_nest_nmm( grid & WRITE(message,*)'TIME STEP ON DOMAIN',grid%id,'==',dt CALL wrf_message(trim(message)) + WRITE(message,*)'IDS,IDE ON DOMAIN',grid%id,'==',ids,ide + CALL wrf_message(trim(message)) ! ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP)) ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP)) @@ -2324,33 +2346,37 @@ SUBROUTINE med_initialize_nest_nmm( grid & ! Since SM has been changed on parent domain to be 0 over sea ice it can not be used here ! to find where sea ice is. That's why alogirthm here is slightly different than the -! one used in module_initalize_real.F +! one used in module_initalize_real.f +#ifdef HWRF +!zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE + IF(.not. grid%analysis)THEN +#endif DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) - IF (SM(I,J).GT.0.9) THEN ! OVER WATER SURFACE - EPSR(I,J)= 0.97 - EMBCK(I,J)= 0.97 - GFFC(I,J)= 0. - ALBEDO(I,J)=.06 - ALBASE(I,J)=.06 + IF (grid%sm(I,J).GT.0.9) THEN ! OVER WATER SURFACE + grid%epsr(I,J)= 0.97 + grid%embck(I,J)= 0.97 + grid%gffc(I,J)= 0. + grid%albedo(I,J)=.06 + grid%albase(I,J)=.06 ENDIF - IF (SICE(I,J).GT.0.9) THEN ! OVER SEA-ICE - SM(I,J)=0. - SI(I,J)=0. - GFFC(I,J)=0. - ALBEDO(I,J)=.60 - ALBASE(I,J)=.60 + IF (grid%sice(I,J).GT.0.9) THEN ! OVER SEA-ICE + grid%sm(I,J)=0. + grid%si(I,J)=0. + grid%gffc(I,J)=0. + grid%albedo(I,J)=.60 + grid%albase(I,J)=.60 ENDIF - IF (SM(I,J).LT.0.5.AND.SICE(I,J).LT.0.5) THEN ! OVER LAND SURFACE - SI(I,J)=5.0*WEASD(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (SI) IS INTERPOLATED - EPSR(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN - EMBCK(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN - GFFC(I,J)=0.0 ! just leave zero as irrelevant - SNO(I,J)=SI(I,J)*.20 ! LAND-SNOW COVER + IF (grid%sm(I,J).LT.0.5.AND.grid%sice(I,J).LT.0.5) THEN ! OVER LAND SURFACE + grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED + grid%epsr(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN + grid%embck(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN + grid%gffc(I,J)=0.0 ! just leave zero as irrelevant + grid%sno(I,J)=grid%si(I,J)*.20 ! LAND-SNOW COVER ENDIF ENDDO @@ -2359,35 +2385,35 @@ SUBROUTINE med_initialize_nest_nmm( grid & #if 0 DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) - IF(SM(I,J).GT.0.9) THEN ! OVER WATER SURFACE + IF(grid%sm(I,J).GT.0.9) THEN ! OVER WATER SURFACE ! IF (XICE(I,J) .gt. 0)THEN ! XICE: SI INPUT ON PARENT, INTERPOLATED ONTO NEST - SI(I,J)=1.0 ! INITIALIZE SI BASED ON XICE FROM INTERPOLATED INPUT + grid%si(I,J)=1.0 ! INITIALIZE SI BASED ON XICE FROM INTERPOLATED INPUT ENDIF ! - EPSR(I,J)= 0.97 ! VALID OVER SEA SURFACE - EMBCK(I,J)= 0.97 ! VALID OVER SEA SURFACE - GFFC(I,J)= 0. - ALBEDO(I,J)=.06 - ALBASE(I,J)=.06 -! - IF(SI (I,J) .GT. 0.)THEN ! VALID OVER SEA-ICE - SM(I,J)=0. - SI(I,J)=0. ! - SICE(I,J)=1. - GFFC(I,J)=0. ! just leave zero as irrelevant - ALBEDO(I,J)=.60 ! DEFINE ALBEDO - ALBASE(I,J)=.60 + grid%epsr(I,J)= 0.97 ! VALID OVER SEA SURFACE + grid%embck(I,J)= 0.97 ! VALID OVER SEA SURFACE + grid%gffc(I,J)= 0. + grid%albedo(I,J)=.06 + grid%albase(I,J)=.06 +! + IF(grid%si (I,J) .GT. 0.)THEN ! VALID OVER SEA-ICE + grid%sm(I,J)=0. + grid%si(I,J)=0. ! + grid%sice(I,J)=1. + grid%gffc(I,J)=0. ! just leave zero as irrelevant + grid%albedo(I,J)=.60 ! DEFINE grid%albedo + grid%albase(I,J)=.60 ENDIF ! ELSE ! OVER LAND SURFACE ! - SI(I,J)=5.0*WEASD(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (SI) IS INTERPOLATED - EPSR(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN - EMBCK(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN - GFFC(I,J)=0.0 ! just leave zero as irrelevant - SICE(I,J)=0. ! SEA ICE - SNO(I,J)=SI(I,J)*.20 ! LAND-SNOW COVER + grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED + grid%epsr(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN + grid%embck(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN + grid%gffc(I,J)=0.0 ! just leave zero as irrelevant + grid%sice(I,J)=0. ! SEA ICE + grid%sno(I,J)=grid%si(I,J)*.20 ! LAND-SNOW COVER ! ENDIF ! @@ -2399,7 +2425,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) - VEGFRA(I,J)=VEGFRC(I,J) + grid%vegfra(I,J)=grid%vegfrc(I,J) ENDDO ENDDO @@ -2410,37 +2436,37 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) - IF(SM(I,J).LT.0.9.AND.SICE(I,J).LT.0.9) THEN + IF(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN ! - IF ( (SNO(I,J) .EQ. 0.0) .OR. & ! SNOWFREE ALBEDO - (ALBASE(I,J) .GE. MXSNAL(I,J) ) ) THEN - ALBEDO(I,J) = ALBASE(I,J) + IF ( (grid%sno(I,J) .EQ. 0.0) .OR. & ! SNOWFREE ALBEDO + (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN + grid%albedo(I,J) = grid%albase(I,J) ELSE - IF (SNO(I,J) .LT. SNUP) THEN ! MODIFY ALBEDO IF SNOWCOVER: - RSNOW = SNO(I,J)/SNUP ! BELOW SNOWDEPTH THRESHOLD + IF (grid%sno(I,J) .LT. SNUP) THEN ! MODIFY ALBEDO IF SNOWCOVER: + RSNOW = grid%sno(I,J)/SNUP ! BELOW SNOWDEPTH THRESHOLD SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP)) ELSE SNOFAC = 1.0 ! ABOVE SNOWDEPTH THRESHOLD ENDIF - ALBEDO(I,J) = ALBASE(I,J) & - + (1.0-VEGFRA(I,J))*SNOFAC*(MXSNAL(I,J)-ALBASE(I,J)) + grid%albedo(I,J) = grid%albase(I,J) & + + (1.0-grid%vegfra(I,J))*SNOFAC*(grid%mxsnal(I,J)-grid%albase(I,J)) ENDIF ! END IF - SI(I,J)=5.0*WEASD(I,J) - SNO(I,J)=WEASD(I,J) + grid%si(I,J)=5.0*grid%weasd(I,J) + grid%sno(I,J)=grid%weasd(I,J) ! this block probably superfluous. Meant to guarantee land/sea agreement - IF (SM(I,J) .gt. 0.5)THEN - landmask(I,J)=0.0 + IF (grid%sm(I,J) .gt. 0.5)THEN + grid%landmask(I,J)=0.0 ELSE - landmask(I,J)=1.0 + grid%landmask(I,J)=1.0 ENDIF - IF (SICE(I,J) .eq. 1.0) then !!!! change vegtyp and sltyp to fit seaice (desireable??) - ISLTYP(I,J)=16 - IVGTYP(I,J)=24 + IF (grid%sice(I,J) .eq. 1.0) then !!!! change vegtyp and sltyp to fit seaice (desireable??) + grid%isltyp(I,J)=16 + grid%ivgtyp(I,J)=24 ENDIF ENDDO @@ -2450,12 +2476,12 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO J = JTS, MIN(JTE,JDE-1) DO I = ITS,MIN(ITE,IDE-1) - IF(SM(I,J).GT.0.9 .AND. VEGFRA(I,J) .NE. 0) THEN - WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE:',I,J,SM(I-1,J),VEGFRA(I-1,j),SM(I,J),VEGFRA(I,J) + IF(grid%sm(I,J).GT.0.9 .AND. grid%vegfra(I,J) .NE. 0) THEN + WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE:',I,J,grid%sm(I-1,J),grid%vegfra(I-1,j),grid%sm(I,J),grid%vegfra(I,J) ENDIF ! - IF(SM(I,J).GT.0.9 .AND. NMM_TSK(I,J) .NE. 0) THEN - WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE:',I,J,SM(I-1,J),NMM_TSK(I-1,J),SM(I,J),NMM_TSK(I,J) + IF(grid%sm(I,J).GT.0.9 .AND. grid%nmm_tsk(I,J) .NE. 0) THEN + WRITE(20,*)'PROBLEM AT THE LAND-WATER INTERFACE:',I,J,grid%sm(I-1,J),grid%nmm_tsk(I-1,J),grid%sm(I,J),grid%nmm_tsk(I,J) ENDIF ENDDO ENDDO @@ -2463,75 +2489,79 @@ SUBROUTINE med_initialize_nest_nmm( grid & ! hardwire root depth for time being - RTDPTH=0. - RTDPTH(1)=0.1 - RTDPTH(2)=0.3 - RTDPTH(3)=0.6 + grid%rtdpth=0. + grid%rtdpth(1)=0.1 + grid%rtdpth(2)=0.3 + grid%rtdpth(3)=0.6 ! hardwire soil depth for time being - SLDPTH=0. - SLDPTH(1)=0.1 - SLDPTH(2)=0.3 - SLDPTH(3)=0.6 - SLDPTH(4)=1.0 + grid%sldpth=0. + grid%sldpth(1)=0.1 + grid%sldpth(2)=0.3 + grid%sldpth(3)=0.6 + grid%sldpth(4)=1.0 +#ifdef HWRF +!zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE + ENDIF ! <------ for analysis set to false +#endif !----------- END OF LAND SURFACE INITIALIZATION ------------------------------------- ! DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) - RES(I,J)=1. + grid%res(I,J)=1. ENDDO ENDDO ! INITIALIZE 2D BOUNDARY MASKS -!! HBM2: +!! grid%hbm2: - HBM2=0. + grid%hbm2=0. DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) IF((J .GE. 3 .and. J .LE. (JDE-1)-2) .AND. & (I .GE. 2 .and. I .LE. (IDE-1)-2+MOD(J,2))) THEN - HBM2(I,J)=1. + grid%hbm2(I,J)=1. ENDIF ENDDO ENDDO -!! HBM3: +!! grid%hbm3: - HBM3=0. + grid%hbm3=0. DO J=JTS,MIN(JTE,JDE-1) - IHWG(J)=mod(J+1,2)-1 + grid%ihwg(J)=mod(J+1,2)-1 IF (J .ge. 4 .and. J .le. (JDE-1)-3) THEN - IHL=(IDS+1)-IHWG(J) + IHL=(IDS+1)-grid%ihwg(J) IHH=(IDE-1)-2 DO I=ITS,MIN(ITE,IDE-1) - IF (I .ge. IHL .and. I .le. IHH) HBM3(I,J)=1. + IF (I .ge. IHL .and. I .le. IHH) grid%hbm3(I,J)=1. ENDDO ENDIF ENDDO -!! VBM2 +!! grid%vbm2 - VBM2=0. + grid%vbm2=0. DO J=JTS,MIN(JTE,JDE-1) DO I=ITS,MIN(ITE,IDE-1) IF((J .ge. 3 .and. J .le. (JDE-1)-2) .AND. & (I .ge. 2 .and. I .le. (IDE-1)-1-MOD(J,2))) THEN - VBM2(I,J)=1. + grid%vbm2(I,J)=1. ENDIF ENDDO ENDDO -!! VBM3 +!! grid%vbm3 - VBM3=0. + grid%vbm3=0. DO J=JTS,MIN(JTE,JDE-1) DO I=ITS,MIN(ITE,IDE-1) IF((J .ge. 4 .and. J .le. (JDE-1)-3) .AND. & (I .ge. 3-MOD(J,2) .and. I .le. (IDE-1)-2)) THEN - VBM3(I,J)=1. + grid%vbm3(I,J)=1. ENDIF ENDDO ENDDO @@ -2543,8 +2573,8 @@ SUBROUTINE med_initialize_nest_nmm( grid & WB = WBD*DTR SBD = grid%SBD0 ! gopal's doing: may use Registry SBD0 now SB = SBD*DTR - DLM = DLMD*DTR ! input now from med_nest_egrid_configure - DPH = DPHD*DTR ! input now from med_nest_egrid_configure + DLM = grid%dlmd*DTR ! input now from med_nest_egrid_configure + DPH = grid%dphd*DTR ! input now from med_nest_egrid_configure TDLM = DLM+DLM TDPH = DPH+DPH WBI = WB+TDLM @@ -2556,7 +2586,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & TSPH = 3600./grid%DT DTAD = 1.0 DTCF = 4.0 - DY_NMM0= DY_NMM ! ERAD*DPH; input now from med_nest_egrid_configure + DY_NMM0= grid%dy_nmm ! ERAD*DPH; input now from med_nest_egrid_configure ! CORIOLIS PARAMETER (There appears to be some roundoff in computing TLM & STPH and other terms, ! in the nested domain. The problem needs to be revisited @@ -2569,7 +2599,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO I=ITS,MIN(ITE,IDE-1) TLM=TLM0 + I*TDLM FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM)) - F(I,J)=0.5*grid%DT*FP + grid%f(I,J)=0.5*grid%DT*FP ENDDO ENDDO @@ -2603,25 +2633,25 @@ SUBROUTINE med_initialize_nest_nmm( grid & ! --------------DERIVED VERTICAL GRID CONSTANTS-------------------------- - WRITE(message,*)'NEW CHANGE',F4D,EF4T,F4Q + WRITE(message,*)'NEW CHANGE',grid%f4d,grid%ef4t,grid%f4q CALL wrf_message(trim(message)) DO L=KDS,KDE-1 - RDETA(L)=1./DETA(L) - F4Q2(L)=-.25*grid%DT*DTAD/DETA(L) + grid%rdeta(L)=1./grid%deta(L) + grid%f4q2(L)=-.25*grid%DT*DTAD/grid%deta(L) ENDDO DO J=JTS,MIN(JTE,JDE-1) DO I=ITS,MIN(ITE,IDE-1) - DX_NMM(I,J)=DXJ(J) - WPDAR(I,J)=WPDARJ(J)*HBM2(I,J) - CPGFU(I,J)=CPGFUJ(J)*VBM2(I,J) - CURV(I,J)=CURVJ(J)*VBM2(I,J) - FCP(I,J)=FCPJ(J)*HBM2(I,J) - FDIV(I,J)=FDIVJ(J)*HBM2(I,J) - FAD(I,J)=FADJ(J) - HDACV(I,J)=HDACJ(J)*VBM2(I,J) - HDAC(I,J)=HDACJ(J)*1.25*HBM2(I,J) + grid%dx_nmm(I,J)=DXJ(J) + grid%wpdar(I,J)=WPDARJ(J)*grid%hbm2(I,J) + grid%cpgfu(I,J)=CPGFUJ(J)*grid%vbm2(I,J) + grid%curv(I,J)=CURVJ(J)*grid%vbm2(I,J) + grid%fcp(I,J)=FCPJ(J)*grid%hbm2(I,J) + grid%fdiv(I,J)=FDIVJ(J)*grid%hbm2(I,J) + grid%fad(I,J)=FADJ(J) + grid%hdacv(I,J)=HDACJ(J)*grid%vbm2(I,J) + grid%hdac(I,J)=HDACJ(J)*1.25*grid%hbm2(I,J) ENDDO ENDDO @@ -2630,21 +2660,21 @@ SUBROUTINE med_initialize_nest_nmm( grid & KHH=(IDE-1)-2+MOD(J,2) ! KHH is global...loop over I that have DO I=ITS,MIN(ITE,IDE-1) IF (I .ge. 2 .and. I .le. KHH) THEN - HDAC(I,J)=HDAC(I,J)* DFC + grid%hdac(I,J)=grid%hdac(I,J)* DFC ENDIF ENDDO ELSE KHH=2+MOD(J,2) DO I=ITS,MIN(ITE,IDE-1) IF (I .ge. 2 .and. I .le. KHH) THEN - HDAC(I,J)=HDAC(I,J)* DFC + grid%hdac(I,J)=grid%hdac(I,J)* DFC ENDIF ENDDO KHH=(IDE-1)-2+MOD(J,2) DO I=ITS,MIN(ITE,IDE-1) IF (I .ge. (IDE-1)-2 .and. I .le. KHH) THEN - HDAC(I,J)=HDAC(I,J)* DFC + grid%hdac(I,J)=grid%hdac(I,J)* DFC ENDIF ENDDO ENDIF @@ -2652,9 +2682,9 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO J=JTS,min(JTE,JDE-1) DO I=ITS,min(ITE,IDE-1) - DDMPU(I,J)=DDMPUJ(J)*VBM2(I,J) - DDMPV(I,J)=DDMPVJ(J)*VBM2(I,J) - HDACV(I,J)=HDACV(I,J)*VBM2(I,J) + grid%ddmpu(I,J)=DDMPUJ(J)*grid%vbm2(I,J) + grid%ddmpv(I,J)=DDMPVJ(J)*grid%vbm2(I,J) + grid%hdacv(I,J)=grid%hdacv(I,J)*grid%vbm2(I,J) ENDDO ENDDO @@ -2665,26 +2695,26 @@ SUBROUTINE med_initialize_nest_nmm( grid & KVH=(IDE-1)-1-MOD(J,2) DO I=ITS,MIN(ITE,IDE-1) IF (I .ge. 2 .and. I .le. KVH) THEN - DDMPU(I,J)=DDMPU(I,J)*DDFC - DDMPV(I,J)=DDMPV(I,J)*DDFC - HDACV(I,J)=HDACV(I,J)*DFC + grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC + grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC + grid%hdacv(I,J)=grid%hdacv(I,J)*DFC ENDIF ENDDO ELSE KVH=3-MOD(J,2) DO I=ITS,MIN(ITE,IDE-1) IF (I .ge. 2 .and. I .le. KVH) THEN - DDMPU(I,J)=DDMPU(I,J)*DDFC - DDMPV(I,J)=DDMPV(I,J)*DDFC - HDACV(I,J)=HDACV(I,J)*DFC + grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC + grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC + grid%hdacv(I,J)=grid%hdacv(I,J)*DFC ENDIF ENDDO KVH=(IDE-1)-1-MOD(J,2) DO I=ITS,MIN(ITE,IDE-1) IF (I .ge. IDE-1-2 .and. I .le. KVH) THEN - DDMPU(I,J)=DDMPU(I,J)*DDFC - DDMPV(I,J)=DDMPV(I,J)*DDFC - HDACV(I,J)=HDACV(I,J)*DFC + grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC + grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC + grid%hdacv(I,J)=grid%hdacv(I,J)*DFC ENDIF ENDDO ENDIF @@ -2694,8 +2724,8 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO J = JTS, MIN(JTE,JDE-1) DO I = ITS, MIN(ITE,IDE-1) - GLAT(I,J)=HLAT(I,J)*DTR - GLON(I,J)=HLON(I,J)*DTR + grid%GLAT(I,J)=grid%HLAT(I,J)*DTR + grid%GLON(I,J)=grid%HLON(I,J)*DTR ENDDO ENDDO @@ -2716,22 +2746,22 @@ SUBROUTINE med_initialize_nest_nmm( grid & JA=JA+1 KHLA(JA)=2 KHHA(JA)=(IDE-1)-1-MOD(J+1,2) - 161 EMT(JA)=EMTJ(J) + 161 grid%emt(JA)=EMTJ(J) DO 162 J=(JDE-1)-4,(JDE-1)-2 JA=JA+1 KHLA(JA)=2 KHHA(JA)=(IDE-1)-1-MOD(J+1,2) - 162 EMT(JA)=EMTJ(J) + 162 grid%emt(JA)=EMTJ(J) DO 163 J=6,(JDE-1)-5 JA=JA+1 KHLA(JA)=2 KHHA(JA)=2+MOD(J,2) - 163 EMT(JA)=EMTJ(J) + 163 grid%emt(JA)=EMTJ(J) DO 164 J=6,(JDE-1)-5 JA=JA+1 KHLA(JA)=(IDE-1)-2 KHHA(JA)=(IDE-1)-1-MOD(J+1,2) - 164 EMT(JA)=EMTJ(J) + 164 grid%emt(JA)=EMTJ(J) ! --------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR---- @@ -2740,22 +2770,22 @@ SUBROUTINE med_initialize_nest_nmm( grid & JA=JA+1 KVLA(JA)=2 KVHA(JA)=(IDE-1)-1-MOD(J,2) - 171 EM(JA)=EMJ(J) + 171 grid%em(JA)=EMJ(J) DO 172 J=(JDE-1)-4,(JDE-2)-2 JA=JA+1 KVLA(JA)=2 KVHA(JA)=(IDE-1)-1-MOD(J,2) - 172 EM(JA)=EMJ(J) + 172 grid%em(JA)=EMJ(J) DO 173 J=6,(JDE-1)-5 JA=JA+1 KVLA(JA)=2 KVHA(JA)=2+MOD(J+1,2) - 173 EM(JA)=EMJ(J) + 173 grid%em(JA)=EMJ(J) DO 174 J=6,(JDE-1)-5 JA=JA+1 KVLA(JA)=(IDE-1)-2 KVHA(JA)=(IDE-1)-1-MOD(J,2) - 174 EM(JA)=EMJ(J) + 174 grid%em(JA)=EMJ(J) ! ENDIF ! wrf_dm_on_monitor @@ -2768,10 +2798,10 @@ SUBROUTINE med_initialize_nest_nmm( grid & DO K=KDS,KDE-1 ! DO J=JDS,JDE-1,2 ! V [H] V H IF (J .ge. JTS .and. J .le. JTE) THEN ! - U(IDE-1,J,K)=0. ! H [x] H V - V(IDE-1,J,K)=0. ! ------ ------ + grid%u(IDE-1,J,K)=0. ! H [x] H V + grid%v(IDE-1,J,K)=0. ! ------ ------ ENDIF ! ide-1 ide - ENDDO ! NMM/SI WRF + ENDDO ! NMM/si WRF ENDDO ! domain domain ENDIF ! (dummy) @@ -2779,8 +2809,8 @@ SUBROUTINE med_initialize_nest_nmm( grid & ! just a test for gravity waves ! PD=62000. -! U=0.0 -! V=0.0 +! grid%u=0.0 +! grid%v=0.0 ! T=300. ! Q=0.0 ! Q2=0.0 @@ -2791,8 +2821,8 @@ SUBROUTINE med_initialize_nest_nmm( grid & ! DO J = JTS, MIN(JTE,JDE-1) ! DO K = KTS,KTE ! DO I = ITS, MIN(ITE,IDE-1) -! SM(I,J)=I -! U(I,K,J)=J +! grid%sm(I,J)=I +! grid%u(I,K,J)=J ! ENDDO ! ENDDO ! ENDDO @@ -2999,7 +3029,7 @@ SUBROUTINE initial_nest_pivot ( parent , nest, iloc, jloc ) KTE = parent%ep33 NIDE = nest%ed31 - NJDE = nest%ed33 + NJDE = nest%ed32 parent_DLMD = parent%dx ! DLMD: dlamda in degrees parent_DPHD = parent%dy ! DPHD: dphi in degrees diff --git a/wrfv2_fire/dyn_nmm/module_ADVECTION.F b/wrfv2_fire/dyn_nmm/module_ADVECTION.F index 6b265985..35267f24 100644 --- a/wrfv2_fire/dyn_nmm/module_ADVECTION.F +++ b/wrfv2_fire/dyn_nmm/module_ADVECTION.F @@ -1038,7 +1038,6 @@ & ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ & & ,Q00,Q4P,QP,QP0 & & ,rdpdn,rdpup,sfacek,sfacqk,sfacwk,RFC,RR & - & ,rfacqk,rfacwk,rfacek,top,bot,dpdn,dpup & & ,SUMNE,SUMNQ,SUMNW,SUMPE,SUMPQ,SUMPW & & ,W00,W4P,WP,WP0 ! @@ -2942,9 +2941,868 @@ END SUBROUTINE HAD2_SCAL ! !----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + subroutine adv2 & +(UPSTRM & +,mype,kss,kse & +,ids,ide,jds,jde,kds,kde & +,ims,ime,jms,jme,kms,kme & +,its,ite,jts,jte,kts,kte & +,N_IUP_H & +,N_IUP_ADH & +,IUP_H,IUP_ADH & +,ENT & +,idtad & +,dt,pdtop & +,ihe,ihw,ive,ivw & +,deta1,deta2 & +,EMT_LOC & +,fad,hbm2,pdsl,pdslo & +,petdt & +,UOLD,VOLD & +,s,sp & +!---temporary arguments------------------------------------------------- +,fne,fse,few,fns,s1,tcs) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +implicit none +!----------------------------------------------------------------------- +real,parameter:: & + cfc=1.533 & ! adams-bashforth positioning in time +,bfc=1.-cfc & ! adams bashforth positioning in time +,cflc=9.005 & ! +,epsq=1.e-20 & ! floor value for specific humidity +,epsq2=0.2 & ! floor value for 2tke +,epscm=2.e-6 & ! a floor value (not used) +,w1=1.0 & ! crank-nicholson uncentering +!,w1=-1.00 & ! crank-nicholson uncentering +,w2=2.-w1 ! crank-nicholson uncentering + +logical,intent(in):: & + upstrm + +integer,intent(in):: & + idtad & ! time step multiplier +,kse & ! terminal species index +,kss & ! initial species index +,mype & ! +,ids,ide,jds,jde,kds,kde & +,ims,ime,jms,jme,kms,kme & +,its,ite,jts,jte,kts,kte + +real,intent(in):: & + ent & ! +,dt & ! dynamics time step +,pdtop ! + +real,dimension(kts:kte),intent(in):: & + deta1 & ! delta sigmas +,deta2 ! delta pressures + +integer,dimension(jms:jme),intent(in):: & + ihe,ihw,ive,ivw & +,n_iup_adh,n_iup_h + +integer,dimension(ims:ime,jms:jme),intent(in):: & + iup_h,iup_adh + +real,dimension(2600),intent(in):: & !!!zj see nmm_max_dim in adve !!!zj + emt_loc + +real,dimension(ims:ime,jms:jme),intent(in):: & + fad & ! +,hbm2 & ! +,pdsl & ! sigma range pressure difference +,pdslo ! sigma range pressure difference + +real,dimension(ims:ime,jms:jme,kms:kme),intent(in):: & + petdt & ! vertical mass flux +,uold,vold + +real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: & + s ! tracers + +real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: & + sp ! s at previous time level + +!---temporary arguments------------------------------------------------- +real,dimension(ims:ime,jms:jme,kms:kme),intent(in):: & + fne & ! mass flux, ne direction +,fse & ! mass flux, se direction +,few & ! mass flux, x direction +,fns ! mass flux, y direction + +real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: & + s1 & ! intermediate value of s +,tcs ! timechange of s + +!--local variables------------------------------------------------------ +integer:: & + i & ! +,j & ! +,k & ! +,ks ! + + INTEGER :: IEND,IFP,IFQ,II,IPQ,ISP,ISQ,ISTART & + & ,IUP_ADH_J & + & ,J1,JA,JAK,JEND,JGLOBAL,JJ,JKNT,JP2,JSTART & + & ,KNTI_ADH,KSTART,KSTOP & + & ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J + + INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB + +real:: & + cf & ! temporary +,cms & ! temporary +,dtq & ! dt/4 +,fahp & ! temporary grid factor +,sn & ! +,rdp & ! 1/deltap +,vvlo & ! vertical velocity, lower interface +,vvup & ! vertical velocity, upper interface +,pvvup ! vertical mass flux, upper interface + + REAL :: ARRAY3_X & + & ,F0,F1,F2,F3 & + & ,PP & + & ,QP & + & ,TEMPA,TEMPB,TTA,TTB + +real,dimension(kts:kte):: & + deta1_pdtop ! + + INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ISPA,ISQA + +real,dimension(its-5:ite+5,jts-5:jte+5):: & + pdop & ! hydrostatic pressure difference at h points +,pvvlo & ! vertical mass flux, lower interface +,ss1 & ! extrapolated species between time levels +,ssne & ! flux, ne direction +,ssse & ! flux, nw direction +,ssx & ! flux, x direction +,ssy ! flux, y direction + + REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ARRAY0,ARRAY1 & + & ,ARRAY2,ARRAY3 + +real,dimension(its-5:ite+5,jts-5:jte+5,kts:kte):: & + crs & ! vertical advection temporary +,rcms ! vertical advection temporary + +real,dimension(its-5:ite+5,jts-5:jte+5,kts:kte,kss:kse):: & + rsts ! vertical advection temporary +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + DO J=JTS-5,JTE+5 + DO I=ITS-5,ITE+5 + pdop (i,j)=0. + pvvlo(i,j)=0. + ss1 (i,j)=0. + ssne (i,j)=0. + ssse (i,j)=0. + enddo + enddo +! + DO K=KTS,KTE + DO J=JTS-5,JTE+5 + DO I=ITS-5,ITE+5 + crs (i,j,k)=0. + rcms(i,j,k)=0. + enddo + enddo + enddo +! + do ks=kss,kse + DO K=KTS,KTE + DO J=JTS-5,JTE+5 + DO I=ITS-5,ITE+5 + rsts(i,j,k,ks)=0. + s1 (i,j,k,ks)=0. + enddo + enddo + enddo + enddo +! + do ks=kss,kse + DO K=KMS,KME + DO J=JMS,JME + DO I=IMS,IME + s1 (i,j,k,ks)=0. + tcs(i,j,k,ks)=0. + enddo + enddo + enddo + enddo +!----------------------------------------------------------------------- + do k=kts,kte + deta1_pdtop(k)=deta1(k)*pdtop + enddo +!----------------------------------------------------------------------- + do ks=kss,kse ! loop by species +!----------------------------------------------------------------------- + DO K=KTS,KTE + DO J=MYJS_P4,MYJE_P4 + DO I=MYIS_P4,MYIE_P4 + s1(i,j,k,ks)=sqrt(s(i,j,k,ks)) + enddo + enddo + enddo +!----------------------------------------------------------------------- + enddo ! end of the loop by species !----------------------------------------------------------------------- + DO J=MYJS_P4,MYJE_P4 + DO I=MYIS_P4,MYIE_P4 + pdop(i,j)=(pdslo(i,j)+pdsl(i,j))*0.5 + enddo + enddo +!---crank-nicholson vertical advection---------------------------------- + dtq=dt*idtad*0.25 + + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + pvvlo(i,j)=petdt(i,j,kte-1)*dtq + vvlo=pvvlo(i,j)/(deta2(kte)*pdop(i,j)+deta1_pdtop(kte)) ! - END MODULE MODULE_ADVECTION + cms=-vvlo*w2+1. + rcms(i,j,kte)=1./cms + crs(i,j,kte)=vvlo*w2 +! + do ks=kss,kse + rsts(i,j,kte,ks)=(-vvlo*w1) & + *(s1(i,j,kte-1,ks)-s1(i,j,kte,ks)) & + +s1(i,j,kte,ks) + enddo + enddo + enddo + DO K=KTE-1,KTS+1,-1 + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + rdp=1./(deta2(k)*pdop(i,j)+deta1_pdtop(k)) + pvvup=pvvlo(i,j) + pvvlo(i,j)=petdt(i,j,k-1)*dtq +! + vvup=pvvup*rdp + vvlo=pvvlo(i,j)*rdp +! +! if(abs(vvlo).gt.cflc) then +! if(vvlo.lt.0.) then +! vvlo=-cflc +! else +! vvlo= cflc +! endif +! endif +! + cf=-vvup*w2*rcms(i,j,k+1) + cms=-crs(i,j,k+1)*cf+((vvup-vvlo)*w2+1.) + rcms(i,j,k)=1./cms + crs(i,j,k)=vvlo*w2 +! + do ks=kss,kse + rsts(i,j,k,ks)=-rsts(i,j,k+1,ks)*cf+s1(i,j,k,ks) & + -(s1(i,j,k ,ks)-s1(i,j,k+1,ks))*vvup*w1 & + -(s1(i,j,k-1,ks)-s1(i,j,k ,ks))*vvlo*w1 + enddo + enddo + enddo + enddo + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + pvvup=pvvlo(i,j) + vvup=pvvup/(deta2(kts)*pdop(i,j)+deta1_pdtop(kts)) +! + cf=-vvup*w2*rcms(i,j,kts+1) + cms=-crs(i,j,kts+1)*cf+(vvup*w2+1.) + rcms(i,j,kts)=1./cms + crs(i,j,kts)=0. +! + do ks=kss,kse + rsts(i,j,kts,ks)=-rsts(i,j,kts+1,ks)*cf+s1(i,j,kts,ks) & + -(s1(i,j,kts,ks)-s1(i,j,kts+1,ks))*vvup*w1 +! + tcs(i,j,kts,ks)=rsts(i,j,kts,ks)*rcms(i,j,kts)-s1(i,j,kts,ks) + enddo + enddo + enddo + do ks=kss,kse + DO K=KTS+1,KTE + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + tcs(i,j,k,ks)=(-crs(i,j,k)*(s1(i,j,k-1,ks)+tcs(i,j,k-1,ks)) & + +rsts(i,j,k,ks)) & + *rcms(i,j,k)-s1(i,j,k,ks) + enddo + enddo + enddo + enddo +!----------------------------------------------------------------------- + do ks=kss,kse ! loop by species +!----------------------------------------------------------------------- + DO K=KTS,KTE + DO J=MYJS_P5,MYJE_P5 + DO I=MYIS_P5,MYIE_P5 + ss1(i,j)=s1(i,j,k,ks)*cfc+sp(i,j,k,ks)*bfc + sp(i,j,k,ks)=s1(i,j,k,ks) + enddo + enddo +!---fluxes-------------------------------------------------------------- + DO J=MYJS1_P2,MYJE1_P2 + DO I=MYIS_P2,MYIE_P3 + ssx(i,j)=(ss1(i+ive(j),j )-ss1(i+ivw(j),j ))*few(i,j,k) & + *hbm2(i,j) + ssy(i,j)=(ss1(i ,j+1)-ss1(i ,j-1))*fns(i,j,k) & + *hbm2(i,j) + enddo + enddo + DO J=MYJS1_P2,MYJE2_P2 + DO I=MYIS_P2,MYIE_P2 + ssne(i,j)=(ss1(i+ihe(j),j+1)-ss1(i,j))*fne(i,j,k)*hbm2(i,j) + enddo + enddo + DO J=MYJS2_P2,MYJE1_P2 + DO I=MYIS_P2,MYIE_P2 + ssse(i,j)=(ss1(i+ihe(j),j-1)-ss1(i,j))*fse(i,j,k)*hbm2(i,j) + enddo + enddo +!---advection of species------------------------------------------------ + DO J=MYJS5,MYJE5 + DO I=MYIS2,MYIE2 + tcs(i,j,k,ks)=((ssx (i+ihw(j),j )+ssx (i+ihe(j),j ) & + +ssy (i ,j-1)+ssy (i ,j+1) & + +ssne(i+ihw(j),j-1)+ssne(i ,j ) & + +ssse(i ,j )+ssse(i+ihw(j),j+1)) & + *fad(i,j)*2.0*idtad & !! 2.0 compensates for fad + /(deta2(k)*pdop(i,j)+deta1_pdtop(k)) & + +tcs(i,j,k,ks))*hbm2(i,j) + enddo + enddo +!----------------------------------------------------------------------- +! +!*** upstream advection +! +!----------------------------------------------------------------------- +! + upstream: IF(UPSTRM)THEN +! +!----------------------------------------------------------------------- +!*** +!*** COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS. +!*** +!----------------------------------------------------------------------- +! + jloop_upstream: DO J=MYJS2,MYJE2 +! + N_IUPH_J=N_IUP_H(J) ! See explanation in START_DOMAIN_NMM + DO II=0,N_IUPH_J-1 +! + I=IUP_H(IMS+II,J) + tta=emt_loc(j) & + *(uold(i ,j-1,k)+uold(i+ihw(j),j ,k) & + +uold(i+ihe(j),j ,k)+uold(i ,j+1,k)) + ttb=ent & + *(vold(i ,j-1,k)+vold(i+ihw(j),j ,k) & + +vold(i+ihe(j),j ,k)+vold(i ,j+1,k)) + PP=-TTA-TTB + QP= TTA-TTB +! + IF(PP<0.)THEN + ISPA(I,J)=-1 + ELSE + ISPA(I,J)= 1 + ENDIF +! + IF(QP<0.)THEN + ISQA(I,J)=-1 + ELSE + ISQA(I,J)= 1 + ENDIF +! + PP=ABS(PP) + QP=ABS(QP) + ARRAY3_X=PP*QP + ARRAY0(I,J)=ARRAY3_X-PP-QP + ARRAY1(I,J)=PP-ARRAY3_X + ARRAY2(I,J)=QP-ARRAY3_X + ARRAY3(I,J)=ARRAY3_X + ENDDO +! +!----------------------------------------------------------------------- +! + N_IUPADH_J=N_IUP_ADH(J) + KNTI_ADH=1 + IUP_ADH_J=IUP_ADH(IMS,J) +! + iloop_T: DO II=0,N_IUPH_J-1 +! + I=IUP_H(IMS+II,J) +! + ISP=ISPA(I,J) + ISQ=ISQA(I,J) + IFP=(ISP-1)/2 + IFQ=(-ISQ-1)/2 + IPQ=(ISP-ISQ)/2 +! +!----------------------------------------------------------------------- +! + IF(I==IUP_ADH_J)THEN ! Upstream advection T tendencies +! + ISP=ISPA(I,J) + ISQ=ISQA(I,J) + IFP=(ISP-1)/2 + IFQ=(-ISQ-1)/2 + IPQ=(ISP-ISQ)/2 +! + F0=ARRAY0(I,J) + F1=ARRAY1(I,J) + F2=ARRAY2(I,J) + F3=ARRAY3(I,J) +! + tcs(i,j,k,ks)=(f0*s1(i,j,k,ks) & + & +f1*s1(i+ihe(j)+ifp,j+isp,k,ks) & + & +f2*s1(i+ihe(j)+ifq,j+isq,k,ks) & + & +f3*s1(i+ipq,j+isp+isq,k,ks))*2.0 & + & *idtad & + & +tcs(i,j,k,ks)*hbm2(i,j) +! +!----------------------------------------------------------------------- +! + IF(KNTI_ADH +#include ! ) @@ -55,7 +58,7 @@ CONTAINS !--------------------------------------------------------------------- SUBROUTINE init_domain_nmm ( grid & ! -# include +# include ! ) @@ -67,7 +70,7 @@ CONTAINS ! TYPE (domain), POINTER :: grid TYPE (domain) :: grid -# include +# include TYPE (grid_config_rec_type) :: config_flags @@ -123,7 +126,7 @@ CONTAINS INTEGER, ALLOCATABLE, DIMENSION(:):: KHL2,KVL2,KHH2,KVH2, & KHLA,KHHA,KVLA,KVHA -! INTEGER, ALLOCATABLE, DIMENSION(:,:):: LU_INDEX +! INTEGER, ALLOCATABLE, DIMENSION(:,:):: grid%lu_index REAL, ALLOCATABLE, DIMENSION(:):: DXJ,WPDARJ,CPGFUJ,CURVJ, & FCPJ,FDIVJ,EMJ,EMTJ,FADJ, & @@ -182,8 +185,8 @@ CONTAINS if (ALLOCATED(ADUM2D)) DEALLOCATE(ADUM2D) if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT) -#define COPY_IN -#include +!#define COPY_IN +!#include #ifdef DM_PARALLEL # include #endif @@ -344,8 +347,8 @@ CONTAINS config_flags%start_day, config_flags%start_hour 435 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':00:00') - dlmd=config_flags%dx - dphd=config_flags%dy + grid%dlmd=config_flags%dx + grid%dphd=config_flags%dy tph0d=config_flags%cen_lat tlm0d=config_flags%cen_lon @@ -373,7 +376,7 @@ CONTAINS num_metgrid_levels = grid%num_metgrid_levels - IF (ght_gc(its,jts,num_metgrid_levels/2) .lt. ght_gc(its,jts,num_metgrid_levels/2+1)) THEN + IF (grid%ght_gc(its,jts,num_metgrid_levels/2) .lt. grid%ght_gc(its,jts,num_metgrid_levels/2+1)) THEN write(message,*) 'normal ground up file order' @@ -386,32 +389,32 @@ CONTAINS write(message,*) 'reverse the order of coordinate' CALL wrf_message(message) - CALL reverse_vert_coord(ght_gc, 2, num_metgrid_levels & + CALL reverse_vert_coord(grid%ght_gc, 2, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) - CALL reverse_vert_coord(p_gc, 2, num_metgrid_levels & + CALL reverse_vert_coord(grid%p_gc, 2, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) - CALL reverse_vert_coord(t_gc, 2, num_metgrid_levels & + CALL reverse_vert_coord(grid%t_gc, 2, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) - CALL reverse_vert_coord(u_gc, 2, num_metgrid_levels & + CALL reverse_vert_coord(grid%u_gc, 2, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) - CALL reverse_vert_coord(v_gc, 2, num_metgrid_levels & + CALL reverse_vert_coord(grid%v_gc, 2, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) - CALL reverse_vert_coord(rh_gc, 2, num_metgrid_levels & + CALL reverse_vert_coord(grid%rh_gc, 2, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) @@ -423,20 +426,20 @@ CONTAINS ! limit extreme deviations from source model topography ! due to potential for nasty extrapolation/interpolation issues ! - write(message,*) 'min, max of ht_gc before adjust: ', minval(ht_gc), maxval(ht_gc) + write(message,*) 'min, max of grid%ht_gc before adjust: ', minval(grid%ht_gc), maxval(grid%ht_gc) CALL wrf_debug(100,message) ICOUNT=0 DO J=JTS,min(JTE,JDE-1) DO I=ITS,min(ITE,IDE-1) - IF ((ht_gc(I,J) - ght_gc(I,J,2)) .LT. -150.) THEN - ht_gc(I,J)=ght_gc(I,J,2)-150. + IF ((grid%ht_gc(I,J) - grid%ght_gc(I,J,2)) .LT. -150.) THEN + grid%ht_gc(I,J)=grid%ght_gc(I,J,2)-150. IF (ICOUNT .LT. 20) THEN write(message,*) 'increasing NMM topo toward RUC ', I,J CALL wrf_debug(100,message) ICOUNT=ICOUNT+1 ENDIF - ELSEIF ((ht_gc(I,J) - ght_gc(I,J,2)) .GT. 150.) THEN - ht_gc(I,J)=ght_gc(I,J,2)+150. + ELSEIF ((grid%ht_gc(I,J) - grid%ght_gc(I,J,2)) .GT. 150.) THEN + grid%ht_gc(I,J)=grid%ght_gc(I,J,2)+150. IF (ICOUNT .LT. 20) THEN write(message,*) 'decreasing NMM topo toward RUC ', I,J CALL wrf_debug(100,message) @@ -446,29 +449,29 @@ CONTAINS END DO END DO - write(message,*) 'min, max of ht_gc after correct: ', minval(ht_gc), maxval(ht_gc) + write(message,*) 'min, max of ht_gc after correct: ', minval(grid%ht_gc), maxval(grid%ht_gc) CALL wrf_debug(100,message) ENDIF - CALL boundary_smooth(ht_gc,landmask, grid, 12 , 12 & + CALL boundary_smooth(grid%ht_gc,grid%landmask, grid, 12 , 12 & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - if (LANDMASK(I,J) .gt. 0.5) SM(I,J)=0. - if (LANDMASK(I,J) .le. 0.5) SM(I,J)=1. - if (tsk_gc(I,J) .gt. 0.) then - NMM_TSK(I,J)=tsk_gc(I,J) + if (grid%landmask(I,J) .gt. 0.5) grid%sm(I,J)=0. + if (grid%landmask(I,J) .le. 0.5) grid%sm(I,J)=1. + if (grid%tsk_gc(I,J) .gt. 0.) then + grid%nmm_tsk(I,J)=grid%tsk_gc(I,J) else - NMM_TSK(I,J)=t_gc(I,J,1) ! stopgap measure + grid%nmm_tsk(I,J)=grid%t_gc(I,J,1) ! stopgap measure endif ! - GLAT(I,J)=hlat_gc(I,J)*DEGRAD - GLON(I,J)=hlon_gc(I,J)*DEGRAD - WEASD(I,J)=SNOW(I,J) - XICE(I,J)=XICE_gc(I,J) + grid%glat(I,J)=grid%hlat_gc(I,J)*DEGRAD + grid%glon(I,J)=grid%hlon_gc(I,J)*DEGRAD + grid%weasd(I,J)=grid%snow(I,J) + grid%xice(I,J)=grid%xice_gc(I,J) ENDDO ENDDO ! First item is to define the target vertical coordinate @@ -477,7 +480,7 @@ CONTAINS eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) ptsgm = model_config_rec%ptsgm p_top_requested = grid%p_top_requested - pt=p_top_requested + grid%pt=p_top_requested if (internal_time_loop .eq. 1) then @@ -517,12 +520,12 @@ CONTAINS allocate(SGML1(1:KDE)) allocate(SGML2(1:KDE)) - CALL define_nmm_vertical_coord (kde-1, ptsgm, pt,pdtop, eta_levels, & - ETA1,DETA1,AETA1, & - ETA2,DETA2,AETA2, DFL, DFRLG ) + CALL define_nmm_vertical_coord (kde-1, ptsgm, grid%pt,grid%pdtop, eta_levels, & + grid%eta1,grid%deta1,grid%aeta1, & + grid%eta2,grid%deta2,grid%aeta2, grid%dfl, grid%dfrlg ) DO L=KDS,KDE-1 - DETA(L)=eta_levels(L)-eta_levels(L+1) + grid%deta(L)=eta_levels(L)-eta_levels(L+1) ENDDO endif @@ -537,31 +540,31 @@ CONTAINS DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - FIS(I,J)=ht_gc(I,J)*g + grid%fis(I,J)=grid%ht_gc(I,J)*g ! -! IF ( p_gc(I,J,1) .ne. 200100. .AND. (ht_gc(I,J) .eq. ght_gc(I,J,1)) .AND. ht_gc(I,J) .ne. 0) THEN - IF ( p_gc(I,J,1) .ne. 200100. .AND. (abs(ht_gc(I,J)-ght_gc(I,J,1)) .lt. 0.01) .AND. ht_gc(I,J) .ne. 0) THEN +! IF ( grid%p_gc(I,J,1) .ne. 200100. .AND. (grid%ht_gc(I,J) .eq. grid%ght_gc(I,J,1)) .AND. grid%ht_gc(I,J) .ne. 0) THEN + IF ( grid%p_gc(I,J,1) .ne. 200100. .AND. (abs(grid%ht_gc(I,J)-grid%ght_gc(I,J,1)) .lt. 0.01) .AND. grid%ht_gc(I,J) .ne. 0) THEN IF (mod(I,10) .eq. 0 .and. mod(J,10) .eq. 0) THEN - write(message,*) 'ht_gc and toposoil to swap, flag_soilhgt ::: ', & - I,J, ht_gc(I,J),toposoil(I,J),flag_soilhgt + write(message,*) 'grid%ht_gc and grid%toposoil to swap, flag_soilhgt ::: ', & + I,J, grid%ht_gc(I,J),grid%toposoil(I,J),flag_soilhgt CALL wrf_debug(10,message) ENDIF IF ( ( flag_soilhgt.EQ. 1 ) ) THEN - ght_gc(I,J,1)=toposoil(I,J) + grid%ght_gc(I,J,1)=grid%toposoil(I,J) ENDIF ENDIF ENDDO ENDDO - CALL compute_nmm_surfacep (ht_gc, ght_gc, p_gc , t_gc & - &, psfc_out, num_metgrid_levels & + CALL compute_nmm_surfacep (grid%ht_gc, grid%ght_gc, grid%p_gc , grid%t_gc & + &, grid%psfc_out, num_metgrid_levels & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) ! H points - CALL compute_3d_pressure (psfc_out,AETA1,AETA2 & - &, pdtop,pt,pd,p3d_out & + CALL compute_3d_pressure (grid%psfc_out,grid%aeta1,grid%aeta2 & + &, grid%pdtop,grid%pt,grid%pd,p3d_out & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) @@ -581,61 +584,61 @@ CONTAINS IF (K .eq. KTS) THEN IF (J .eq. JDS .and. I .lt. IDE-1) THEN ! S boundary - PDVP(I,J)=0.5*(PD(I,J)+PD(I+1,J)) - PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J)+PSFC_OUT(I+1,J)) + PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J)) + PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J)) ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary - PDVP(I,J)=0.5*(PD(I,J)+PD(I+1,J)) - PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J)+PSFC_OUT(I+1,J)) + PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J)) + PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J)) ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary - PDVP(I,J)=0.5*(PD(I,J-1)+PD(I,J+1)) - PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J-1)+PSFC_OUT(I,J+1)) + PDVP(I,J)=0.5*(grid%pd(I,J-1)+grid%pd(I,J+1)) + PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J-1)+grid%psfc_out(I,J+1)) ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary - PDVP(I,J)=0.5*(PD(I,J-1)+PD(I,J+1)) - PSFC_OUTV(I,J)=0.5*(PSFC_OUT(I,J-1)+PSFC_OUT(I,J+1)) + PDVP(I,J)=0.5*(grid%pd(I,J-1)+grid%pd(I,J+1)) + PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J-1)+grid%psfc_out(I,J+1)) ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary - PDVP(I,J)=PD(I,J) - PSFC_OUTV(I,J)=PSFC_OUT(I,J) + PDVP(I,J)=grid%pd(I,J) + PSFC_OUTV(I,J)=grid%psfc_out(I,J) ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row - PDVP(I,J)=0.25*(PD(I,J)+PD(I-1,J)+PD(I,J+1)+PD(I,J-1)) - PSFC_OUTV(I,J)=0.25*(PSFC_OUT(I,J)+PSFC_OUT(I-1,J)+ & - PSFC_OUT(I,J+1)+PSFC_OUT(I,J-1)) + PDVP(I,J)=0.25*(grid%pd(I,J)+grid%pd(I-1,J)+grid%pd(I,J+1)+grid%pd(I,J-1)) + PSFC_OUTV(I,J)=0.25*(grid%psfc_out(I,J)+grid%psfc_out(I-1,J)+ & + grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1)) ELSE ! interior odd row - PDVP(I,J)=0.25*(PD(I,J)+PD(I+1,J)+PD(I,J+1)+PD(I,J-1)) - PSFC_OUTV(I,J)=0.25*(PSFC_OUT(I,J)+PSFC_OUT(I+1,J)+ & - PSFC_OUT(I,J+1)+PSFC_OUT(I,J-1)) + PDVP(I,J)=0.25*(grid%pd(I,J)+grid%pd(I+1,J)+grid%pd(I,J+1)+grid%pd(I,J-1)) + PSFC_OUTV(I,J)=0.25*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J)+ & + grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1)) ENDIF ENDIF IF (J .eq. JDS .and. I .lt. IDE-1) THEN ! S boundary - P3DV_IN(I,J,K)=0.5*(p_gc(I,J,K)+p_gc(I+1,J,K)) + P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K)) ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary - P3DV_IN(I,J,K)=0.5*(p_gc(I,J,K)+p_gc(I+1,J,K)) + P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K)) ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary - P3DV_IN(I,J,K)=0.5*(p_gc(I,J-1,K)+p_gc(I,J+1,K)) + P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J-1,K)+grid%p_gc(I,J+1,K)) ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary - P3DV_IN(I,J,K)=0.5*(p_gc(I,J-1,K)+p_gc(I,J+1,K)) + P3DV_IN(I,J,K)=0.5*(grid%p_gc(I,J-1,K)+grid%p_gc(I,J+1,K)) ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary - P3DV_IN(I,J,K)=p_gc(I,J,K) + P3DV_IN(I,J,K)=grid%p_gc(I,J,K) ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row - P3DV_IN(I,J,K)=0.25*(p_gc(I,J,K)+p_gc(I-1,J,K) + & - p_gc(I,J+1,K)+p_gc(I,J-1,K)) + P3DV_IN(I,J,K)=0.25*(grid%p_gc(I,J,K)+grid%p_gc(I-1,J,K) + & + grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K)) ELSE ! interior odd row - P3DV_IN(I,J,K)=0.25*(p_gc(I,J,K)+p_gc(I+1,J,K) + & - p_gc(I,J+1,K)+p_gc(I,J-1,K)) + P3DV_IN(I,J,K)=0.25*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K) + & + grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K)) ENDIF enddo enddo enddo - CALL compute_3d_pressure (psfc_outv,AETA1,AETA2 & - &, pdtop,pt,pdvp,p3dv_out & + CALL compute_3d_pressure (psfc_outv,grid%aeta1,grid%aeta2 & + &, grid%pdtop,grid%pt,pdvp,p3dv_out & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) - CALL interp_press2press_lin(p_gc, p3d_out & - &, t_gc, T,num_metgrid_levels & + CALL interp_press2press_lin(grid%p_gc, p3d_out & + &, grid%t_gc, grid%t,num_metgrid_levels & &, .TRUE.,.TRUE.,.TRUE. & ! extrap, ignore_lowest, t_field &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & @@ -643,21 +646,21 @@ CONTAINS CALL interp_press2press_lin(p3dv_in, p3dv_out & - &, u_gc, U,num_metgrid_levels & + &, grid%u_gc, grid%u,num_metgrid_levels & &, .FALSE.,.TRUE.,.FALSE. & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop ) CALL interp_press2press_lin(p3dv_in, p3dv_out & - &, V_gc, V,num_metgrid_levels & + &, grid%v_gc, grid%v,num_metgrid_levels & &, .FALSE.,.TRUE.,.FALSE. & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop ) IF (hyb_coor) THEN - CALL wind_adjust(p3dv_in,p3dv_out,U_gc,V_gc,U,V & + CALL wind_adjust(p3dv_in,p3dv_out,grid%u_gc,grid%v_gc,grid%u,grid%v & &, num_metgrid_levels,5000. & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & @@ -668,7 +671,7 @@ CONTAINS ALLOCATE(qtmp(IMS:IME,JMS:JME,num_metgrid_levels)) ALLOCATE(qtmp2(IMS:IME,JMS:JME,num_metgrid_levels)) - CALL rh_to_mxrat (rh_gc, t_gc, p_gc, qtmp , .TRUE. , & + CALL rh_to_mxrat (grid%rh_gc, grid%t_gc, grid%p_gc, qtmp , .TRUE. , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) @@ -681,8 +684,8 @@ CONTAINS end do end do - CALL interp_press2press_log(p_gc, p3d_out & - &, QTMP2, Q,num_metgrid_levels & + CALL interp_press2press_log(grid%p_gc, p3d_out & + &, QTMP2, grid%q,num_metgrid_levels & &, .FALSE.,.TRUE. & &, IDS,IDE,JDS,JDE,KDS,KDE & &, IMS,IME,JMS,JME,KMS,KME & @@ -693,23 +696,23 @@ CONTAINS ! Get the monthly values interpolated to the current date ! for the traditional monthly - ! fields of green-ness fraction and background albedo. + ! fields of green-ness fraction and background grid%albedo. - if (internal_time_loop .eq. 1) then + if (internal_time_loop .eq. 1 .or. config_flags%sst_update .eq. 1) then - CALL monthly_interp_to_date ( greenfrac_gc , current_date , vegfra , & + CALL monthly_interp_to_date ( grid%greenfrac_gc , current_date , grid%vegfra , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) - CALL monthly_interp_to_date ( albedo12m_gc , current_date , albbck , & + CALL monthly_interp_to_date ( grid%albedo12m_gc , current_date , grid%albbck , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) ! Get the min/max of each i,j for the monthly green-ness fraction. - CALL monthly_min_max ( greenfrac_gc , shdmin , shdmax , & + CALL monthly_min_max ( grid%greenfrac_gc , grid%shdmin , grid%shdmax , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -718,31 +721,31 @@ CONTAINS DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) -!! vegfra(i,j) = vegfra(i,j) * 100. - shdmax(i,j) = shdmax(i,j) * 100. - shdmin(i,j) = shdmin(i,j) * 100. - VEGFRC(I,J)=VEGFRA(I,J) +!! grid%vegfra(i,j) = grid%vegfra(i,j) * 100. + grid%shdmax(i,j) = grid%shdmax(i,j) * 100. + grid%shdmin(i,j) = grid%shdmin(i,j) * 100. + grid%vegfrc(I,J)=grid%vegfra(I,J) END DO END DO - ! The model expects the albedo fields as + ! The model expects the grid%albedo fields as ! a fraction, not a percent. Set the water values to 8%. DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - if (albbck(i,j) .lt. 5.) then - write(message,*) 'reset albedo to 8%... I,J,albbck:: ', I,J,albbck(I,J) + if (grid%albbck(i,j) .lt. 5.) then + write(message,*) 'reset grid%albedo to 8%... I,J,grid%albbck:: ', I,J,grid%albbck(I,J) CALL wrf_debug(10,message) - albbck(I,J)=8. + grid%albbck(I,J)=8. endif - albbck(i,j) = albbck(i,j) / 100. - snoalb(i,j) = snoalb(i,j) / 100. - IF ( landmask(i,j) .LT. 0.5 ) THEN - albbck(i,j) = 0.08 - snoalb(i,j) = 0.08 + grid%albbck(i,j) = grid%albbck(i,j) / 100. + grid%snoalb(i,j) = grid%snoalb(i,j) / 100. + IF ( grid%landmask(i,j) .LT. 0.5 ) THEN + grid%albbck(i,j) = 0.08 + grid%snoalb(i,j) = 0.08 END IF - albase(i,j)=albbck(i,j) - mxsnal(i,j)=snoalb(i,j) + grid%albase(i,j)=grid%albbck(i,j) + grid%mxsnal(i,j)=grid%snoalb(i,j) END DO END DO @@ -753,75 +756,104 @@ CONTAINS END IF ! <----- END OF VERTICAL INTERPOLATION PART ----> + +!! compute SST at each time if updating SST + if (config_flags%sst_update == 1) then + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + + if (grid%SM(I,J) .lt. 0.5) then + grid%SST(I,J)=0. + endif + + if (grid%SM(I,J) .gt. 0.5) then + grid%SST(I,J)=grid%NMM_TSK(I,J) + grid%NMM_TSK(I,J)=0. + endif + + IF ( (grid%NMM_TSK(I,J)+grid%SST(I,J)) .lt. 200. .or. & + (grid%NMM_TSK(I,J)+grid%SST(I,J)) .gt. 350. ) THEN + write(message,*) 'TSK, SST trouble at : ', I,J + CALL wrf_message(message) + write(message,*) 'SM, NMM_TSK,SST ', grid%SM(I,J),grid%NMM_TSK(I,J),grid%SST(I,J) + CALL wrf_message(message) + ENDIF + + ENDDO + ENDDO + + endif ! sst_update test + if (internal_time_loop .eq. 1) then -!!! WEASD has "snow water equivalent" in mm +!!! grid%weasd has "grid%snow water equivalent" in mm DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - IF(SM(I,J).GT.0.9) THEN + IF(grid%sm(I,J).GT.0.9) THEN - IF (XICE(I,J) .gt. 0) then - SI(I,J)=1.0 + IF (grid%xice(I,J) .gt. 0) then + grid%si(I,J)=1.0 ENDIF ! SEA - EPSR(I,J)=.97 - EMBCK(I,J)=.97 - GFFC(I,J)=0. - ALBEDO(I,J)=.06 - ALBASE(I,J)=.06 - IF(SI (I,J).GT.0. ) THEN + grid%epsr(I,J)=.97 + grid%embck(I,J)=.97 + grid%gffc(I,J)=0. + grid%albedo(I,J)=.06 + grid%albase(I,J)=.06 + IF(grid%si (I,J).GT.0. ) THEN ! SEA-ICE - SM(I,J)=0. - SI(I,J)=0. - SICE(I,J)=1. - GFFC(I,J)=0. ! just leave zero as irrelevant - ALBEDO(I,J)=.60 - ALBASE(I,J)=.60 + grid%sm(I,J)=0. + grid%si(I,J)=0. + grid%sice(I,J)=1. + grid%gffc(I,J)=0. ! just leave zero as irrelevant + grid%albedo(I,J)=.60 + grid%albase(I,J)=.60 ENDIF ELSE - SI(I,J)=5.0*WEASD(I,J)/1000. + grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! LAND - EPSR(I,J)=1.0 - EMBCK(I,J)=1.0 - GFFC(I,J)=0.0 ! just leave zero as irrelevant - SICE(I,J)=0. - SNO(I,J)=SI(I,J)*.20 + grid%epsr(I,J)=1.0 + grid%embck(I,J)=1.0 + grid%gffc(I,J)=0.0 ! just leave zero as irrelevant + grid%sice(I,J)=0. + grid%sno(I,J)=grid%si(I,J)*.20 ENDIF ENDDO ENDDO -! DETERMINE ALBEDO OVER LAND +! DETERMINE grid%albedo OVER LAND DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - IF(SM(I,J).LT.0.9.AND.SICE(I,J).LT.0.9) THEN -! SNOWFREE ALBEDO - IF ( (SNO(I,J) .EQ. 0.0) .OR. & - (ALBASE(I,J) .GE. MXSNAL(I,J) ) ) THEN - ALBEDO(I,J) = ALBASE(I,J) + IF(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN +! SNOWFREE grid%albedo + IF ( (grid%sno(I,J) .EQ. 0.0) .OR. & + (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN + grid%albedo(I,J) = grid%albase(I,J) ELSE -! MODIFY ALBEDO IF SNOWCOVER: +! MODIFY grid%albedo IF SNOWCOVER: ! BELOW SNOWDEPTH THRESHOLD... - IF (SNO(I,J) .LT. SNUP) THEN - RSNOW = SNO(I,J)/SNUP + IF (grid%sno(I,J) .LT. SNUP) THEN + RSNOW = grid%sno(I,J)/SNUP SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP)) ! ABOVE SNOWDEPTH THRESHOLD... ELSE SNOFAC = 1.0 ENDIF -! CALCULATE ALBEDO ACCOUNTING FOR SNOWDEPTH AND VGFRCK - ALBEDO(I,J) = ALBASE(I,J) & - + (1.0-VEGFRA(I,J))*SNOFAC*(MXSNAL(I,J)-ALBASE(I,J)) +! CALCULATE grid%albedo ACCOUNTING FOR SNOWDEPTH AND VGFRCK + grid%albedo(I,J) = grid%albase(I,J) & + + (1.0-grid%vegfra(I,J))*SNOFAC*(grid%mxsnal(I,J)-grid%albase(I,J)) ENDIF END IF - SI(I,J)=5.0*WEASD(I,J) - SNO(I,J)=WEASD(I,J) + grid%si(I,J)=5.0*grid%weasd(I,J) + grid%sno(I,J)=grid%weasd(I,J) -!! convert VEGFRA - VEGFRA(I,J)=VEGFRA(I,J)*100. +!! convert grid%vegfra + grid%vegfra(I,J)=grid%vegfra(I,J)*100. ! ENDDO ENDDO @@ -830,14 +862,14 @@ CONTAINS ALLOCATE(SM_G(IDS:IDE,JDS:JDE),SICE_G(IDS:IDE,JDS:JDE)) - CALL WRF_PATCH_TO_GLOBAL_REAL( SICE(IMS,JMS) & + CALL WRF_PATCH_TO_GLOBAL_REAL( grid%sice(IMS,JMS) & &, SICE_G,grid%DOMDESC & &, 'z','xy' & &, IDS,IDE-1,JDS,JDE-1,1,1 & &, IMS,IME,JMS,JME,1,1 & &, ITS,ITE,JTS,JTE,1,1 ) - CALL WRF_PATCH_TO_GLOBAL_REAL( SM(IMS,JMS) & + CALL WRF_PATCH_TO_GLOBAL_REAL( grid%sm(IMS,JMS) & &, SM_G,grid%DOMDESC & &, 'z','xy' & &, IDS,IDE-1,JDS,JDE-1,1,1 & @@ -898,14 +930,14 @@ CONTAINS ENDIF - CALL WRF_GLOBAL_TO_PATCH_REAL( SICE_G, SICE & + CALL WRF_GLOBAL_TO_PATCH_REAL( SICE_G, grid%sice & &, grid%DOMDESC & &, 'z','xy' & &, IDS,IDE-1,JDS,JDE-1,1,1 & &, IMS,IME,JMS,JME,1,1 & &, ITS,ITE,JTS,JTE,1,1 ) - CALL WRF_GLOBAL_TO_PATCH_REAL( SM_G,SM & + CALL WRF_GLOBAL_TO_PATCH_REAL( SM_G,grid%sm & &, grid%DOMDESC & &, 'z','xy' & &, IDS,IDE-1,JDS,JDE-1,1,1 & @@ -922,7 +954,7 @@ CONTAINS ! write(message,*) 'revised sea ice on patch' ! CALL wrf_debug(100,message) ! DO J=JTE,JTS,-(((JTE-JTS)/25)+1) -! write(message,637) (SICE(I,J),I=ITS,ITE,ITE/20) +! write(message,637) (grid%sice(I,J),I=ITS,ITE,ITE/20) ! CALL wrf_debug(100,message) ! END DO @@ -940,23 +972,23 @@ CONTAINS ! any sea ice around point in question? - IF (SM(I,J) .gt. 0.9) THEN - SEAICESUM=SICE(I+IHE(J),J+1)+SICE(I+IHW(J),J+1)+ & - SICE(I+IHE(J),J-1)+SICE(I+IHW(J),J-1) + IF (grid%sm(I,J) .gt. 0.9) THEN + SEAICESUM=grid%sice(I+IHE(J),J+1)+grid%sice(I+IHW(J),J+1)+ & + grid%sice(I+IHE(J),J-1)+grid%sice(I+IHW(J),J-1) IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN - IF ((SICE(I+IHE(J),J+1).lt.0.1 .and. SM(I+IHE(J),J+1).lt.0.1) .OR. & - (SICE(I+IHW(J),J+1).lt.0.1 .and. SM(I+IHW(J),J+1).lt.0.1) .OR. & - (SICE(I+IHE(J),J-1).lt.0.1 .and. SM(I+IHE(J),J-1).lt.0.1) .OR. & - (SICE(I+IHW(J),J-1).lt.0.1 .and. SM(I+IHW(J),J-1).lt.0.1)) THEN + IF ((grid%sice(I+IHE(J),J+1).lt.0.1 .and. grid%sm(I+IHE(J),J+1).lt.0.1) .OR. & + (grid%sice(I+IHW(J),J+1).lt.0.1 .and. grid%sm(I+IHW(J),J+1).lt.0.1) .OR. & + (grid%sice(I+IHE(J),J-1).lt.0.1 .and. grid%sm(I+IHE(J),J-1).lt.0.1) .OR. & + (grid%sice(I+IHW(J),J-1).lt.0.1 .and. grid%sm(I+IHW(J),J-1).lt.0.1)) THEN ! HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE - SICE(I,J)=1.0 - SM(I,J)=0. + grid%sice(I,J)=1.0 + grid%sm(I,J)=0. ENDIF ELSEIF (SEAICESUM .ge. 3) THEN ! WATER POINT SURROUNDED BY ICE - CONVERT TO SEA ICE - SICE(I,J)=1.0 - SM(I,J)=0. + grid%sice(I,J)=1.0 + grid%sm(I,J)=0. ENDIF ENDIF @@ -966,28 +998,28 @@ CONTAINS #endif -! this block meant to guarantee land/sea agreement between SM and landmask +! this block meant to guarantee land/sea agreement between grid%sm and grid%landmask DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - IF (SM(I,J) .gt. 0.5) THEN - landmask(I,J)=0.0 - ELSEIF (SM(I,J) .lt. 0.5 .and. SICE(I,J) .gt. 0.9) then - landmask(I,J)=0.0 - ELSEIF (SM(I,J) .lt. 0.5 .and. SICE(I,J) .lt. 0.1) then - landmask(I,J)=1.0 + IF (grid%sm(I,J) .gt. 0.5) THEN + grid%landmask(I,J)=0.0 + ELSEIF (grid%sm(I,J) .lt. 0.5 .and. grid%sice(I,J) .gt. 0.9) then + grid%landmask(I,J)=0.0 + ELSEIF (grid%sm(I,J) .lt. 0.5 .and. grid%sice(I,J) .lt. 0.1) then + grid%landmask(I,J)=1.0 ELSE - write(message,*) 'missed point in landmask definition ' , I,J + write(message,*) 'missed point in grid%landmask definition ' , I,J CALL wrf_message(message) - landmask(I,J)=0.0 + grid%landmask(I,J)=0.0 ENDIF ! - IF (SICE(I,J) .gt. 0.5 .and. NMM_TSK(I,J) .lt. 0.1 .and. SST(I,J) .gt. 0.) THEN - write(message,*) 'set NMM_TSK to: ', SST(I,J) + IF (grid%sice(I,J) .gt. 0.5 .and. grid%nmm_tsk(I,J) .lt. 0.1 .and. grid%sst(I,J) .gt. 0.) THEN + write(message,*) 'set grid%nmm_tsk to: ', grid%sst(I,J) CALL wrf_message(message) - NMM_TSK(I,J)=SST(I,J) - SST(I,J)=0. + grid%nmm_tsk(I,J)=grid%sst(I,J) + grid%sst(I,J)=0. endif ENDDO @@ -1000,7 +1032,7 @@ CONTAINS ( flag_st000010 .EQ. 1 ) ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) - soiltb(i,j) = st000010(i,j) + grid%soiltb(i,j) = grid%st000010(i,j) END DO END DO END IF @@ -1015,22 +1047,22 @@ CONTAINS DO J=jms,jme DO I=ims,ime - HT(I,J)=FIS(I,J)/9.81 + HT(I,J)=grid%fis(I,J)/9.81 END DO END DO -! if (maxval(toposoil) .gt. 100.) then +! if (maxval(grid%toposoil) .gt. 100.) then ! ! Being avoided. Something to revisit eventually. ! -!1219 might be simply a matter of including TOPOSOIL +!1219 might be simply a matter of including grid%toposoil ! ! CODE NOT TESTED AT NCEP USING THIS FUNCTIONALITY, ! SO TO BE SAFE WILL AVOID FOR RETRO RUNS. ! -! CALL adjust_soil_temp_new ( soiltb , 2 , & -! nmm_tsk , ht , toposoil , landmask, flag_toposoil , & -! st000010 , st010040 , st040100 , st100200 , st010200 , & +! CALL adjust_soil_temp_new ( grid%soiltb , 2 , & +! grid%nmm_tsk , ht , grid%toposoil , grid%landmask, flag_toposoil , & +! grid%st000010 , st010040 , st040100 , st100200 , st010200 , & ! flag_st000010 , flag_st010040 , flag_st040100 , & ! flag_st100200 , flag_st010200 , & ! soilt000 , soilt005 , soilt020 , soilt040 , & @@ -1052,24 +1084,24 @@ CONTAINS ! (dominant category as input) IF ( config_flags%surface_input_source .EQ. 1 ) THEN - vegcat (its,jts) = 0 - soilcat(its,jts) = 0 + grid%vegcat (its,jts) = 0 + grid%soilcat(its,jts) = 0 END IF ! Generate the vegetation and soil category information ! from the fractional input ! data, or use the existing dominant category fields if they exist. - IF ((soilcat(its,jts) .LT. 0.5) .AND. (vegcat(its,jts) .LT. 0.5)) THEN + IF ((grid%soilcat(its,jts) .LT. 0.5) .AND. (grid%vegcat(its,jts) .LT. 0.5)) THEN - num_veg_cat = SIZE ( landusef_gc , DIM=3 ) - num_soil_top_cat = SIZE ( soilctop_gc , DIM=3 ) - num_soil_bot_cat = SIZE ( soilcbot_gc , DIM=3 ) + num_veg_cat = SIZE ( grid%landusef_gc , DIM=3 ) + num_soil_top_cat = SIZE ( grid%soilctop_gc , DIM=3 ) + num_soil_bot_cat = SIZE ( grid%soilcbot_gc , DIM=3 ) do J=JMS,JME do K=1,num_veg_cat do I=IMS,IME - landusef(I,K,J)=landusef_gc(I,J,K) + grid%landusef(I,K,J)=grid%landusef_gc(I,J,K) enddo enddo enddo @@ -1077,7 +1109,7 @@ CONTAINS do J=JMS,JME do K=1,num_soil_top_cat do I=IMS,IME - soilctop(I,K,J)=soilctop_gc(I,J,K) + grid%soilctop(I,K,J)=grid%soilctop_gc(I,J,K) enddo enddo enddo @@ -1085,27 +1117,27 @@ CONTAINS do J=JMS,JME do K=1,num_soil_bot_cat do I=IMS,IME - soilcbot(I,K,J)=soilcbot_gc(I,J,K) + grid%soilcbot(I,K,J)=grid%soilcbot_gc(I,J,K) enddo enddo enddo -! sm (1=water, 0=land) -! landmask(0=water, 1=land) +! grid%sm (1=water, 0=land) +! grid%landmask(0=water, 1=land) - write(message,*) 'landmask into process_percent_cat_new' + write(message,*) 'grid%landmask into process_percent_cat_new' CALL wrf_debug(1,message) do J=JTE,JTS,-(((JTE-JTS)/20)+1) - write(message,641) (landmask(I,J),I=ITS,min(ITE,IDE-1),((ITE-ITS)/15)+1) + write(message,641) (grid%landmask(I,J),I=ITS,min(ITE,IDE-1),((ITE-ITS)/15)+1) CALL wrf_debug(1,message) enddo 641 format(25(f3.0,1x)) - CALL process_percent_cat_new ( landmask , & - landusef , soilctop , soilcbot , & - isltyp , ivgtyp , & + CALL process_percent_cat_new ( grid%landmask , & + grid%landusef , grid%soilctop , grid%soilcbot , & + grid%isltyp , grid%ivgtyp , & num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & @@ -1114,8 +1146,8 @@ CONTAINS DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) - vegcat(i,j) = ivgtyp(i,j) - soilcat(i,j) = isltyp(i,j) + grid%vegcat(i,j) = grid%ivgtyp(i,j) + grid%soilcat(i,j) = grid%isltyp(i,j) END DO END DO @@ -1123,17 +1155,17 @@ CONTAINS ! Do we have dominant soil and veg data from the input already? - IF ( soilcat(its,jts) .GT. 0.5 ) THEN + IF ( grid%soilcat(its,jts) .GT. 0.5 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - isltyp(i,j) = NINT( soilcat(i,j) ) + grid%isltyp(i,j) = NINT( grid%soilcat(i,j) ) END DO END DO END IF - IF ( vegcat(its,jts) .GT. 0.5 ) THEN + IF ( grid%vegcat(its,jts) .GT. 0.5 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - ivgtyp(i,j) = NINT( vegcat(i,j) ) + grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) ) END DO END DO END IF @@ -1143,21 +1175,21 @@ CONTAINS DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - IF (SICE(I,J) .lt. 0.1) THEN - IF (landmask(I,J) .gt. 0.5 .and. sm(I,J) .gt. 0.5) THEN - write(message,*) 'land mask and SM both > 0.5: ', & - I,J,landmask(I,J),sm(I,J) + IF (grid%sice(I,J) .lt. 0.1) THEN + IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J) .gt. 0.5) THEN + write(message,*) 'land mask and grid%sm both > 0.5: ', & + I,J,grid%landmask(I,J),grid%sm(I,J) CALL wrf_message(message) - SM(I,J)=0. - ELSEIF (landmask(I,J) .lt. 0.5 .and. sm(I,J) .lt. 0.5) THEN - write(message,*) 'land mask and SM both < 0.5: ', & - I,J, landmask(I,J),sm(I,J) + grid%sm(I,J)=0. + ELSEIF (grid%landmask(I,J) .lt. 0.5 .and. grid%sm(I,J) .lt. 0.5) THEN + write(message,*) 'land mask and grid%sm both < 0.5: ', & + I,J, grid%landmask(I,J),grid%sm(I,J) CALL wrf_message(message) - SM(I,J)=1. + grid%sm(I,J)=1. ENDIF ELSE - IF (landmask(I,J) .gt. 0.5 .and. SM(I,J)+SICE(I,J) .gt. 0.9) then - write(message,*) 'landmask says LAND, SM/SICE say SEAICE: ', I,J + IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J)+grid%sice(I,J) .gt. 0.9) then + write(message,*) 'grid%landmask says LAND, grid%sm/grid%sice say SEAICE: ', I,J ENDIF ENDIF @@ -1167,9 +1199,9 @@ CONTAINS DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - if (SICE(I,J) .gt. 0.9) then - ISLTYP(I,J)=16 - IVGTYP(I,J)=24 + if (grid%sice(I,J) .gt. 0.9) then + grid%isltyp(I,J)=16 + grid%ivgtyp(I,J)=24 endif ENDDO @@ -1178,40 +1210,40 @@ CONTAINS DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - if (SM(I,J) .lt. 0.5) then - SST(I,J)=0. + if (grid%sm(I,J) .lt. 0.5) then + grid%sst(I,J)=0. endif - if (SM(I,J) .gt. 0.5) then - if (SST(I,J) .lt. 0.1) then - SST(I,J)=NMM_TSK(I,J) + if (grid%sm(I,J) .gt. 0.5) then + if (grid%sst(I,J) .lt. 0.1) then + grid%sst(I,J)=grid%nmm_tsk(I,J) endif - NMM_TSK(I,J)=0. + grid%nmm_tsk(I,J)=0. endif - IF ( (NMM_TSK(I,J)+SST(I,J)) .lt. 200. .or. & - (NMM_TSK(I,J)+SST(I,J)) .gt. 350. ) THEN - write(message,*) 'TSK, SST trouble at : ', I,J + IF ( (grid%nmm_tsk(I,J)+grid%sst(I,J)) .lt. 200. .or. & + (grid%nmm_tsk(I,J)+grid%sst(I,J)) .gt. 350. ) THEN + write(message,*) 'TSK, grid%sst trouble at : ', I,J CALL wrf_message(message) - write(message,*) 'SM, NMM_TSK,SST ', SM(I,J),NMM_TSK(I,J),SST(I,J) + write(message,*) 'grid%sm, grid%nmm_tsk,grid%sst ', grid%sm(I,J),grid%nmm_tsk(I,J),grid%sst(I,J) CALL wrf_message(message) ENDIF ENDDO ENDDO - write(message,*) 'SM' + write(message,*) 'grid%sm' CALL wrf_message(message) DO J=min(jde-1,jte),jts,-((jte-jts)/15+1) - write(message,635) (sm(i,J),I=its,ite,((ite-its)/10)+1) + write(message,635) (grid%sm(i,J),I=its,ite,((ite-its)/10)+1) CALL wrf_message(message) END DO - write(message,*) 'SST/NMM_TSK' + write(message,*) 'grid%sst/grid%nmm_tsk' CALL wrf_debug(10,message) DO J=min(jde-1,jte),jts,-((jte-jts)/15+1) - write(message,635) (SST(I,J)+NMM_TSK(I,J),I=ITS,min(ide-1,ite),((ite-its)/10)+1) + write(message,635) (grid%sst(I,J)+grid%nmm_tsk(I,J),I=ITS,min(ide-1,ite),((ite-its)/10)+1) CALL wrf_debug(10,message) END DO @@ -1219,10 +1251,10 @@ CONTAINS DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN - soiltb(i,j) = sst(i,j) - ELSE IF ( landmask(i,j) .GT. 0.5 ) THEN - soiltb(i,j) = nmm_tsk(i,j) + IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN + grid%soiltb(i,j) = grid%sst(i,j) + ELSE IF ( grid%landmask(i,j) .GT. 0.5 ) THEN + grid%soiltb(i,j) = grid%nmm_tsk(i,j) END IF END DO END DO @@ -1231,11 +1263,11 @@ CONTAINS ! Land use categories, dominant soil and vegetation types (if available). -! allocate(lu_index(ims:ime,jms:jme)) +! allocate(grid%lu_index(ims:ime,jms:jme)) DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - lu_index(i,j) = ivgtyp(i,j) + grid%lu_index(i,j) = grid%ivgtyp(i,j) END DO END DO @@ -1260,12 +1292,12 @@ CONTAINS IF (.NOT. ALLOCATED(TG_ALT))ALLOCATE(TG_ALT(grid%sm31:grid%em31,jms:jme)) TPH0=TPH0D*DTR - WBD=-(((ide-1)-1)*DLMD) + WBD=-(((ide-1)-1)*grid%dlmd) WB= WBD*DTR - SBD=-(((jde-1)/2)*DPHD) + SBD=-(((jde-1)/2)*grid%dphd) SB= SBD*DTR - DLM=DLMD*DTR - DPH=DPHD*DTR + DLM=grid%dlmd*DTR + DPH=grid%dphd*DTR TDLM=DLM+DLM TDPH=DPH+DPH WBI=WB+TDLM @@ -1290,7 +1322,7 @@ CONTAINS TERM1=(STPH0*CTPH*COS(TLM)+CTPH0*STPH) FP=TWOM*(TERM1) - F(I,J)=0.5*GRID%DT*FP + grid%f(I,J)=0.5*GRID%DT*FP ENDDO ENDDO DO J=JTS,min(JTE,JDE-1) @@ -1310,30 +1342,30 @@ CONTAINS TERM1=MIN(TERM1,1.0D0) TERM1=MAX(TERM1,-1.0D0) APH=ASIN(TERM1) - TG_ALT(I,J)=TG0+TGA*COS(APH)-FIS(I,J)/3333. + TG_ALT(I,J)=TG0+TGA*COS(APH)-grid%fis(I,J)/3333. ENDDO ENDDO DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) -! IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. & -! SICE(I,J) .eq. 0. ) THEN -! TG(i,j) = sst(i,j) -! ELSEIF (SICE(I,J) .eq. 1) THEN -! TG(i,j) = 271.16 +! IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. & +! grid%sice(I,J) .eq. 0. ) THEN +! grid%tg(i,j) = grid%sst(i,j) +! ELSEIF (grid%sice(I,J) .eq. 1) THEN +! grid%tg(i,j) = 271.16 ! END IF - if (TG(I,J) .lt. 200.) then ! only use default TG_ALT definition if - ! not getting TGROUND from SI - TG(I,J)=TG_ALT(I,J) + if (grid%tg(I,J) .lt. 200.) then ! only use default TG_ALT definition if + ! not getting TGROUND from grid%si + grid%tg(I,J)=TG_ALT(I,J) endif - if (TG(I,J) .lt. 200. .or. TG(I,J) .gt. 320.) then - write(message,*) 'problematic TG point at : ', I,J + if (grid%tg(I,J) .lt. 200. .or. grid%tg(I,J) .gt. 320.) then + write(message,*) 'problematic grid%tg point at : ', I,J CALL wrf_message( message ) endif - adum2d(i,j)=nmm_tsk(I,J)+sst(I,J) + adum2d(i,j)=grid%nmm_tsk(I,J)+grid%sst(I,J) END DO END DO @@ -1345,12 +1377,12 @@ CONTAINS ! ============================================================= - CALL process_soil_real ( adum2d, TG , & - landmask, sst, & + CALL process_soil_real ( adum2d, grid%tg , & + grid%landmask, grid%sst, & st_input, sm_input, sw_input, & st_levels_input , sm_levels_input , & sw_levels_input , & - sldpth , dzsoil , stc , smc , sh2o, & + grid%sldpth , grid%dzsoil , grid%stc , grid%smc , grid%sh2o, & flag_sst , flag_soilt000, flag_soilm000, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & @@ -1386,12 +1418,12 @@ CONTAINS IF ( FLAG_SM000010 .EQ. 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - IF ((landmask(i,j).gt.0.5) .and. (stc(i,1,j) .gt. 200) .and. & - (stc(i,1,j) .lt. 400) .and. (smc(i,1,j) .lt. 0.005)) then - write(message,*) 'Noah > Noah: bad soil moisture at i,j = ',i,j,smc(i,:,j) + IF ((grid%landmask(i,j).gt.0.5) .and. (grid%stc(i,1,j) .gt. 200) .and. & + (grid%stc(i,1,j) .lt. 400) .and. (grid%smc(i,1,j) .lt. 0.005)) then + write(message,*) 'Noah > Noah: bad soil moisture at i,j = ',i,j,grid%smc(i,:,j) CALL wrf_message(message) iicount = iicount + 1 - smc(i,:,j) = 0.005 + grid%smc(i,:,j) = 0.005 END IF END DO END DO @@ -1403,18 +1435,18 @@ CONTAINS ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - smc(i,:,j) = smc(i,:,j) + lqmi(isltyp(i,j)) + grid%smc(i,:,j) = grid%smc(i,:,j) + lqmi(grid%isltyp(i,j)) END DO END DO DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - IF ((landmask(i,j).gt.0.5) .and. (stc(i,1,j) .gt. 200) .and. & - (stc(i,1,j) .lt. 400) .and. (smc(i,1,j) .lt. 0.004)) then + IF ((grid%landmask(i,j).gt.0.5) .and. (grid%stc(i,1,j) .gt. 200) .and. & + (grid%stc(i,1,j) .lt. 400) .and. (grid%smc(i,1,j) .lt. 0.004)) then write(message,*) 'RUC -> Noah: bad soil moisture at i,j = ' & - ,i,j,smc(i,:,j) + ,i,j,grid%smc(i,:,j) CALL wrf_message(message) iicount = iicount + 1 - smc(i,:,j) = 0.004 + grid%smc(i,:,j) = 0.004 END IF END DO END DO @@ -1429,7 +1461,7 @@ CONTAINS IF ( FLAG_SM000010 .EQ. 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - smc(i,:,j) = MAX ( smc(i,:,j) - lqmi(isltyp(i,j)) , 0. ) + grid%smc(i,:,j) = MAX ( grid%smc(i,:,j) - lqmi(grid%isltyp(i,j)) , 0. ) END DO END DO ELSE IF ( FLAG_SOILM000 .EQ. 1 ) THEN @@ -1438,30 +1470,30 @@ CONTAINS END SELECT account_for_zero_soil_moisture -!!! zero out NMM_TSK at water points again +!!! zero out grid%nmm_tsk at water points again DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - if (SM(I,J) .gt. 0.5) then - NMM_TSK(I,J)=0. + if (grid%sm(I,J) .gt. 0.5) then + grid%nmm_tsk(I,J)=0. endif END DO END DO -!! check on STC +!! check on grid%stc DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - IF (SICE(I,J) .gt. 0.9) then + IF (grid%sice(I,J) .gt. 0.9) then DO L = 1, grid%num_soil_layers - STC(I,L,J)=271.16 ! TG value used by Eta/NMM + grid%stc(I,L,J)=271.16 ! grid%tg value used by Eta/NMM END DO END IF - IF (SM(I,J) .gt. 0.9) then + IF (grid%sm(I,J) .gt. 0.9) then DO L = 1, grid%num_soil_layers - STC(I,L,J)=273.16 ! TG value used by Eta/NMM + grid%stc(I,L,J)=273.16 ! grid%tg value used by Eta/NMM END DO END IF @@ -1471,8 +1503,8 @@ CONTAINS DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) - if (SM(I,J) .lt. 0.1 .and. STC(I,1,J) .lt. 0.1) THEN - write(message,*) 'troublesome SM,STC,SMC value: ', I,J,SM(I,J), stc(I,1,J),smc(I,1,J) + if (grid%sm(I,J) .lt. 0.1 .and. grid%stc(I,1,J) .lt. 0.1) THEN + write(message,*) 'troublesome grid%sm,grid%stc,grid%smc value: ', I,J,grid%sm(I,J), grid%stc(I,1,J),grid%smc(I,1,J) CALL wrf_message(message) do JJ=J-1,J+1 do L=1, grid%num_soil_layers @@ -1481,19 +1513,19 @@ CONTAINS if (II .ge. its .and. II .le. MIN(ide-1,ite) .and. & JJ .ge. jts .and. JJ .le. MIN(jde-1,jte)) then - STC(I,L,J)=amax1(STC(I,L,J),STC(II,L,JJ)) - cur_smc=SMC(I,L,J) + grid%stc(I,L,J)=amax1(grid%stc(I,L,J),grid%stc(II,L,JJ)) + cur_smc=grid%smc(I,L,J) - if ( SMC(II,L,JJ) .gt. 0.005 .and. SMC(II,L,JJ) .lt. 1.0) then - aposs_smc=SMC(II,L,JJ) + if ( grid%smc(II,L,JJ) .gt. 0.005 .and. grid%smc(II,L,JJ) .lt. 1.0) then + aposs_smc=grid%smc(II,L,JJ) if ( cur_smc .eq. 0 ) then cur_smc=aposs_smc - SMC(I,L,J)=cur_smc + grid%smc(I,L,J)=cur_smc else cur_smc=amin1(cur_smc,aposs_smc) cur_smc=amin1(cur_smc,aposs_smc) - SMC(I,L,J)=cur_smc + grid%smc(I,L,J)=cur_smc endif endif @@ -1502,12 +1534,12 @@ CONTAINS enddo enddo enddo - write(message,*) 'STC, SMC(1) now: ', stc(I,1,J),smc(I,1,J) + write(message,*) 'grid%stc, grid%smc(1) now: ', grid%stc(I,1,J),grid%smc(I,1,J) CALL wrf_message(message) endif - if (STC(I,1,J) .lt. 0.1) then - write(message,*) 'QUITTING DUE TO STILL troublesome STC value: ', I,J, stc(I,1,J),smc(I,1,J) + if (grid%stc(I,1,J) .lt. 0.1) then + write(message,*) 'QUITTING DUE TO STILL troublesome grid%stc value: ', I,J, grid%stc(I,1,J),grid%smc(I,1,J) call wrf_error_fatal(message) endif @@ -1521,53 +1553,53 @@ CONTAINS ! RTDPTH(2)=0.3 ! RTDPTH(3)=0.6 -! SLDPTH=0. -! SLDPTH(1)=0.1 -! SLDPTH(2)=0.3 -! SLDPTH(3)=0.6 -! SLDPTH(4)=1.0 +! grid%sldpth=0. +! grid%sldpth(1)=0.1 +! grid%sldpth(2)=0.3 +! grid%sldpth(3)=0.6 +! grid%sldpth(4)=1.0 !!! main body of nmm_specific starts here ! do J=jts,min(jte,jde-1) do I=its,min(ite,ide-1) - RES(I,J)=1. + grid%res(I,J)=1. enddo enddo -!! HBM2 +!! grid%hbm2 - HBM2=0. + grid%hbm2=0. do J=jts,min(jte,jde-1) do I=its,min(ite,ide-1) IF ( (J .ge. 3 .and. J .le. (jde-1)-2) .AND. & (I .ge. 2 .and. I .le. (ide-1)-2+mod(J,2)) ) THEN - HBM2(I,J)=1. + grid%hbm2(I,J)=1. ENDIF enddo enddo -!! HBM3 - HBM3=0. +!! grid%hbm3 + grid%hbm3=0. !! LOOP OVER LOCAL DIMENSIONS do J=jts,min(jte,jde-1) - IHWG(J)=mod(J+1,2)-1 + grid%ihwg(J)=mod(J+1,2)-1 IF (J .ge. 4 .and. J .le. (jde-1)-3) THEN - IHL=(ids+1)-IHWG(J) + IHL=(ids+1)-grid%ihwg(J) IHH=(ide-1)-2 do I=its,min(ite,ide-1) - IF (I .ge. IHL .and. I .le. IHH) HBM3(I,J)=1. + IF (I .ge. IHL .and. I .le. IHH) grid%hbm3(I,J)=1. enddo ENDIF enddo -!! VBM2 +!! grid%vbm2 - VBM2=0. + grid%vbm2=0. do J=jts,min(jte,jde-1) do I=its,min(ite,ide-1) @@ -1575,23 +1607,23 @@ CONTAINS IF ( (J .ge. 3 .and. J .le. (jde-1)-2) .AND. & (I .ge. 2 .and. I .le. (ide-1)-1-mod(J,2)) ) THEN - VBM2(I,J)=1. + grid%vbm2(I,J)=1. ENDIF enddo enddo -!! VBM3 +!! grid%vbm3 - VBM3=0. + grid%vbm3=0. do J=jts,min(jte,jde-1) do I=its,min(ite,ide-1) IF ( (J .ge. 4 .and. J .le. (jde-1)-3) .AND. & (I .ge. 3-mod(J,2) .and. I .le. (ide-1)-2) ) THEN - VBM3(I,J)=1. + grid%vbm3(I,J)=1. ENDIF enddo @@ -1601,10 +1633,10 @@ CONTAINS ! IDTCF=DTCF, IDTCF=4 DTCF=4.0 ! used? - DY_NMM=ERAD*DPH - CPGFV=-GRID%DT/(48.*DY_NMM) - EN= GRID%DT/( 4.*DY_NMM)*DTAD - ENT=GRID%DT/(16.*DY_NMM)*DTAD + grid%dy_nmm=ERAD*DPH + grid%cpgfv=-GRID%DT/(48.*grid%dy_nmm) + grid%en= GRID%DT/( 4.*grid%dy_nmm)*DTAD + grid%ent=GRID%DT/(16.*grid%dy_nmm)*DTAD DO J=jts,nnyp KHL2(J)=(IDE-1)*(J-1)-(J-1)/2+2 @@ -1620,21 +1652,21 @@ CONTAINS DXP=ERAD*DLM*COS(TPH) DXJ(J)=DXP WPDARJ(J)=-W_NMM * & - ((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM**2)/ & - (GRID%DT*32.*DXP*DY_NMM) + ((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+grid%dy_nmm**2)/ & + (GRID%DT*32.*DXP*grid%dy_nmm) CPGFUJ(J)=-GRID%DT/(48.*DXP) CURVJ(J)=.5*GRID%DT*TAN(TPH)/ERAD - FCPJ(J)=GRID%DT/(CP*192.*DXP*DY_NMM) - FDIVJ(J)=1./(12.*DXP*DY_NMM) + FCPJ(J)=GRID%DT/(CP*192.*DXP*grid%dy_nmm) + FDIVJ(J)=1./(12.*DXP*grid%dy_nmm) ! EMJ(J)= GRID%DT/( 4.*DXP)*DTAD ! EMTJ(J)=GRID%DT/(16.*DXP)*DTAD - FADJ(J)=-GRID%DT/(48.*DXP*DY_NMM)*DTAD - ACDT=GRID%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+DY_NMM**2) + FADJ(J)=-GRID%DT/(48.*DXP*grid%dy_nmm)*DTAD + ACDT=GRID%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+grid%dy_nmm**2) CDDAMP=CODAMP*ACDT - HDACJ(J)=COAC*ACDT/(4.*DXP*DY_NMM) + HDACJ(J)=COAC*ACDT/(4.*DXP*grid%dy_nmm) DDMPUJ(J)=CDDAMP/DXP - DDMPVJ(J)=CDDAMP/DY_NMM + DDMPVJ(J)=CDDAMP/grid%dy_nmm ENDDO DO J=JTS,min(JTE,JDE-1) @@ -1651,33 +1683,33 @@ CONTAINS endif FP=TWOM*(CTPH0*STPH+STPH0*CTPH*COS(TLM)) - F(I,J)=0.5*GRID%DT*FP + grid%f(I,J)=0.5*GRID%DT*FP ENDDO ENDDO ! --------------DERIVED VERTICAL GRID CONSTANTS-------------------------- - EF4T=.5*GRID%DT/CP - F4Q = -GRID%DT*DTAD - F4D =-.5*GRID%DT*DTAD + grid%ef4t=.5*GRID%DT/CP + grid%f4q = -GRID%DT*DTAD + grid%f4d =-.5*GRID%DT*DTAD DO L=KDS,KDE-1 - RDETA(L)=1./DETA(L) - F4Q2(L)=-.25*GRID%DT*DTAD/DETA(L) + grid%rdeta(L)=1./grid%deta(L) + grid%f4q2(L)=-.25*GRID%DT*DTAD/grid%deta(L) ENDDO DO J=JTS,min(JTE,JDE-1) DO I=ITS,min(ITE,IDE-1) - DX_NMM(I,J)=DXJ(J) - WPDAR(I,J)=WPDARJ(J)*HBM2(I,J) - CPGFU(I,J)=CPGFUJ(J)*VBM2(I,J) - CURV(I,J)=CURVJ(J)*VBM2(I,J) - FCP(I,J)=FCPJ(J)*HBM2(I,J) - FDIV(I,J)=FDIVJ(J)*HBM2(I,J) - FAD(I,J)=FADJ(J) - HDACV(I,J)=HDACJ(J)*VBM2(I,J) - HDAC(I,J)=HDACJ(J)*1.25*HBM2(I,J) + grid%dx_nmm(I,J)=DXJ(J) + grid%wpdar(I,J)=WPDARJ(J)*grid%hbm2(I,J) + grid%cpgfu(I,J)=CPGFUJ(J)*grid%vbm2(I,J) + grid%curv(I,J)=CURVJ(J)*grid%vbm2(I,J) + grid%fcp(I,J)=FCPJ(J)*grid%hbm2(I,J) + grid%fdiv(I,J)=FDIVJ(J)*grid%hbm2(I,J) + grid%fad(I,J)=FADJ(J) + grid%hdacv(I,J)=HDACJ(J)*grid%vbm2(I,J) + grid%hdac(I,J)=HDACJ(J)*1.25*grid%hbm2(I,J) ENDDO ENDDO @@ -1688,7 +1720,7 @@ CONTAINS KHH=(IDE-1)-2+MOD(J,2) ! KHH is global...loop over I that have DO I=ITS,MIN(IDE-1,ITE) IF (I .ge. 2 .and. I .le. KHH) THEN - HDAC(I,J)=HDAC(I,J)* DFC + grid%hdac(I,J)=grid%hdac(I,J)* DFC ENDIF ENDDO @@ -1697,7 +1729,7 @@ CONTAINS KHH=2+MOD(J,2) DO I=ITS,MIN(IDE-1,ITE) IF (I .ge. 2 .and. I .le. KHH) THEN - HDAC(I,J)=HDAC(I,J)* DFC + grid%hdac(I,J)=grid%hdac(I,J)* DFC ENDIF ENDDO @@ -1705,7 +1737,7 @@ CONTAINS DO I=ITS,MIN(IDE-1,ITE) IF (I .ge. (IDE-1)-2 .and. I .le. KHH) THEN - HDAC(I,J)=HDAC(I,J)* DFC + grid%hdac(I,J)=grid%hdac(I,J)* DFC ENDIF ENDDO ENDIF @@ -1713,9 +1745,9 @@ CONTAINS DO J=JTS,min(JTE,JDE-1) DO I=ITS,min(ITE,IDE-1) - DDMPU(I,J)=DDMPUJ(J)*VBM2(I,J) - DDMPV(I,J)=DDMPVJ(J)*VBM2(I,J) - HDACV(I,J)=HDACV(I,J)*VBM2(I,J) + grid%ddmpu(I,J)=DDMPUJ(J)*grid%vbm2(I,J) + grid%ddmpv(I,J)=DDMPVJ(J)*grid%vbm2(I,J) + grid%hdacv(I,J)=grid%hdacv(I,J)*grid%vbm2(I,J) ENDDO ENDDO ! --------------INCREASING DIFFUSION ALONG THE BOUNDARIES---------------- @@ -1725,57 +1757,57 @@ CONTAINS KVH=(IDE-1)-1-MOD(J,2) DO I=ITS,min(IDE-1,ITE) IF (I .ge. 2 .and. I .le. KVH) THEN - DDMPU(I,J)=DDMPU(I,J)*DDFC - DDMPV(I,J)=DDMPV(I,J)*DDFC - HDACV(I,J)=HDACV(I,J)* DFC + grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC + grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC + grid%hdacv(I,J)=grid%hdacv(I,J)* DFC ENDIF ENDDO ELSE KVH=3-MOD(J,2) DO I=ITS,min(IDE-1,ITE) IF (I .ge. 2 .and. I .le. KVH) THEN - DDMPU(I,J)=DDMPU(I,J)*DDFC - DDMPV(I,J)=DDMPV(I,J)*DDFC - HDACV(I,J)=HDACV(I,J)* DFC + grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC + grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC + grid%hdacv(I,J)=grid%hdacv(I,J)* DFC ENDIF ENDDO KVH=(IDE-1)-1-MOD(J,2) DO I=ITS,min(IDE-1,ITE) IF (I .ge. IDE-1-2 .and. I .le. KVH) THEN - DDMPU(I,J)=DDMPU(I,J)*DDFC - DDMPV(I,J)=DDMPV(I,J)*DDFC - HDACV(I,J)=HDACV(I,J)* DFC + grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC + grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC + grid%hdacv(I,J)=grid%hdacv(I,J)* DFC ENDIF ENDDO ENDIF ENDDO - write(message,*) 'STC(1)' + write(message,*) 'grid%stc(1)' CALL wrf_message(message) DO J=min(jde-1,jte),jts,-((jte-jts)/15+1) - write(message,635) (stc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1) + write(message,635) (grid%stc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1) CALL wrf_message(message) ENDDO - write(message,*) 'SMC(1)' + write(message,*) 'grid%smc(1)' CALL wrf_message(message) DO J=min(jde-1,jte),jts,-((jte-jts)/15+1) - write(message,635) (smc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1) + write(message,635) (grid%smc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1) CALL wrf_message(message) ENDDO DO j = jts, MIN(jde-1,jte) DO i= ITS, MIN(IDE-1,ITE) - if (SM(I,J) .lt. 0.1 .and. SMC(I,1,J) .gt. 0.5 .and. SICE(I,J) .lt. 0.1) then - write(message,*) 'very moist on land point: ', I,J,SMC(I,1,J) + if (grid%sm(I,J) .lt. 0.1 .and. grid%smc(I,1,J) .gt. 0.5 .and. grid%sice(I,J) .lt. 0.1) then + write(message,*) 'very moist on land point: ', I,J,grid%smc(I,1,J) CALL wrf_debug(10,message) endif enddo enddo -!!! compute EMT, EM on global domain, and only on task 0. +!!! compute grid%emt, grid%em on global domain, and only on task 0. #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN !!!! NECESSARY TO LIMIT THIS TO TASK ZERO? @@ -1797,22 +1829,22 @@ CONTAINS JA=JA+1 KHLA(JA)=2 KHHA(JA)=(IDE-1)-1-MOD(J+1,2) - 161 EMT(JA)=EMTJ(J) + 161 grid%emt(JA)=EMTJ(J) DO 162 J=(JDE-1)-4,(JDE-1)-2 JA=JA+1 KHLA(JA)=2 KHHA(JA)=(IDE-1)-1-MOD(J+1,2) - 162 EMT(JA)=EMTJ(J) + 162 grid%emt(JA)=EMTJ(J) DO 163 J=6,(JDE-1)-5 JA=JA+1 KHLA(JA)=2 KHHA(JA)=2+MOD(J,2) - 163 EMT(JA)=EMTJ(J) + 163 grid%emt(JA)=EMTJ(J) DO 164 J=6,(JDE-1)-5 JA=JA+1 KHLA(JA)=(IDE-1)-2 KHHA(JA)=(IDE-1)-1-MOD(J+1,2) - 164 EMT(JA)=EMTJ(J) + 164 grid%emt(JA)=EMTJ(J) ! --------------SPREADING OF UPSTREAM VELOCITY-POINT ADVECTION FACTOR---- @@ -1821,28 +1853,28 @@ CONTAINS JA=JA+1 KVLA(JA)=2 KVHA(JA)=(IDE-1)-1-MOD(J,2) - 171 EM(JA)=EMJ(J) + 171 grid%em(JA)=EMJ(J) DO 172 J=(JDE-1)-4,(JDE-1)-2 JA=JA+1 KVLA(JA)=2 KVHA(JA)=(IDE-1)-1-MOD(J,2) - 172 EM(JA)=EMJ(J) + 172 grid%em(JA)=EMJ(J) DO 173 J=6,(JDE-1)-5 JA=JA+1 KVLA(JA)=2 KVHA(JA)=2+MOD(J+1,2) - 173 EM(JA)=EMJ(J) + 173 grid%em(JA)=EMJ(J) DO 174 J=6,(JDE-1)-5 JA=JA+1 KVLA(JA)=(IDE-1)-2 KVHA(JA)=(IDE-1)-1-MOD(J,2) - 174 EM(JA)=EMJ(J) + 174 grid%em(JA)=EMJ(J) 696 continue ENDIF ! wrf_dm_on_monitor/serial job - call NMM_SH2O(IMS,IME,JMS,JME,ITS,NNXP,JTS,NNYP,grid%num_soil_layers,ISLTYP, & - SM,SICE,STC,SMC,SH2O) + call NMM_SH2O(IMS,IME,JMS,JME,ITS,NNXP,JTS,NNYP,grid%num_soil_layers,grid%isltyp, & + grid%sm,grid%sice,grid%stc,grid%smc,grid%sh2o) !! must be a better place to put this, but will eliminate "phantom" !! wind points here (no wind point on eastern boundary of odd numbered rows) @@ -1853,8 +1885,8 @@ CONTAINS DO K=1,KDE-1 DO J=JDS,JDE-1,2 IF (J .ge. JTS .and. J .le. JTE) THEN - u(IDE-1,J,K)=0. - v(IDE-1,J,K)=0. + grid%u(IDE-1,J,K)=0. + grid%v(IDE-1,J,K)=0. ENDIF ENDDO ENDDO @@ -1864,16 +1896,16 @@ CONTAINS DO j = jms, jme DO i = ims, ime - fisx=max(fis(i,j),0.) - Z0(I,J) =SM(I,J)*Z0SEA+(1.-SM(I,J))* & + fisx=max(grid%fis(i,j),0.) + grid%z0(I,J) =grid%sm(I,J)*Z0SEA+(1.-grid%sm(I,J))* & & (0.*Z0MAX+FISx *FCM+Z0LAND) ENDDO ENDDO - write(message,*) 'Z0 over memory, leaving module_initialize_real' + write(message,*) 'grid%z0 over memory, leaving module_initialize_real' CALL wrf_message(message) DO J=JME,JMS,-((JME-JMS)/20+1) - write(message,635) (Z0(I,J),I=IMS,IME,(IME-IMS)/14+1) + write(message,635) (grid%z0(I,J),I=IMS,IME,(IME-IMS)/14+1) CALL wrf_message(message) ENDDO @@ -1889,17 +1921,17 @@ CONTAINS !================================================================================== -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE init_domain_nmm !------------------------------------------------------ - SUBROUTINE define_nmm_vertical_coord ( LM, PTSGM, PT, PDTOP,HYBLEVS, & + SUBROUTINE define_nmm_vertical_coord ( LM, PTSGM, pt, pdtop,HYBLEVS, & SG1,DSG1,SGML1, & - SG2,DSG2,SGML2,DFL, DFRLG ) + SG2,DSG2,SGML2,dfl, dfrlg ) IMPLICIT NONE @@ -1909,7 +1941,7 @@ CONTAINS !!! elsewhere within WRF. Done for initial testing purposes. INTEGER :: LM, LPT2, L - REAL :: PTSGM, PT, PL, PT2, PDTOP + REAL :: PTSGM, pt, PL, PT2, pdtop REAL :: RGOG, PSIG,PHYB,PHYBM REAL, PARAMETER :: Rd = 287.04 ! J deg{-1} kg{-1} REAL, PARAMETER :: CP=1004.6,GAMMA=.0065,PRF0=101325.,T0=288. @@ -1917,7 +1949,7 @@ CONTAINS REAL, DIMENSION(LM) :: DSG,DSG1,DSG2 REAL, DIMENSION(LM) :: SGML1,SGML2 - REAL, DIMENSION(LM+1) :: SG1,SG2,HYBLEVS,DFL,DFRLG + REAL, DIMENSION(LM+1) :: SG1,SG2,HYBLEVS,dfl,dfrlg CHARACTER(LEN=255) :: message @@ -2090,10 +2122,10 @@ CONTAINS rgog=(rd*gamma)/g DO L=1,LM+1 - DFL(L)=g*T0*(1.-((pt+SG1(L)*pdtop+SG2(L)*(101325.-pt2)) & + dfl(L)=g*T0*(1.-((pt+SG1(L)*pdtop+SG2(L)*(101325.-pt2)) & /101325.)**rgog)/gamma - DFRLG(L)=DFL(L)/g - write(message,*) 'L, DFL(L): ', L, DFL(L) + dfrlg(L)=dfl(L)/g + write(message,*) 'L, dfl(L): ', L, dfl(L) CALL wrf_debug(100,message) ENDDO @@ -2492,7 +2524,7 @@ CONTAINS IF ( TERRAIN_HGT_T(I,J) .eq. TOPO_IN(I,J)) THEN dum2d(I,J)=PSFC_IN(I,J) IF (dum2d(I,J) .lt. 50000. .or. dum2d(I,J) .gt. 108000.) THEN - write(message,*) 'bad dum2d(f): ', I,J,DUM2D(I,J) + write(message,*) 'bad dum2d(grid%f): ', I,J,DUM2D(I,J) CALL wrf_message(message) ENDIF write(message,*) 'matched input topo, psfc: ', I,J,TOPO_IN(I,J),PSFC_IN(I,J) @@ -2723,7 +2755,7 @@ CONTAINS CALL wrf_message(message) ENDIF - IF (PSFC_OUT(I,J) .lt. 50000. ) THEN + IF (psfc_out(I,J) .lt. 50000. ) THEN IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J) CALL wrf_debug(2,message) @@ -2738,7 +2770,7 @@ CONTAINS ENDIF ENDIF - IF (PSFC_OUT(I,J) .gt. 108000. ) THEN + IF (psfc_out(I,J) .gt. 108000. ) THEN IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J) CALL wrf_debug(2,message) @@ -2778,7 +2810,7 @@ CONTAINS REAL, INTENT(IN) :: SGML1(KDE),SGML2(KDE),pdtop,pt REAL, INTENT(OUT):: p3d_out(IMS:IME,JMS:JME,KDS:KDE-1) - REAL, INTENT(OUT):: PD(IMS:IME,JMS:JME) + REAL, INTENT(OUT):: pd(IMS:IME,JMS:JME) CHARACTER (len=255) :: message @@ -2787,14 +2819,14 @@ CONTAINS DO J=JTS,min(JTE,JDE-1) DO I=ITS,min(ITE,IDE-1) - PD(I,J)=psfc_out(I,J)-PDTOP-PT + pd(I,J)=psfc_out(I,J)-pdtop-pt ENDDO ENDDO DO J=JTS,min(JTE,JDE-1) DO K=KDS,KDE-1 DO I=ITS,min(ITE,IDE-1) - p3d_out(I,J,K)=PD(I,J)*SGML2(K)+PDTOP*SGML1(K)+PT + p3d_out(I,J,K)=pd(I,J)*SGML2(K)+pdtop*SGML1(K)+pt IF (p3d_out(I,J,K) .ge. psfc_out(I,J) .or. p3d_out(I,J,K) .le. pt) THEN write(message,*) 'I,K,J,p3d_out: ', I,K,J,p3d_out(I,J,K) @@ -3947,7 +3979,7 @@ CONTAINS ! ------------------------------------------------------------------- - subroutine spline(NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) + subroutine spline(NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,q) ! ******************************************************************** ! * * @@ -3968,7 +4000,7 @@ CONTAINS ! * FUNCTION ARE CALCULATED. XNEW(K) MUST BE GE XOLD(1) * ! * AND LE XOLD(NOLD). * ! * YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED. * -! * P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2. * +! * P, q - AUXILIARY VECTORS OF THE LENGTH NOLD-2. * ! * * ! ******************************************************************** ! @@ -3988,7 +4020,7 @@ CONTAINS REAL,DIMENSION(NOLD),INTENT(IN) :: XOLD,YOLD REAL,DIMENSION(NNEW),INTENT(IN) :: XNEW REAL,DIMENSION(NNEW),INTENT(OUT) :: YNEW - REAL,DIMENSION(NOLD+2),INTENT(INOUT) :: P,Q,Y2 + REAL,DIMENSION(NOLD+2),INTENT(INOUT) :: P,q,Y2 ! INTEGER :: K,K1,K2,KOLD,NOLDM1, K2_hold, K_hold REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR & @@ -4004,7 +4036,7 @@ CONTAINS RTDXC=0.5/(DXL+DXR) P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) - Q(1)=-RTDXC*DXR + q(1)=-RTDXC*DXR K=3 first_loop: DO K=3,NOLD-1 @@ -4013,13 +4045,13 @@ CONTAINS DXR=XOLD(K+1)-XOLD(K) DYDXR=(YOLD(K+1)-YOLD(K))/DXR DXC=DXL+DXR - DEN=1./(DXL*Q(K-2)+DXC+DXC) + DEN=1./(DXL*q(K-2)+DXC+DXC) P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) - Q(K-1)=-DEN*DXR + q(K-1)=-DEN*DXR END DO first_loop DO K=NOLDM1,2,-1 - Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) + Y2(K)=P(K-1)+q(K-1)*Y2(K+1) K_hold=K END DO @@ -4064,22 +4096,22 @@ CONTAINS !-------------------------------------------------------------------- SUBROUTINE NMM_SH2O(IMS,IME,JMS,JME,ISTART,IM,JSTART,JM,& NSOIL,ISLTPK, & - SM,SICE,STC,SMC,SH2O) + sm,sice,stc,smc,sh2o) !! INTEGER, PARAMETER:: NSOTYP=9 ! INTEGER, PARAMETER:: NSOTYP=16 INTEGER, PARAMETER:: NSOTYP=19 !!!!!!!!MAYBE??? REAL :: PSIS(NSOTYP),BETA(NSOTYP),SMCMAX(NSOTYP) - REAL :: STC(IMS:IME,NSOIL,JMS:JME), & - SMC(IMS:IME,NSOIL,JMS:JME) - REAL :: SH2O(IMS:IME,NSOIL,JMS:JME),SICE(IMS:IME,JMS:JME),& - SM(IMS:IME,JMS:JME) + REAL :: stc(IMS:IME,NSOIL,JMS:JME), & + smc(IMS:IME,NSOIL,JMS:JME) + REAL :: sh2o(IMS:IME,NSOIL,JMS:JME),sice(IMS:IME,JMS:JME),& + sm(IMS:IME,JMS:JME) REAL :: HLICE,GRAV,T0,BLIM INTEGER :: ISLTPK(IMS:IME,JMS:JME) CHARACTER(LEN=255) :: message -! Constants used in cold start SH2O initialization +! Constants used in cold start sh2o initialization DATA HLICE/3.335E5/,GRAV/9.81/,T0/273.15/ DATA BLIM/5.5/ ! DATA PSIS /0.04,0.62,0.47,0.14,0.10,0.26,0.14,0.36,0.04/ @@ -4107,16 +4139,16 @@ CONTAINS DO I=ISTART,IM !tst - IF (SMC(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then + IF (smc(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then if (K .eq. 1) then - write(message,*) 'I,J,reducing SMC from ' ,I,J,SMC(I,K,J), 'to ', SMCMAX(ISLTPK(I,J)) + write(message,*) 'I,J,reducing smc from ' ,I,J,smc(I,K,J), 'to ', SMCMAX(ISLTPK(I,J)) CALL wrf_debug(100,message) endif - SMC(I,K,J)=SMCMAX(ISLTPK(I,J)) + smc(I,K,J)=SMCMAX(ISLTPK(I,J)) ENDIF !tst - IF ( (SM(I,J) .lt. 0.5) .and. (SICE(I,J) .lt. 0.5) ) THEN + IF ( (sm(I,J) .lt. 0.5) .and. (sice(I,J) .lt. 0.5) ) THEN IF (ISLTPK(I,J) .gt. 19) THEN WRITE(message,*) 'FORCING ISLTPK at : ', I,J @@ -4129,10 +4161,10 @@ CONTAINS ENDIF -! cold start: determine liquid soil water content (SH2O) -! SH2O <= SMC for T < 273.149K (-0.001C) +! cold start: determine liquid soil water content (sh2o) +! sh2o <= smc for t < 273.149K (-0.001C) - IF (STC(I,K,J) .LT. 273.149) THEN + IF (stc(I,K,J) .LT. 273.149) THEN ! first guess following explicit solution for Flerchinger Eqn from Koren ! et al, JGR, 1999, Eqn 17 (KCOUNT=0 in FUNCTION FRH2O). @@ -4150,35 +4182,35 @@ CONTAINS CALL wrf_message(message) endif - if (BX .eq. 0 .or. STC(I,K,J) .eq. 0) then - write(message,*) 'TROUBLE -- I,J,BX, STC: ', I,J,BX,STC(I,K,J) + if (BX .eq. 0 .or. stc(I,K,J) .eq. 0) then + write(message,*) 'TROUBLE -- I,J,BX, stc: ', I,J,BX,stc(I,K,J) CALL wrf_message(message) endif FK = (((HLICE/(GRAV*(-PSIS(ISLTPK(I,J)))))* & - ((STC(I,K,J)-T0)/STC(I,K,J)))** & + ((stc(I,K,J)-T0)/stc(I,K,J)))** & (-1/BX))*SMCMAX(ISLTPK(I,J)) IF (FK .LT. 0.02) FK = 0.02 - SH2O(I,K,J) = MIN ( FK, SMC(I,K,J) ) + sh2o(I,K,J) = MIN ( FK, smc(I,K,J) ) ! ---------------------------------------------------------------------- ! now use iterative solution for liquid soil water content using ! FUNCTION FRH2O (from the Eta "NOAH" land-surface model) with the -! initial guess for SH2O from above explicit first guess. +! initial guess for sh2o from above explicit first guess. - SH2O(I,K,J)=FRH2O_init(STC(I,K,J),SMC(I,K,J),SH2O(I,K,J), & + sh2o(I,K,J)=FRH2O_init(stc(I,K,J),smc(I,K,J),sh2o(I,K,J), & SMCMAX(ISLTPK(I,J)),BETA(ISLTPK(I,J)), & PSIS(ISLTPK(I,J))) ELSE ! above freezing - SH2O(I,K,J)=SMC(I,K,J) + sh2o(I,K,J)=smc(I,K,J) ENDIF ELSE ! water point - SH2O(I,K,J)=SMC(I,K,J) + sh2o(I,K,J)=smc(I,K,J) ENDIF ! test on land/ice/sea - if (SH2O(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then - write(message,*) 'SH2O > THAN SMCMAX ', I,J,SH2O(I,K,J),SMCMAX(ISLTPK(I,J)),SMC(I,K,J) + if (sh2o(I,K,J) .gt. SMCMAX(ISLTPK(I,J))) then + write(message,*) 'sh2o > THAN SMCMAX ', I,J,sh2o(I,K,J),SMCMAX(ISLTPK(I,J)),smc(I,K,J) CALL wrf_message(message) endif @@ -4190,7 +4222,7 @@ CONTAINS !------------------------------------------------------------------- - FUNCTION FRH2O_init(TKELV,SMC,SH2O,SMCMAX,B,PSIS) + FUNCTION FRH2O_init(TKELV,smc,sh2o,SMCMAX,B,PSIS) IMPLICIT NONE @@ -4214,8 +4246,8 @@ CONTAINS ! INPUT: ! ! TKELV.........Temperature (Kelvin) -! SMC...........Total soil moisture content (volumetric) -! SH2O..........Liquid soil moisture content (volumetric) +! smc...........Total soil moisture content (volumetric) +! sh2o..........Liquid soil moisture content (volumetric) ! SMCMAX........Saturation soil moisture content (from REDPRM) ! B.............Soil type "B" parameter (from REDPRM) ! PSIS..........Saturated soil matric potential (from REDPRM) @@ -4239,8 +4271,8 @@ CONTAINS REAL GS REAL HLICE REAL PSIS - REAL SH2O - REAL SMC + REAL sh2o + REAL smc REAL SMCMAX REAL SWL REAL SWLK @@ -4275,13 +4307,13 @@ CONTAINS KCOUNT=0 ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! C IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), SH2O = SMC +! C IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (T0), sh2o = smc ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF (TKELV .GT. (T0 - 1.E-3)) THEN - FRH2O_init=SMC + FRH2O_init=smc ELSE @@ -4293,9 +4325,9 @@ CONTAINS ! CCCCCCCCCCCC IN KOREN ET AL, JGR, 1999, EQN 17 CCCCCCCCCCCCCCCCC ! INITIAL GUESS FOR SWL (frozen content) - SWL = SMC-SH2O + SWL = smc-sh2o ! KEEP WITHIN BOUNDS. - IF (SWL .GT. (SMC-0.02)) SWL=SMC-0.02 + IF (SWL .GT. (smc-0.02)) SWL=smc-0.02 IF(SWL .LT. 0.) SWL=0. ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! C START OF ITERATIONS @@ -4303,11 +4335,11 @@ CONTAINS DO WHILE (NLOG .LT. 10 .AND. KCOUNT .EQ. 0) NLOG = NLOG+1 DF = ALOG(( PSIS*GS/HLICE ) * ( ( 1.+CK*SWL )**2. ) * & - ( SMCMAX/(SMC-SWL) )**BX) - ALOG(-(TKELV-T0)/TKELV) - DENOM = 2. * CK / ( 1.+CK*SWL ) + BX / ( SMC - SWL ) + ( SMCMAX/(smc-SWL) )**BX) - ALOG(-(TKELV-T0)/TKELV) + DENOM = 2. * CK / ( 1.+CK*SWL ) + BX / ( smc - SWL ) SWLK = SWL - DF/DENOM ! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. - IF (SWLK .GT. (SMC-0.02)) SWLK = SMC - 0.02 + IF (SWLK .GT. (smc-0.02)) SWLK = smc - 0.02 IF(SWLK .LT. 0.) SWLK = 0. ! MATHEMATICAL SOLUTION BOUNDS APPLIED. DSWL=ABS(SWLK-SWL) @@ -4324,7 +4356,7 @@ CONTAINS ! C END OF ITERATIONS ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. - FRH2O_init = SMC - SWL + FRH2O_init = smc - SWL ! CCCCCCCCCCCCCCCCCCCCCCCC END OPTION 1 CCCCCCCCCCCCCCCCCCCCCCCCCCC @@ -4340,7 +4372,7 @@ CONTAINS FK=(((HLICE/(GS*(-PSIS)))*((TKELV-T0)/TKELV))**(-1/BX))*SMCMAX ! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION IF (FK .LT. 0.02) FK = 0.02 - FRH2O_init = MIN ( FK, SMC ) + FRH2O_init = MIN ( FK, smc ) ! CCCCCCCCCCCCCCCCCCCCCCCCC END OPTION 2 CCCCCCCCCCCCCCCCCCCCCCCCCC diff --git a/wrfv2_fire/dyn_nmm/module_si_io_nmm.F b/wrfv2_fire/dyn_nmm/module_si_io_nmm.F index 6137aad0..9816c605 100644 --- a/wrfv2_fire/dyn_nmm/module_si_io_nmm.F +++ b/wrfv2_fire/dyn_nmm/module_si_io_nmm.F @@ -273,12 +273,13 @@ CONTAINS IF ( first_time_in ) THEN CLOSE(12) - OPEN ( FILE = 'real_input_nm.global.metadata' , & - UNIT = 12 , & - STATUS = 'OLD' , & - ACCESS = 'SEQUENTIAL' , & - FORM = 'UNFORMATTED' , & - IOSTAT = ok_open ) + OPEN ( FILE = 'real_input_nm.global.metadata' & + ,UNIT = 12 & + ,STATUS = 'OLD' & + ,ACCESS = 'SEQUENTIAL' & + ,FORM = 'UNFORMATTED' & + ) +! IOSTAT = ok ) IF ( ok_open .NE. 0 ) THEN PRINT '(A)','You asked for WRF SI data, but no real_input_nm.global.metadata file exists.' @@ -1309,4 +1310,1642 @@ print *,'------------------> skipping ', var_info%name(1:8) END SUBROUTINE read_si +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! ------------------------------------------------------------ + + SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) + + USE module_soil_pre + USE module_domain + + IMPLICIT NONE + +#if defined(DM_PARALLEL) && !defined(STUBMPI) + INCLUDE "mpif.h" +#endif + + TYPE(domain) , INTENT(INOUT) :: grid + CHARACTER (LEN=19) , INTENT(IN) :: file_date_string + CHARACTER (LEN=19) :: VarName + CHARACTER (LEN=150) :: chartemp + CHARACTER (*) , INTENT(IN) :: filename + + INTEGER :: ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte + + INTEGER :: i , j , k , loop, IMAX, JMAX + INTEGER :: DATAHANDLE, num_metgrid_levels + INTEGER :: Sysdepinfo, Status, N + INTEGER :: istatus,ioutcount,iret,index,ierr + + integer :: nrecs,iunit, L,hor_size + +!! + character*132, allocatable :: datestr_all(:) + character*132, allocatable :: varname_all(:) + integer, allocatable :: domainend_all(:,:) + integer, allocatable :: start_block(:) + integer, allocatable :: end_block(:) + integer, allocatable :: start_byte(:) + integer, allocatable :: end_byte(:) + integer, allocatable :: file_offset(:) +!! + + REAL :: dummy,tmp,garb + REAL, ALLOCATABLE:: dumdata(:,:,:) + + CHARACTER (LEN= 8) :: dummy_char + + INTEGER :: ok , map_proj , ok_open, igarb + REAL :: pt + INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch + + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! tile is entire patch + + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! tile is entire patch + + END SELECT + + ! Initialize what soil temperature and moisture is available. + + + flag_st000010 = 0 + flag_st010040 = 0 + flag_st040100 = 0 + flag_st100200 = 0 + flag_sm000010 = 0 + flag_sm010040 = 0 + flag_sm040100 = 0 + flag_sm100200 = 0 + flag_st010200 = 0 + flag_sm010200 = 0 + + flag_soilt010 = 0 + flag_soilt040 = 0 + flag_soilt100 = 0 + flag_soilt200 = 0 + flag_soilm010 = 0 + flag_soilm040 = 0 + flag_soilm100 = 0 + flag_soilm200 = 0 + + flag_sst = 0 + flag_toposoil = 0 + + ! How many soil levels have we found? Well, right now, none. + + num_st_levels_input = 0 + num_sm_levels_input = 0 + st_levels_input = -1 + sm_levels_input = -1 + + CALL nl_set_mminlu ( grid%id, 'USGS') + CALL nl_set_iswater (grid%id, 16 ) + CALL nl_set_isice (grid%id, 24 ) + + + ! Get the space for the data if this is the first time here. + +! write(6,*) 'pre allocations' +! call summary() + + IF (.NOT. ALLOCATED (pmsl) ) ALLOCATE ( pmsl(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (psfc_in) ) ALLOCATE ( psfc_in(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (st_inputx)) ALLOCATE (st_inputx(its:ite,jts:jte,num_st_levels_alloc)) + IF (.NOT. ALLOCATED (sm_inputx)) ALLOCATE (sm_inputx(its:ite,jts:jte,num_st_levels_alloc)) + IF (.NOT. ALLOCATED (sw_inputx)) ALLOCATE (sw_inputx(its:ite,jts:jte,num_st_levels_alloc)) + IF (.NOT. ALLOCATED (soilt010_input) ) ALLOCATE ( soilt010_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilt040_input) ) ALLOCATE ( soilt040_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilt100_input) ) ALLOCATE ( soilt100_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilt200_input) ) ALLOCATE ( soilt200_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilm010_input) ) ALLOCATE ( soilm010_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilm040_input) ) ALLOCATE ( soilm040_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilm100_input) ) ALLOCATE ( soilm100_input(its:ite,jts:jte) ) + IF (.NOT. ALLOCATED (soilm200_input) ) ALLOCATE ( soilm200_input(its:ite,jts:jte) ) + +! write(6,*) 'past allocations' +! call summary() + + ! Local arrays + + +!!! MPI IO + + iunit=33 + call count_recs_wrf_binary_file(iunit, trim(fileName), nrecs) + write(0,*) 'nrecs: ', nrecs + + allocate (datestr_all(nrecs)) + allocate (varname_all(nrecs)) + allocate (domainend_all(3,nrecs)) + allocate (start_block(nrecs)) + allocate (end_block(nrecs)) + allocate (start_byte(nrecs)) + allocate (end_byte(nrecs)) + allocate (file_offset(nrecs)) + + call inventory_wrf_binary_file(iunit, trim(filename), nrecs, & + datestr_all,varname_all,domainend_all, & + start_block,end_block,start_byte,end_byte,file_offset) + + do N=1,NRECS + write(0,*) 'N,varname_all(N): ',N, varname_all(N) + enddo + + call mpi_file_open(mpi_comm_world, trim(filename), & + mpi_mode_rdonly,mpi_info_null, iunit, ierr) + if (ierr /= 0) then + call wrf_error_fatal("Error opening file with mpi io") + end if + + VarName='CEN_LAT' + call retrieve_index(index,VarName,varname_all,nrecs,iret) + if (iret /= 0) then + print*,VarName," not found in file" + else + + call mpi_file_read_at(iunit,file_offset(index)+5*4, & + garb,1,mpi_real4, & + mpi_status_ignore, ierr) + + if (ierr /= 0) then + print*,"Error reading ", VarName," using MPIIO" + else + print*,VarName, ' from MPIIO READ= ',garb + CALL nl_set_cen_lat ( grid%id , garb ) + write(0,*) 'cenlat= ', garb + end if + end if + + VarName='CEN_LON' + call retrieve_index(index,VarName,varname_all,nrecs,iret) + call mpi_file_read_at(iunit,file_offset(index)+5*4, & + garb,1,mpi_real4, & + mpi_status_ignore, ierr) + CALL nl_set_cen_lon ( grid%id , garb ) + CALL nl_set_stand_lon ( grid%id , garb ) + + VarName='TRUELAT1' + call retrieve_index(index,VarName,varname_all,nrecs,iret) + call mpi_file_read_at(iunit,file_offset(index)+5*4, & + garb,1,mpi_real4, & + mpi_status_ignore, ierr) + CALL nl_set_truelat1 ( grid%id , garb ) + + VarName='TRUELAT2' + call retrieve_index(index,VarName,varname_all,nrecs,iret) + call mpi_file_read_at(iunit,file_offset(index)+5*4, & + garb,1,mpi_real4, & + mpi_status_ignore, ierr) + CALL nl_set_truelat2 ( grid%id , garb ) + + VarName='MAP_PROJ' + call retrieve_index(index,VarName,varname_all,nrecs,iret) + call mpi_file_read_at(iunit,file_offset(index)+5*4, & + igarb,1,mpi_integer4, & + mpi_status_ignore, ierr) + + CALL nl_set_map_proj( grid%id, igarb) + + +! CALL ext_int_ioinit(SysDepInfo,Status) +! CALL ext_int_open_for_read( trim(fileName), 0, 0, " ", & +! DataHandle, Status) + + hor_size=(IDE-IDS)*(JDE-JDS) + write(0,*) 'hor_size: ', hor_size + write(0,*) 'IDE, JDE: ', IDE, JDE + + varName='PRES' + allocate(dumdata(IDS:IDE-1,JDS:JDE-1,num_metgrid_levels)) + + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_metgrid_levels,mpi_real4, & + mpi_status_ignore, ierr) + + write(0,*) 'ierr from mpi_file_read_at for PRES: ', ierr + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + + write(6,*) 'post first read_from_wps_int' +! call summary() + + DO K=1,num_metgrid_levels + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%p_gc(I,J,K)=dumdata(I,J,K) + if (I .eq. 1 .and. J .eq. 1) then +! write(0,*) 'I,J,K,grid%p_gc(I,J,K): ', I,J,K,grid%p_gc(I,J,K) + endif + if (I .eq. min(ITE,IDE-1) .and. J .eq. min(JTE,JDE-1)) then +! write(0,*) 'I,J,K,grid%p_gc(I,J,K): ', I,J,K,grid%p_gc(I,J,K) + endif + ENDDO + ENDDO + ENDDO + + write(0,*) 'grid%p_gc(25,25,25): ', grid%p_gc(25,25,25) + +! varName='SMC_WPS' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) +! +! varName='STC_WPS' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + + varName='GHT' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_metgrid_levels,mpi_real4, & + mpi_status_ignore, ierr) + + + DO K=1,num_metgrid_levels + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%ght_gc(I,J,K)=dumdata(I,J,K) + +! if (K .eq. 15 .and. mod(I,10) .eq. 0 .and. mod(J,10) .eq. 0) then +! write(0,*) 'I,J,K,grid%ght_gc(I,J,K): ', I,J,K,grid%ght_gc(I,J,K) +! endif + + if (I .eq. 1 .and. J .eq. 1) then +! write(0,*) 'I,J,K,grid%ght_gc(I,J,K): ', I,J,K,grid%ght_gc(I,J,K) + endif + + if (I .eq. min(ITE,IDE-1) .and. J .eq. min(JTE,JDE-1)) then +! write(0,*) 'I,J,K,grid%ght_gc(I,J,K): ', I,J,K,grid%ght_gc(I,J,K) + endif + + ENDDO + ENDDO + ENDDO + + +! write(6,*) 'post GHT read' +! call summary() + + varName='VEGCAT' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%vegcat(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SOIL_CAT' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%input_soil_cat(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='CANWAT' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%canwat(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SNOW' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%snow(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SKINTEMP' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%tsk_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + write(0,*) 'skintemp(25,25): ', grid%tsk_gc(25,25) + + varName='SOILHGT' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%toposoil(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + +! varName='LANDSEA' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) +!??? + + varName='SEAICE' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%xice_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='ST100200' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%st100200(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='ST040100' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%st040100(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='ST010040' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%st010040(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='ST000010' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%st000010(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SM100200' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%sm100200(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SM040100' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%sm040100(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SM010040' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%sm010040(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SM000010' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%sm000010(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='PSFC' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%psfc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='RH' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_metgrid_levels,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO K=1,num_metgrid_levels + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%rh_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='VV' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_metgrid_levels,mpi_real4, & + mpi_status_ignore, ierr) + DO K=1,num_metgrid_levels + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%v_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='UU' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_metgrid_levels,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO K=1,num_metgrid_levels + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%u_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='TT' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + + if (IRET .eq. 0) then + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_metgrid_levels,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO K=1,num_metgrid_levels + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%t_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + write(0,*) 't_gc(25,25,25): ', grid%t_gc(25,25,25) + endif + +! varName='RWMR' +! CALL retrieve_index(index,VarName,varname_all,nrecs,iret) +! if (iret .ne. 0) then +! grid%rwmr_gc=0. +! grid%snmr_gc=0. +! grid%clwmr_gc=0. +! grid%cice_gc=0. +! grid%rimef_gc=0. +! write(0,*) 'skipping cloud reads' +! goto 979 +! endif + +! CALL mpi_file_read_at(iunit,file_offset(index+1), & +! dumdata,hor_size*num_metgrid_levels,mpi_real4, & +! mpi_status_ignore, ierr) +! DO K=1,num_metgrid_levels +! DO J=JTS,min(JTE,JDE-1) +! DO I=ITS,min(ITE,IDE-1) +! grid%rwmr_gc(I,J,K)=dumdata(I,J,K) +! ENDDO +! ENDDO +! ENDDO + +! varName='SNMR' +! CALL retrieve_index(index,VarName,varname_all,nrecs,iret) +! CALL mpi_file_read_at(iunit,file_offset(index+1), & +! dumdata,hor_size*num_metgrid_levels,mpi_real4, & +! mpi_status_ignore, ierr) +! DO K=1,num_metgrid_levels +! DO J=JTS,min(JTE,JDE-1) +! DO I=ITS,min(ITE,IDE-1) +! grid%snmr_gc(I,J,K)=dumdata(I,J,K) +! ENDDO +! ENDDO +! ENDDO + +! varName='CLWMR' +! CALL retrieve_index(index,VarName,varname_all,nrecs,iret) +! CALL mpi_file_read_at(iunit,file_offset(index+1), & +! dumdata,hor_size*num_metgrid_levels,mpi_real4, & +! mpi_status_ignore, ierr) +! DO K=1,num_metgrid_levels +! DO J=JTS,min(JTE,JDE-1) +! DO I=ITS,min(ITE,IDE-1) +! grid%clwmr_gc(I,J,K)=dumdata(I,J,K) +! ENDDO +! ENDDO +! ENDDO + +! varName='CICE' +! CALL retrieve_index(index,VarName,varname_all,nrecs,iret) +! CALL mpi_file_read_at(iunit,file_offset(index+1), & +! dumdata,hor_size*num_metgrid_levels,mpi_real4, & +! mpi_status_ignore, ierr) +! DO K=1,num_metgrid_levels +! DO J=JTS,min(JTE,JDE-1) +! DO I=ITS,min(ITE,IDE-1) +! grid%cice_gc(I,J,K)=dumdata(I,J,K) +! ENDDO +! ENDDO +! ENDDO + +! varName='FRIMEF' +! CALL retrieve_index(index,VarName,varname_all,nrecs,iret) +! CALL mpi_file_read_at(iunit,file_offset(index+1), & +! dumdata,hor_size*num_metgrid_levels,mpi_real4, & +! mpi_status_ignore, ierr) +! DO K=1,num_metgrid_levels +! DO J=JTS,min(JTE,JDE-1) +! DO I=ITS,min(ITE,IDE-1) +! grid%rimef_gc(I,J,K)=dumdata(I,J,K) +! ENDDO +! ENDDO +! ENDDO + + 979 continue + +! varName='PMSL' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + + varName='SLOPECAT' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%slopecat(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='SNOALB' + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%snoalb(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + num_veg_cat = SIZE ( grid%landusef_gc , DIM=3 ) + write(0,*) 'num_veg_cat: ', num_veg_cat + num_soil_top_cat = SIZE ( grid%soilctop_gc , DIM=3 ) + num_soil_bot_cat = SIZE ( grid%soilcbot_gc , DIM=3 ) + + varName='GREENFRAC' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*12,mpi_real4, & + mpi_status_ignore, ierr) + + DO K=1,12 + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%greenfrac_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='ALBEDO12M' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*12,mpi_real4, & + mpi_status_ignore, ierr) + + DO K=1,12 + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%albedo12m_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='SOILCBOT' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_soil_bot_cat,mpi_real4, & + mpi_status_ignore, ierr) + + DO K=1,num_soil_bot_cat + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%soilcbot_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='SOILCAT' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%soilcat(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + write(0,*) 'veg_cat and soil_cat sizes:::: ', num_veg_cat , num_soil_top_cat + + varName='SOILCTOP' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_soil_top_cat,mpi_real4, & + mpi_status_ignore, ierr) + DO K=1,num_soil_top_cat + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%soilctop_gc(I,J,K)=dumdata(I,J,K) + ENDDO + ENDDO + ENDDO + + varName='SOILTEMP' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%tmn_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='HGT_V' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%htv_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='HGT_M' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%ht_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='LU_INDEX' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%lu_index(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='LANDUSEF' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size*num_veg_cat,mpi_real4, & + mpi_status_ignore, ierr) + + DO K=1,num_veg_cat + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%landusef_gc(I,J,K)=dumdata(I,J,K) + + if (I .eq. 50 .and. J .eq. 50) then + write(0,*) 'I,J,landusef_gc:: ', I,J,grid%landusef_gc(I,J,K) + endif + + ENDDO + ENDDO + ENDDO + + varName='LANDMASK' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%landmask(I,J)=dumdata(I,J,1) + if (I .eq. 50 .and. J .eq. 50) then + write(0,*) 'I,J,landmask:: ', I,J,grid%landmask(I,J) + endif + ENDDO + ENDDO + +! varName='F' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) +! varName='E' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + + + varName='XLONG_V' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%vlon_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='XLAT_V' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%vlat_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='XLONG_M' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%hlon_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + varName='XLAT_M' +! call read_from_wps_int(filename,file_date_string,DataHandle,varname,dumdata,IDE,JDE,num_metgrid_levels) + CALL retrieve_index(index,VarName,varname_all,nrecs,iret) + CALL mpi_file_read_at(iunit,file_offset(index+1), & + dumdata,hor_size,mpi_real4, & + mpi_status_ignore, ierr) + + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + grid%hlat_gc(I,J)=dumdata(I,J,1) + ENDDO + ENDDO + + call mpi_file_close(mpi_comm_world, ierr) + + varName='ST000010' + flag_st000010 = 1 + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + st_inputx(I,J,num_st_levels_input + 1) = grid%st000010(i,j) + ENDDO + ENDDO + + varName='ST010040' + flag_st010040 = 1 + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + st_inputx(I,J,num_st_levels_input + 1) = grid%st010040(i,j) + ENDDO + ENDDO + + varName='ST040100' + flag_st040100 = 1 + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + st_inputx(I,J,num_st_levels_input + 1) = grid%st040100(i,j) + ENDDO + ENDDO + + varName='ST100200' + flag_st100200 = 1 + num_st_levels_input = num_st_levels_input + 1 + st_levels_input(num_st_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + st_inputx(I,J,num_st_levels_input + 1) = grid%st100200(i,j) + ENDDO + ENDDO + + varName='SM000010' + flag_sm000010 = 1 + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm000010(i,j) + ENDDO + ENDDO + + varName='SM010040' + flag_sm010040 = 1 + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm010040(i,j) + ENDDO + ENDDO + + varName='SM040100' + flag_sm040100 = 1 + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm040100(i,j) + ENDDO + ENDDO + + varName='SM100200' + flag_sm100200 = 1 + num_sm_levels_input = num_sm_levels_input + 1 + sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8)) + DO J=JTS,min(JTE,JDE-1) + DO I=ITS,min(ITE,IDE-1) + sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm100200(i,j) + ENDDO + ENDDO + + flag_sst = 1 + +!new + sw_inputx=0. +!new + + sw_input=0. + +! write(0,*) 'maxval st_inputx(1): ', maxval(st_inputx(:,:,1)) +! write(0,*) 'maxval st_inputx(2): ', maxval(st_inputx(:,:,2)) +! write(0,*) 'maxval st_inputx(3): ', maxval(st_inputx(:,:,3)) +! write(0,*) 'maxval st_inputx(4): ', maxval(st_inputx(:,:,4)) + + write(6,*) 'to st_input...sw_input definition' +! call summary() + + do J=JTS,min(JDE-1,JTE) + do K=1,num_st_levels_alloc + do I=ITS,min(IDE-1,ITE) + st_input(I,K,J)=st_inputx(I,J,K) + sm_input(I,K,J)=sm_inputx(I,J,K) + sw_input(I,K,J)=sw_inputx(I,J,K) + enddo + enddo + enddo + write(6,*) 'past st_input...sw_input definition' +! call summary() + + write(0,*) 'maxval st_input(1): ', maxval(st_input(:,1,:)) + write(0,*) 'maxval st_input(2): ', maxval(st_input(:,2,:)) + write(0,*) 'maxval st_input(3): ', maxval(st_input(:,3,:)) + write(0,*) 'maxval st_input(4): ', maxval(st_input(:,4,:)) + + DEALLOCATE(pmsl) + DEALLOCATE(psfc_in) + DEALLOCATE(st_inputx) + DEALLOCATE(sm_inputx) + DEALLOCATE(sw_inputx) + DEALLOCATE(soilt010_input) + DEALLOCATE(soilt040_input) + DEALLOCATE(soilt100_input) + DEALLOCATE(soilt200_input) + DEALLOCATE(soilm010_input) + DEALLOCATE(soilm040_input) + DEALLOCATE(soilm100_input) + DEALLOCATE(soilm200_input) + DEALLOCATE(dumdata) + + end subroutine read_wps + +! ------------------------------------------------------------------------- +! ------------------------------------------------------------------------- +! ------------------------------------------------------------------------- +! ------------------------------------------------------------------------- +!!!! MPI-IO pieces + +subroutine retrieve_index(index,string,varname_all,nrecs,iret) +!$$$ subprogram documentation block +! . . . . +! subprogram: retrieve_index get record number of desired variable +! prgmmr: parrish org: np22 date: 2004-11-29 +! +! abstract: by examining previously generated inventory of wrf binary restart file, +! find record number that contains the header record for variable +! identified by input character variable "string". +! +! program history log: +! 2004-11-29 parrish +! +! input argument list: +! string - mnemonic for variable desired +! varname_all - list of all mnemonics obtained from inventory of file +! nrecs - total number of sequential records counted in wrf +! binary restart file +! +! output argument list: +! index - desired record number +! iret - return status, set to 0 if variable was found, +! non-zero if not. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + implicit none + + integer,intent(out)::iret + integer,intent(in)::nrecs + integer,intent(out):: index + character(*), intent(in):: string + character(132),intent(in)::varname_all(nrecs) + + integer i + + iret=0 + + do i=1,nrecs + if(trim(string) == trim(varname_all(i))) then + index=i + return + end if + end do + + write(6,*)' problem reading wrf nmm binary file, rec id "',trim(string),'" not found' + + iret=-1 + +end subroutine retrieve_index +subroutine next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) +!$$$ subprogram documentation block +! . . . . +! subprogram: next_buf bring in next direct access block +! prgmmr: parrish org: np22 date: 2004-11-29 +! +! abstract: bring in next direct access block when needed, as the file is scanned +! from beginning to end during counting and inventory of records. +! (subroutines count_recs_wrf_binary_file and inventory_wrf_binary_file) +! +! program history log: +! 2004-11-29 parrish +! +! input argument list: +! in_unit - fortran unit number where input file is opened through. +! nextbyte - byte number from beginning of file that is desired +! locbyte - byte number from beginning of last block read for desired byt +! lrecl - direct access block length +! nreads - number of blocks read before now (for diagnostic information +! lastbuf - logical, if true, then no more blocks, so return +! +! output argument list: +! buf - output array containing contents of next block +! locbyte - byte number from beginning of new block read for desired byte +! thisblock - number of new block being read by this routine +! nreads - number of blocks read now (for diagnostic information only) +! lastbuf - logical, if true, then at end of file. +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + implicit none + + integer lrecl + integer in_unit,nreads + integer buf(lrecl) + integer nextbyte,locbyte,thisblock + logical lastbuf + + integer ierr + + if(lastbuf) return + + ierr=0 + nreads=nreads+1 + +! compute thisblock: + + thisblock = 1 + (nextbyte-1)/lrecl + + locbyte = 1+mod(locbyte-1,lrecl) + + read(in_unit,rec=thisblock,iostat=ierr)buf + lastbuf = ierr /= 0 + +end subroutine next_buf + +subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & + datestr_all,varname_all,domainend_all, & + start_block,end_block,start_byte,end_byte,file_offset) +!$$$ subprogram documentation block +! . . . . +! subprogram: inventory_wrf_binary_file get contents of wrf binary file +! prgmmr: parrish org: np22 date: 2004-11-29 +! +! abstract: generate list of contents and map of wrf binary file which can be +! used for reading and writing with mpi io routines. +! same basic routine as count_recs_wrf_binary_file, except +! now wrf unpacking routines are used to decode wrf header +! records, and send back lists of variable mnemonics, dates, +! grid dimensions, and byte addresses relative to start of +! file for each field (this is used by mpi io routines). +! +! program history log: +! 2004-11-29 parrish +! +! +! input argument list: +! in_unit - fortran unit number where input file is opened through. +! wrf_ges_filename - filename of input wrf binary restart file +! nrecs - number of sequential records found on input wrf binary restart file. +! (obtained by a previous call to count_recs_wrf_binary_file) +! +! output argument list: (all following dimensioned nrecs) +! datestr_all - date character string for each field, where applicable (or else blanks) +! varname_all - wrf mnemonic for each variable, where applicable (or blank) +! domainend_all - dimensions of each field, where applicable (up to 3 dimensions) +! start_block - direct access block number containing 1st byte of record +! (after 4 byte record mark) +! end_block - direct access block number containing last byte of record +! (before 4 byte record mark) +! start_byte - relative byte address in direct access block of 1st byte of record +! end_byte - relative byte address in direct access block of last byte of record +! file_offset - absolute address of byte before 1st byte of record (used by mpi io) +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + use module_internal_header_util + implicit none + + integer,intent(in)::in_unit,nrecs + character(*),intent(in)::wrf_ges_filename + character(132),intent(out)::datestr_all(nrecs),varname_all(nrecs) + integer,intent(out)::domainend_all(3,nrecs) + integer,intent(out)::start_block(nrecs),end_block(nrecs) + integer,intent(out)::start_byte(nrecs),end_byte(nrecs) + integer,intent(out)::file_offset(nrecs) + + integer irecs + integer nextbyte,locbyte,thisblock + integer lenrec4(4) + integer lenrec,lensave + equivalence (lenrec4(1),lenrec) + integer missing4(4) + integer missing + equivalence (missing,missing4(1)) + integer,parameter:: lrecl=2**20 + integer buf(lrecl) + integer i,loc_count,nreads + logical lastbuf + integer hdrbuf4(2048) + integer hdrbuf(512) + equivalence(hdrbuf(1),hdrbuf4(1)) + integer,parameter:: int_field = 530 + integer,parameter:: int_dom_ti_char = 220 + integer,parameter:: int_dom_ti_real = 140 + integer,parameter:: int_dom_ti_integer = 180 + integer hdrbufsize + integer inttypesize + integer datahandle,count + character(128) element,dumstr,strdata + integer loccode + character(132) blanks + integer typesize + integer fieldtype,comm,iocomm + integer domaindesc + character(132) memoryorder,stagger,dimnames(3) + integer domainstart(3),domainend(3) + integer memorystart(3),memoryend(3) + integer patchstart(3),patchend(3) + character(132) datestr,varname + real dummy_field(1) +! integer dummy_field +! real dummy_field + integer itypesize + integer idata(1) + real rdata(16) + + call wrf_sizeof_integer(itypesize) + inttypesize=itypesize + + blanks=trim(' ') + + open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl) + irecs=0 + missing=-9999 + nextbyte=0 + locbyte=lrecl + nreads=0 + lastbuf=.false. + do + +! get length of next record + + do i=1,4 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + lenrec4(i)=buf(locbyte) + end do + if(lenrec <= 0 .and. lastbuf) go to 900 + if(lenrec <= 0 .and. .not. lastbuf) go to 885 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + + irecs=irecs+1 + start_block(irecs)=thisblock + start_byte(irecs)=locbyte + file_offset(irecs)=nextbyte-1 + hdrbuf4(1)=buf(locbyte) + hdrbuf4(2:4)=missing4(2:4) + hdrbuf4(5:8)=missing4(1:4) + datestr_all(irecs)=blanks + varname_all(irecs)=blanks + domainend_all(1:3,irecs)=0 + + loc_count=1 + do i=2,8 + if(loc_count.ge.lenrec) exit + loc_count=loc_count+1 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + hdrbuf4(i)=buf(locbyte) + end do + + if(lenrec==2048) write(6,*)' irecs,hdrbuf(2),int_dom_ti_char,int_field=', & + irecs,hdrbuf(2),int_dom_ti_char,int_field + if(lenrec==2048.and.(hdrbuf(2) == int_dom_ti_char .or. hdrbuf(2) == int_field & + .or. hdrbuf(2) == int_dom_ti_real .or. hdrbuf(2) == int_dom_ti_integer)) then + +! bring in next full record, so we can unpack datestr, varname, and domainend + do i=9,lenrec + loc_count=loc_count+1 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + hdrbuf4(i)=buf(locbyte) + end do + + if(hdrbuf(2) == int_dom_ti_char) then + + call int_get_ti_header_char(hdrbuf,hdrbufsize,inttypesize, & + datahandle,element,dumstr,strdata,loccode) + varname_all(irecs)=trim(element) + datestr_all(irecs)=trim(strdata) + write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),trim(datestr_all(irecs)) + + else if(hdrbuf(2) == int_dom_ti_real) then + + call int_get_ti_header_real(hdrbuf,hdrbufsize,inttypesize,typesize, & + datahandle,element,rdata,count,loccode) + varname_all(irecs)=trim(element) +! datestr_all(irecs)=trim(strdata) + write(6,*) 'count: ', count + write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),rdata(1:count) + + else if(hdrbuf(2) == int_dom_ti_integer) then + + call int_get_ti_header_integer(hdrbuf,hdrbufsize,inttypesize,typesize, & + datahandle,element,idata,count,loccode) + varname_all(irecs)=trim(element) +! datestr_all(irecs)=trim(strdata) + write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),idata(1:count) + + else + + call int_get_write_field_header(hdrbuf,hdrbufsize,inttypesize,typesize, & + datahandle,datestr,varname,dummy_field,fieldtype,comm,iocomm, & + domaindesc,memoryorder,stagger,dimnames, & + domainstart,domainend,memorystart,memoryend,patchstart,patchend) + varname_all(irecs)=trim(varname) + datestr_all(irecs)=trim(datestr) + domainend_all(1:3,irecs)=domainend(1:3) + write(6,*)' irecs,datestr,domend,varname = ', & + irecs,trim(datestr_all(irecs)),domainend_all(1:3,irecs),trim(varname_all(irecs)) + + end if + end if + + nextbyte=nextbyte-loc_count+lenrec + locbyte=locbyte-loc_count+lenrec + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + end_block(irecs)=thisblock + end_byte(irecs)=locbyte + lensave=lenrec + do i=1,4 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + lenrec4(i)=buf(locbyte) + end do + if(lenrec /= lensave) go to 890 + + end do + +880 continue + write(6,*)' reached impossible place in inventory_wrf_binary_file' + close(in_unit) + return + +885 continue + write(6,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file' + write(6,*)' lenrec =',lenrec + close(in_unit) + return + +890 continue + write(6,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal' + write(6,*)' begining reclen =',lensave + write(6,*)' ending reclen =',lenrec + write(6,*)' irecs =',irecs + write(6,*)' nrecs =',nrecs + close(in_unit) + return + +900 continue + write(6,*)' normal end of file reached in inventory_wrf_binary_file' + write(6,*)' nblocks=',thisblock + write(6,*)' irecs,nrecs=',irecs,nrecs + write(6,*)' nreads=',nreads + close(in_unit) + +end subroutine inventory_wrf_binary_file + +SUBROUTINE wrf_sizeof_integer( retval ) + IMPLICIT NONE + INTEGER retval +! 4 is defined by CPP + retval = 4 + RETURN +END SUBROUTINE wrf_sizeof_integer + +SUBROUTINE wrf_sizeof_real( retval ) + IMPLICIT NONE + INTEGER retval +! 4 is defined by CPP + retval = 4 + RETURN +END SUBROUTINE wrf_sizeof_real +subroutine count_recs_wrf_binary_file(in_unit,wrf_ges_filename,nrecs) +!$$$ subprogram documentation block +! . . . . +! subprogram: count_recs_binary_file count # recs on wrf binary file +! prgmmr: parrish org: np22 date: 2004-11-29 +! +! abstract: count number of sequential records contained in wrf binary +! file. this is done by opening the file in direct access +! mode with block length of 2**20, the size of the physical +! blocks on ibm "blue" and "white" machines. for optimal +! performance, change block length to correspond to the +! physical block length of host machine disk space. +! records are counted by looking for the 4 byte starting +! and ending sequential record markers, which contain the +! record size in bytes. only blocks are read which are known +! by simple calculation to contain these record markers. +! even though this is done on one processor, it is still +! very fast, and the time will always scale by the number of +! sequential records, not their size. this step and the +! following inventory step consistently take less than 0.1 seconds +! to complete. +! +! program history log: +! 2004-11-29 parrish +! +! input argument list: +! in_unit - fortran unit number where input file is opened through. +! wrf_ges_filename - filename of input wrf binary restart file +! +! output argument list: +! nrecs - number of sequential records found on input wrf binary restart fil +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + +! do an initial read through of a wrf binary file, and get total number of sequential fil + + implicit none + + integer,intent(in)::in_unit + character(*),intent(in)::wrf_ges_filename + integer,intent(out)::nrecs + + integer nextbyte,locbyte,thisblock + integer lenrec4(4) + integer lenrec,lensave + equivalence (lenrec4(1),lenrec) + integer missing4(4) + integer missing + equivalence (missing,missing4(1)) + integer ,parameter:: lrecl=2**20 + integer buf(lrecl) + integer i,loc_count,nreads + logical lastbuf + + open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl) + nrecs=0 + missing=-9999 + nextbyte=0 + locbyte=lrecl + nreads=0 + lastbuf=.false. + do + +! get length of next record + + do i=1,4 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + lenrec4(i)=buf(locbyte) + end do + if(lenrec <= 0 .and. lastbuf) go to 900 + if(lenrec <= 0 .and. .not.lastbuf) go to 885 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + + nrecs=nrecs+1 + + loc_count=1 + do i=2,4 + if(loc_count.ge.lenrec) exit + loc_count=loc_count+1 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + end do + do i=1,4 + if(loc_count.ge.lenrec) exit + loc_count=loc_count+1 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + end do + nextbyte=nextbyte-loc_count+lenrec + locbyte=locbyte-loc_count+lenrec + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + lensave=lenrec + do i=1,4 + nextbyte=nextbyte+1 + locbyte=locbyte+1 + if(locbyte > lrecl .and. lastbuf) go to 900 + if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf) + lenrec4(i)=buf(locbyte) + end do + if(lenrec /= lensave) go to 890 + + end do + +880 continue + write(6,*)' reached impossible place in count_recs_wrf_binary_file' + close(in_unit) + return + +885 continue + write(6,*)' problem in count_recs_wrf_binary_file, lenrec has bad value before end of file' + write(6,*)' lenrec =',lenrec + close(in_unit) + return + +890 continue + write(6,*)' problem in count_recs_wrf_binary_file, beginning and ending rec len words unequal' + write(6,*)' begining reclen =',lensave + write(6,*)' ending reclen =',lenrec + close(in_unit) + return + +900 continue + write(6,*)' normal end of file reached in count_recs_wrf_binary_file' + write(6,*)' nblocks=',thisblock + write(6,*)' nrecs=',nrecs + write(6,*)' nreads=',nreads + close(in_unit) + +end subroutine count_recs_wrf_binary_file + +subroutine retrieve_field(in_unit,wrfges,out,start_block,end_block,start_byte,end_byte) +!$$$ subprogram documentation block +! . . . . +! subprogram: retrieve_field retrieve field from wrf binary file +! prgmmr: parrish org: np22 date: 2004-11-29 +! +! abstract: still using direct access, retrieve a field from the wrf binary restart file. +! +! program history log: +! 2004-11-29 parrish +! +! input argument list: +! in_unit - fortran unit number where input file is opened through. +! wrfges - filename of input wrf binary restart file +! start_block - direct access block number containing 1st byte of record +! (after 4 byte record mark) +! end_block - direct access block number containing last byte of record +! (before 4 byte record mark) +! start_byte - relative byte address in direct access block of 1st byte of record +! end_byte - relative byte address in direct access block of last byte of record +! +! output argument list: +! out - output buffer where desired field is deposited +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ + + implicit none + + integer,intent(in)::in_unit + character(50),intent(in)::wrfges + integer,intent(in)::start_block,end_block,start_byte,end_byte + integer,intent(out)::out(*) + + integer,parameter:: lrecl=2**20 + integer buf(lrecl) + integer i,ii,k,ibegin,iend + integer ierr + + open(in_unit,file=trim(wrfges),access='direct',recl=lrecl) + + write(6,*)' in retrieve_field, start_block,end_block=',start_block,end_block + write(6,*)' in retrieve_field, start_byte,end_byte=',start_byte,end_byte + ii=0 + ierr=0 + do k=start_block,end_block + read(in_unit,rec=k,iostat=ierr)buf + ibegin=1 ; iend=lrecl + if(k == start_block) ibegin=start_byte + if(k == end_block) iend=end_byte + do i=ibegin,iend + ii=ii+1 + out(ii)=buf(i) + end do + end do + close(in_unit) + +end subroutine retrieve_field + + END MODULE module_si_io_nmm diff --git a/wrfv2_fire/dyn_nmm/shift_domain_nmm.F b/wrfv2_fire/dyn_nmm/shift_domain_nmm.F index 281ab40c..54310140 100644 --- a/wrfv2_fire/dyn_nmm/shift_domain_nmm.F +++ b/wrfv2_fire/dyn_nmm/shift_domain_nmm.F @@ -1,6 +1,6 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & ! -# include +# include ! ) USE module_domain @@ -26,10 +26,10 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & CHARACTER(LEN=255) :: message ! Definitions of dummy arguments to solve -#include +#include -#define COPY_IN -#include +!#define COPY_IN +!#include #ifdef DM_PARALLEL # include @@ -51,19 +51,19 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & write(message,*)' S_BDY,N_BDY,W_BDY,E_BDY ', S_BDY,N_BDY,W_BDY,E_BDY CALL wrf_message(trim(message)) - imask_nostag=0 + grid%imask_nostag=0 IF ( disp_x > 0 ) THEN IF ( E_BDY ) THEN DO J=jps,min(jde-1,jpe) DO I=ips,min(ide-1,ipe-2-mod(j+1,2)) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO ELSE DO J=jps,min(jde-1,jpe) DO I=ips,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO END IF @@ -72,13 +72,13 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & IF ( W_BDY ) THEN DO J=jps,min(jde-1,jpe) DO I=ips+1,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO ELSE DO J=jps,min(jde-1,jpe) DO I=ips,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO END IF @@ -87,13 +87,13 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & IF ( N_BDY ) THEN DO J=jps,min(jde-1,jpe-3) DO I=ips,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO ELSE DO J=jps,min(jde-1,jpe) DO I=ips,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO END IF @@ -102,21 +102,21 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & IF ( S_BDY ) THEN DO J=jps+2,min(jde-1,jpe) DO I=ips,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO ELSE DO J=jps,min(jde-1,jpe) DO I=ips,min(ide-1,ipe) - imask_nostag(i,j) = 1 + grid%imask_nostag(i,j) = 1 END DO END DO END IF END IF -! imask_nostag(ips:min(ide-4,ipe),jps:min(jde-1,jpe)) = 1 -! imask_nostag(ips+1:min(ide-2,ipe),jps+1:min(jde-2,jpe)) = 1 -! imask_nostag(ips+1:min(ide-1,ipe-1),jps+2:min(jde-1,jpe-2)) = 1 +! grid%imask_nostag(ips:min(ide-4,ipe),jps:min(jde-1,jpe)) = 1 +! grid%imask_nostag(ips+1:min(ide-2,ipe),jps+1:min(jde-2,jpe)) = 1 +! grid%imask_nostag(ips+1:min(ide-1,ipe-1),jps+2:min(jde-1,jpe-2)) = 1 px = isign(grid%parent_grid_ratio,disp_x) py = isign(grid%parent_grid_ratio,disp_y) @@ -144,7 +144,7 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & CALL wrf_message(trim(message)) endif -#define COPY_OUT -#include +!#define COPY_OUT +!#include END SUBROUTINE shift_domain_nmm diff --git a/wrfv2_fire/dyn_nmm/solve_nmm.F b/wrfv2_fire/dyn_nmm/solve_nmm.F index 7f12c9b8..e516a70e 100644 --- a/wrfv2_fire/dyn_nmm/solve_nmm.F +++ b/wrfv2_fire/dyn_nmm/solve_nmm.F @@ -9,7 +9,7 @@ ! SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! & ) !----------------------------------------------------------------------- @@ -18,11 +18,16 @@ USE MODULE_MODEL_CONSTANTS USE MODULE_STATE_DESCRIPTION USE MODULE_CTLBLK -!#ifdef DM_PARALLEL -! USE MODULE_DM -!#endif +#ifdef DM_PARALLEL + USE MODULE_DM, ONLY : LOCAL_COMMUNICATOR & + ,MYTASK,NTASKS,NTASKS_X & + ,NTASKS_Y + USE MODULE_COMM_DM +#endif USE MODULE_IGWAVE_ADJUST, ONLY: PDTE,PFDHT,DDAMP,VTOA - USE MODULE_ADVECTION, ONLY: ADVE,VAD2,HAD2,VAD2_SCAL,HAD2_SCAL + USE MODULE_ADVECTION, ONLY: ADVE,VAD2,HAD2 & + ,ADV2,MONO & + ,VAD2_SCAL,HAD2_SCAL USE MODULE_NONHY_DYNAM, ONLY: EPS,VADZ,HADZ USE MODULE_DIFFUSION_NMM, ONLY: HDIFF USE MODULE_BNDRY_COND, ONLY: BOCOH,BOCOV @@ -55,7 +60,7 @@ ! JM, 20050819 ! !---------------------------- -#include +#include !---------------------------- ! !*** STRUCTURE THAT CONTAINS RUN-TIME CONFIGURATION (NAMELIST) DATA FOR DOMAIN @@ -70,6 +75,7 @@ !*** LOCAL VARIABLES ! !----------------------------------------------------------------------- +! INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE & @@ -77,6 +83,10 @@ ! INTEGER :: I,ICLTEND,IDF,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST & & ,NTSD_current,L +#ifdef HWRF +!zhang's doing + INTEGER,SAVE :: NTSD_restart1,NTSD_restart2 +#endif integer :: ierr INTEGER,SAVE :: NTSD_restart ! INTEGER :: MPI_COMM_COMP,MYPE,MYPROC,NPES @@ -84,18 +94,15 @@ INTEGER :: KVH,NTSD_rad,RC INTEGER :: NUM_OZMIXM,NUM_AEROSOLC ! - REAL :: DT_INV,FICE,FRAIN,GPS,QI,QR,QW,WC,SFENTH + REAL :: DT_INV,FICE,FRAIN,GPS,QI,QR,QW,WC ! LOGICAL :: LAST_TIME,OPERATIONAL_PHYSICS ! - CHARACTER(256) :: MESSAGE + CHARACTER(80) :: MESSAGE ! !*** For precip assimilation: INTEGER :: ISTAT REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: PPTDAT -#ifdef WRF_CHEM - REAL,ALLOCATABLE,DIMENSION(:,:,:,:) :: CHEM_TRANS -#endif ! !----------------------------------------------------------------------- !*** For physics compatibility with other packages @@ -136,14 +143,32 @@ #endif !----------------------------------------------------------------------- ! -#ifdef DEREF_KLUDGE -! SEE http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm - INTEGER :: SM31,EM31,SM32,EM32,SM33,EM33 - INTEGER :: SM31X,EM31X,SM32X,EM32X,SM33X,EM33X - INTEGER :: SM31Y,EM31Y,SM32Y,EM32Y,SM33Y,EM33Y -#endif +!#ifdef DEREF_KLUDGE +!! SEE http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm +! INTEGER :: SM31,EM31,SM32,EM32,SM33,EM33 +! INTEGER :: SM31X,EM31X,SM32X,EM32X,SM33X,EM33X +! INTEGER :: SM31Y,EM31Y,SM32Y,EM32Y,SM33Y,EM33Y +!#endif ! !----------------------------------------------------------------------- +!*** Passive substance variables +!----------------------------------------------------------------------- +! + LOGICAL :: EULER + INTEGER :: IDTADT + INTEGER :: IDTADC + INTEGER :: KS ! species index in 4d tracer array +! + REAL,SAVE :: SUMDRRW +! +#ifdef WRF_CHEM + REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: & ! i,j,k,ks + CHE & ! 4d i,j,k chem tracers + ,CH1 & ! intermediate tracer variable + ,CHP & ! ch1 at previous time level + ,TCC ! time change of tracers +#endif +!----------------------------------------------------------------------- ! ! LIMIT THE NUMBER OF ARGUMENTS IF COMPILED WITH -DLIMIT_ARGS BY COPYING ! SCALAR (NON-ARRAY) ARGUMENTS OUT OF THE GRID DATA STRUCTURE INTO LOCALLY @@ -154,8 +179,8 @@ ! DIRECTION OF THE COPY. NMM_SCALAR_DEREFS IS GENERATED FROM REGISTRY. ! !----------------------------------------------------------------------- -#define COPY_IN -#include +!#define COPY_IN +!#include !----------------------------------------------------------------------- ! ! TRICK PROBLEMATIC COMPILERS INTO NOT PERFORMING COPY-IN/COPY-OUT BY ADDING @@ -180,7 +205,7 @@ !*** !----------------------------------------------------------------------- ! -!*** NTSD IS THE TIMESTEP COUNTER (Number of Time Steps Done) +!*** ntsd IS THE TIMESTEP COUNTER (Number of Time Steps Done) ! !----------------------------------------------------------------------- !*** @@ -192,27 +217,49 @@ ! IF(NTSD_current==0)THEN IF(GRID%RESTART.AND.GRID%TSTART>0.)THEN - IHRST=NSTART_HOUR - NTSD_restart=NTSD +#ifdef HWRF +!zhang's doing: temporarily hardwired for two domains + if( grid%id .eq. 1 ) NTSD_restart1=INT(grid%TSTART*3600./GRID%DT+0.5) + if( grid%id .eq. 2 ) NTSD_restart2=INT(grid%TSTART*3600./GRID%DT+0.5) +#endif + IHRST=grid%nstart_hour + NTSD_restart=grid%ntsd ELSE IHRST=GRID%GMT - NSTART_HOUR=IHRST + grid%nstart_hour=IHRST +#ifdef HWRF +!zhang's doing + NTSD_restart1=0 + NTSD_restart2=0 +#else NTSD_restart=0 +#endif ENDIF ENDIF -! - NTSD=NTSD_restart+NTSD_current +#ifdef HWRF +!zhang's doing + if( grid%id .eq. 1 ) grid%ntsd=NTSD_restart1+NTSD_current + if( grid%id .eq. 2 ) grid%ntsd=NTSD_restart2+NTSD_current +#else + grid%ntsd=NTSD_restart+NTSD_current +#endif LAST_TIME=domain_last_time_step(GRID) ! !----------------------------------------------------------------------- ! !!!!! IF(WRF_DM_ON_MONITOR() )THEN - WRITE(MESSAGE,125)NTSD,NTSD*GRID%DT/3600. + WRITE(MESSAGE,125)grid%ntsd,grid%ntsd*GRID%DT/3600. 125 FORMAT(' SOLVE_NMM: TIMESTEP IS ',I5,' TIME IS ',F7.3,' HOURS') CALL WRF_MESSAGE(TRIM(MESSAGE)) !!!! ENDIF ! !----------------------------------------------------------------------- +! + EULER=model_config_rec%EULER_ADV + IDTADT=model_config_rec%IDTADT + IDTADC=model_config_rec%IDTADC +! +!----------------------------------------------------------------------- CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP) CALL WRF_GET_NPROC(NPES) CALL WRF_GET_MYPROC(MYPROC) @@ -263,7 +310,6 @@ ALLOCATE(RQVBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT) ALLOCATE(RTHRATEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT) #ifdef WRF_CHEM - ALLOCATE(CHEM_TRANS(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT) #endif ! @@ -271,15 +317,15 @@ DO J=JMS,JME DO K=KMS,KME DO I=IMS,IME - TTEN(I,K,J)=T(I,J,K) - QTEN(I,K,J)=Q(I,J,K) + TTEN(I,K,J)=grid%t(I,J,K) + QTEN(I,K,J)=grid%q(I,J,K) ENDDO ENDDO ENDDO ENDIF ! GRID%SIGMA=1 - HYDRO=.FALSE. + grid%hydro=.FALSE. ! ! IDF=IDE-1 @@ -297,18 +343,29 @@ JTE=MIN(JPE,JDF) KTS=KPS KTE=MIN(KPE,KDF) - if(ntsd==0)then +!----------------------------------------------------------------------- +! + write(0,*)'grid%ntsd=',grid%ntsd + if(grid%ntsd==0)then write(message,*)' its=',its,' ite=',ite call wrf_message(trim(message)) write(message,*)' jts=',jts,' jte=',jte call wrf_message(trim(message)) write(message,*)' kts=',kts,' kte=',kte call wrf_message(trim(message)) +! +#ifdef WRF_CHEM + ALLOCATE (CHE(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) + ALLOCATE (CH1(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) + ALLOCATE (CHP(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) + ALLOCATE (TCC(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) +#endif +!----------------------------------------------------------------------- endif !----------------------------------------------------------------------- !*** SET TIMING VARIABLES TO ZERO AT START OF FORECAST. !----------------------------------------------------------------------- - if(ntsd==0)then + if(grid%ntsd==0)then solve_tim=0. exch_tim=0. pdte_tim=0. @@ -338,17 +395,17 @@ N_MOIST=NUM_MOIST ! DO J=MYJS_P4,MYJE_P4 - IHEG(J)=MOD(J+1,2) - IHWG(J)=IHEG(J)-1 - IVEG(J)=MOD(J,2) - IVWG(J)=IVEG(J)-1 + grid%iheg(J)=MOD(J+1,2) + grid%ihwg(J)=grid%iheg(J)-1 + grid%iveg(J)=MOD(J,2) + grid%ivwg(J)=grid%iveg(J)-1 ENDDO DO J=MYJS_P4,MYJE_P4 - IVW(J)=IVWG(J) - IVE(J)=IVEG(J) - IHE(J)=IHEG(J) - IHW(J)=IHWG(J) + grid%ivw(J)=grid%ivwg(J) + grid%ive(J)=grid%iveg(J) + grid%ihe(J)=grid%iheg(J) + grid%ihw(J)=grid%ihwg(J) ENDDO ! !*** LATERAL POINTS IN THE BOUNDARY ARRAYS @@ -358,7 +415,7 @@ !*** APPROXIMATE GRIDPOINT SPACING (METERS) ! JC=JMS+(JME-JMS)/2 - GPS=SQRT(DX_NMM(IMS,JC)**2+DY_NMM**2) + GPS=SQRT(grid%dx_nmm(IMS,JC)**2+grid%dy_nmm**2) ! !*** TIMESTEPS PER HOUR ! @@ -385,27 +442,26 @@ IF(GRID%ID/=1)THEN ! - CALL NESTBC_PATCH (PD_BXS,PD_BXE,PD_BYS,PD_BYE,T_BXS,T_BXE,T_BYS,T_BYE,Q_BXS,Q_BXE & - ,Q_BYS,Q_BYE,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS,V_BXE,V_BYS,V_BYE & - ,Q2_BXS,Q2_BXE,Q2_BYS,Q2_BYE,CWM_BXS,CWM_BXE,CWM_BYS,CWM_BYE & - ,PD_BTXS,PD_BTXE,PD_BTYS,PD_BTYE,T_BTXS,T_BTXE,T_BTYS,T_BTYE & - ,Q_BTXS,Q_BTXE,Q_BTYS,Q_BTYE,U_BTXS,U_BTXE,U_BTYS,U_BTYE & - ,V_BTXS,V_BTXE,V_BTYS,V_BTYE,Q2_BTXS,Q2_BTXE,Q2_BTYS,Q2_BTYE & - ,CWM_BTXS,CWM_BTXE,CWM_BTYS,CWM_BTYE,PDNEST_B,TNEST_B,QNEST_B,UNEST_B & - ,VNEST_B,Q2NEST_B,CWMNEST_B,PDNEST_BT,TNEST_BT,QNEST_BT & - ,UNEST_BT,VNEST_BT,Q2NEST_BT,CWMNEST_BT & + CALL NESTBC_PATCH (grid%PD_BXS,grid%PD_BXE,grid%PD_BYS,grid%PD_BYE,grid%T_BXS,grid%T_BXE,grid%T_BYS,grid%T_BYE,grid%Q_BXS,grid%Q_BXE & + ,grid%Q_BYS,grid%Q_BYE,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS,grid%V_BXE,grid%V_BYS,grid%V_BYE & + ,grid%Q2_BXS,grid%Q2_BXE,grid%Q2_BYS,grid%Q2_BYE,grid%CWM_BXS,grid%CWM_BXE,grid%CWM_BYS,grid%CWM_BYE & + ,grid%PD_BTXS,grid%PD_BTXE,grid%PD_BTYS,grid%PD_BTYE,grid%T_BTXS,grid%T_BTXE,grid%T_BTYS,grid%T_BTYE & + ,grid%Q_BTXS,grid%Q_BTXE,grid%Q_BTYS,grid%Q_BTYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE & + ,grid%V_BTXS,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%Q2_BTXS,grid%Q2_BTXE,grid%Q2_BTYS,grid%Q2_BTYE & + ,grid%CWM_BTXS,grid%CWM_BTXE,grid%CWM_BTYS,grid%CWM_BTYE,grid%pdnest_b,grid%tnest_b,grid%qnest_b,grid%unest_b & + ,grid%vnest_b,grid%q2nest_b,grid%cwmnest_b,grid%pdnest_bt,grid%tnest_bt,grid%qnest_bt & + ,grid%unest_bt,grid%vnest_bt,grid%q2nest_bt,grid%cwmnest_bt & ,GRID%SPEC_BDY_WIDTH & ,IDS,IDF,JDS,JDF,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE ) - CALL wrf_debug ( 100 , 'nmm: out of patch' ) ! #ifdef MOVE_NESTS - IF(GRID%ID/=1.AND.MOD(NTSD,1)==0.AND.GRID%NUM_MOVES==-99)THEN - XLOC_1=(IDE-1)/2 ! This maneuvers the storm to the center of the nest quickly - YLOC_1=(JDE-1)/2 ! This maneuvers the storm to the center of the nest quickly + IF(GRID%ID/=1.AND.MOD(grid%ntsd,1)==0.AND.GRID%NUM_MOVES==-99)THEN + grid%XLOC_1=(IDE-1)/2 ! This maneuvers the storm to the center of the nest quickly + grid%YLOC_1=(JDE-1)/2 ! This maneuvers the storm to the center of the nest quickly ENDIF #endif @@ -424,16 +480,17 @@ !*** !*** Call READPCP to !*** 1) READ IN PRECIPITATION FOR HOURS 1, 2 and 3; -!*** 2) Initialize DDATA to 999. (this is the amount +!*** 2) Initialize grid%ddata to 999. (this is the amount !*** of input precip allocated to each physics time step -!*** in ADJPPT; TURBL/SURFCE, which uses DDATA, is called +!*** in ADJPPT; TURBL/SURFCE, which uses grid%ddata, is called !*** before ADJPPT) -!*** 3) Initialize LSPA to zero +!*** 3) Initialize grid%lspa to zero !*** !----------------------------------------------------------------------- - IF (NTSD==0) THEN + + IF (grid%ntsd==0) THEN IF (GRID%PCPFLG) THEN - CALL READPCP(PPTDAT,DDATA,LSPA & + CALL READPCP(PPTDAT,grid%ddata,grid%lspa & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -447,30 +504,89 @@ !*** ZERO OUT ACCUMULATED QUANTITIES WHEN NEEDED. !----------------------------------------------------------------------- ! - CALL BUCKETS(NTSD,NPREC,NSRFC,NRDSW,NRDLW & + CALL BUCKETS(grid%ntsd,grid%nprec,grid%nsrfc,grid%nrdsw,grid%nrdlw & & ,GRID%RESTART,GRID%TSTART & - & ,NCLOD,NHEAT,GRID%NPHS,TSPH & - & ,ACPREC,CUPREC,ACSNOW,ACSNOM,SSROFF,BGROFF & - & ,SFCEVP,POTEVP,SFCSHX,SFCLHX,SUBSHX,SNOPCX & - & ,SFCUVX,POTFLX & - & ,ARDSW,ASWIN,ASWOUT,ASWTOA & - & ,ARDLW,ALWIN,ALWOUT,ALWTOA & - & ,ACFRST,NCFRST,ACFRCV,NCFRCV & - & ,AVCNVC,AVRAIN,TCUCN,TRAIN & - & ,ASRFC & - & ,T,TLMAX,TLMIN,TSHLTR,PSHLTR,QSHLTR & - & ,T02_MAX,T02_MIN,RH02_MAX,RH02_MIN & + & ,grid%nclod,grid%nheat,GRID%NPHS,TSPH & + & ,grid%acprec,grid%cuprec,grid%acsnow,grid%acsnom,grid%ssroff,grid%bgroff & + & ,grid%sfcevp,grid%potevp,grid%sfcshx,grid%sfclhx,grid%subshx,grid%snopcx & + & ,grid%sfcuvx,grid%potflx & + & ,grid%ardsw,grid%aswin,grid%aswout,grid%aswtoa & + & ,grid%ardlw,grid%alwin,grid%alwout,grid%alwtoa & + & ,grid%acfrst,grid%ncfrst,grid%acfrcv,grid%ncfrcv & + & ,grid%avcnvc,grid%avrain,grid%tcucn,grid%train & + & ,grid%asrfc & + & ,grid%t,grid%tlmax,grid%tlmin,grid%tshltr,grid%pshltr,grid%qshltr & + & ,grid%t02_max,grid%t02_min,grid%rh02_max,grid%rh02_min & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) !----------------------------------------------------------------------- ! - IF(NTSD==0)THEN +#ifdef HWRF +!zhang + IF(NTSD_current==0)THEN +#else + IF(grid%ntsd==0)THEN +#endif FIRST=.TRUE. ! call hpm_init() btimx=timef() ! !----------------------------------------------------------------------- +!*** FIRST STEP INITIALIZATION OF PASSIVE SUBSTANCE VARIABLES +!----------------------------------------------------------------------- +! + IF(EULER) THEN + SUMDRRW=0. +! + DO K=KTS,KTE + DO J=JMS,JME + DO I=IMS,IME + grid%rrw(I,J,K)=0. +! + IF(I>=IDE/2-6.AND.I<=IDE/2+6.AND. & + J>=JDE/2-6.AND.J<=JDE/2+6 ) THEN + grid%rrw(I,J,K)=10.0 !youhua +! grid%rrw(I,J,K)=0.9 !zj + ENDIF +! + ENDDO + ENDDO + ENDDO +! + DO KS=PARAM_FIRST_SCALAR,NUM_SZJ + DO K=KMS,KME + DO J=JMS,JME + DO I=IMS,IME + SZJ(I,J,K,KS)=0. + S1Z(I,J,K,KS)=0. + SPZ(I,J,K,KS)=0. + TCS(I,J,K,KS)=0. + ENDDO + ENDDO + ENDDO + ENDDO +! + ENDIF +! +!----------------------------------------------------------------------- +! +#ifdef WRF_CHEM + DO KS=1,NUM_CHEM + DO K=KMS,KME + DO J=JMS,JME + DO I=IMS,IME + CHE(I,J,K,KS)=0. + CH1(I,J,K,KS)=0. + CHP(I,J,K,KS)=0. + TCC(I,J,K,KS)=0. + ENDDO + ENDDO + ENDDO + ENDDO +#endif +! +!----------------------------------------------------------------------- #ifdef DM_PARALLEL # include "HALO_NMM_A.inc" #endif @@ -482,6 +598,52 @@ ENDIF #endif !----------------------------------------------------------------------- +!*** FIRST STEP INITIALIZATION OF PASSIVE SUBSTANCE VARIABLES +!----------------------------------------------------------------------- +! + IF(EULER) THEN +! + DO K=KTS,KTE + DO J=JMS,JME + DO I=IMS,IME + SPZ(I,J,K,P_SPZ1)=SQRT(MAX(grid%q (I,J,K),EPSQ)) + SPZ(I,J,K,P_SPZ2)=SQRT(MAX(grid%cwm(I,J,K),EPSQ)) + SPZ(I,J,K,P_SPZ4)=SQRT(MAX(grid%rrw(I,J,K),0. )) + ENDDO + ENDDO + ENDDO +! + DO J=JMS,JME + DO I=IMS,IME + SPZ(I,J,KTE,P_SPZ3)=SQRT(MAX((grid%q2(I,J,KTE)+EPSQ2)*0.5,EPSQ2)) + ENDDO + ENDDO +! + DO K=KTE-1,KTS,-1 + DO J=JMS,JME + DO I=IMS,IME + SPZ(I,J,K,P_SPZ3)=SQRT(MAX((grid%q2(I,J,K)+grid%q2(I,J,K+1))*0.5,EPSQ2)) + ENDDO + ENDDO + ENDDO +! + ENDIF +! +!----------------------------------------------------------------------- +! +#ifdef WRF_CHEM + DO KS=1,NUM_CHEM + DO K=KMS,KME + DO J=JMS,JME + DO I=IMS,IME + CHP(I,J,K,KS)=SQRT(MAX(CHEM(I,K,J,KS),0. )) + ENDDO + ENDDO + ENDDO + ENDDO +#endif +! +!----------------------------------------------------------------------- ! !*** Only for chemistry: ! @@ -501,7 +663,17 @@ ! exch_tim_max=exch_tim_max+et_max !----------------------------------------------------------------------- ! +#ifdef HWRF +!zhang's doing + if(GRID%RESTART) then + FIRST=.FALSE. + else + GO TO 2003 + endif +!end of zhang's doing +#else GO TO 2003 +#endif ENDIF ! !----------------------------------------------------------------------- @@ -512,15 +684,17 @@ #ifdef HWRF ! Coupling insertion:-> ! - call ATM_TSTEP_INIT(NTSD,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, & +!zhang's doing call ATM_TSTEP_INIT(NTSD,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, & + call ATM_TSTEP_INIT(NTSD_current,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, & +!end of zhang's doing ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme, & kds,kde,kts,kte,kms,kme, & - HLON,HLAT,VLON,VLAT,SM, & + grid%HLON,grid%HLAT,grid%VLON,grid%VLAT,grid%sm, & grid%i_parent_start,grid%j_parent_start) ! CALL ATM_RECVdtc(NPHS*dt) <- now called from ATM_TSTEP_INIT with no arg. ! CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT) <- now called from ATM_TSTEP_INIT -! CALL ATM_SENDSLM(SM) <- now called from ATM_TSTEP_INIT -!<-:oupling insertion +! CALL ATM_SENDSLM(grid%sm) <- now called from ATM_TSTEP_INIT +!<-:coupling insertion ! #endif !----------------------------------------------------------------------- @@ -545,10 +719,10 @@ #ifdef DM_PARALLEL & GRID,MYPE,MPI_COMM_COMP, & #endif - & NTSD,GRID%DT,PT,ETA2,RES,HYDRO,HBM2 & - & ,PD,PDSL,PDSLO & - & ,PETDT,DIV,PSDT & - & ,IHE,IHW,IVE,IVW & + & grid%ntsd,GRID%DT,grid%pt,grid%eta2,grid%res,grid%hydro,grid%hbm2 & + & ,grid%pd,grid%pdsl,grid%pdslo & + & ,grid%petdt,grid%div,grid%psdt & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -557,7 +731,7 @@ pdte_tim=pdte_tim+timef()-btimx ! !----------------------------------------------------------------------- -!*** ADVECTION OF T, U, AND V +!*** ADVECTION OF grid%t, grid%u, AND grid%v !----------------------------------------------------------------------- ! btimx=timef() @@ -574,17 +748,17 @@ ! exch_tim_max=exch_tim_max+et_max btimx=timef() ! - CALL ADVE(NTSD,GRID%DT,DETA1,DETA2,PDTOP & - & ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX_NMM,DY_NMM & - & ,HBM2,VBM2 & - & ,T,U,V,PDSLO,TOLD,UOLD,VOLD & - & ,PETDT,UPSTRM & - & ,FEW,FNS,FNE,FSE & - & ,ADT,ADU,ADV & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + CALL ADVE(grid%ntsd,GRID%DT,grid%deta1,grid%deta2,grid%pdtop & + & ,grid%curv,grid%f,grid%fad,grid%f4d,grid%em_loc,grid%emt_loc,grid%en,grid%ent,grid%dx_nmm,grid%dy_nmm & + & ,grid%hbm2,grid%vbm2 & + & ,grid%t,grid%u,grid%v,grid%pdslo,grid%told,grid%uold,grid%vold & + & ,grid%petdt,grid%upstrm & + & ,grid%few,grid%fns,grid%fne,grid%fse & + & ,grid%adt,grid%adu,grid%adv & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -592,6 +766,283 @@ adve_tim=adve_tim+timef()-btimx ! !----------------------------------------------------------------------- +!*** PASSIVE SUBSTANCE WORKING PART +!----------------------------------------------------------------------- +! + eulerian: IF(EULER) THEN ! Eulerian advection for model tracers +! +!----------------------------------------------------------------------- +! + IF(config_flags%MP_PHYSICS/=ETAMPNEW) THEN + WRITE( wrf_err_message , * ) 'EULER advection works only with ETAMPNEW microphysics.' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF +! +!----------------------------------------------------------------------- + idtadt_block: IF(MOD(grid%ntsd,IDTADT)==0) THEN +!----------------------------------------------------------------------- + btimx=timef() +#ifdef DM_PARALLEL +# include "HALO_NMM_I.inc" +#endif + exch_tim=exch_tim+timef()-btimx +! + btimx=timef() +! + DO K=KTS,KTE + DO J=JMS,JME + DO I=IMS,IME + SZJ(I,J,K,P_SPZ1)=MAX(grid%q (I,J,K),EPSQ) + SZJ(I,J,K,P_SPZ2)=MAX(grid%cwm(I,J,K),EPSQ) + SZJ(I,J,K,P_SPZ4)=MAX(grid%rrw(I,J,K),0. ) + ENDDO + ENDDO + ENDDO +! + DO J=JMS,JME + DO I=IMS,IME + SZJ(I,J,KTE,P_SPZ3)=MAX((grid%q2 (I,J,KTE)+EPSQ2)*0.5,EPSQ2) + ENDDO + ENDDO +! + DO K=KTE-1,KTS,-1 + DO J=JMS,JME + DO I=IMS,IME + SZJ(I,J,K,P_SPZ3)=MAX((grid%q2 (I,J,K)+grid%q2 (I,J,K+1))*0.5,EPSQ2) + ENDDO + ENDDO + ENDDO +! +#ifdef DM_PARALLEL +# include "HALO_TRACERS.inc" +#endif + CALL ADV2 & + (grid%upstrm & + ,MYPE,PARAM_FIRST_SCALAR,NUM_SZJ & + ,IDS,IDE,JDS,JDE,KDS,KDE & + ,IMS,IME,JMS,JME,KMS,KME & + ,ITS,ITE,JTS,JTE,KTS,KTE & + ,grid%n_iup_h & + ,grid%n_iup_adh & + ,grid%iup_h,grid%iup_adh & + ,grid%ent & + ,IDTADT & + ,grid%DT,grid%pdtop & + ,grid%ihe,grid%ihw,grid%ive,grid%ivw & + ,grid%deta1,grid%deta2 & + ,grid%emt_loc & + ,grid%fad,grid%hbm2,grid%pdsl,grid%pdslo & + ,grid%petdt & + ,grid%uold,grid%vold & + ,SZJ,SPZ & + !temporary arguments + ,grid%fne,grid%fse,grid%few,grid%fns,S1Z,TCS) +! +#ifdef DM_PARALLEL +# include "HALO_TRACERS.inc" +#endif + CALL MONO & + ( & +#if defined(DM_PARALLEL) + GRID%DOMDESC, & +#endif + MYPE,grid%ntsd,grid%ntsd*GRID%DT/3600.,PARAM_FIRST_SCALAR,NUM_SZJ & + ,IDS,IDE,JDS,JDE,KDS,KDE & + ,IMS,IME,JMS,JME,KMS,KME & + ,ITS,ITE,JTS,JTE,KTS,KTE & + ,IDTADT & + ,grid%dy_nmm,grid%pdtop & + ,SUMDRRW & + ,grid%ihe,grid%ihw & + ,grid%deta1,grid%deta2 & + ,grid%dx_nmm,grid%hbm2,grid%pdsl & + ,SZJ & + !temporary arguments + ,S1Z,TCS) +! + DO KS=PARAM_FIRST_SCALAR,NUM_SZJ ! loop by species + DO K=KTS,KTE + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + SZJ(I,J,K,KS)=SZJ(I,J,K,KS)+TCS(I,J,K,KS) + ENDDO + ENDDO + ENDDO + ENDDO ! end of the loop by the species +! + DO K=KTS,KTE + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + grid%q (I,J,K)=SZJ(I,J,K,P_SZJ1) + grid%cwm(I,J,K)=SZJ(I,J,K,P_SZJ2) + grid%rrw(I,J,K)=SZJ(I,J,K,P_SZJ4) + ENDDO + ENDDO + ENDDO +! + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + grid%q2(I,J,KTE)=MAX(SZJ(I,J,KTE,P_SZJ3)+SZJ(I,J,KTE,P_SZJ3)-EPSQ2 & + ,EPSQ2) + ENDDO + ENDDO +! + DO K=KTE-1,KTS+1,-1 + DO J=MYJS2,MYJE2 + DO I=MYIS1,MYIE1 + IF(K>KTS)THEN + grid%q2(I,J,K)=MAX(SZJ(I,J,K,P_SZJ3)+SZJ(I,J,K,P_SZJ3)-grid%q2(I,J,K+1) & + ,EPSQ2) + ELSE + grid%q2(I,J,K)=grid%q2(I,J,K+1) + ENDIF + ENDDO + ENDDO + ENDDO +!----------------------------------------------------------------------- + +! +!*** UPDATE MOIST ARRAY. +!*** REMEMBER THAT MOIST IS ONLY USED WITH THE PHYSICS AND THUS +!*** THE P_QV SLOT (=2) IS MIXING RATIO, NOT SPECIFIC HUMIDITY. +!*** ALTHOUGH MOIST IS ONLY USED FOR PHYSICS IN OPERATIONS, IT IS +!*** UPDATED HERE FROM grid%q EVERY ADVECTION TIMESTEP FOR NON-OPERATIONAL +!*** CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS. +! + IF(.NOT.OPERATIONAL_PHYSICS)THEN + DO K=KTS,KTE + DO J=MYJS,MYJE + DO I=MYIS,MYIE + MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K)) + WC = grid%cwm(I,J,K) + QI = 0. + QR = 0. + QW = 0. + FICE=grid%f_ice(I,K,J) + FRAIN=grid%f_rain(I,K,J) +! + IF(FICE>=1.)THEN + QI=WC + ELSEIF(FICE<=0.)THEN + QW=WC + ELSE + QI=FICE*WC + QW=WC-QI + ENDIF +! + IF(QW>0..AND.FRAIN>0.)THEN + IF(FRAIN>=1.)THEN + QR=QW + QW=0. + ELSE + QR=FRAIN*QW + QW=QW-QR + ENDIF + ENDIF +! + MOIST(I,J,K,P_QC)=QW + MOIST(I,J,K,P_QR)=QR + MOIST(I,J,K,P_QI)=0. + MOIST(I,J,K,P_QS)=QI + MOIST(I,J,K,P_QG)=0. + ENDDO + ENDDO + ENDDO + ENDIF +! + had2_tim=had2_tim+timef()-btimx +!----------------------------------------------------------------------- +! + ENDIF idtadt_block +! +!----------------------------------------------------------------------- +! + ENDIF eulerian ! eulerian advection for model tracers +! +!----------------------------------------------------------------------- +! +#ifdef WRF_CHEM +!----------------------------------------------------------------------- +! + idtadc_block: IF(MOD(grid%ntsd,IDTADC)==0) THEN +! +!----------------------------------------------------------------------- + btimx=timef() +#ifdef DM_PARALLEL +# include "HALO_NMM_I_2.inc" +#endif + exch_tim=exch_tim+timef()-btimx +! + btimx=timef() +! + do KS=1,NUM_CHEM + DO K=KTS,KTE + DO J=JMS,JME + DO I=IMS,IME + CHE(I,J,K,KS)=MAX(CHEM(I,K,J,KS),0. ) + ENDDO + ENDDO + ENDDO + ENDDO +! + CALL ADV2 & + (grid%upstrm & + ,MYPE,1,NUM_CHEM & + ,IDS,IDE,JDS,JDE,KDS,KDE & + ,IMS,IME,JMS,JME,KMS,KME & + ,ITS,ITE,JTS,JTE,KTS,KTE & + ,grid%n_iup_h & + ,grid%n_iup_adh & + ,grid%iup_h,grid%iup_adh & + ,grid%ent & + ,IDTADC & + ,grid%DT,grid%pdtop & + ,grid%ihe,grid%ihw,grid%ive,grid%ivw & + ,grid%deta1,grid%deta2 & + ,grid%emt_loc & + ,grid%fad,grid%hbm2,grid%pdsl,grid%pdslo & + ,grid%petdt & + ,grid%uold,grid%vold & + ,CHE,CHP & + !temporary arguments + ,grid%fne,grid%fse,grid%few,grid%fns,CH1,TCC) +! + CALL MONO & + ( & +#if defined(DM_PARALLEL) + GRID%DOMDESC, & +#endif + MYPE,grid%ntsd,grid%ntsd*GRID%DT/3600.,1,NUM_CHEM & + ,IDS,IDE,JDS,JDE,KDS,KDE & + ,IMS,IME,JMS,JME,KMS,KME & + ,ITS,ITE,JTS,JTE,KTS,KTE & + ,IDTADT & + ,grid%dy_nmm,grid%pdtop & + ,SUMDRRW & + ,grid%ihe,grid%ihw & + ,grid%deta1,grid%deta2 & + ,grid%dx_nmm,grid%hbm2,grid%pdsl & + ,CHE & + !temporary arguments + ,CH1,TCC) +! + DO KS=1,NUM_CHEM + DO K=KTS,KTE + DO J=JMS,JME + DO I=IMS,IME + CHEM(I,K,J,KS)=CHE(I,J,K,KS)+TCC(I,J,K,KS) + ENDDO + ENDDO + ENDDO + ENDDO +!----------------------------------------------------------------------- +! + ENDIF idtadc_block +! +!----------------------------------------------------------------------- +#endif +! +!----------------------------------------------------------------------- !*** PRESSURE TENDENCY, ETA/SIGMADOT, VERTICAL PART OF OMEGA-ALPHA TERM !----------------------------------------------------------------------- ! @@ -601,11 +1052,11 @@ #ifdef DM_PARALLEL & GRID, & #endif - & NTSD,GRID%DT,PT,ETA2 & - & ,HBM2,EF4T & - & ,T,DWDT,RTOP,OMGALF & - & ,PINT,DIV,PSDT,RES & - & ,IHE,IHW,IVE,IVW & + & grid%ntsd,GRID%DT,grid%pt,grid%eta2 & + & ,grid%hbm2,grid%ef4t & + & ,grid%t,grid%dwdt,grid%rtop,grid%omgalf & + & ,grid%pint,grid%div,grid%psdt,grid%res & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -621,11 +1072,11 @@ - CALL VADZ(NTSD,GRID%DT,FIS,GRID%SIGMA,DFL,HBM2 & - & ,DETA1,DETA2,PDTOP & - & ,PINT,PDSL,PDSLO,PETDT & - & ,RTOP,T,Q,CWM,Z,W,DWDT,PDWDT & - & ,IHE,IHW,IVE,IVW & + CALL VADZ(grid%ntsd,GRID%DT,grid%fis,GRID%SIGMA,grid%dfl,grid%hbm2 & + & ,grid%deta1,grid%deta2,grid%pdtop & + & ,grid%pint,grid%pdsl,grid%pdslo,grid%petdt & + & ,grid%rtop,grid%t,grid%q,grid%cwm,grid%z,grid%w,grid%dwdt,grid%pdwdt & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -650,11 +1101,11 @@ ! btimx=timef() ! - CALL HADZ(NTSD,GRID%DT,HYDRO,HBM2,DETA1,DETA2,PDTOP & - & ,DX_NMM,DY_NMM,FAD & - & ,FEW,FNS,FNE,FSE & - & ,PDSL,U,V,W,Z & - & ,IHE,IHW,IVE,IVW & + CALL HADZ(grid%ntsd,GRID%DT,grid%hydro,grid%hbm2,grid%deta1,grid%deta2,grid%pdtop & + & ,grid%dx_nmm,grid%dy_nmm,grid%fad & + & ,grid%few,grid%fns,grid%fne,grid%fse & + & ,grid%pdsl,grid%u,grid%v,grid%w,grid%z & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -662,7 +1113,7 @@ hadz_tim=hadz_tim+timef()-btimx ! !----------------------------------------------------------------------- -!*** ADVECTION OF W +!*** ADVECTION OF grid%w !----------------------------------------------------------------------- ! btimx=timef() @@ -679,14 +1130,14 @@ ! btimx=timef() ! - CALL EPS(NTSD,GRID%DT,HYDRO,DX_NMM,DY_NMM,FAD & - & ,DETA1,DETA2,PDTOP,PT & - & ,HBM2,HBM3 & - & ,PDSL,PDSLO,PINT,RTOP,PETDT,PDWDT & - & ,DWDT,DWDTMN,DWDTMX & - & ,FNS,FEW,FNE,FSE & - & ,T,U,V,W,Q,CWM & - & ,IHE,IHW,IVE,IVW & + CALL EPS(grid%ntsd,GRID%DT,grid%hydro,grid%dx_nmm,grid%dy_nmm,grid%fad & + & ,grid%deta1,grid%deta2,grid%pdtop,grid%pt & + & ,grid%hbm2,grid%hbm3 & + & ,grid%pdsl,grid%pdslo,grid%pint,grid%rtop,grid%petdt,grid%pdwdt & + & ,grid%dwdt,grid%dwdtmn,grid%dwdtmx & + & ,grid%fns,grid%few,grid%fne,grid%fse & + & ,grid%t,grid%u,grid%v,grid%w,grid%q,grid%cwm & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -694,59 +1145,63 @@ eps_tim=eps_tim+timef()-btimx ! !----------------------------------------------------------------------- -!*** VERTICAL ADVECTION OF Q, TKE, AND CLOUD WATER +! + not_euler: IF(.NOT.EULER) THEN ! Lagrangian model tracer advection +! +!----------------------------------------------------------------------- +!*** VERTICAL ADVECTION OF grid%q, TKE, AND CLOUD WATER !----------------------------------------------------------------------- ! - IF(MOD(NTSD,GRID%IDTAD)==0)THEN + IF(MOD(grid%ntsd,GRID%IDTAD)==0)THEN btimx=timef() ! vad2_micro_check: IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN - CALL VAD2(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP,HBM2 & - & ,Q,Q2,CWM,PETDT & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + CALL VAD2(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop,grid%hbm2 & + & ,grid%q,grid%q2,grid%cwm,grid%petdt & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! ELSE vad2_micro_check - CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2 & - & ,Q2,PETDT & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + CALL VAD2_SCAL(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2 & + & ,grid%q2,grid%petdt & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,1,1 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) - CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2 & - & ,MOIST,PETDT & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + CALL VAD2_SCAL(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2 & + & ,MOIST,grid%petdt & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,NUM_MOIST,2 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2 & - & ,SCALAR,PETDT & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + CALL VAD2_SCAL(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2 & + & ,SCALAR,grid%petdt & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,NUM_SCALAR,2 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & @@ -756,7 +1211,7 @@ DO K=KTS,KTE DO J=MYJS,MYJE DO I=MYIS,MYIE - Q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV)) + grid%q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV)) ENDDO ENDDO ENDDO @@ -768,47 +1223,10 @@ ENDIF ! !----------------------------------------------------------------------- -!*** VERTICAL ADVECTION OF CHEMISTRY -!----------------------------------------------------------------------- -! -#ifdef WRF_CHEM - IF(MOD(NTSD,GRID%IDTAD)==0)THEN -#ifdef IBM - btimx=timef() -#endif -! - DO L=1,NUM_CHEM - DO K=KMS,KME - DO J=JMS,JME - DO I=IMS,IME - CHEM_TRANS(I,J,K,L)=CHEM(I,K,J,L) - ENDDO - ENDDO - ENDDO - ENDDO - - - CALL VAD2_SCAL(NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2 & - & ,CHEM_TRANS,PETDT & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & - & ,NUM_CHEM,1 & - & ,IDS,IDF,JDS,JDF,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) -! - ENDIF -#endif -! -!----------------------------------------------------------------------- -!*** HORIZONTAL ADVECTION OF Q, TKE, AND CLOUD WATER +!*** HORIZONTAL ADVECTION OF grid%q, TKE, AND CLOUD WATER !----------------------------------------------------------------------- ! - IF(MOD(NTSD,GRID%IDTAD)==0)THEN + idtad_block: IF(MOD(grid%ntsd,GRID%IDTAD)==0)THEN btimx=timef() !----------------- #ifdef DM_PARALLEL @@ -838,14 +1256,14 @@ #if defined(DM_PARALLEL) & GRID%DOMDESC, & #endif - & NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2,HBM3 & - & ,Q,Q2,CWM,U,V,Z,HYDRO & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + & grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2,grid%hbm3 & + & ,grid%q,grid%q2,grid%cwm,grid%u,grid%v,grid%z,grid%hydro & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -854,20 +1272,20 @@ !*** REMEMBER THAT MOIST IS ONLY USED WITH THE PHYSICS AND THUS !*** THE P_QV SLOT (=2) IS MIXING RATIO, NOT SPECIFIC HUMIDITY. !*** ALTHOUGH MOIST IS ONLY USED FOR PHYSICS IN OPERATIONS, IT IS -!*** UPDATED HERE FROM Q EVERY ADVECTION TIMESTEP FOR NON-OPERATIONAL +!*** UPDATED HERE FROM grid%q EVERY ADVECTION TIMESTEP FOR NON-OPERATIONAL !*** CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS. ! IF(.NOT.OPERATIONAL_PHYSICS)THEN DO K=KTS,KTE DO J=MYJS,MYJE DO I=MYIS,MYIE - MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K)) - WC = CWM(I,J,K) + MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K)) + WC = grid%cwm(I,J,K) QI = 0. QR = 0. QW = 0. - FICE=F_ICE(I,K,J) - FRAIN=F_RAIN(I,K,J) + FICE=grid%f_ice(I,K,J) + FRAIN=grid%f_rain(I,K,J) ! IF(FICE>=1.)THEN QI=WC @@ -890,8 +1308,15 @@ ! MOIST(I,J,K,P_QC)=QW MOIST(I,J,K,P_QR)=QR - MOIST(I,J,K,P_QI)=0. - MOIST(I,J,K,P_QS)=QI + if (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)then +#ifdef HWRF + MOIST(I,J,K,P_QI)=QI + MOIST(I,J,K,P_QS)=0. +#else + MOIST(I,J,K,P_QI)=0. + MOIST(I,J,K,P_QS)=QI +#endif + endif MOIST(I,J,K,P_QG)=0. ENDDO ENDDO @@ -906,14 +1331,14 @@ #if defined(DM_PARALLEL) & GRID%DOMDESC, & #endif - & NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2,HBM3 & - & ,Q2,U,V,Z,HYDRO & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + & grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2,grid%hbm3 & + & ,grid%q2,grid%u,grid%v,grid%z,grid%hydro & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,1,1 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & @@ -923,14 +1348,14 @@ #if defined(DM_PARALLEL) & GRID%DOMDESC, & #endif - & NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2,HBM3 & - & ,MOIST,U,V,Z,HYDRO & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + & grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2,grid%hbm3 & + & ,MOIST,grid%u,grid%v,grid%z,grid%hydro & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,NUM_MOIST,2 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & @@ -940,14 +1365,14 @@ #if defined(DM_PARALLEL) & GRID%DOMDESC, & #endif - & NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2,HBM3 & - & ,SCALAR,U,V,Z,HYDRO & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & + & grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & + & ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop & + & ,grid%hbm2,grid%hbm3 & + & ,SCALAR,grid%u,grid%v,grid%z,grid%hydro & + & ,grid%n_iup_h,grid%n_iup_v & + & ,grid%n_iup_adh,grid%n_iup_adv & + & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,NUM_SCALAR,2 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & @@ -956,7 +1381,7 @@ DO K=KTS,KTE DO J=MYJS,MYJE DO I=MYIS,MYIE - Q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV)) + grid%q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV)) ENDDO ENDDO ENDDO @@ -964,57 +1389,14 @@ !----------------------------------------------------------------------- ENDIF had2_micro_check !----------------------------------------------------------------------- -! had2_tim=had2_tim+timef()-btimx - ENDIF -! -!----------------------------------------------------------------------- -!*** HORIZONTAL ADVECTION OF CHEMISTRY !----------------------------------------------------------------------- ! -#ifdef WRF_CHEM - IF(MOD(NTSD,GRID%IDTAD)==0)THEN - btimx=timef() -#ifdef DM_PARALLEL -# include "HALO_NMM_I_2.inc" -#endif - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx -! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & -! & ,mpi_comm_comp,irtn) -! exch_tim_max=exch_tim_max+et_max + ENDIF idtad_block ! - btimx=timef() +!---------------------------------------------------------------------- ! - CALL HAD2_SCAL( & -#if defined(DM_PARALLEL) - & GRID%DOMDESC, & -#endif - & NTSD,GRID%DT,GRID%IDTAD,DX_NMM,DY_NMM & - & ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP & - & ,HBM2,HBM3 & - & ,CHEM_TRANS,U,V,Z,HYDRO & - & ,N_IUP_H,N_IUP_V & - & ,N_IUP_ADH,N_IUP_ADV & - & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & - & ,IHE,IHW,IVE,IVW & - & ,NUM_CHEM,1 & - & ,IDS,IDF,JDS,JDF,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) - - ENDIF - DO L=1,NUM_CHEM - DO J=JMS,JME - DO K=KMS,KME - DO I=IMS,IME - CHEM(I,K,J,L)=CHEM_TRANS(I,J,K,L) - ENDDO - ENDDO - ENDDO - ENDDO -#endif - + ENDIF not_euler ! Lagrangian model tracer advection ! !---------------------------------------------------------------------- !*** RADIATION @@ -1026,14 +1408,14 @@ NUM_OZMIXM=1 NUM_AEROSOLC=1 ! - IF(NTSD<=0)THEN - NTSD_rad=NTSD + IF(grid%ntsd<=0)THEN + NTSD_rad=grid%ntsd ELSE ! !*** Call radiation just BEFORE the top of the hour !*** so that updated fields are written to history files. ! - NTSD_rad=NTSD+1 + NTSD_rad=grid%ntsd+1 ENDIF ! IF(MOD(NTSD_rad,GRID%NRADS)==0.OR. & @@ -1041,7 +1423,7 @@ ! btimx=timef() IF(OPERATIONAL_PHYSICS)THEN - CALL UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST & + CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1050,20 +1432,20 @@ CALL RADIATION(NTSD_rad,GRID%DT,GRID%JULDAY,GRID%JULYR & & ,GRID%XTIME,GRID%JULIAN & & ,IHRST,GRID%NPHS & - & ,GLAT,GLON,GRID%NRADS,GRID%NRADL & - & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT & - & ,PD,RES,PINT,T,Q,MOIST,THS,ALBEDO,EPSR & - & ,F_ICE,F_RAIN & + & ,grid%glat,grid%glon,GRID%NRADS,GRID%NRADL & + & ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2,grid%pdtop,grid%pt & + & ,grid%pd,grid%res,grid%pint,grid%t,grid%q,MOIST,grid%ths,grid%albedo,grid%epsr & + & ,grid%f_ice,grid%f_rain & #ifdef WRF_CHEM & ,GD_CLOUD,GD_CLOUD2 & #endif - & ,SM,HBM2,CLDFRA,N_MOIST,RESTRT & - & ,RLWTT,RSWTT,RLWIN,RSWIN,RSWINC,RSWOUT & - & ,RLWTOA,RSWTOA,CZMEAN & - & ,CFRACL,CFRACM,CFRACH,SIGT4 & - & ,ACFRST,NCFRST,ACFRCV,NCFRCV & - & ,CUPPT,VEGFRC,SNO,HTOP,HBOT & - & ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM & + & ,grid%sm,grid%hbm2,grid%cldfra,N_MOIST,RESTRT & + & ,grid%rlwtt,grid%rswtt,grid%rlwin,grid%rswin,grid%rswinc,grid%rswout & + & ,grid%rlwtoa,grid%rswtoa,grid%czmean & + & ,grid%cfracl,grid%cfracm,grid%cfrach,grid%sigt4 & + & ,grid%acfrst,grid%ncfrst,grid%acfrcv,grid%ncfrcv & + & ,grid%cuppt,grid%vegfrc,grid%sno,grid%htop,grid%hbot & + & ,grid%z,grid%sice,NUM_AEROSOLC,NUM_OZMIXM & & ,GRID,CONFIG_FLAGS & & ,RTHRATEN & #ifdef WRF_CHEM @@ -1078,13 +1460,13 @@ ! DO J=JMS,JME DO I=IMS,IME - GSW(I,J)=RSWIN(I,J)-RSWOUT(I,J) + grid%gsw(I,J)=grid%rswin(I,J)-grid%rswout(I,J) ENDDO ENDDO ! ! *** NOTE *** -! RLWIN/RSWIN - downward longwave/shortwave at the surface (formerly TOTLWDN/TOTSWDN) -! RSWINC - CLEAR-SKY downward shortwave at the surface (new for AQ) +! grid%rlwin/grid%rswin - downward longwave/shortwave at the surface (formerly TOTLWDN/TOTSWDN) +! grid%rswinc - CLEAR-SKY downward shortwave at the surface (new for AQ) ! *** NOTE *** ! radiation_tim=radiation_tim+timef()-btimx @@ -1100,24 +1482,25 @@ ! the time passed into the zenith angle code consistently between ! RDTEMP and RADIATION. - CALL RDTEMP(NTSD,GRID%DT,GRID%JULDAY,GRID%JULYR & - & ,GRID%XTIME,IHRST,GLAT,GLON & - & ,CZEN,CZMEAN,T,RSWTT,RLWTT,HBM2 & + CALL RDTEMP(grid%ntsd,GRID%DT,GRID%JULDAY,GRID%JULYR & + & ,GRID%XTIME,IHRST,grid%glat,grid%glon & + & ,grid%czen,grid%czmean,grid%t,grid%rswtt,grid%rlwtt,grid%hbm2 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! rdtemp_tim=rdtemp_tim+timef()-btimx ! +! #ifdef HWRF ! !------------------------------------------------------------------------------------- !*** GET SSTs FROM DMITRY's COUPLER ON TO THE PARENT AND NESTED GRID !------------------------------------------------------------------------------------- ! Coupling insertion:-> - CALL ATM_GETSST(SST,SM) + CALL ATM_GETSST(grid%sst,grid%sm) !<-:Coupling insertion - IF(GRID%ID .EQ. 1 .AND. MOD(NTSD,grid%NPHS)==0)THEN + IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN btimx=timef() sst_tim=sst_tim+timef()-btimx ENDIF @@ -1127,63 +1510,64 @@ !*** TURBULENT PROCESSES !---------------------------------------------------------------------- ! - IF(MOD(NTSD,GRID%NPHS)==0)THEN + IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN ! btimx=timef() ! IF(OPERATIONAL_PHYSICS & & .AND.MOD(NTSD_rad,GRID%NRADS)/=0 & & .AND.MOD(NTSD_rad,GRID%NRADL)/=0)THEN - CALL UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST & + CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ENDIF ! - CALL TURBL(NTSD,GRID%DT,GRID%NPHS,RESTRT & - & ,N_MOIST,GRID%NUM_SOIL_LAYERS,SLDPTH,DZSOIL & - & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT & - & ,SM,HBM2,VBM2,DX_NMM,DFRLG & - & ,CZEN,CZMEAN,SIGT4,RLWIN,RSWIN,RADOT & - & ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR & - & ,Q2,U,V,THS,NMM_TSK,SST,PREC,SNO & - & ,FIS,Z0,Z0BASE,USTAR,MIXHT,PBLH,LPBL,EL_MYJ & !PLee (3/07) - & ,MOIST,RMOL,MOL & - & ,EXCH_H,EXCH_M,F,AKHS,AKMS,AKHS_OUT,AKMS_OUT & - & ,THZ0,QZ0,UZ0,VZ0,QSH,MAVAIL & - & ,STC,SMC,CMC,SMSTAV,SMSTOT,SSROFF,BGROFF & - & ,IVGTYP,ISLTYP,VEGFRC,SHDMIN,SHDMAX,GRNFLX & - & ,SNOTIME & - & ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB & - & ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR,EMBCK & - & ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR & - & ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG & + CALL TURBL(grid%ntsd,GRID%DT,GRID%NPHS,RESTRT & + & ,N_MOIST,GRID%NUM_SOIL_LAYERS,grid%sldpth,grid%dzsoil & + & ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2,grid%pdtop,grid%pt & + & ,grid%sm,grid%hbm2,grid%vbm2,grid%dx_nmm,grid%dfrlg & + & ,grid%czen,grid%czmean,grid%sigt4,grid%rlwin,grid%rswin,grid%radot & + & ,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%f_ice,grid%f_rain,grid%sr & + & ,grid%q2,grid%u,grid%v,grid%ths,grid%nmm_tsk,grid%sst,grid%prec,grid%sno & + & ,grid%fis,grid%z0,grid%z0base,grid%ustar,grid%mixht,grid%pblh,grid%lpbl,grid%el_myj & !PLee (3/07) + & ,MOIST,grid%rmol,grid%mol & + & ,grid%exch_h,grid%exch_m,grid%f,grid%akhs,grid%akms,grid%akhs_out,grid%akms_out & + & ,grid%thz0,grid%qz0,grid%uz0,grid%vz0,grid%qsh,grid%mavail & + & ,grid%stc,grid%smc,grid%cmc,grid%smstav,grid%smstot,grid%ssroff,grid%bgroff & + & ,grid%ivgtyp,grid%isltyp,grid%vegfrc,grid%shdmin,grid%shdmax,grid%grnflx & + & ,grid%snotime & + & ,grid%sfcexc,grid%acsnow,grid%acsnom,grid%snopcx,grid%sice,grid%tg,grid%soiltb & + & ,grid%albase,grid%mxsnal,grid%albedo,grid%sh2o,grid%si,grid%epsr,grid%embck & + & ,grid%u10,grid%v10,grid%th10,grid%q10,grid%tshltr,grid%qshltr,grid%pshltr & + & ,grid%t2,grid%qsg,grid%qvg,grid%qcg,grid%soilt1,grid%tsnav,grid%smfr3d,grid%keepfr3dflag & #if (NMM_CORE==1) - & ,TWBS,QWBS,TAUX,TAUY,SFCSHX,SFCLHX,SFCEVP & + & ,grid%twbs,grid%qwbs,grid%taux,grid%tauy,grid%sfcshx,grid%sfclhx,grid%sfcevp & #else - & ,TWBS,QWBS,SFCSHX,SFCLHX,SFCEVP & + & ,grid%twbs,grid%qwbs,grid%sfcshx,grid%sfclhx,grid%sfcevp & #endif - & ,POTEVP,POTFLX,SUBSHX & - & ,APHTIM,ARDSW,ARDLW,ASRFC & - & ,RSWOUT,RSWTOA,RLWTOA & - & ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA & + & ,grid%potevp,grid%potflx,grid%subshx & + & ,grid%aphtim,grid%ardsw,grid%ardlw,grid%asrfc & + & ,grid%rswout,grid%rswtoa,grid%rlwtoa & + & ,grid%aswin,grid%aswout,grid%aswtoa,grid%alwin,grid%alwout,grid%alwtoa & #if (NMM_CORE==1) - & ,UZ0H,VZ0H,DUDT,DVDT,UGWDsfc,VGWDsfc,SFENTH & + & ,grid%uz0h,grid%vz0h,grid%dudt,grid%dvdt,grid%ugwdsfc,grid%vgwdsfc,grid%sfenth & #else - & ,UZ0H,VZ0H,DUDT,DVDT & + & ,grid%uz0h,grid%vz0h,grid%dudt,grid%dvdt & #endif & ,RTHBLTEN,RQVBLTEN & - & ,GRID%PCPFLG,DDATA & - & ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW,HLENS & ! GWD - & ,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX,CROT,SROT & ! GWD + & ,GRID%PCPFLG,grid%ddata & + & ,grid%hstdv,grid%hcnvx,grid%hasyw,grid%hasys,grid%hasysw,grid%hasynw,grid%hlenw,grid%hlens & ! GWD + & ,grid%hlensw,grid%hlennw,grid%hangl,grid%hanis,grid%hslop,grid%hzmax,grid%crot,grid%srot & ! GWD & ,GRID,CONFIG_FLAGS & - & ,IHE,IHW,IVE,IVW & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & + & ,GRID%DISHEAT & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! ! *** NOTE *** -! RLWIN/RSWIN - downward longwave/shortwave at the surface +! grid%rlwin/grid%rswin - downward longwave/shortwave at the surface ! *** NOTE *** ! turbl_tim=turbl_tim+timef()-btimx @@ -1194,27 +1578,27 @@ !*** ATMOSPHERIC MODEL OUTPUTS FROM PARENT AND NESTED GRID FOR DMITRYs COUPLER !------------------------------------------------------------------------------ ! -!-- TWBS : surface sensible heat flux, positive downward (W/m2) -!-- QWBS : surface latent heat flux, positive downward (W/m2) -!-- RLWIN : downward long wave flux at ground surface,positive downward (W/m2) -!-- RSWIN : downward short wave flux at ground surface, positive downward (W/m2) -!-- RADOT : outgoing long wave flux at ground surface, positive upward (W/m2) -!-- RSWOUT: outgoing short wave flux at ground surface, positive upward (W/m2) -!-- TAUX : x component of surface stress, u positive Eastward -!-- TAUY : y component of surface stress, v positive Northward -!-- PINT : 3d array of interface pressure (pascals) -!-- PREC : prec (m/timestep;timestep on grid1=60 sec) +!-- grid%twbs : surface sensible heat flux, positive downward (grid%w/m2) +!-- grid%qwbs : surface latent heat flux, positive downward (grid%w/m2) +!-- grid%rlwin : downward long wave flux at ground surface,positive downward (grid%w/m2) +!-- grid%rswin : downward short wave flux at ground surface, positive downward (grid%w/m2) +!-- grid%radot : outgoing long wave flux at ground surface, positive upward (grid%w/m2) +!-- grid%rswout: outgoing short wave flux at ground surface, positive upward (grid%w/m2) +!-- grid%taux : x component of surface stress, grid%u positive Eastward +!-- grid%tauy : y component of surface stress, grid%v positive Northward +!-- grid%pint : 3d array of interface pressure (pascals) +!-- grid%prec : grid%prec (m/timestep;timestep on grid1=60 sec) ! ! ! Coupling insertion:-> - call ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, & - TAUX,TAUY,PINT(:,1,:),PREC) + call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, & + grid%taux,grid%tauy,grid%pint(:,1,:),grid%prec) !<-:Coupling insertion ! - IF(GRID%ID .EQ. 1 .AND. MOD(NTSD,grid%NPHS)==0)THEN + IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN btimx=timef() flux_tim=flux_tim+timef()-btimx ENDIF @@ -1237,11 +1621,11 @@ ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! -!*** INTERPOLATE WINDS FROM H POINTS BACK TO V POINTS. +!*** INTERPOLATE WINDS FROM H POINTS BACK TO grid%v POINTS. ! btimx=timef() - CALL UV_H_TO_V(NTSD,GRID%DT,GRID%NPHS,UZ0H,VZ0H,UZ0,VZ0 & - & ,DUDT,DVDT,U,V,HBM2,IVE,IVW & + CALL UV_H_TO_V(grid%ntsd,GRID%DT,GRID%NPHS,grid%uz0h,grid%vz0h,grid%uz0,grid%vz0 & + & ,grid%dudt,grid%dvdt,grid%u,grid%v,grid%hbm2,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1278,20 +1662,21 @@ ICLTEND=-1 btimx=timef() ! - CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ & + CALL CLTEND(ICLTEND,GRID%NPHS,grid%t,grid%t_old,grid%t_adj & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! cltend_tim=cltend_tim+timef()-btimx - ENDIF + ENDIF ! !---------------------------------------------------------------------- !*** CONVECTIVE PRECIPITATION !---------------------------------------------------------------------- ! - IF(MOD(NTSD,GRID%NCNVC)==0.AND. & - & CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME)THEN + IF(MOD(grid%ntsd,GRID%NCNVC)==0.AND. & + & (CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME .or. & + CONFIG_FLAGS%CU_PHYSICS==SASSCHEME))THEN ! Kwon's doing for SAS ! btimx=timef() !----------------- @@ -1304,7 +1689,7 @@ ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max - ENDIF + ENDIF ! convection: IF(CONFIG_FLAGS%CU_PHYSICS/=0)THEN btimx=timef() @@ -1316,8 +1701,8 @@ DO J=JMS,JME DO K=KMS,KME DO I=IMS,IME - TTEN(I,K,J)=(T(I,J,K)-TTEN(I,K,J))*DT_INV - QTEN(I,K,J)=(Q(I,J,K)-QTEN(I,K,J))*DT_INV + TTEN(I,K,J)=(grid%t(I,J,K)-TTEN(I,K,J))*DT_INV + QTEN(I,K,J)=(grid%q(I,J,K)-QTEN(I,K,J))*DT_INV ENDDO ENDDO ENDDO @@ -1328,37 +1713,43 @@ IF(OPERATIONAL_PHYSICS & & .AND.MOD(NTSD_rad,GRID%NRADS)/=0 & & .AND.MOD(NTSD_rad,GRID%NRADL)/=0 & - & .AND.MOD(NTSD,GRID%NPHS)/=0)THEN - CALL UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST & + & .AND.MOD(grid%ntsd,GRID%NPHS)/=0)THEN + CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) - ENDIF + ENDIF ! !---------------------------------------------------------------------- - CALL CUCNVC(NTSD,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL & - & ,GPS,RESTRT,HYDRO,CLDEFI,N_MOIST,GRID%ENSDIM & + CALL CUCNVC(grid%ntsd,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL & + & ,GPS,RESTRT,grid%hydro,grid%cldefi,N_MOIST,GRID%ENSDIM & & ,MOIST & - & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 & - & ,F_ICE,F_RAIN & + & ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2 & + & ,grid%f_ice,grid%f_rain & !*** Changes for other cu schemes, most for GD scheme - & ,APR_GR,APR_W,APR_MC,TTEN,QTEN & - & ,APR_ST,APR_AS,APR_CAPMA & - & ,APR_CAPME,APR_CAPMI & - & ,MASS_FLUX,XF_ENS & - & ,PR_ENS,GSW & + & ,grid%apr_gr,grid%apr_w,grid%apr_mc,TTEN,QTEN & + & ,grid%apr_st,grid%apr_as,grid%apr_capma & + & ,grid%apr_capme,grid%apr_capmi & + & ,grid%mass_flux,grid%xf_ens & + & ,grid%pr_ens,grid%gsw & #ifdef WRF_CHEM & ,GD_CLOUD,GD_CLOUD2,RAINCV & #endif ! - & ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN & - & ,OMGALF,U,V,W,Z,FIS,W0AVG & - & ,PREC,ACPREC,CUPREC,CUPPT,CPRATE & - & ,SM,HBM2,LPBL,CNVBOT,CNVTOP & - & ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS & + & ,grid%pdtop,grid%pt,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%tcucn & + & ,grid%omgalf,grid%u,grid%v,grid%w,grid%z,grid%fis,grid%w0avg & + & ,grid%prec,grid%acprec,grid%cuprec,grid%cuppt,grid%cprate & + & ,grid%sm,grid%hbm2,grid%lpbl,grid%cnvbot,grid%cnvtop & + & ,grid%htop,grid%hbot,grid%htopd,grid%hbotd,grid%htops,grid%hbots & & ,RTHBLTEN,RQVBLTEN,RTHRATEN & - & ,AVCNVC,ACUTIM,IHE,IHW & +#if (NMM_CORE==1) + & ,grid%DUCUDT, grid%DVCUDT, GRID%MOMMIX, grid%store_rand & +#endif + & ,grid%avcnvc,grid%acutim,grid%ihe,grid%ihw & & ,GRID,CONFIG_FLAGS & +#ifdef HWRF + & ,grid%NRND1 & ! NRND1 zhang's doing +#endif & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE & @@ -1367,25 +1758,63 @@ ! cucnvc_tim=cucnvc_tim+timef()-btimx ! - ENDIF convection + + +#if (NMM_CORE==1) +!#ifdef HWRF +!------------------------------------------------------------------------------------- +! This is gopal's doing for HWRFSAS + + IF(MOD(grid%ntsd,GRID%NCNVC).eq.0.and.(CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN +! + btimx=timef() +!----------------- +#ifdef DM_PARALLEL +# include "HALO_NMM_SAS_A.inc" +#endif +!----------------- +#ifdef DM_PARALLEL +# include "HALO_NMM_SAS_B.inc" +#endif +!----------------- + exch_tim=exch_tim+timef()-btimx + +! +!*** INTERPOLATE WINDS FROM H POINTS BACK TO V POINTS AFTER SAS +! + btimx=timef() + + CALL UV_H_TO_V(grid%NTSD,GRID%DT,GRID%NPHS,grid%UZ0H,grid%VZ0H,grid%UZ0,grid%VZ0 & + & ,grid%DUCUDT,grid%DVCUDT,grid%U,grid%V,grid%HBM2,grid%IVE,grid%IVW & + & ,IDS,IDF,JDS,JDF,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE) + uv_htov_tim=uv_htov_tim+timef()-btimx + + ENDIF ! for SAS only +!#endif +#endif +!-------------------------------------------------------------------------------- +! + ENDIF convection ! !---------------------------------------------------------------------- !*** GRIDSCALE MICROPHYSICS (CONDENSATION & PRECIPITATION) !---------------------------------------------------------------------- ! - IF(MOD(NTSD,GRID%NPHS)==0)THEN + IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN btimx=timef() ! - CALL GSMDRIVE(NTSD,GRID%DT,GRID%NPHS,N_MOIST & - & ,DX_NMM(ITS,JC),GRID%DY,SM,HBM2,FIS & - & ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2 & - & ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TRAIN & + CALL GSMDRIVE(grid%ntsd,GRID%DT,GRID%NPHS,N_MOIST & + & ,grid%dx_nmm(ITS,JC),GRID%DY,grid%sm,grid%hbm2,grid%fis & + & ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2 & + & ,grid%pdtop,grid%pt,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%train & & ,MOIST,SCALAR,NUM_SCALAR & - & ,F_ICE,F_RAIN,F_RIMEF,SR & - & ,PREC,ACPREC,AVRAIN & - & ,MP_RESTART_STATE & - & ,TBPVS_STATE & - & ,TBPVS0_STATE & + & ,grid%f_ice,grid%f_rain,grid%f_rimef,grid%sr & + & ,grid%prec,grid%acprec,grid%avrain & + & ,grid%mp_restart_state & + & ,grid%tbpvs_state & + & ,grid%tbpvs0_state & & ,GRID,CONFIG_FLAGS & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & @@ -1400,11 +1829,11 @@ IF (GRID%PCPFLG) THEN btimx=timef() ! - CALL CHKSNOW(NTSD,GRID%DT,GRID%NPHS,SR,PPTDAT & + CALL CHKSNOW(grid%ntsd,GRID%DT,GRID%NPHS,grid%sr,PPTDAT & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) - CALL ADJPPT(NTSD,GRID%DT,GRID%NPHS,PREC,LSPA,PPTDAT,DDATA & + CALL ADJPPT(grid%ntsd,GRID%DT,GRID%NPHS,grid%prec,grid%lspa,PPTDAT,grid%ddata & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1419,7 +1848,7 @@ ICLTEND=0 btimx=timef() ! - CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ & + CALL CLTEND(ICLTEND,GRID%NPHS,grid%t,grid%t_old,grid%t_adj & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1434,7 +1863,7 @@ ICLTEND=1 btimx=timef() ! - CALL CLTEND(ICLTEND,GRID%NPHS,T,T_OLD,T_ADJ & + CALL CLTEND(ICLTEND,GRID%NPHS,grid%t,grid%t_old,grid%t_adj & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1459,14 +1888,15 @@ ! btimx=timef() ! - CALL HDIFF(NTSD,GRID%DT,FIS,DY_NMM,HDAC,HDACV & - & ,HBM2,DETA1,GRID%SIGMA & + CALL HDIFF(grid%ntsd,GRID%DT,grid%fis,grid%dy_nmm,grid%hdac,grid%hdacv & + & ,grid%hbm2,grid%deta1,GRID%SIGMA & #ifdef HWRF - & ,T,Q,U,V,Q2,Z,W,SM,SICE,grid%h_diff & + & ,grid%t,grid%q,grid%u,grid%v,grid%q2,grid%z,grid%w,grid%sm,grid%sice,grid%h_diff & #else - & ,T,Q,U,V,Q2,Z,W,SM,SICE & + & ,grid%t,grid%q,grid%u,grid%v,grid%q2,grid%z,grid%w,grid%sm,grid%sice & #endif - & ,IHE,IHW,IVE,IVW & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & + & ,CONFIG_FLAGS & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1475,8 +1905,8 @@ DO K=KTS,KTE DO J=MYJS,MYJE DO I=MYIS,MYIE -!!! MOIST(I,J,K,P_QV)=MAX(0.,Q(I,J,K)/(1.-Q(I,J,K))) - MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K)) !<-- Update mixing ratio +!!! MOIST(I,J,K,P_QV)=MAX(0.,grid%q(I,J,K)/(1.-grid%q(I,J,K))) + MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K)) !<-- Update mixing ratio ENDDO ENDDO ENDDO @@ -1512,22 +1942,22 @@ ! btimx=timef() ! - CALL BOCOH(GRID%ID,NTSD,GRID%DT,NEST,NUNIT_NBC,NBOCO,LAST_TIME,TSPH & - & ,LB,ETA1,ETA2,PDTOP,PT,RES & - & ,PD_BXS,PD_BXE,PD_BYS,PD_BYE,T_BXS,T_BXE,T_BYS,T_BYE & - & ,Q_BXS,Q_BXE,Q_BYS,Q_BYE,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS & - & ,V_BXE,V_BYS,V_BYE,Q2_BXS,Q2_BXE,Q2_BYS,Q2_BYE,CWM_BXS & - & ,CWM_BXE,CWM_BYS,CWM_BYE,PD_BTXS,PD_BTXE,PD_BTYS & - & ,PD_BTYE,T_BTXS,T_BTXE,T_BTYS,T_BTYE,Q_BTXS,Q_BTXE & - & ,Q_BTYS,Q_BTYE,U_BTXS,U_BTXE,U_BTYS,U_BTYE,V_BTXS & - & ,V_BTXE,V_BTYS,V_BTYE,Q2_BTXS,Q2_BTXE,Q2_BTYS,Q2_BTYE & - & ,CWM_BTXS,CWM_BTXE,CWM_BTYS,CWM_BTYE,PD,T,Q,Q2,CWM,PINT & + CALL BOCOH(GRID%ID,grid%ntsd,GRID%DT,NEST,NUNIT_NBC,NBOCO,LAST_TIME,TSPH & + & ,LB,grid%eta1,grid%eta2,grid%pdtop,grid%pt,grid%res & + & ,grid%PD_BXS,grid%PD_BXE,grid%PD_BYS,grid%PD_BYE,grid%T_BXS,grid%T_BXE,grid%T_BYS,grid%T_BYE & + & ,grid%Q_BXS,grid%Q_BXE,grid%Q_BYS,grid%Q_BYE,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS & + & ,grid%V_BXE,grid%V_BYS,grid%V_BYE,grid%Q2_BXS,grid%Q2_BXE,grid%Q2_BYS,grid%Q2_BYE,grid%CWM_BXS & + & ,grid%CWM_BXE,grid%CWM_BYS,grid%CWM_BYE,grid%PD_BTXS,grid%PD_BTXE,grid%PD_BTYS & + & ,grid%PD_BTYE,grid%T_BTXS,grid%T_BTXE,grid%T_BTYS,grid%T_BTYE,grid%Q_BTXS,grid%Q_BTXE & + & ,grid%Q_BTYS,grid%Q_BTYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS & + & ,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%Q2_BTXS,grid%Q2_BTXE,grid%Q2_BTYS,grid%Q2_BTYE & + & ,grid%CWM_BTXS,grid%CWM_BTXE,grid%CWM_BTYS,grid%CWM_BTYE,grid%pd,grid%t,grid%q,grid%q2,grid%cwm,grid%pint & & ,MOIST,N_MOIST,SCALAR,NUM_SCALAR & #ifdef WRF_CHEM & ,CHEM,NUMGAS,CONFIG_FLAGS & #endif - & ,GRID%SPEC_BDY_WIDTH,Z & - & ,IHE,IHW,IVE,IVW & + & ,GRID%SPEC_BDY_WIDTH,grid%z & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1535,8 +1965,8 @@ ! bocoh_tim=bocoh_tim+timef()-btimx -! if(mod(ntsd,n_print_time)==0)then -! call twr(t,0,'t',ntsd,mype,npes,mpi_comm_comp & +! if(mod(grid%ntsd,n_print_time)==0)then +! call twr(grid%t,0,'grid%t',grid%ntsd,mype,npes,mpi_comm_comp & ! & ,ids,ide,jds,jde,kds,kde & ! & ,ims,ime,jms,jme,kms,kme & ! & ,its,ite,jts,jte,kts,kte) @@ -1578,13 +2008,13 @@ ! btimx=timef() ! - CALL PFDHT(NTSD,LAST_TIME,PT,DETA1,DETA2,PDTOP,RES,FIS & - & ,HYDRO,GRID%SIGMA,FIRST,DX_NMM,DY_NMM & - & ,HBM2,VBM2,VBM3 & - & ,FDIV,FCP,WPDAR,DFL,CPGFU,CPGFV & - & ,PD,PDSL,T,Q,U,V,CWM,OMGALF,PINT,DWDT & - & ,RTOP,DIV,FEW,FNS,FNE,FSE & - & ,IHE,IHW,IVE,IVW & + CALL PFDHT(grid%ntsd,LAST_TIME,grid%pt,grid%deta1,grid%deta2,grid%pdtop,grid%res,grid%fis & + & ,grid%hydro,GRID%SIGMA,FIRST,grid%dx_nmm,grid%dy_nmm & + & ,grid%hbm2,grid%vbm2,grid%vbm3 & + & ,grid%fdiv,grid%fcp,grid%wpdar,grid%dfl,grid%cpgfu,grid%cpgfv & + & ,grid%pd,grid%pdsl,grid%t,grid%q,grid%u,grid%v,grid%cwm,grid%omgalf,grid%pint,grid%dwdt & + & ,grid%rtop,grid%div,grid%few,grid%fns,grid%fne,grid%fse & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1610,9 +2040,9 @@ ! btimx=timef() ! - CALL DDAMP(NTSD,GRID%DT,DETA1,DETA2,PDSL,PDTOP,DIV,HBM2 & - & ,T,U,V,DDMPU,DDMPV & - & ,IHE,IHW,IVE,IVW & + CALL DDAMP(grid%ntsd,GRID%DT,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop,grid%div,grid%hbm2 & + & ,grid%t,grid%u,grid%v,grid%ddmpu,grid%ddmpv & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1622,7 +2052,7 @@ !---------------------------------------------------------------------- !---------------------------------------------------------------------- ! - IF(FIRST.AND.NTSD==0)THEN + IF(FIRST.AND.grid%ntsd==0)THEN FIRST=.FALSE. btimx=timef() !----------------- @@ -1662,11 +2092,11 @@ ! btimx=timef() ! - CALL BOCOV(GRID%ID,NTSD,GRID%DT,LB,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS & - & ,V_BXE,V_BYS,V_BYE,U_BTXS,U_BTXE,U_BTYS,U_BTYE,V_BTXS & - & ,V_BTXE,V_BTYS,V_BTYE,U,V & + CALL BOCOV(GRID%ID,grid%ntsd,GRID%DT,LB,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS & + & ,grid%V_BXE,grid%V_BYS,grid%V_BYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS & + & ,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%u,grid%v & & ,GRID%SPEC_BDY_WIDTH & - & ,IHE,IHW,IVE,IVW & + & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE ) @@ -1675,13 +2105,13 @@ bocov_tim=bocov_tim+timef()-btimx ! !---------------------------------------------------------------------- -!*** COPY THE NMM VARIABLE Q2 TO THE WRF VARIABLE TKE_MYJ +!*** COPY THE NMM VARIABLE grid%q2 TO THE WRF VARIABLE grid%tke_myj !---------------------------------------------------------------------- ! DO K=KTS,KTE DO J=JTS,JTE DO I=ITS,ITE - TKE_MYJ(I,J,K)=0.5*Q2(I,J,K) !TKE is q squared over 2 + grid%tke_myj(I,J,K)=0.5*grid%q2(I,J,K) !TKE is grid%q squared over 2 ENDDO ENDDO ENDDO @@ -1706,8 +2136,8 @@ & +bocoh_tim+pfdht_tim+ddamp_tim+bocov_tim+uv_htov_tim & & +exch_tim+adjppt_tim ! - if(mod(ntsd,n_print_time)==0)then - write(message,*)' ntsd=',ntsd,' solve_tim=',solve_tim*1.e-3 & + if(mod(grid%ntsd,n_print_time)==0)then + write(message,*)' grid%ntsd=',grid%ntsd,' solve_tim=',solve_tim*1.e-3 & & ,' sum_tim=',sum_tim*1.e-3 call wrf_message(trim(message)) write(message,*)' pdte_tim=',pdte_tim*1.e-3,' pct=',pdte_tim/sum_tim*100. @@ -1754,11 +2184,11 @@ call wrf_message(trim(message)) write(message,*)' exch_tim=',exch_tim*1.e-3,' pct=',exch_tim/sum_tim*100. call wrf_message(trim(message)) -! call time_stats(exch_tim,'exchange',ntsd,mype,npes,mpi_comm_comp) +! call time_stats(exch_tim,'exchange',grid%ntsd,mype,npes,mpi_comm_comp) ! write(message,*)' exch_tim_max=',exch_tim_max*1.e-3 ! call wrf_message(trim(message)) ! - call field_stats(t,mype,mpi_comm_comp & + call field_stats(grid%t,mype,mpi_comm_comp & & ,ids,ide,jds,jde,kds,kde & & ,ims,ime,jms,jme,kms,kme & & ,its,ite,jts,jte,kts,kte) @@ -1771,7 +2201,6 @@ DEALLOCATE(RTHBLTEN,STAT=ISTAT) DEALLOCATE(RQVBLTEN,STAT=ISTAT) #ifdef WRF_CHEM - DEALLOCATE(CHEM_TRANS,STAT=ISTAT) #endif ! ! FOR VORTEX FOLLOWING MOVING NEST @@ -1781,18 +2210,23 @@ !----------------------------------------------------------------------------- ! #ifdef MOVE_NESTS - IF(grid%id .NE. 1 .AND. MOD(NTSD,1)==0 .AND. grid%num_moves.EQ.-99)THEN + IF(grid%id .NE. 1 .AND. MOD(grid%ntsd,1)==0 .AND. grid%num_moves.EQ.-99)THEN !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_TRACK.inc" #endif !----------------- - CALL STATS_FOR_MOVE (XLOC_2,YLOC_2,PDYN,MSLP,SQWS & - ,PINT,T,Q,U,V & - ,FIS,PD,SM,PDTOP,PT & - ,DETA1,DETA2 & - ,GRID%MOVED,MVNEST,NTSD,GRID%NPHS,GRID%MOVEMIN & ! MOVEMIN*DT*NPHS=540s + CALL STATS_FOR_MOVE (grid%XLOC_2,grid%YLOC_2,grid%PDYN,grid%MSLP,grid%SQWS & + ,grid%pint,grid%t,grid%q,grid%u,grid%v & + ,grid%fis,grid%pd,grid%sm,grid%pdtop,grid%pt & + ,grid%deta1,grid%deta2 & +#ifdef HWRF + ,GRID%RESTART,grid%NTIME0 & ! zhang's doing + ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS,GRID%MOVEMIN & ! MOVEMIN*DT*NPHS=540s +#else + ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS +#endif ,IDS,IDF,JDS,JDF,KDS,KDE & ! MOVEMIN is defined in ,IMS,IME,JMS,JME,KMS,KME & ! Registry ,ITS,ITE,JTS,JTE,KTS,KTE ) ! FOR NEST:DT=18,NPHS=3 @@ -1801,8 +2235,8 @@ #endif -#define COPY_OUT -#include +!#define COPY_OUT +!#include #ifdef HWRF !----------------------------------------------------------------------- !*** ACCUMULATED ATMOSPHERIC MODEL FLUXES FOR DMITRYs COUPLER @@ -1816,7 +2250,7 @@ ! ! Kwon's doing to check heat flux ! -! IF(grid%id==2)WRITE(0,*)'AFTER ATM_SENDFLUX QWBS TWBS AT 10 10 ',NTSD,QWBS(10,10),TWBS(10,10) +! IF(grid%id==2)WRITE(0,*)'AFTER ATM_SENDFLUX grid%qwbs grid%twbs AT 10 10 ',grid%ntsd,grid%qwbs(10,10),grid%twbs(10,10) ! #endif @@ -1833,7 +2267,7 @@ !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- - SUBROUTINE TWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP & + SUBROUTINE TWR(ARRAY,KK,FIELD,ntsd,MYPE,NPES,MPI_COMM_COMP & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1850,7 +2284,7 @@ INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE & - & ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD + & ,KK,MPI_COMM_COMP,MYPE,NPES,ntsd ! REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME+KK),INTENT(IN) :: ARRAY ! @@ -1877,23 +2311,23 @@ !********************************************************************** !---------------------------------------------------------------------- ! - IF(NTSD<=9)THEN + IF(ntsd<=9)THEN FMT='(I1.1)' NLEN=1 - ELSEIF(NTSD<=99)THEN + ELSEIF(ntsd<=99)THEN FMT='(I2.2)' NLEN=2 - ELSEIF(NTSD<=999)THEN + ELSEIF(ntsd<=999)THEN FMT='(I3.3)' NLEN=3 - ELSEIF(NTSD<=9999)THEN + ELSEIF(ntsd<=9999)THEN FMT='(I4.4)' NLEN=4 - ELSEIF(NTSD<=99999)THEN + ELSEIF(ntsd<=99999)THEN FMT='(I5.5)' NLEN=5 ENDIF - WRITE(TIMESTEP,FMT)NTSD + WRITE(TIMESTEP,FMT)ntsd FILENAME=FIELD//'_'//TIMESTEP(1:NLEN) ! IF(MYPE==0)THEN @@ -2007,7 +2441,7 @@ !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- - SUBROUTINE VWR(ARRAY,KK,FIELD,NTSD,MYPE,NPES,MPI_COMM_COMP & + SUBROUTINE VWR(ARRAY,KK,FIELD,ntsd,MYPE,NPES,MPI_COMM_COMP & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -2024,7 +2458,7 @@ INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE & - & ,KK,MPI_COMM_COMP,MYPE,NPES,NTSD + & ,KK,MPI_COMM_COMP,MYPE,NPES,ntsd ! REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME+KK),INTENT(IN) :: ARRAY ! @@ -2052,23 +2486,23 @@ !********************************************************************** !---------------------------------------------------------------------- ! - IF(NTSD<=9)THEN + IF(ntsd<=9)THEN FMT='(I1.1)' NLEN=1 - ELSEIF(NTSD<=99)THEN + ELSEIF(ntsd<=99)THEN FMT='(I2.2)' NLEN=2 - ELSEIF(NTSD<=999)THEN + ELSEIF(ntsd<=999)THEN FMT='(I3.3)' NLEN=3 - ELSEIF(NTSD<=9999)THEN + ELSEIF(ntsd<=9999)THEN FMT='(I4.4)' NLEN=4 - ELSEIF(NTSD<=99999)THEN + ELSEIF(ntsd<=99999)THEN FMT='(I5.5)' NLEN=5 ENDIF - WRITE(TIMESTEP,FMT)NTSD + WRITE(TIMESTEP,FMT)ntsd FILENAME=FIELD//'_'//TIMESTEP(1:NLEN) ! IF(MYPE==0)THEN @@ -2196,8 +2630,8 @@ !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- - SUBROUTINE EXIT(NAME,PINT,T,Q,U,V,Q2,W & - & ,NTSD,MYPE,MPI_COMM_COMP & + SUBROUTINE EXIT(NAME,pint,t,q,u,v,q2,w & + & ,ntsd,MYPE,MPI_COMM_COMP & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -2215,10 +2649,10 @@ INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE & - & ,MYPE,MPI_COMM_COMP,NTSD + & ,MYPE,MPI_COMM_COMP,ntsd ! - REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT,T,Q & - ,U,V,Q2,W + REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: pint,t,q & + ,u,v,q2,w CHARACTER(*),INTENT(IN) :: NAME ! INTEGER :: I,J,K,IEND,IERR,IRET @@ -2226,7 +2660,7 @@ LOGICAL :: E_BDY,S_BDY !---------------------------------------------------------------------- IRET=0 - 100 FORMAT(' EXIT ',A,' AT NTSD=',I5) + 100 FORMAT(' EXIT ',A,' AT ntsd=',I5) IEND=ITE S_BDY=(JTS==JDS) E_BDY=(ITE==IDE-1) @@ -2237,53 +2671,53 @@ IF(E_BDY.AND.MOD(J,2)==0)IEND=ITE-1 ! DO I=ITS,IEND - IF(T(I,J,K)>330..OR.T(I,J,K)<180..OR.T(I,J,K)/=T(I,J,K))THEN - WRITE(errmess,100)NAME,NTSD + IF(t(I,J,K)>330..OR.t(I,J,K)<180..OR.t(I,J,K)/=t(I,J,K))THEN + WRITE(errmess,100)NAME,ntsd CALL wrf_message(trim(errmess)) - WRITE(errmess,200)I,J,K,T(I,J,K),MYPE,NTSD + WRITE(errmess,200)I,J,K,t(I,J,K),MYPE,ntsd CALL wrf_message(trim(errmess)) - 200 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' T=',E12.5 & - &, ' MYPE=',I3,' NTSD=',I5) + 200 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' t=',E12.5 & + &, ' MYPE=',I3,' ntsd=',I5) IRET=666 return -! WRITE(ERRMESS,205)NAME,T(I,J,K),I,J,K,MYPE +! WRITE(ERRMESS,205)NAME,t(I,J,K),I,J,K,MYPE 205 FORMAT(' EXIT ',A,' TEMPERATURE=',E12.5 & &, ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3) ! CALL WRF_ERROR_FATAL(ERRMESS) ! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) - ELSEIF(Q(I,J,K)<-1.E-4.OR.Q(I,J,K)>30.E-3 & - & .OR.Q(I,J,K)/=Q(I,J,K))THEN - WRITE(errmess,100)NAME,NTSD + ELSEIF(q(I,J,K)<-1.E-4.OR.q(I,J,K)>30.E-3 & + & .OR.q(I,J,K)/=q(I,J,K))THEN + WRITE(errmess,100)NAME,ntsd CALL wrf_message(trim(errmess)) - WRITE(errmess,300)I,J,K,Q(I,J,K),MYPE,NTSD + WRITE(errmess,300)I,J,K,q(I,J,K),MYPE,ntsd CALL wrf_message(trim(errmess)) - 300 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' Q=',E12.5 & - &, ' MYPE=',I3,' NTSD=',I5) + 300 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' q=',E12.5 & + &, ' MYPE=',I3,' ntsd=',I5) IRET=666 return -! WRITE(ERRMESS,305)NAME,Q(I,J,K),I,J,K,MYPE +! WRITE(ERRMESS,305)NAME,q(I,J,K),I,J,K,MYPE 305 FORMAT(' EXIT ',A,' SPEC HUMIDITY=',E12.5 & &, ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3) ! CALL WRF_ERROR_FATAL(ERRMESS) ! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) - ELSEIF(PINT(I,J,K)<0..OR.PINT(I,J,K)/=PINT(I,J,K))THEN - WRITE(errmess,100)NAME,NTSD + ELSEIF(pint(I,J,K)<0..OR.pint(I,J,K)/=pint(I,J,K))THEN + WRITE(errmess,100)NAME,ntsd CALL wrf_message(trim(errmess)) - WRITE(errmess,315)I,J,K,PINT(I,J,K),MYPE,NTSD + WRITE(errmess,315)I,J,K,pint(I,J,K),MYPE,ntsd CALL wrf_message(trim(errmess)) - 315 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' PINT=',E12.5 & - &, ' MYPE=',I3,' NTSD=',I5) + 315 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' pint=',E12.5 & + &, ' MYPE=',I3,' ntsd=',I5) IRET=666 return ! CALL WRF_ERROR_FATAL(ERRMESS) ! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) - ELSEIF(W(I,J,K)/=W(I,J,K))THEN - WRITE(errmess,100)NAME,NTSD + ELSEIF(w(I,J,K)/=w(I,J,K))THEN + WRITE(errmess,100)NAME,ntsd CALL wrf_message(trim(errmess)) - WRITE(errmess,325)I,J,K,W(I,J,K),MYPE,NTSD + WRITE(errmess,325)I,J,K,w(I,J,K),MYPE,ntsd CALL wrf_message(trim(errmess)) - 325 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' W=',E12.5 & - &, ' MYPE=',I3,' NTSD=',I5) + 325 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' w=',E12.5 & + &, ' MYPE=',I3,' ntsd=',I5) IRET=666 return ! CALL WRF_ERROR_FATAL(ERRMESS) @@ -2298,18 +2732,18 @@ IEND=ITE IF(E_BDY.AND.MOD(J,2)==1)IEND=ITE-1 DO I=ITS,IEND - IF(ABS(U(I,J,K))>125..OR.ABS(V(I,J,K))>125. & - & .OR.U(I,J,K)/=U(I,J,K).OR.V(I,J,K)/=V(I,J,K))THEN - WRITE(errmess,100)NAME,NTSD + IF(ABS(u(I,J,K))>125..OR.ABS(v(I,J,K))>125. & + & .OR.u(I,J,K)/=u(I,J,K).OR.v(I,J,K)/=v(I,J,K))THEN + WRITE(errmess,100)NAME,ntsd CALL wrf_message(trim(errmess)) - WRITE(errmess,400)I,J,K,U(I,J,K),V(I,J,K),MYPE,NTSD + WRITE(errmess,400)I,J,K,u(I,J,K),v(I,J,K),MYPE,ntsd CALL wrf_message(trim(errmess)) - 400 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' U=',E12.5 & - &, ' V=',E12.5,' MYPE=',I3,' NTSD=',I5) + 400 FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' u=',E12.5 & + &, ' v=',E12.5,' MYPE=',I3,' ntsd=',I5) IRET=666 return -! WRITE(ERRMESS,405)NAME,U(I,J,K),V(I,J,K),I,J,K,MYPE - 405 FORMAT(' EXIT ',A,' U=',E12.5,' V=',E12.5 & +! WRITE(ERRMESS,405)NAME,u(I,J,K),v(I,J,K),I,J,K,MYPE + 405 FORMAT(' EXIT ',A,' u=',E12.5,' v=',E12.5 & &, ' AT (',I3,',',I2,',',I3,')',' MYPE=',I3) ! CALL WRF_ERROR_FATAL(ERRMESS) ! CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) @@ -2322,7 +2756,7 @@ !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- - SUBROUTINE TIME_STATS(TIME_LCL,NAME,NTSD,MYPE,NPES,MPI_COMM_COMP) + SUBROUTINE TIME_STATS(TIME_LCL,NAME,ntsd,MYPE,NPES,MPI_COMM_COMP) !---------------------------------------------------------------------- !********************************************************************** USE MODULE_EXT_INTERNAL @@ -2334,7 +2768,7 @@ INCLUDE "mpif.h" #endif !---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE,NPES,NTSD + INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE,NPES,ntsd REAL,INTENT(IN) :: TIME_LCL ! CHARACTER(*),INTENT(IN) :: NAME @@ -2362,23 +2796,23 @@ !********************************************************************** !---------------------------------------------------------------------- ! - IF(NTSD<=9)THEN + IF(ntsd<=9)THEN FMT='(I1.1)' NLEN=1 - ELSEIF(NTSD<=99)THEN + ELSEIF(ntsd<=99)THEN FMT='(I2.2)' NLEN=2 - ELSEIF(NTSD<=999)THEN + ELSEIF(ntsd<=999)THEN FMT='(I3.3)' NLEN=3 - ELSEIF(NTSD<=9999)THEN + ELSEIF(ntsd<=9999)THEN FMT='(I4.4)' NLEN=4 - ELSEIF(NTSD<=99999)THEN + ELSEIF(ntsd<=99999)THEN FMT='(I5.5)' NLEN=5 ENDIF - WRITE(TIMESTEP,FMT)NTSD + WRITE(TIMESTEP,FMT)ntsd TITLE=NAME//'_'//TIMESTEP(1:NLEN) ! !---------------------------------------------------------------------- diff --git a/wrfv2_fire/dyn_nmm/start_domain_nmm.F b/wrfv2_fire/dyn_nmm/start_domain_nmm.F index e8be8dd1..779f3ac8 100644 --- a/wrfv2_fire/dyn_nmm/start_domain_nmm.F +++ b/wrfv2_fire/dyn_nmm/start_domain_nmm.F @@ -5,7 +5,7 @@ ! SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! -#include +#include ! & ) !---------------------------------------------------------------------- @@ -17,7 +17,14 @@ USE MODULE_WRF_ERROR USE MODULE_MPP USE MODULE_CTLBLK +#ifdef DM_PARALLEL + USE MODULE_DM, ONLY : LOCAL_COMMUNICATOR & + ,MYTASK,NTASKS,NTASKS_X & + ,NTASKS_Y + USE MODULE_COMM_DM +#else USE MODULE_DM +#endif ! USE MODULE_IGWAVE_ADJUST,ONLY: PDTE, PFDHT, DDAMP USE MODULE_ADVECTION, ONLY: ADVE, VAD2, HAD2 @@ -32,6 +39,7 @@ ! #ifdef WRF_CHEM USE MODULE_AEROSOLS_SORGAM, ONLY: SUM_PM_SORGAM + USE MODULE_GOCART_AEROSOLS, ONLY: SUM_PM_GOCART USE MODULE_MOSAIC_DRIVER, ONLY: SUM_PM_MOSAIC #endif ! @@ -46,7 +54,7 @@ TYPE(DOMAIN),INTENT(INOUT) :: GRID LOGICAL , INTENT(IN) :: allowed_to_read ! -#include +#include ! TYPE(GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS ! @@ -58,6 +66,9 @@ !*** !*** LOCAL DATA !*** +#ifdef HWRF + LOGICAL :: ANAL !zhang's doing, added for analysis option +#endif INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE @@ -95,6 +106,11 @@ !!! REAL :: BLDT,CWML,EXNSFC,G_INV,PLYR,PSFC,ROG,SFCZ,THSIJ,TL REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL,ZOQING REAL :: TEND +#ifdef HWRF +!zhang's doing + REAL :: TSTART +!zhang's doing ends +#endif ! !!! REAL,ALLOCATABLE,DIMENSION(:,:) :: RAINBL,RAINNC,RAINNC & @@ -123,7 +139,7 @@ REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_OLD #endif #if 0 - REAL,ALLOCATABLE,DIMENSION(:,:,:) :: W0AVG + REAL,ALLOCATABLE,DIMENSION(:,:,:) :: w0avg #endif LOGICAL :: E_BDY,N_BDY,S_BDY,W_BDY,WARM_RAIN,ADV_MOIST_COND LOGICAL :: START_OF_SIMULATION @@ -160,8 +176,8 @@ ! end z0base new ! !---------------------------------------------------------------------- -#define COPY_IN -#include +!#define COPY_IN +!#include !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- @@ -183,6 +199,11 @@ & ,config_flags) ! RESTRT=config_flags%restart +#ifdef HWRF +!zhang's doing added for analysis option + ANAL=config_flags%analysis ! gopal's doing +!zhang's doing ends +#endif #if 1 IF(IME>NMM_MAX_DIM )THEN @@ -414,17 +435,17 @@ #endif ! DO J=MYJS_P4,MYJE_P4 - IHEG(J)=MOD(J+1,2) - IHWG(J)=IHEG(J)-1 - IVEG(J)=MOD(J,2) - IVWG(J)=IVEG(J)-1 + grid%iheg(J)=MOD(J+1,2) + grid%ihwg(J)=grid%iheg(J)-1 + grid%iveg(J)=MOD(J,2) + grid%ivwg(J)=grid%iveg(J)-1 ENDDO ! DO J=MYJS_P4,MYJE_P4 - IVW(J)=IVWG(J) - IVE(J)=IVEG(J) - IHE(J)=IHEG(J) - IHW(J)=IHWG(J) + grid%ivw(J)=grid%ivwg(J) + grid%ive(J)=grid%iveg(J) + grid%ihe(J)=grid%iheg(J) + grid%ihw(J)=grid%ihwg(J) ENDDO ! CAPA=R_D/CP @@ -435,34 +456,40 @@ JFE=MIN(JPE,JDE-1) IFE=MIN(IPE,IDE-1) ! +#ifdef HWRF +!zhang's doing + IF((.NOT.RESTRT .AND. .NOT.ANAL) .OR. .NOT.allowed_to_read)THEN +!end of zhang's doing +#else IF(.NOT.RESTRT)THEN +#endif DO J=JFS,JFE DO I=IFS,IFE - PDSL(I,J) =PD(I,J)*RES(I,J) - PREC(I,J) =0. - IF(allowed_to_read)ACPREC(I,J)=0. ! This is gopal's inclusion for moving nest - CUPREC(I,J)=0. + grid%pdsl(I,J) =grid%pd(I,J)*grid%res(I,J) + grid%prec(I,J) =0. + IF(allowed_to_read)grid%acprec(I,J)=0. ! This is gopal's inclusion for moving nest + grid%cuprec(I,J)=0. rg=1./g - ht=fis(i,j)*rg + ht=grid%fis(i,j)*rg !!! fisx=ht*g -! fisx=max(fis(i,j),0.) -! prodx=Z0(I,J)*Z0MAX -! Z0(I,J) =SM(I,J)*Z0SEA+(1.-SM(I,J))* & -! & (Z0(I,J)*Z0MAX+FISx *FCM+Z0LAND) +! fisx=max(grid%fis(i,j),0.) +! prodx=grid%z0(I,J)*Z0MAX +! grid%z0(I,J) =grid%sm(I,J)*Z0SEA+(1.-grid%sm(I,J))* & +! & (grid%z0(I,J)*Z0MAX+FISx *FCM+Z0LAND) !!! & (prodx +FISx *FCM+Z0LAND) - QSH(I,J) =0. - AKMS(I,J) =0. - AKHS(I,J) =0. - TWBS(I,J) =0. - QWBS(I,J) =0. + grid%qsh(I,J) =0. + grid%akms(I,J) =0. + grid%akhs(I,J) =0. + grid%twbs(I,J) =0. + grid%qwbs(I,J) =0. IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest - CLDEFI(I,J)=1. - HTOP(I,J) =REAL(KTS) - HTOPD(I,J) =REAL(KTS) - HTOPS(I,J) =REAL(KTS) - HBOT(I,J) =REAL(KTE) - HBOTD(I,J) =REAL(KTE) - HBOTS(I,J) =REAL(KTE) + grid%cldefi(I,J)=1. + grid%htop(I,J) =REAL(KTS) + grid%htopd(I,J) =REAL(KTS) + grid%htops(I,J) =REAL(KTS) + grid%hbot(I,J) =REAL(KTE) + grid%hbotd(I,J) =REAL(KTE) + grid%hbots(I,J) =REAL(KTE) ENDIF !*** !*** AT THIS POINT, WE MUST CALCULATE THE INITIAL POTENTIAL TEMPERATURE @@ -473,52 +500,52 @@ ! !*** BECAUSE WE REINITIALIZE TOPOGRAPHY, LAND SEA MASK AND FIND THE TEMPERATURE !*** FIELD OVER THE NEW TOPOGRAPHY, AFTER THE MOVE, I THINK IT MORE APPROPRIATE -!*** TO USE NMM_TSK OR SST TO RE-DERIVE THS AND QS (AND CONSEQUENTLY THZ0 AND QZ0). +!*** TO USE grid%nmm_tsk OR grid%sst TO RE-DERIVE grid%ths AND QS (AND CONSEQUENTLY grid%thz0 AND grid%qz0). !*** THIS MAY BE MORE CONSISTENT WITH THE PSEUDO-HYDROSTATIC BALANCING THAT IS -!*** DONE OVER THE NEW TERRAIN (AND WITH NEW SM). gopal! +!*** DONE OVER THE NEW TERRAIN (AND WITH NEW grid%sm). gopal! !*** !*** IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest - PM1=AETA1(KTS)*PDTOP+AETA2(KTS)*PDSL(I,J)+PT + PM1=grid%aeta1(KTS)*grid%pdtop+grid%aeta2(KTS)*grid%pdsl(I,J)+grid%pt APEM1=(1.E5/PM1)**CAPA - IF(NMM_TSK(I,J)>=200.)THEN ! have a specific skin temp, use it + IF(grid%nmm_tsk(I,J)>=200.)THEN ! have a specific skin temp, use it #ifdef HWRF - THS(I,J)=NMM_TSK(I,J)*(1.+P608*Q(I,J,KTS+1))*APEM1 - TSFCK=NMM_TSK(I,J)*(1.+P608*Q(I,J,KTS+1)) + grid%ths(I,J)=grid%nmm_tsk(I,J)*(1.+P608*grid%q(I,J,KTS+1))*APEM1 + TSFCK=grid%nmm_tsk(I,J)*(1.+P608*grid%q(I,J,KTS+1)) #else - THS(I,J)=NMM_TSK(I,J)*APEM1 - TSFCK=NMM_TSK(I,J) + grid%ths(I,J)=grid%nmm_tsk(I,J)*APEM1 + TSFCK=grid%nmm_tsk(I,J) #endif ELSE ! use lowest layer as a proxy #ifdef HWRF - THS(I,J)=T(I,J,KTS)*(1.+P608*Q(I,J,KTS+1))*APEM1 - TSFCK=T(I,J,KTS)*(1.+P608*Q(I,J,KTS+1)) + grid%ths(I,J)=grid%t(I,J,KTS)*(1.+P608*grid%q(I,J,KTS+1))*APEM1 + TSFCK=grid%t(I,J,KTS)*(1.+P608*grid%q(I,J,KTS+1)) #else - THS(I,J)=T(I,J,KTS)*APEM1 - TSFCK=T(I,J,KTS) + grid%ths(I,J)=grid%t(I,J,KTS)*APEM1 + TSFCK=grid%t(I,J,KTS) #endif ENDIF - PSFCK=PD(I,J)+PDTOP+PT + PSFCK=grid%pd(I,J)+grid%pdtop+grid%pt ! - IF(SM(I,J)<0.5) THEN - QSH(I,J)=PQ0/PSFCK*EXP(A2*(TSFCK-A3)/(TSFCK-A4)) - ELSEIF(SM(I,J)>0.5) THEN - THS(I,J)=SST(I,J)*(1.E5/(PD(I,J)+PDTOP+PT))**CAPA + IF(grid%sm(I,J)<0.5) THEN + grid%qsh(I,J)=PQ0/PSFCK*EXP(A2*(TSFCK-A3)/(TSFCK-A4)) + ELSEIF(grid%sm(I,J)>0.5) THEN + grid%ths(I,J)=grid%sst(I,J)*(1.E5/(grid%pd(I,J)+grid%pdtop+grid%pt))**CAPA ENDIF ! - TERM1=-0.068283/T(I,J,KTS) - PSHLTR(I,J)=(PD(I,J)+PDTOP+PT)*EXP(TERM1) + TERM1=-0.068283/grid%t(I,J,KTS) + grid%pshltr(I,J)=(grid%pd(I,J)+grid%pdtop+grid%pt)*EXP(TERM1) ! - USTAR(I,J)=0.1 - THZ0(I,J)=THS(I,J) - QZ0(I,J)=QSH(I,J) - UZ0(I,J)=0. - VZ0(I,J)=0. + grid%ustar(I,J)=0.1 + grid%thz0(I,J)=grid%ths(I,J) + grid%qz0(I,J)=grid%qsh(I,J) + grid%uz0(I,J)=0. + grid%vz0(I,J)=0. ENDIF ! endif for allowed to read ! @@ -528,15 +555,15 @@ !*** !*** INITIALIZE CLOUD FIELDS !*** - IF (MAXVAL(CWM) .gt. 0. .and. MAXVAL(CWM) .lt. 1.) then - CALL wrf_message('appear to have CWM values...do not zero') + IF (MAXVAL(grid%cwm) .gt. 0. .and. MAXVAL(grid%cwm) .lt. 1.) then + CALL wrf_message('appear to have grid%cwm values...do not zero') ELSE IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest - CALL wrf_message('zeroing CWM') + CALL wrf_message('zeroing grid%cwm') DO K=KPS,KPE DO J=JFS,JFE DO I=IFS,IFE - CWM(I,J,K)=0. + grid%cwm(I,J,K)=0. ENDDO ENDDO ENDDO @@ -545,36 +572,36 @@ !*** !*** INITIALIZE ACCUMULATOR ARRAYS TO ZERO. !*** - ARDSW=0.0 - ARDLW=0.0 - ASRFC=0.0 - AVRAIN=0.0 - AVCNVC=0.0 + grid%ardsw=0.0 + grid%ardlw=0.0 + grid%asrfc=0.0 + grid%avrain=0.0 + grid%avcnvc=0.0 ! DO J=JFS,JFE DO I=IFS,IFE - ACFRCV(I,J)=0. - NCFRCV(I,J)=0 - ACFRST(I,J)=0. - NCFRST(I,J)=0 - ACSNOW(I,J)=0. - ACSNOM(I,J)=0. - SSROFF(I,J)=0. - BGROFF(I,J)=0. - ALWIN(I,J) =0. - ALWOUT(I,J)=0. - ALWTOA(I,J)=0. - ASWIN(I,J) =0. - ASWOUT(I,J)=0. - ASWTOA(I,J)=0. - SFCSHX(I,J)=0. - SFCLHX(I,J)=0. - SUBSHX(I,J)=0. - SNOPCX(I,J)=0. - SFCUVX(I,J)=0. - SFCEVP(I,J)=0. - POTEVP(I,J)=0. - POTFLX(I,J)=0. + grid%acfrcv(I,J)=0. + grid%ncfrcv(I,J)=0 + grid%acfrst(I,J)=0. + grid%ncfrst(I,J)=0 + grid%acsnow(I,J)=0. + grid%acsnom(I,J)=0. + grid%ssroff(I,J)=0. + grid%bgroff(I,J)=0. + grid%alwin(I,J) =0. + grid%alwout(I,J)=0. + grid%alwtoa(I,J)=0. + grid%aswin(I,J) =0. + grid%aswout(I,J)=0. + grid%aswtoa(I,J)=0. + grid%sfcshx(I,J)=0. + grid%sfclhx(I,J)=0. + grid%subshx(I,J)=0. + grid%snopcx(I,J)=0. + grid%sfcuvx(I,J)=0. + grid%sfcevp(I,J)=0. + grid%potevp(I,J)=0. + grid%potflx(I,J)=0. ENDDO ENDDO !*** @@ -585,10 +612,10 @@ IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest DO J=JFS,JFE DO I=IFS,IFE - IF(SM(I,J)>0.5)THEN - CLOGES =-CM1/SST(I,J)-CM2*ALOG10(SST(I,J))+CM3 + IF(grid%sm(I,J)>0.5)THEN + CLOGES =-CM1/grid%sst(I,J)-CM2*ALOG10(grid%sst(I,J))+CM3 ESE = 10.**(CLOGES+2.) - QSH(I,J)= SM(I,J)*EPS*ESE/(PD(I,J)+PDTOP+PT-ESE*(1.-EPS)) + grid%qsh(I,J)= grid%sm(I,J)*EPS*ESE/(grid%pd(I,J)+grid%pdtop+grid%pt-ESE*(1.-EPS)) ENDIF ENDDO ENDDO @@ -599,20 +626,20 @@ !*** THE LOWEST MODEL LAYER. IN THE LOWEST TWO ATMOSPHERIC !*** ETA LAYERS SET TKE TO A SMALL VALUE (Q2INI). !*** -!***EROGERS: add check for realistic values of q2 +!***EROGERS: add check for realistic values of grid%q2 ! - IF (MAXVAL(Q2) .gt. epsq2 .and. MAXVAL(Q2) .lt. 200.) then - CALL wrf_message('appear to have Q2 values...do not zero') + IF (MAXVAL(grid%q2) .gt. epsq2 .and. MAXVAL(grid%q2) .lt. 200.) then + CALL wrf_message('appear to have grid%q2 values...do not zero') ELSE IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest - CALL wrf_message('zeroing Q2') + CALL wrf_message('zeroing grid%q2') DO K=KPS,KPE-1 DO J=JFS,JFE DO I=IFS,IFE #ifdef HWRF - Q2(I,J,K)=0. + grid%q2(I,J,K)=0. #else - Q2(I,J,K)=HBM2(I,J)*EPSQ2 + grid%q2(I,J,K)=grid%hbm2(I,J)*EPSQ2 #endif ENDDO ENDDO @@ -620,13 +647,13 @@ ! DO J=JFS,JFE DO I=IFS,IFE - Q2(I,J,LM) = 0. + grid%q2(I,J,LM) = 0. #ifdef HWRF - Q2(I,J,KTE-2)= 0. - Q2(I,J,KTE-1)= 0. + grid%q2(I,J,KTE-2)= 0. + grid%q2(I,J,KTE-1)= 0. #else - Q2(I,J,KTE-2)= HBM2(I,J)*Q2INI - Q2(I,J,KTE-1)= HBM2(I,J)*Q2INI + grid%q2(I,J,KTE-2)= grid%hbm2(I,J)*Q2INI + grid%q2(I,J,KTE-1)= grid%hbm2(I,J)*Q2INI #endif ENDDO ENDDO @@ -639,9 +666,9 @@ DO K=KPS,KPE DO J=JFS,JFE DO I=IFS,IFE - IF(Q(I,J,K)=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN J=JJ ! -MY_JS_GLB+1 ! DO I=1,4 - IUP_H(IMS+I-1,J)=I - IUP_V(IMS+I-1,J)=I + grid%iup_h(IMS+I-1,J)=I + grid%iup_v(IMS+I-1,J)=I ENDDO - N_IUP_H(J)=4 - N_IUP_V(J)=4 + grid%n_iup_h(J)=4 + grid%n_iup_v(J)=4 ENDIF ENDDO ! @@ -893,18 +930,18 @@ KNTI=0 IEND=2+MOD(JJ,2) DO I=2,IEND - IUP_ADH(IMS+KNTI,J)=I + grid%iup_adh(IMS+KNTI,J)=I KNTI=KNTI+1 ENDDO - N_IUP_ADH(J)=KNTI + grid%n_iup_adh(J)=KNTI ! KNTI=0 IEND=2+MOD(JJ+1,2) DO I=2,IEND - IUP_ADV(IMS+KNTI,J)=I + grid%iup_adv(IMS+KNTI,J)=I KNTI=KNTI+1 ENDDO - N_IUP_ADV(J)=KNTI + grid%n_iup_adv(J)=KNTI ! ENDIF ENDDO @@ -913,7 +950,7 @@ CALL WRF_GET_NPROCX(INPES) ! IF(E_BDY)THEN - UPSTRM=.TRUE. + grid%upstrm=.TRUE. IRPAD2=0 DO JJ=8,JDE-8 ! JM-7 IF(JJ>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN @@ -926,14 +963,14 @@ !*** POINTS TO THE EASTSIDE POINTS IN EACH ROW. ! KNTI=0 - IF(INPES.EQ.1)KNTI=N_IUP_H(J) + IF(INPES.EQ.1)KNTI=grid%n_iup_h(J) ! DO II=ISTART,IEND I=II ! -MY_IS_GLB+1 - IUP_H(IMS+KNTI,J)=I + grid%iup_h(IMS+KNTI,J)=I KNTI=KNTI+1 ENDDO - N_IUP_H(J)=KNTI + grid%n_iup_h(J)=KNTI ENDIF ENDDO ! @@ -943,13 +980,13 @@ IEND=IM-1-MOD(JJ+1,2) ISTART=IEND-MOD(JJ,2) KNTI=0 - IF(INPES==1)KNTI=N_IUP_ADH(J) + IF(INPES==1)KNTI=grid%n_iup_adh(J) DO II=ISTART,IEND I=II ! -MY_IS_GLB+1 - IUP_ADH(IMS+KNTI,J)=I + grid%iup_adh(IMS+KNTI,J)=I KNTI=KNTI+1 ENDDO - N_IUP_ADH(J)=KNTI + grid%n_iup_adh(J)=KNTI ENDIF ENDDO !*** @@ -959,14 +996,14 @@ IEND=IM-MOD(JJ,2) ISTART=IEND-3 KNTI=0 - IF(INPES==1)KNTI=N_IUP_V(J) + IF(INPES==1)KNTI=grid%n_iup_v(J) ! DO II=ISTART,IEND I=II ! -MY_IS_GLB+1 - IUP_V(IMS+KNTI,J)=I + grid%iup_v(IMS+KNTI,J)=I KNTI=KNTI+1 ENDDO - N_IUP_V(J)=KNTI + grid%n_iup_v(J)=KNTI ENDIF ENDDO ! @@ -976,30 +1013,30 @@ IEND=IM-1-MOD(JJ,2) ISTART=IEND-MOD(JJ+1,2) KNTI=0 - IF(INPES==1)KNTI=N_IUP_ADV(J) + IF(INPES==1)KNTI=grid%n_iup_adv(J) DO II=ISTART,IEND I=II ! -MY_IS_GLB+1 - IUP_ADV(IMS+KNTI,J)=I + grid%iup_adv(IMS+KNTI,J)=I KNTI=KNTI+1 ENDDO - N_IUP_ADV(J)=KNTI + grid%n_iup_adv(J)=KNTI ENDIF ENDDO ENDIF !---------------------------------------------------------------------- jam=6+2*(JDE-JDS-1-9) ! -!*** EXTRACT EM AND EMT FOR THE LOCAL SUBDOMAINS +!*** EXTRACT em AND emt FOR THE LOCAL SUBDOMAINS ! DO J=MYJS_P5,MYJE_P5 - EM_LOC(J)=-9.E9 - EMT_LOC(J)=-9.E9 + grid%em_loc(J)=-9.E9 + grid%emt_loc(J)=-9.E9 ENDDO !!! IF(IBROW==1)THEN IF(S_BDY)THEN DO J=3,5 - EM_LOC(J)=EM(J-2) - EMT_LOC(J)=EMT(J-2) + grid%em_loc(J)=grid%em(J-2) + grid%emt_loc(J)=grid%emt(J-2) ENDDO ENDIF !!! IF(ITROW==1)THEN @@ -1008,8 +1045,8 @@ DO JJ=JDE-5,JDE-3 ! JM-4,JM-2 KNT=KNT+1 J=JJ ! -MY_JS_GLB+1 - EM_LOC(J)=EM(KNT) - EMT_LOC(J)=EMT(KNT) + grid%em_loc(J)=grid%em(KNT) + grid%emt_loc(J)=grid%emt(KNT) ENDDO ENDIF !!! IF(ILCOL==1)THEN @@ -1019,8 +1056,8 @@ KNT=KNT+1 IF(JJ>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN J=JJ ! -MY_JS_GLB+1 - EM_LOC(J)=EM(KNT) - EMT_LOC(J)=EMT(KNT) + grid%em_loc(J)=grid%em(KNT) + grid%emt_loc(J)=grid%emt(KNT) ENDIF ENDDO ENDIF @@ -1031,8 +1068,8 @@ KNT=KNT+1 IF(JJ>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN J=JJ ! -MY_JS_GLB+1 - EM_LOC(J)=EM(KNT) - EMT_LOC(J)=EMT(KNT) + grid%em_loc(J)=grid%em(KNT) + grid%emt_loc(J)=grid%emt(KNT) ENDIF ENDDO ENDIF @@ -1043,75 +1080,81 @@ !*** !*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS !*** +#ifdef HWRF +!zhang'sdoing IF(NSTART.EQ.0)THEN + IF(NSTART.EQ.0 .or. .not.allowed_to_read )THEN +!zhang's doing ends +#else IF(NSTART.EQ.0)THEN +#endif ! GRID%NSOIL= GRID%NUM_SOIL_LAYERS DO J=JFS,JFE DO I=IFS,IFE - PCTSNO(I,J)=-999.0 - IF(SM(I,J)<0.5)THEN - CMC(I,J)=0.0 -! CMC(I,J)=canwat(i,j) ! tgs - IF(SICE(I,J)>0.5)THEN + grid%pctsno(I,J)=-999.0 + IF(grid%sm(I,J)<0.5)THEN + grid%cmc(I,J)=0.0 +! grid%cmc(I,J)=grid%canwat(i,j) ! tgs + IF(grid%sice(I,J)>0.5)THEN !*** !*** SEA-ICE CASE !*** - SMSTAV(I,J)=1.0 - SMSTOT(I,J)=1.0 - SSROFF(I,J)=0.0 - BGROFF(I,J)=0.0 - CMC(I,J)=0.0 + grid%smstav(I,J)=1.0 + grid%smstot(I,J)=1.0 + grid%ssroff(I,J)=0.0 + grid%bgroff(I,J)=0.0 + grid%cmc(I,J)=0.0 DO NS=1,GRID%NSOIL - SMC(I,NS,J)=1.0 -! SH2O(I,NS,J)=0.05 - SH2O(I,NS,J)=1.0 + grid%smc(I,NS,J)=1.0 +! grid%sh2o(I,NS,J)=0.05 + grid%sh2o(I,NS,J)=1.0 ENDDO ENDIF ELSE !*** !*** WATER CASE !*** - SMSTAV(I,J)=1.0 - SMSTOT(I,J)=1.0 - SSROFF(I,J)=0.0 - BGROFF(I,J)=0.0 - SOILTB(I,J)=273.16 - GRNFLX(I,J)=0. - SUBSHX(I,J)=0.0 - ACSNOW(I,J)=0.0 - ACSNOM(I,J)=0.0 - SNOPCX(I,J)=0.0 - CMC(I,J)=0.0 - SNO(I,J)=0.0 + grid%smstav(I,J)=1.0 + grid%smstot(I,J)=1.0 + grid%ssroff(I,J)=0.0 + grid%bgroff(I,J)=0.0 + grid%soiltb(I,J)=273.16 + grid%grnflx(I,J)=0. + grid%subshx(I,J)=0.0 + grid%acsnow(I,J)=0.0 + grid%acsnom(I,J)=0.0 + grid%snopcx(I,J)=0.0 + grid%cmc(I,J)=0.0 + grid%sno(I,J)=0.0 DO NS=1,GRID%NSOIL - SMC(I,NS,J)=1.0 - STC(I,NS,J)=273.16 -! SH2O(I,NS,J)=0.05 - SH2O(I,NS,J)=1.0 + grid%smc(I,NS,J)=1.0 + grid%stc(I,NS,J)=273.16 +! grid%sh2o(I,NS,J)=0.05 + grid%sh2o(I,NS,J)=1.0 ENDDO ENDIF ! ENDDO ENDDO ! - APHTIM=0.0 - ARATIM=0.0 - ACUTIM=0.0 + grid%aphtim=0.0 + grid%aratim=0.0 + grid%acutim=0.0 ! ENDIF ! !---------------------------------------------------------------------- !*** INITIALIZE RADTN VARIABLES !*** CALCULATE THE NUMBER OF STEPS AT EACH POINT. -!*** THE ARRAY 'LVL' WILL COORDINATE VERTICAL LOCATIONS BETWEEN +!*** THE ARRAY 'lvl' WILL COORDINATE VERTICAL LOCATIONS BETWEEN !*** THE LIFTED WORKING ARRAYS AND THE FUNDAMENTAL MODEL ARRAYS. -!*** LVL HOLDS THE HEIGHT (IN MODEL LAYERS) OF THE TOPOGRAPHY AT +!*** lvl HOLDS THE HEIGHT (IN MODEL LAYERS) OF THE TOPOGRAPHY AT !*** EACH GRID POINT. !---------------------------------------------------------------------- ! DO J=JFS,JFE DO I=IFS,IFE - LVL(I,J)=LM-KTE + grid%lvl(I,J)=LM-KTE ENDDO ENDDO !*** @@ -1120,11 +1163,11 @@ !*** (HEIGHT-WISE) 400 MB. (K400) !*** K400=0 - PSUM=PT + PSUM=grid%pt SLPM=101325. - PDIF=SLPM-PT + PDIF=SLPM-grid%pt DO K=1,LM - PSUM=PSUM+DETA(K)*PDIF + PSUM=PSUM+grid%deta(K)*PDIF IF(LPTOP(3)==0)THEN IF(PSUM>PHITP)LPTOP(3)=K ELSEIF(LPTOP(2)==0)THEN @@ -1143,12 +1186,12 @@ !*** CALCULATE THE MIDLAYER PRESSURES IN THE STANDARD ATMOSPHERE !*** PSS=101325. - PDIF=PSS-PT + PDIF=PSS-grid%pt ! ALLOCATE(PHALF(LM+1),STAT=I) ! DO K=KPS,KPE-1 - PHALF(K+1)=AETA(K)*PDIF+PT + PHALF(K+1)=grid%aeta(K)*PDIF+grid%pt ENDDO ! @@ -1166,7 +1209,7 @@ !*** CALL ZENITH SIMPLY TO GET THE DAY OF THE YEAR FOR !*** THE SETUP OF THE OZONE DATA !*** - TIME=(NTSD-1)*GRID%DT + TIME=(grid%ntsd-1)*GRID%DT ! !!! CALL ZENITH(TIME,DAYI,HOUR) ! @@ -1188,19 +1231,27 @@ !*** !*** TRY A SIMPLE LINEAR INTERP TO GET 2/10 M VALUES !*** - PDSL(I,J)=PD(I,J)*RES(I,J) +#ifdef HWRF +!zhang's doing + IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) then + grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J) + endif +!end of zhang's doing +#else + grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J) +#endif ! - ULM=U(I,J,KTS) - VLM=V(I,J,KTS) - TLM=T(I,J,KTS) - QLM=Q(I,J,KTS) - PLM=AETA1(KTS)*PDTOP+AETA2(KTS)*PDSL(I,J)+PT + ULM=grid%u(I,J,KTS) + VLM=grid%v(I,J,KTS) + TLM=grid%t(I,J,KTS) + QLM=grid%q(I,J,KTS) + PLM=grid%aeta1(KTS)*grid%pdtop+grid%aeta2(KTS)*grid%pdsl(I,J)+grid%pt APELM=(1.0E5/PLM)**CAPA - TERM1=-0.068283/T(I,J,KTS) - PSHLTR(I,J)=(PD(I,J)+PDTOP+PT)*EXP(TERM1) - APELMNW=(1.0E5/PSHLTR(I,J))**CAPA + TERM1=-0.068283/grid%t(I,J,KTS) + grid%pshltr(I,J)=(grid%pd(I,J)+grid%pdtop+grid%pt)*EXP(TERM1) + APELMNW=(1.0E5/grid%pshltr(I,J))**CAPA THLM=TLM*APELM - DPLM=(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSL(I,J))*0.5 + DPLM=(grid%deta1(KTS)*grid%pdtop+grid%deta2(KTS)*grid%pdsl(I,J))*0.5 DZLM=R_D*DPLM*TLM*(1.+P608*QLM)/(G*PLM) FAC1=10./DZLM FAC2=(DZLM-10.)/DZLM @@ -1209,32 +1260,38 @@ FAC2=0. ENDIF ! +#ifdef HWRF +!zhang's doing + IF(.NOT.RESTRT .OR. .NOT.allowed_to_read)THEN +!end of zhang's doing +#else IF(.NOT.RESTRT)THEN - TH10(I,J)=FAC2*THS(I,J)+FAC1*THLM - Q10(I,J)=FAC2*QSH(I,J)+FAC1*QLM +#endif + grid%th10(I,J)=FAC2*grid%ths(I,J)+FAC1*THLM + grid%q10(I,J)=FAC2*grid%qsh(I,J)+FAC1*QLM #ifdef HWRF - IF(SM(I,J).LT.0.5)THEN - U10(I,J)=ULM*(log(10./Z0(I,J))/log(DZLM/Z0(I,J))) ! this is all Qingfu's doing - V10(I,J)=VLM*(log(10./Z0(I,J))/log(DZLM/Z0(I,J))) - ZOQING=1.944*SQRT(U10(I,J)*U10(I,J)+V10(I,J)*V10(I,J)) + IF(grid%sm(I,J).LT.0.5)THEN + grid%u10(I,J)=ULM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J))) ! this is all Qingfu's doing + grid%v10(I,J)=VLM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J))) + ZOQING=1.944*SQRT(grid%u10(I,J)*grid%u10(I,J)+grid%v10(I,J)*grid%v10(I,J)) IF(ZOQING.GT.60.)THEN - U10(I,J)=U10(I,J)*(1.12-7.2/ZOQING) - V10(I,J)=V10(I,J)*(1.12-7.2/ZOQING) + grid%u10(I,J)=grid%u10(I,J)*(1.12-7.2/ZOQING) + grid%v10(I,J)=grid%v10(I,J)*(1.12-7.2/ZOQING) ENDIF ELSE ZOQING=(0.074*SQRT(ULM*ULM+VLM*VLM)-0.58)*1.0e-3 - ZOQING=MAX(ZOQING,Z0(I,J)) ! for winds greater than 12.5 m/s - U10(I,J)=ULM*(log(10./ZOQING))/log(DZLM/ZOQING) ! this is all Qingfu's doing - V10(I,J)=VLM*(log(10./ZOQING))/log(DZLM/ZOQING) - ZOQING=1.944*SQRT(U10(I,J)*U10(I,J)+V10(I,J)*V10(I,J)) + ZOQING=MAX(ZOQING,grid%z0(I,J)) ! for winds greater than 12.5 m/s + grid%u10(I,J)=ULM*(log(10./ZOQING))/log(DZLM/ZOQING) ! this is all Qingfu's doing + grid%v10(I,J)=VLM*(log(10./ZOQING))/log(DZLM/ZOQING) + ZOQING=1.944*SQRT(grid%u10(I,J)*grid%u10(I,J)+grid%v10(I,J)*grid%v10(I,J)) IF(ZOQING.GT.60.)THEN - U10(I,J)=U10(I,J)*(1.12-7.2/ZOQING) - V10(I,J)=V10(I,J)*(1.12-7.2/ZOQING) + grid%u10(I,J)=grid%u10(I,J)*(1.12-7.2/ZOQING) + grid%v10(I,J)=grid%v10(I,J)*(1.12-7.2/ZOQING) END IF ENDIF #else - U10(I,J)=ULM - V10(I,J)=VLM + grid%u10(I,J)=ULM + grid%v10(I,J)=VLM #endif ENDIF ! @@ -1247,7 +1304,7 @@ ! IF(.NOT.RESTRT.OR.NEST)THEN ! - IF ( (THLM-THS(I,J))>2.0) THEN ! weight differently in different scenarios + IF ( (THLM-grid%ths(I,J))>2.0) THEN ! weight differently in different scenarios FAC1=0.3 FAC2=0.7 ELSE @@ -1256,11 +1313,11 @@ ENDIF #ifdef HWRF - TSHLTR(I,J)=0.2*THS(I,J)+0.8*THLM - QSHLTR(I,J)=0.2*QSH(I,J)+0.8*QLM + grid%tshltr(I,J)=0.2*grid%ths(I,J)+0.8*THLM + grid%qshltr(I,J)=0.2*grid%qsh(I,J)+0.8*QLM #else - TSHLTR(I,J)=FAC2*THS(I,J)+FAC1*THLM - QSHLTR(I,J)=FAC2*QSH(I,J)+FAC1*QLM + grid%tshltr(I,J)=FAC2*grid%ths(I,J)+FAC1*THLM + grid%qshltr(I,J)=FAC2*grid%qsh(I,J)+FAC1*QLM #endif ENDIF !*** @@ -1270,7 +1327,7 @@ !EROGERS: COMMENT OUT IN WRF-NMM !*** ! IF(RESTRT)THEN -! TSHLTR(I,J)=TSHLTR(I,J)*APELMNW +! grid%tshltr(I,J)=grid%tshltr(I,J)*APELMNW ! ENDIF ENDDO ENDDO @@ -1281,13 +1338,18 @@ !*** INITIALIZE TAU-1 VALUES FOR ADAMS-BASHFORTH !---------------------------------------------------------------------- ! +#ifdef HWRF +!zhang's doing + IF(.NOT.RESTRT .OR. .NOT.allowed_to_read)THEN !zhang's doing +#else IF(.NOT.RESTRT)THEN +#endif DO K=KPS,KPE DO J=JFS,JFE DO I=ifs,ife - TOLD(I,J,K)=T(I,J,K) ! T AT TAU-1 - UOLD(I,J,K)=U(I,J,K) ! U AT TAU-1 - VOLD(I,J,K)=V(I,J,K) ! V AT TAU-1 + grid%told(I,J,K)=grid%t(I,J,K) ! grid%t AT TAU-1 + grid%uold(I,J,K)=grid%u(I,J,K) ! grid%u AT TAU-1 + grid%vold(I,J,K)=grid%v(I,J,K) ! grid%v AT TAU-1 ENDDO ENDDO ENDDO @@ -1297,62 +1359,80 @@ !*** INITIALIZE NONHYDROSTATIC QUANTITIES !---------------------------------------------------------------------- ! -!!!! SHOULD DWDT BE REDEFINED IF RESTRT? +!!!! SHOULD grid%dwdt BE REDEFINED IF RESTRT? IF((.NOT.RESTRT.OR.NEST).AND. allowed_to_read)THEN ! This is gopal's inclusion for moving nest DO K=KPS,KPE DO J=JFS,JFE DO I=IFS,IFE - DWDT(I,J,K)=1. + grid%dwdt(I,J,K)=1. ENDDO ENDDO ENDDO ENDIF !*** +#ifdef HWRF + IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) THEN !zhang's doing +#endif IF(GRID%SIGMA==1)THEN DO J=JFS,JFE DO I=IFS,IFE - PDSL(I,J)=PD(I,J) + grid%pdsl(I,J)=grid%pd(I,J) ENDDO ENDDO ELSE DO J=JFS,JFE DO I=IFS,IFE - PDSL(I,J)=RES(I,J)*PD(I,J) + grid%pdsl(I,J)=grid%res(I,J)*grid%pd(I,J) ENDDO ENDDO ENDIF +#ifdef HWRF + ENDIF !zhang's doing +#endif ! !*** ! ! -!!!! SHOULD PINT,Z,W BE REDEFINED IF RESTRT? +!!!! SHOULD pint,z,w BE REDEFINED IF RESTRT? WRITE( wrf_err_message, * )' restrt=',restrt,' nest=',nest CALL wrf_debug( 0, TRIM(wrf_err_message) ) - WRITE( wrf_err_message, * )' pdtop=',pdtop,' pt=',pt + WRITE( wrf_err_message, * )' grid%pdtop=',grid%pdtop,' grid%pt=',grid%pt CALL wrf_debug( 0, TRIM(wrf_err_message) ) - +#ifdef HWRF +!zhang's doing + IF(.NOT.RESTRT.OR.NEST .OR. .NOT.allowed_to_read)THEN +!end of zhang's doing +#else IF(.NOT.RESTRT.OR.NEST)THEN +#endif DO K=KPS,KPE DO J=JFS,JFE DO I=IFS,IFE - PINT(I,J,K)=ETA1(K)*PDTOP+ETA2(K)*PDSL(I,J)+PT - Z(I,J,K)=PINT(I,J,K) - W(I,J,K)=0. + grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt + grid%z(I,J,K)=grid%pint(I,J,K) + grid%w(I,J,K)=0. ENDDO ENDDO ENDDO ENDIF +#ifdef HWRF +!zhang's doing + IF(.NOT.RESTRT.OR.NEST .OR. .NOT.allowed_to_read)THEN +#endif DO K=KTS,KTE-1 DO J=JFS,JFE DO I=IFS,IFE - RTOP(I,J,K)=(Q(I,J,K)*P608-CWM(I,J,K)+1.)*T(I,J,K)*R_D/ & - ((PINT(I,J,K+1)+PINT(I,J,K))*0.5) + grid%rtop(I,J,K)=(grid%q(I,J,K)*P608-grid%cwm(I,J,K)+1.)*grid%t(I,J,K)*R_D/ & + ((grid%pint(I,J,K+1)+grid%pint(I,J,K))*0.5) ENDDO ENDDO ENDDO +#ifdef HWRF + ENDIF !zhang +#endif #ifndef NO_RESTRICT_ACCEL !---------------------------------------------------------------------- @@ -1361,8 +1441,8 @@ ! DO J=JFS,JFE DO I=IFS,IFE - DWDTMN(I,J)=-EPSIN - DWDTMX(I,J)= EPSIN + grid%dwdtmn(I,J)=-EPSIN + grid%dwdtmx(I,J)= EPSIN ENDDO ENDDO ! @@ -1377,8 +1457,8 @@ DO I=1,IDE-1 ! IM IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN IX=I ! -MY_IS_GLB+1 - DWDTMN(IX,JX)=-EPSB - DWDTMX(IX,JX)= EPSB + grid%dwdtmn(IX,JX)=-EPSB + grid%dwdtmx(IX,JX)= EPSB ENDIF ENDDO ENDIF @@ -1390,8 +1470,8 @@ DO I=1,IDE-1 ! IM IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN IX=I ! -MY_IS_GLB+1 - DWDTMN(IX,JX)=-EPSB - DWDTMX(IX,JX)= EPSB + grid%dwdtmn(IX,JX)=-EPSB + grid%dwdtmx(IX,JX)= EPSB ENDIF ENDDO ENDIF @@ -1403,8 +1483,8 @@ DO I=1,IHL IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN IX=I ! -MY_IS_GLB+1 - DWDTMN(IX,JX)=-EPSB - DWDTMX(IX,JX)= EPSB + grid%dwdtmn(IX,JX)=-EPSB + grid%dwdtmx(IX,JX)= EPSB ENDIF ENDDO ENDIF @@ -1418,8 +1498,8 @@ DO I=IHH,IDE-1 ! IM IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN IX=I ! -MY_IS_GLB+1 - DWDTMN(IX,JX)=-EPSB - DWDTMX(IX,JX)= EPSB + grid%dwdtmn(IX,JX)=-EPSB + grid%dwdtmx(IX,JX)= EPSB ENDIF ENDDO ENDIF @@ -1443,7 +1523,7 @@ ALLOCATE(GLW(IMS:IME,JMS:JME),STAT=I) ; GLW = 0. ALLOCATE(HFX(IMS:IME,JMS:JME),STAT=I) ; HFX = 0. ALLOCATE(LOWLYR(IMS:IME,JMS:JME),STAT=I) ; LOWLYR = 0. -! ALLOCATE(MAVAIL(IMS:IME,JMS:JME),STAT=I) ; MAVAIL = 0. +! ALLOCATE(grid%mavail(IMS:IME,JMS:JME),STAT=I) ; grid%mavail = 0. ALLOCATE(NCA(IMS:IME,JMS:JME),STAT=I) ; NCA = 0. ALLOCATE(QFX(IMS:IME,JMS:JME),STAT=I) ; QFX = 0. ALLOCATE(RAINBL(IMS:IME,JMS:JME),STAT=I) ; RAINBL = 0. @@ -1485,7 +1565,7 @@ ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; CLDFRA_OLD = 0. #endif #if 0 - ALLOCATE(W0AVG(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; W0AVG = 0. + ALLOCATE(w0avg(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; w0avg = 0. #endif !----------------------------------------------------------------------- !jm added set of g_inv @@ -1498,24 +1578,32 @@ ! DO J=MYJS,MYJE DO I=MYIS,MYIE - SFCZ=FIS(I,J)*G_INV + SFCZ=grid%fis(I,J)*G_INV ZINT(I,KTS,J)=SFCZ - PDSL(I,J)=PD(I,J)*RES(I,J) - PSURF=PINT(I,J,KTS) +#ifdef HWRF +!zhang's doing + IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) then + grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J) + endif +!end of zhang's doing +#else + grid%pdsl(I,J)=grid%pd(I,J)*grid%res(I,J) +#endif + PSURF=grid%pint(I,J,KTS) EXNSFC=(1.E5/PSURF)**CAPA - XLAND(I,J)=SM(I,J)+1. - THSIJ=(SST(I,J)*EXNSFC)*(XLAND(I,J)-1.) & - & +THS(I,J)*(2.-SM(I,J)) + grid%xland(I,J)=grid%sm(I,J)+1. + THSIJ=(grid%sst(I,J)*EXNSFC)*(grid%xland(I,J)-1.) & + & +grid%ths(I,J)*(2.-grid%sm(I,J)) TSFC(I,J)=THSIJ/EXNSFC ! DO K=KTS,KTE-1 - PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5 - TL=T(I,J,K) - CWML=CWM(I,J,K) - RRI(I,K,J)=R_D*TL*(1.+P608*Q(I,J,K))/PLYR + PLYR=(grid%pint(I,J,K)+grid%pint(I,J,K+1))*0.5 + TL=grid%t(I,J,K) + CWML=grid%cwm(I,J,K) + RRI(I,K,J)=R_D*TL*(1.+P608*grid%q(I,J,K))/PLYR ZINT(I,K+1,J)=ZINT(I,K,J)+TL/PLYR & - *(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))*ROG & - *(Q(I,J,K)*P608-CWML+1.) + *(grid%deta1(K)*grid%pdtop+grid%deta2(K)*grid%pdsl(I,J))*ROG & + *(grid%q(I,J,K)*P608-CWML+1.) ENDDO ! ! DO K=KTS,KTE @@ -1530,45 +1618,51 @@ !*** NOTE: KTE=NUMBER OF LAYERS PLUS ONE !----------------------------------------------------------------------- ! - PDTOT=101325.-PT + PDTOT=101325.-grid%pt RPDTOT=1./PDTOT - PDBOT=PDTOT-PDTOP + PDBOT=PDTOT-grid%pdtop SFULL(KTS)=1. SFULL(KTE)=0. DSIGSUM = 0. DO K=KTS+1,KTE - DSIG=(DETA1(K-1)*PDTOP+DETA2(K-1)*PDBOT)*RPDTOT + DSIG=(grid%deta1(K-1)*grid%pdtop+grid%deta2(K-1)*PDBOT)*RPDTOT DSIGSUM=DSIGSUM+DSIG SFULL(K)=SFULL(K-1)-DSIG SMID(K-1)=0.5*(SFULL(K-1)+SFULL(K)) ENDDO - DSIG=(DETA1(KTE-1)*PDTOP+DETA2(KTE-1)*PDBOT)*RPDTOT + DSIG=(grid%deta1(KTE-1)*grid%pdtop+grid%deta2(KTE-1)*PDBOT)*RPDTOT DSIGSUM=DSIGSUM+DSIG SMID(KTE-1)=0.5*(SFULL(KTE-1)+SFULL(KTE)) ! !----------------------------------------------------------------------- - LU_INDEX=IVGTYP +#ifdef HWRF +!zhang's doing + if(.NOT.RESTRT .OR. .NOT.allowed_to_read)grid%LU_INDEX=grid%IVGTYP +!end of zhang's doing +#else + grid%lu_index=grid%ivgtyp +#endif IF(.NOT.RESTRT)THEN DO J=MYJS,MYJE DO I=MYIS,MYIE - Z0_DUM(I,J)=Z0(I,J) ! hold - ALBEDO_DUM(I,J)=ALBEDO(I,J) ! Save albedos + Z0_DUM(I,J)=grid%z0(I,J) ! hold + ALBEDO_DUM(I,J)=grid%albedo(I,J) ! Save albedos ENDDO ENDDO ENDIF ! -!*** Always define the quantity Z0BASE +!*** Always define the quantity grid%z0base IF(.NOT.RESTRT)THEN DO J=MYJS,MYJE DO I=MYIS,MYIE ! - IF(SM(I,J)==0)then - Z0BASE(I,J)=VZ0TBL_24(IVGTYP(I,J))+Z0LAND + IF(grid%sm(I,J)==0)then + grid%z0base(I,J)=VZ0TBL_24(grid%ivgtyp(I,J))+Z0LAND ELSE - Z0BASE(I,J)=VZ0TBL_24(IVGTYP(I,J))+Z0SEA + grid%z0base(I,J)=VZ0TBL_24(grid%ivgtyp(I,J))+Z0SEA ENDIF ! ENDDO @@ -1588,25 +1682,33 @@ CALL domain_setgmtetc( GRID, START_OF_SIMULATION ) if(restrt) then +#ifdef HWRF +!zhang + CALL nl_get_julyr (grid%id, grid%julyr) + CALL nl_get_julday (grid%id, grid%julday) + CALL nl_get_gmt (grid%id, grid%gmt) +!zhang end +#else CALL domain_clock_get( grid, current_time=currentTime ) CALL WRFU_TimeGet( currentTime, YY=grid%julyr, dayOfYear=grid%julday, & H=hr, M=mn, S=sec, MS=ms, rc=rc) grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600) WRITE( wrf_err_message , * ) 'DEBUG start_domain_nmm(): gmt = ',grid%gmt CALL wrf_debug( 150, TRIM(wrf_err_message) ) +#endif endif ! Several arguments are RCONFIG entries in Registry.NMM. Registry no longer ! includes these as dummy arguments or declares them. Access them from ! GRID. JM 20050819 #ifndef WRF_NMM_NEST - MOVED = .FALSE. + grid%moved = .FALSE. #endif IF (GRID%RESTART) THEN LRESTART = GRID%RESTART ELSE - IF (moved) THEN + IF (grid%moved) THEN LRESTART = .TRUE. ELSE LRESTART = .FALSE. @@ -1614,39 +1716,40 @@ END IF CALL PHY_INIT(GRID%ID,CONFIG_FLAGS,GRID%DT,LRESTART,SFULL,SMID & - & ,PT,TSFC,GRID%RADT,GRID%BLDT,GRID%CUDT,GRID%GSMDT & + & ,grid%pt,TSFC,GRID%RADT,GRID%BLDT,GRID%CUDT,GRID%GSMDT & & ,RTHCUTEN, RQVCUTEN, RQRCUTEN & & ,RQCCUTEN, RQSCUTEN, RQICUTEN & & ,RUBLTEN,RVBLTEN,RTHBLTEN & & ,RQVBLTEN,RQCBLTEN,RQIBLTEN & & ,RTHRATEN,RTHRATENLW,RTHRATENSW & & ,STEPBL,STEPRA,STEPCU & - & ,W0AVG, RAINNC, RAINC, RAINCV, RAINNCV & + & ,grid%w0avg, RAINNC, RAINC, grid%raincv, RAINNCV & & ,NCA,GRID%SWRAD_SCAT & - & ,CLDEFI,LOWLYR & - & ,MASS_FLUX & - & ,RTHFTEN, RQVFTEN & - & ,CLDFRA_TRANS,CLDFRA_OLD,GLW,GSW,EMISS,EMTEMP,LU_INDEX& + & ,grid%cldefi,LOWLYR & + & ,grid%mass_flux & + & ,grid%rthften, grid%rqvften & + & ,CLDFRA_TRANS,CLDFRA_OLD,GLW,grid%gsw,EMISS,EMTEMP,grid%lu_index& & ,GRID%LANDUSE_ISICE, GRID%LANDUSE_LUCATS & & ,GRID%LANDUSE_LUSEAS, GRID%LANDUSE_ISN & & ,GRID%LU_STATE & - & ,XLAT,XLONG,ALBEDO,ALBBCK & + & ,grid%xlat,grid%xlong,grid%albedo,grid%albbck & & ,GRID%GMT,GRID%JULYR,GRID%JULDAY & & ,GRID%LEVSIZ, NUM_OZMIXM, NUM_AEROSOLC, GRID%PAERLEV & - & ,TMN,XLAND,ZNT,Z0,USTAR,MOL,PBLH,TKE_MYJ & - & ,EXCH_H,THC,SNOWC,MAVAIL,HFX,QFX,RAINBL & - & ,STC,ZS,DZS,GRID%NUM_SOIL_LAYERS,WARM_RAIN & + & ,TMN,grid%xland,grid%znt,grid%z0,grid%ustar,grid%mol,grid%pblh,grid%tke_myj & + & ,grid%DUCUDT, grid%DVCUDT & + & ,grid%exch_h,THC,SNOWC,grid%mavail,HFX,QFX,RAINBL & + & ,grid%stc,ZS,DZS,GRID%NUM_SOIL_LAYERS,WARM_RAIN & & ,ADV_MOIST_COND & - & ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS & - & ,APR_CAPMA,APR_CAPME,APR_CAPMI & - & ,XICE,XICE,VEGFRA,SNOW,CANWAT,SMSTAV & - & ,SMSTOT, SFCRUNOFF,UDRUNOFF,GRDFLX,ACSNOW & - & ,ACSNOM,IVGTYP,ISLTYP,SFCEVP,SMC & - & ,SH2O, SNOWH, SMFR3D & ! temporary + & ,grid%apr_gr,grid%apr_w,grid%apr_mc,grid%apr_st,grid%apr_as & + & ,grid%apr_capma,grid%apr_capme,grid%apr_capmi & + & ,grid%xice,grid%xice,grid%vegfra,grid%snow,grid%canwat,grid%smstav & + & ,grid%smstot, grid%sfcrunoff,grid%udrunoff,grid%grdflx,grid%acsnow & + & ,grid%acsnom,grid%ivgtyp,grid%isltyp,grid%sfcevp,grid%smc & + & ,grid%sh2o, grid%snowh, grid%smfr3d & ! temporary & ,grid%SNOALB & - & ,GRID%DX,GRID%DY,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY & - & ,MP_RESTART_STATE,TBPVS_STATE,TBPVS0_STATE & - & ,.TRUE.,moved,START_OF_SIMULATION & + & ,GRID%DX,GRID%DY,grid%f_ice_phy,grid%f_rain_phy,grid%f_rimef_phy & + & ,grid%mp_restart_state,grid%tbpvs_state,grid%tbpvs0_state & + & ,.TRUE.,grid%moved,START_OF_SIMULATION & & ,1 & ! lagday & ,IDS, IDE, JDS, JDE, KDS, KDE & & ,IMS, IME, JMS, JME, KMS, KME & @@ -1654,6 +1757,13 @@ & ,NUM_URBAN_LAYERS & & ) +#ifdef HWRF +!zhang's doing + grid%julyr_rst=grid%julyr_rst + grid%julday_rst=grid%julday_rst + grid%gmt_rst=grid%gmt_rst +!end of zhang's doing +#endif !----------------------------------------------------------------------- !---- Initialization for gravity wave drag (GWD) & mountain blocking (MB) ! @@ -1661,33 +1771,37 @@ CALL nl_get_cen_lon(GRID%ID, CEN_LON) !-- CEN_LON in deg DTPHS=grid%dt*grid%nphs CALL GWD_init(DTPHS,GRID%DX,GRID%DY,CEN_LAT,CEN_LON,RESTRT & - & ,GLAT,GLON,CROT,SROT,HANGL & + & ,grid%glat,grid%glon,grid%crot,grid%srot,grid%hangl & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE ) IF(.NOT.RESTRT)THEN DO J=MYJS,MYJE DO I=MYIS,MYIE - UGWDsfc(I,J)=0. - VGWDsfc(I,J)=0. + grid%ugwdsfc(I,J)=0. + grid%vgwdsfc(I,J)=0. ENDDO ENDDO ENDIF !----------------------------------------------------------------------- ! - IF(NSTART==0)THEN +#ifdef HWRF + IF(NSTART.EQ.0 .or. .not.allowed_to_read )THEN +#else + IF(NSTART==0)THEN +#endif DO J=JMS,JME DO I=IMS,IME - Z0(I,J)=Z0BASE(I,J) + grid%z0(I,J)=grid%z0base(I,J) ENDDO ENDDO DO K=KMS,KME DO J=JMS,JME DO I=IMS,IME - CLDFRA(I,J,K)=CLDFRA_TRANS(I,K,J) + grid%cldfra(I,J,K)=CLDFRA_TRANS(I,K,J) ENDDO ENDDO ENDDO @@ -1698,10 +1812,12 @@ ! !mp replace F*_PHY with values defined in module_initialize_real.F? #ifdef HWRF + IF (.NOT. RESTRT) THEN !zhang moist = 0.0 - F_ICE = F_ICE_PHY - F_RIMEF = F_RIMEF_PHY - F_RAIN = F_RAIN_PHY + grid%f_ice = grid%f_ice_phy + grid%f_rimef = grid%f_rimef_phy + grid%f_rain = grid%f_rain_phy + ENDIF !zhang #endif IF (.NOT. RESTRT) THEN @@ -1709,43 +1825,43 @@ ! mixing ratio (from NMM's specific humidity var) into moist array. !!mp - CALL wrf_message('Initializng moist(:,:,:, Qv) from Q') + CALL wrf_message('Initializng moist(:,:,:, Qv) from q') DO K=KPS,KPE DO J=JFS,JFE DO I=IFS,IFE - moist(I,J,K,P_QV) = Q(I,J,K) / (1.-Q(I,J,K)) + moist(I,J,K,P_QV) = grid%q(I,J,K) / (1.-grid%q(I,J,K)) enddo enddo enddo -! Also sum cloud water, ice, rain, snow, graupel into Ferrier CWM +! Also sum cloud water, ice, rain, snow, graupel into Ferrier cwm ! array (if any hydrometeors found and non-zero from initialization ! package). Then, determine fractions ice and rain from species. - IF (.not. (MAXVAL(CWM).gt.0. .and. MAXVAL(CWM).lt.1.) ) then + IF (.not. (MAXVAL(grid%cwm).gt.0. .and. MAXVAL(grid%cwm).lt.1.) ) then do i_m = 2, num_moist if (i_m.ne.p_qv) & - & CALL wrf_message(' summing moist(:,:,:,i_m) into CWM array') + & CALL wrf_message(' summing moist(:,:,:,i_m) into cwm array') DO K=KPS,KPE DO J=JFS,JFE DO I=IFS,IFE IF ( (moist(I,J,K,i_m).gt.EPSQ) .and. (i_m.ne.p_qv) ) THEN - CWM(I,J,K) = CWM(I,J,K) + moist(I,J,K,i_m) + grid%cwm(I,J,K) = grid%cwm(I,J,K) + moist(I,J,K,i_m) ENDIF enddo enddo enddo enddo - IF (.not. ( (maxval(F_ICE)+maxval(F_RAIN)) .gt. EPSQ) ) THEN - CALL wrf_message(' computing F_ICE') + IF (.not. ( (maxval(grid%f_ice)+maxval(grid%f_rain)) .gt. EPSQ) ) THEN + CALL wrf_message(' computing grid%f_ice') do i_m = 2, num_moist DO J=JFS,JFE DO K=KPS,KPE DO I=IFS,IFE IF ( (moist(I,J,K,i_m).gt.EPSQ) .and. & & ( (i_m.eq.p_qi).or.(i_m.eq.p_qs).or.(i_m.eq.p_qg) ) ) THEN - F_ICE(I,K,J) = F_ICE(I,K,J) + moist(I,J,K,i_m) + grid%f_ice(I,K,J) = grid%f_ice(I,K,J) + moist(I,J,K,i_m) ENDIF if (model_config_rec%mp_physics(grid%id).EQ.ETAMPNEW) then if ((i_m.eq.p_qi).or.(i_m.eq.p_qg) ) then @@ -1757,21 +1873,21 @@ enddo enddo enddo - CALL wrf_message(' computing F_RAIN') + CALL wrf_message(' computing f_rain') ! DO J=JFS,JFE DO K=KPS,KPE DO I=IFS,IFE - IF(F_ICE(i,k,j)<=EPSQ)THEN - F_ICE(I,K,J)=0. + IF(grid%f_ice(i,k,j)<=EPSQ)THEN + grid%f_ice(I,K,J)=0. ELSE - F_ICE(I,K,J) = F_ICE(I,K,J)/CWM(I,J,K) + grid%f_ice(I,K,J) = grid%f_ice(I,K,J)/grid%cwm(I,J,K) ENDIF IF ( (moist(I,J,K,p_qr)+moist(I,J,K,p_qc)).gt.EPSQ) THEN IF(moist(i,j,k,p_qr)<=EPSQ)THEN - F_RAIN(I,K,J)=0. + grid%f_rain(I,K,J)=0. ELSE - F_RAIN(I,K,J) = moist(i,j,k,p_qr) & + grid%f_rain(I,K,J) = moist(i,j,k,p_qr) & & / (moist(i,j,k,p_qr)+moist(i,j,k,p_qc)) ENDIF ENDIF @@ -1782,31 +1898,31 @@ ENDIF ! End addition by Greg Thompson - IF (maxval(F_ICE) .gt. 0.) THEN + IF (maxval(grid%f_ice) .gt. 0.) THEN do J=JMS,JME do K=KMS,KME do I=IMS,IME - F_ICE_PHY(I,K,J)=F_ICE(I,K,J) + grid%f_ice_phy(I,K,J)=grid%f_ice(I,K,J) enddo enddo enddo ENDIF - IF (maxval(F_RAIN) .gt. 0.) THEN + IF (maxval(grid%f_rain) .gt. 0.) THEN do J=JMS,JME do K=KMS,KME do I=IMS,IME - F_RAIN_PHY(I,K,J)=F_RAIN(I,K,J) + grid%f_rain_phy(I,K,J)=grid%f_rain(I,K,J) enddo enddo enddo ENDIF - IF (maxval(F_RIMEF) .gt. 0.) THEN + IF (maxval(grid%f_rimef) .gt. 0.) THEN do J=JMS,JME do K=KMS,KME do I=IMS,IME - F_RIMEF_PHY(I,K,J)=F_RIMEF(I,K,J) + grid%f_rimef_phy(I,K,J)=grid%f_rimef(I,K,J) enddo enddo enddo @@ -1818,17 +1934,22 @@ IF(MAXVAL(ALBEDO_DUM)>0.)THEN DO J=JMS,JME DO I=IMS,IME - ALBEDO(I,J)=ALBEDO_DUM(I,J) + grid%albedo(I,J)=ALBEDO_DUM(I,J) ENDDO ENDDO ENDIF ENDIF +#ifdef HWRF + if(.NOT. RESTRT .OR. .NOT.allowed_to_read) then !zhang's doing +!zhang's doing +#else IF(.NOT.RESTRT)THEN +#endif DO J=JMS,JME DO I=IMS,IME - APREC(I,J)=RAINNC(I,J)*1.E-3 - CUPREC(I,J)=RAINCV(I,J)*1.E-3 + grid%aprec(I,J)=RAINNC(I,J)*1.E-3 + grid%cuprec(I,J)=grid%raincv(I,J)*1.E-3 ENDDO ENDDO ENDIF @@ -1841,7 +1962,7 @@ KK=MIN(KDE-1,K) DO I=ITS,ITE II=MIN(IDE-1,I) - CONVFAC(I,K,J) = PINT(II,JJ,KK)/RGASUNIV/T(II,JJ,KK) + CONVFAC(I,K,J) = grid%pint(II,JJ,KK)/RGASUNIV/grid%t(II,JJ,KK) ENDDO ENDDO ENDDO @@ -1849,20 +1970,36 @@ DO J=JMS,JME DO K=KMS,KME DO I=IMS,IME - PINT_TRANS(I,K,J)=PINT(I,J,K) - T_TRANS(I,K,J)=T(I,J,K) + PINT_TRANS(I,K,J)=grid%pint(I,J,K) + T_TRANS(I,K,J)=grid%t(I,J,K) ENDDO ENDDO ENDDO - CALL CHEM_INIT (GRID%ID,CHEM,GRID%DT,GRID%BIOEMDT,GRID%PHOTDT,GRID%CHEMDT, & + DO J=JMS,JME + DO I=IMS,IME + grid%xlat(i,j)=grid%glat(I,J)/DEGRAD + grid%xlong(I,J)=grid%glon(I,J)/DEGRAD + + ENDDO + ENDDO +!!! write(0,*)'now do chem_init' + CALL CHEM_INIT (GRID%ID,CHEM,EMIS_ANT,scalar,GRID%DT,GRID%BIOEMDT,GRID%PHOTDT,GRID%CHEMDT, & STEPBIOE,STEPPHOT,STEPCHEM,STEPFIREPL,GRID%PLUMERISEFIRE_FRQ, & - ZINT,G,AERWRF,CONFIG_FLAGS, & + ZINT,grid%xlat,grid%xlong,G,AERWRF,CONFIG_FLAGS,grid, & RRI,T_TRANS,PINT_TRANS,CONVFAC, & - GD_CLOUD,GD_CLOUD2,GD_CLOUD_B,GD_CLOUD2_B, & + grid%ttday,grid%tcosz,grid%julday,grid%gmt, & + GD_CLOUD,GD_CLOUD2,raincv_a,raincv_b, & + GD_CLOUD_a,GD_CLOUD2_a, & + GD_CLOUD_B,GD_CLOUD2_B, & TAUAER1,TAUAER2,TAUAER3,TAUAER4, & GAER1,GAER2,GAER3,GAER4, & WAER1,WAER2,WAER3,WAER4, & - PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC,GRID%CHEM_IN_OPT, & + l2AER,l3AER,l4AER,l5AER,l6aer,l7aer, & + PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC, & + grid%last_chem_time_year,grid%last_chem_time_month, & + grid%last_chem_time_day,grid%last_chem_time_hour, & + grid%last_chem_time_minute,grid%last_chem_time_second, & + GRID%CHEM_IN_OPT, & GRID%KEMIT, & IDS , IDE , JDS , JDE , KDS , KDE , & IMS , IME , JMS , JME , KMS , KME , & @@ -1872,7 +2009,14 @@ ! calculate initial pm ! SELECT CASE (CONFIG_FLAGS%CHEM_OPT) - CASE (RADM2SORG, RACMSORG,RACMSORG_KPP) + case (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + call sum_pm_gocart ( & + RRI, CHEM, PM2_5_DRY, PM2_5_DRY_EC, PM10, & + IDS,IDE, JDS,JDE, KDS,KDE, & + IMS,IME, JMS,JME, KMS,KME, & + ITS,ITE, JTS,JTE, KTS,KTE-1 ) + CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_KPP) +!!! write(0,*)'sum pm ' CALL SUM_PM_SORGAM ( & RRI, CHEM, H2OAJ, H2OAI, & PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC, PM10, & @@ -1909,7 +2053,7 @@ DEALLOCATE(GLW) DEALLOCATE(HFX) DEALLOCATE(LOWLYR) -! DEALLOCATE(MAVAIL) +! DEALLOCATE(grid%mavail) DEALLOCATE(NCA) DEALLOCATE(QFX) DEALLOCATE(RAINBL) @@ -1946,14 +2090,14 @@ DEALLOCATE(CLDFRA_OLD) #endif #if 0 - DEALLOCATE(W0AVG) + DEALLOCATE(w0avg) #endif !----------------------------------------------------------------------- !---------------------------------------------------------------------- DO J=jfs,jfe DO I=ifs,ife - DWDTMN(I,J)=DWDTMN(I,J)*HBM3(I,J) - DWDTMX(I,J)=DWDTMX(I,J)*HBM3(I,J) + grid%dwdtmn(I,J)=grid%dwdtmn(I,J)*grid%hbm3(I,J) + grid%dwdtmx(I,J)=grid%dwdtmx(I,J)*grid%hbm3(I,J) ENDDO ENDDO !---------------------------------------------------------------------- @@ -2000,8 +2144,8 @@ # include # include #endif -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN diff --git a/wrfv2_fire/external/RSL_LITE/gen_comms.c b/wrfv2_fire/external/RSL_LITE/gen_comms.c index 5f1518ec..02b59b41 100644 --- a/wrfv2_fire/external/RSL_LITE/gen_comms.c +++ b/wrfv2_fire/external/RSL_LITE/gen_comms.c @@ -191,11 +191,11 @@ int print_body( FILE * fp, char * commname ) } int -gen_halos ( char * dirname , char * incname , node_t * halos ) +gen_halos ( char * dirname , char * incname , node_t * halos, int split ) { node_t * p, * q ; node_t * dimd ; - char commname[NAMELEN] ; + char commname[NAMELEN], subs_fname[NAMELEN] ; char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ; char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ; char commuse[NAMELEN] ; @@ -221,9 +221,28 @@ gen_halos ( char * dirname , char * incname , node_t * halos ) int need_config_flags; #define MAX_4DARRAYS 1000 char name_4d[MAX_4DARRAYS][NAMELEN] ; +#define FRAC 4 + int num_halos, fraction, ihalo, j ; if ( dirname == NULL ) return(1) ; + if ( split ) { + for ( p = halos, num_halos=0 ; p != NULL ; p = p-> next ) { /* howmany deez guys? */ + if ( incname == NULL ) { + strcpy( commname, p->name ) ; + make_upper_case(commname) ; + } + else { + strcpy( commname, incname ) ; + } + if ( !( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN" ) + || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH" ) ) ) { + num_halos++ ; + } + } + } + + ihalo = 0 ; for ( p = halos ; p != NULL ; p = p->next ) { need_config_flags = 0; /* 0 = do not need, 1 = need */ @@ -246,9 +265,23 @@ gen_halos ( char * dirname , char * incname , node_t * halos ) continue ; } print_warning(fpcall,fnamecall) ; + + if ( !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN") + || !strcmp(commname,"HALO_INTERP_UP" ) || !strcmp(commname,"HALO_INTERP_SMOOTH") ) { + sprintf(subs_fname, "REGISTRY_COMM_NESTING_DM_subs.inc" ) ; + } else { + if ( split ) { + j = ihalo / ((num_halos+1)/FRAC+1) ; /* the compiler you save may be your own */ + sprintf(subs_fname, "REGISTRY_COMM_DM_%d_subs.inc", j ) ; + ihalo++ ; + } else { + sprintf(subs_fname, "REGISTRY_COMM_DM_subs.inc" ) ; + } + } + /* Generate definition of custom routine that encapsulates inlined comm calls */ - if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_subs.inc",dirname) ; } - else { sprintf(fnamesub,"REGISTRY_COMM_DM_subs.inc") ; } + if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/%s",dirname,subs_fname) ; } + else { sprintf(fnamesub,"%s",subs_fname) ; } if ((fpsub = fopen( fnamesub , "a" )) == NULL ) { fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ; @@ -1655,7 +1688,7 @@ if ( p->subgrid != 0 ) { /* moving nests not implemented for subgrid variables if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ; } - gen_halos( dirname , NULL, &Shift ) ; + gen_halos( dirname , NULL, &Shift, 0 ) ; sprintf(fname,"%s/shift_halo_%s.inc",dirname,*direction) ; if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; @@ -2058,7 +2091,7 @@ gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path ) int i, d1 ; node_t *p, *p1, *dim ; int d2, d3, xdex, ydex, zdex ; - int io_mask ; + int nest_mask ; char * grid ; char ddim[3][2][NAMELEN] ; char mdim[3][2][NAMELEN] ; @@ -2073,17 +2106,17 @@ gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path ) if ( p1->node_kind & FOURD ) { if ( p1->members->next ) - io_mask = p1->members->next->io_mask ; + nest_mask = p1->members->next->nest_mask ; else continue ; } else { - io_mask = p1->io_mask ; + nest_mask = p1->nest_mask ; } p = p1 ; - if ( io_mask & down_path ) + if ( nest_mask & down_path ) { if ( p->node_kind & FOURD ) { if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ; @@ -2262,7 +2295,7 @@ count_fields ( node_t * node , int * d2 , int * d3 , char * fourd_names, int do } else { - if ( p->io_mask & down_path ) + if ( p->nest_mask & down_path ) { if ( p->node_kind == FOURD ) zdex = get_index_for_coord( p->members , COORD_Z ) ; @@ -2370,9 +2403,14 @@ gen_comms ( char * dirname ) fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ; /* truncate this file if it exists */ + if ((fpsub = fopen( "inc/REGISTRY_COMM_NESTING_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ; if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ; + if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_0_subs.inc" , "w" )) != NULL ) fclose(fpsub) ; + if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_1_subs.inc" , "w" )) != NULL ) fclose(fpsub) ; + if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_2_subs.inc" , "w" )) != NULL ) fclose(fpsub) ; + if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_3_subs.inc" , "w" )) != NULL ) fclose(fpsub) ; - gen_halos( "inc" , NULL, Halos ) ; + gen_halos( "inc" , NULL, Halos, 1 ) ; gen_shift( "inc" ) ; gen_periods( "inc", Periods ) ; gen_swaps( "inc", Swaps ) ; diff --git a/wrfv2_fire/external/RSL_LITE/module_dm.F b/wrfv2_fire/external/RSL_LITE/module_dm.F index 11033805..f452825e 100644 --- a/wrfv2_fire/external/RSL_LITE/module_dm.F +++ b/wrfv2_fire/external/RSL_LITE/module_dm.F @@ -5,7 +5,7 @@ MODULE module_dm USE module_machine USE module_wrf_error USE module_driver_constants - USE module_comm_dm +! USE module_comm_dm IMPLICIT NONE #if ( NMM_CORE == 1 ) || defined( WRF_CHEM ) @@ -22,7 +22,7 @@ MODULE module_dm LOGICAL :: dm_debug_flag = .FALSE. INTERFACE wrf_dm_maxval -#ifdef PROMOTE_FLOAT +#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) ) MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer #else MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision @@ -30,7 +30,7 @@ MODULE module_dm END INTERFACE INTERFACE wrf_dm_minval ! gopal's doing -#ifdef PROMOTE_FLOAT +#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) ) MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer #else MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision @@ -1920,8 +1920,7 @@ SUBROUTINE write_68( grid, v , s , & END SUBROUTINE wrf_abort - - implicit none + IMPLICIT NONE #ifndef STUBMPI INCLUDE 'mpif.h' INTEGER ierr @@ -2997,7 +2996,7 @@ END !------------------------------------------------------------------ -#if ( EM_CORE == 1 ) +#if ( EM_CORE == 1 && DA_CORE != 1 ) !------------------------------------------------------------------ @@ -3010,7 +3009,7 @@ END USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, local_communicator, mytask - USE module_comm_dm, ONLY : halo_force_down_sub + USE module_comm_nesting_dm, ONLY : halo_force_down_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") @@ -3030,6 +3029,7 @@ END ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7,itrace + REAL dummy_xs, dummy_xe, dummy_ys, dummy_ye CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & @@ -3147,7 +3147,7 @@ END USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, & mytask, get_dm_max_halo_width - USE module_comm_dm, ONLY : halo_interp_down_sub + USE module_comm_nesting_dm, ONLY : halo_interp_down_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") @@ -3211,7 +3211,7 @@ END USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask - USE module_comm_dm, ONLY : halo_interp_up_sub + USE module_comm_nesting_dm, ONLY : halo_interp_up_sub IMPLICIT NONE ! TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid") @@ -3357,7 +3357,7 @@ END USE module_configure, ONLY : grid_config_rec_type, model_config_rec USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width - USE module_comm_dm, ONLY : halo_interp_up_sub + USE module_comm_nesting_dm, ONLY : halo_interp_up_sub USE module_utility IMPLICIT NONE @@ -3472,20 +3472,21 @@ END SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width USE module_timing IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid -#include +#include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw @@ -3511,8 +3512,8 @@ END CALL wrf_get_myproc( myproc ) CALL wrf_get_nproc( nproc ) -#define COPY_IN -#include +!#define COPY_IN +!#include CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & @@ -3543,8 +3544,8 @@ END CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm ) -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE interp_domain_nmm_part1 @@ -3552,18 +3553,20 @@ END SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + USE module_comm_nesting_dm, ONLY : halo_interp_down_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -3583,16 +3586,16 @@ END INTEGER myproc INTEGER ierr -#ifdef DEREF_KLUDGE -! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm - INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 - INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x - INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -#endif +!#ifdef DEREF_KLUDGE +!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm +! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 +! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x +! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +!#endif #include "deref_kludge.h" -#define COPY_IN -#include +!#define COPY_IN +!#include CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -3611,13 +3614,12 @@ END ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) -!#include "HALO_NMM_INTERP_DOWN1.inc" #include "HALO_INTERP_DOWN.inc" #include "nest_interpdown_interp.inc" -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE interp_domain_nmm_part2 @@ -3626,18 +3628,19 @@ END SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width USE module_timing ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid -#include +#include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -3651,8 +3654,8 @@ END INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 -#define COPY_IN -#include +!#define COPY_IN +!#include ! CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & @@ -3670,8 +3673,8 @@ END ! WRITE(0,*)'I have completed PACKING of BCs data successfully' -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE force_domain_nmm_part1 @@ -3679,18 +3682,20 @@ END SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + USE module_comm_dm, ONLY : HALO_NMM_FORCE_DOWN1_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -3706,19 +3711,20 @@ END ips, ipe, jps, jpe, kps, kpe INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 + REAL dummy_xs, dummy_xe, dummy_ys, dummy_ye integer myproc -#ifdef DEREF_KLUDGE -! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm - INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 - INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x - INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -#endif +!#ifdef DEREF_KLUDGE +!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm +! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 +! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x +! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +!#endif #include "deref_kludge.h" -#define COPY_IN -#include +!#define COPY_IN +!#include CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & @@ -3743,8 +3749,8 @@ integer myproc ! code here to interpolate the data into the nested domain #include "nest_forcedown_interp.inc" -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE force_domain_nmm_part2 @@ -3762,20 +3768,22 @@ integer myproc SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + USE module_comm_dm, ONLY : HALO_NMM_WEIGHTS_sub IMPLICIT NONE ! TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid") TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of ! soil temp, moisture, etc., has vertical dim ! of soil categories -#include +#include INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3786,16 +3794,16 @@ integer myproc INTEGER :: idum1, idum2 -#ifdef DEREF_KLUDGE -! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm - INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 - INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x - INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -#endif +!#ifdef DEREF_KLUDGE +!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm +! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 +! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x +! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +!#endif #include "deref_kludge.h" -#define COPY_IN -#include +!#define COPY_IN +!#include CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & @@ -3806,8 +3814,8 @@ integer myproc #include "HALO_NMM_WEIGHTS.inc" #endif -#define COPY_OUT -#include +!#define COPY_OUT +!#include END SUBROUTINE feedback_nest_prep_nmm @@ -3815,18 +3823,19 @@ integer myproc SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec - USE module_dm + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE(domain), POINTER :: xgrid @@ -3843,17 +3852,17 @@ integer myproc INTEGER local_comm, myproc, nproc, idum1, idum2 -#ifdef DEREF_KLUDGE -! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm - INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 - INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x - INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -#endif +!#ifdef DEREF_KLUDGE +!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm +! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 +! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x +! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +!#endif INTERFACE SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description @@ -3862,12 +3871,12 @@ integer myproc ! TYPE (grid_config_rec_type) :: config_flags TYPE(domain), TARGET :: grid -#include +#include END SUBROUTINE feedback_nest_prep_nmm END INTERFACE ! -#define COPY_IN -#include +!#define COPY_IN +!#include CALL wrf_get_dm_communicator ( local_comm ) CALL wrf_get_myproc( myproc ) @@ -3907,7 +3916,7 @@ integer myproc #include "deref_kludge.h" CALL feedback_nest_prep_nmm ( grid, config_flags & ! -#include "actual_args.inc" +#include "actual_new_args.inc" ! ) @@ -3920,8 +3929,8 @@ integer myproc #include "nest_feedbackup_interp.inc" -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE feedback_domain_nmm_part1 @@ -3929,15 +3938,16 @@ integer myproc SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags & ! -#include "dummy_args.inc" +#include "dummy_new_args.inc" ! ) USE module_state_description USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm, ONLY : halo_interp_up_sub, get_dm_max_halo_width, ips_save, ipe_save, & + USE module_dm, ONLY : get_dm_max_halo_width, ips_save, ipe_save, & jps_save, jpe_save, ntasks, mytask, ntasks_x, ntasks_y, & local_communicator, itrace + USE module_comm_nesting_dm, ONLY : halo_interp_up_sub USE module_utility IMPLICIT NONE @@ -3946,7 +3956,7 @@ integer myproc TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid -#include +#include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -3975,8 +3985,8 @@ integer myproc LOGICAL, EXTERNAL :: cd_feedback_mask LOGICAL, EXTERNAL :: cd_feedback_mask_v -#define COPY_IN -#include +!#define COPY_IN +!#include ! On entry to this routine, ! "grid" refers to the parent domain @@ -4052,8 +4062,8 @@ integer myproc #include "nest_feedbackup_smooth.inc" -#define COPY_OUT -#include +!#define COPY_OUT +!#include RETURN END SUBROUTINE feedback_domain_nmm_part2 @@ -4263,6 +4273,122 @@ integer myproc END SUBROUTINE wrf_scatterv_integer ! end new stuff 20070124 + SUBROUTINE wrf_dm_gatherv ( v, elemsize , km_s, km_e, wordsz ) + IMPLICIT NONE + INTEGER elemsize, km_s, km_e, wordsz + REAL v(*) + IF ( wordsz .EQ. DWORDSIZE ) THEN + CALL wrf_dm_gatherv_double(v, elemsize , km_s, km_e) + ELSE + CALL wrf_dm_gatherv_single(v, elemsize , km_s, km_e) + ENDIF + END SUBROUTINE wrf_dm_gatherv + + SUBROUTINE wrf_dm_gatherv_double ( v, elemsize , km_s, km_e ) + IMPLICIT NONE + INTEGER elemsize, km_s, km_e + REAL*8 v(0:*) +#ifndef STUBMPI +# ifndef USE_MPI_IN_PLACE + REAL*8 v_local((km_e-km_s+1)*elemsize) +# endif + INTEGER, DIMENSION(:), ALLOCATABLE :: recvcounts, displs + INTEGER send_type, myproc, nproc, local_comm, ierr, i + INCLUDE 'mpif.h' + send_type = MPI_DOUBLE_PRECISION + CALL wrf_get_dm_communicator ( local_comm ) + CALL wrf_get_nproc( nproc ) + CALL wrf_get_myproc( myproc ) + ALLOCATE( recvcounts(nproc), displs(nproc) ) + i = (km_e-km_s+1)*elemsize + CALL mpi_allgather( i,1,MPI_INTEGER,recvcounts,1,MPI_INTEGER,local_comm,ierr) ; + i = (km_s)*elemsize + CALL mpi_allgather( i,1,MPI_INTEGER,displs,1,MPI_INTEGER,local_comm,ierr) ; +# ifdef USE_MPI_IN_PLACE + CALL mpi_allgatherv( MPI_IN_PLACE, & +# else + DO i = 1,elemsize*(km_e-km_s+1) + v_local(i) = v(i+km_s-1) + ENDDO + CALL mpi_allgatherv( v_local, & +# endif + (km_e-km_s+1)*elemsize, & + send_type, & + v, & + recvcounts, & + displs, & + send_type, & + local_comm, & + ierr ) + DEALLOCATE(recvcounts) + DEALLOCATE(displs) +#endif + return + END SUBROUTINE wrf_dm_gatherv_double + + SUBROUTINE wrf_dm_gatherv_single ( v, elemsize , km_s, km_e ) + IMPLICIT NONE + INTEGER elemsize, km_s, km_e + REAL*4 v(0:*) +#ifndef STUBMPI +# ifndef USE_MPI_IN_PLACE + REAL*4 v_local((km_e-km_s+1)*elemsize) +# endif + INTEGER, DIMENSION(:), ALLOCATABLE :: recvcounts, displs + INTEGER send_type, myproc, nproc, local_comm, ierr, i + INCLUDE 'mpif.h' + send_type = MPI_REAL + CALL wrf_get_dm_communicator ( local_comm ) + CALL wrf_get_nproc( nproc ) + CALL wrf_get_myproc( myproc ) + ALLOCATE( recvcounts(nproc), displs(nproc) ) + i = (km_e-km_s+1)*elemsize + CALL mpi_allgather( i,1,MPI_INTEGER,recvcounts,1,MPI_INTEGER,local_comm,ierr) ; + i = (km_s)*elemsize + CALL mpi_allgather( i,1,MPI_INTEGER,displs,1,MPI_INTEGER,local_comm,ierr) ; +# ifdef USE_MPI_IN_PLACE + CALL mpi_allgatherv( MPI_IN_PLACE, & +# else + DO i = 1,elemsize*(km_e-km_s+1) + v_local(i) = v(i+km_s-1) + ENDDO + CALL mpi_allgatherv( v_local, & +# endif + (km_e-km_s+1)*elemsize, & + send_type, & + v, & + recvcounts, & + displs, & + send_type, & + local_comm, & + ierr ) + DEALLOCATE(recvcounts) + DEALLOCATE(displs) +#endif + return + END SUBROUTINE wrf_dm_gatherv_single + + SUBROUTINE wrf_dm_decomp1d( nt, km_s, km_e ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: nt + INTEGER, INTENT(OUT) :: km_s, km_e + ! local + INTEGER nn, nnp, na, nb + INTEGER myproc, nproc + + CALL wrf_get_myproc(myproc) + CALL wrf_get_nproc(nproc) + nn = nt / nproc ! min number done by this task + nnp = nn + if ( myproc .lt. mod( nt, nproc ) ) nnp = nnp + 1 ! distribute remainder + + na = min( myproc, mod(nt,nproc) ) ! Number of blocks with remainder that precede this one + nb = max( 0, myproc - na ) ! number of blocks without a remainder that precede this one + km_s = na * ( nn+1) + nb * nn ! starting iteration for this task + km_e = km_s + nnp - 1 ! ending iteration for this task + END SUBROUTINE wrf_dm_decomp1d + + SUBROUTINE wrf_dm_define_comms ( grid ) USE module_domain, ONLY : domain IMPLICIT NONE diff --git a/wrfv2_fire/external/RSL_LITE/rsl_bcast.c b/wrfv2_fire/external/RSL_LITE/rsl_bcast.c index 3b5ba4d5..a7ac7e3d 100755 --- a/wrfv2_fire/external/RSL_LITE/rsl_bcast.c +++ b/wrfv2_fire/external/RSL_LITE/rsl_bcast.c @@ -533,6 +533,7 @@ rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) for ( Rbufsize = 0, P = 0, Rdisplacements[0] = 0 ; P < ntasks ; P++ ) { Rdisplacements[P+1] = Rsizes[P] + Rdisplacements[P] ; + Rbufsize += Rsizes[P] ; } diff --git a/wrfv2_fire/external/atm_pom/Makefile b/wrfv2_fire/external/atm_pom/Makefile index aee18abb..5d88ad13 100644 --- a/wrfv2_fire/external/atm_pom/Makefile +++ b/wrfv2_fire/external/atm_pom/Makefile @@ -16,11 +16,14 @@ library: $(OBJ) $(RANLIB) $(TARGET) .F.o: - $(CPP) $(CFLAGS) $*.F > $*.f90 + $(CPP) $(CPPFLAGS) -DDM_PARALLEL $*.F > $*.f90 $(FC) -o $@ -c $(FFLAGS) $*.f90 clean: rm -f $(OBJ) $(TARGET) + rm -f *.f90 + rm -f *.mod + superclean: clean # DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) diff --git a/wrfv2_fire/external/atm_pom/atm_comm_pom.F b/wrfv2_fire/external/atm_pom/atm_comm_pom.F index 533fe41e..c1139e2d 100644 --- a/wrfv2_fire/external/atm_pom/atm_comm_pom.F +++ b/wrfv2_fire/external/atm_pom/atm_comm_pom.F @@ -69,7 +69,7 @@ ! !*********************************************************************** ! - SUBROUTINE ATM_CMP_START + SUBROUTINE ATM_CMP_START(atm_comm) USE ATM_cc @@ -77,6 +77,7 @@ integer Atmos_id /1/, Atmos_master_rank_local /0/ character*20 s + integer atm_comm ! !<-id of OM as a component of the coupled system @@ -116,7 +117,7 @@ else MPI_kind_lonlat=MPI_kind_alt_REAL end if - + atm_comm=MPI_COMM_Atmos return END ! diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc index ea261aae..bab7744b 100644 --- a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc +++ b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc @@ -38,7 +38,7 @@ by both C++ and F90 compilers. ! Note that MAX_ALARMS must match MAX_WRF_ALARMS defined in ! ../../frame/module_domain.F !!! Eliminate this dependence with ! grow-as-you-go AlarmList in ESMF_Clock... -#define MAX_ALARMS 28 +#define MAX_ALARMS (2*(MAX_HISTORY)+10) ! TBH: TODO: Hook this into the WRF build so WRF can use either "no-leap" or ! TBH: Gregorian calendar. Now WRF is hard-wired to use Gregorian. diff --git a/wrfv2_fire/external/fftpack/fftpack5/Makefile b/wrfv2_fire/external/fftpack/fftpack5/Makefile index 56eab4c3..41a549b9 100644 --- a/wrfv2_fire/external/fftpack/fftpack5/Makefile +++ b/wrfv2_fire/external/fftpack/fftpack5/Makefile @@ -23,6 +23,6 @@ library: $(OBJ) $(FC) -c $(FFLAGS) $< clean: - rm -f $(OBJ) $(TARGET) + rm -f $(OBJ) $(TARGET) *.obj superclean: clean diff --git a/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90 b/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90 index eddfc34b..d99198fb 100644 --- a/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90 +++ b/wrfv2_fire/external/io_esmf/ext_esmf_read_field.F90 @@ -39,7 +39,6 @@ SUBROUTINE ext_esmf_read_field ( DataHandle , DateStr , VarName , Field , FieldT TYPE(ESMF_Array) :: tmpArray TYPE(ESMF_ArraySpec) :: arrayspec INTEGER :: esmf_kind - TYPE(ESMF_RelLoc) :: horzRelloc REAL(ESMF_KIND_R4), POINTER :: data_esmf_real_ptr(:,:) REAL(ESMF_KIND_R4), POINTER :: tmp_esmf_r4_ptr(:,:) INTEGER(ESMF_KIND_I4), POINTER :: data_esmf_int_ptr(:,:) @@ -202,7 +201,7 @@ write(0,*)__FILE__,__LINE__,'ext_esmf_read_field PatchEnd ', PatchEnd(1:esmf_ra ! rc=rc ) ! END DOESNOTWORK !TODO: Compute horzrelloc from Stagger as above once ESMF supports staggering - horzrelloc=ESMF_CELL_CENTER +! horzrelloc=ESMF_CELL_CENTER !TODO: Add code for other data types here... ! ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) ) ALLOCATE( tmp_esmf_r4_ptr(ips:ipe,jps:jpe) ) diff --git a/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90 b/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90 index 284ea1bb..3e042dc9 100644 --- a/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90 +++ b/wrfv2_fire/external/io_esmf/ext_esmf_write_field.F90 @@ -41,7 +41,6 @@ SUBROUTINE ext_esmf_write_field ( DataHandle , DateStr , VarName , Field , Field TYPE(ESMF_ArraySpec) :: arrayspec ! TYPE(ESMF_DataKind) :: esmf_kind INTEGER :: esmf_kind - TYPE(ESMF_RelLoc) :: horzRelloc REAL(ESMF_KIND_R4), POINTER :: data_esmf_real_ptr(:,:) REAL(ESMF_KIND_R4), POINTER :: tmp_esmf_r4_ptr(:,:) INTEGER(ESMF_KIND_I4), POINTER :: data_esmf_int_ptr(:,:) @@ -204,7 +203,7 @@ write(0,*)__FILE__,__LINE__,'ext_esmf_write_field PatchEnd ', PatchEnd(1:esmf_r ! rc=rc ) ! END DOESNOTWORK !TODO: Compute horzrelloc from Stagger as above once ESMF supports staggering - horzrelloc=ESMF_CELL_CENTER +! horzrelloc=ESMF_CELL_CENTER !TODO: Add code for other data types here... ! ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) ) ALLOCATE( tmp_esmf_r4_ptr(ips:ipe,jps:jpe) ) diff --git a/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90 b/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90 index b01da5c2..7fbee36f 100644 --- a/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90 +++ b/wrfv2_fire/external/io_esmf/module_esmf_extensions.F90 @@ -399,20 +399,19 @@ CONTAINS ! extend ESMF_TimeGet() to make dayOfYear_r8 work... subroutine WRFU_TimeGet(time, yy, yy_i8, & - mm, dd, & - d, d_i8, & - h, m, & - s, s_i8, & - ms, us, ns, & - d_r8, h_r8, m_r8, s_r8, & - ms_r8, us_r8, ns_r8, & - sN, sD, & - calendar, calendarType, timeZone, & - timeString, timeStringISOFrac, & - dayOfWeek, midMonth, & - dayOfYear, dayOfYear_r8, & - dayOfYear_intvl, rc) - + mm, dd, & + d, d_i8, & + h, m, & + s, s_i8, & + ms, us, ns, & + d_r8, h_r8, m_r8, s_r8, & + ms_r8, us_r8, ns_r8, & + sN, sD, & + calendar, calendarType, timeZone, & + timeString, timeStringISOFrac, & + dayOfWeek, midMonth, & + dayOfYear, dayOfYear_r8, & + dayOfYear_intvl, rc) type(ESMF_Time), intent(inout) :: time integer(ESMF_KIND_I4), intent(out), optional :: yy integer(ESMF_KIND_I8), intent(out), optional :: yy_i8 @@ -451,20 +450,20 @@ CONTAINS INTEGER(ESMF_KIND_I4) :: year, seconds, Sn, Sd INTEGER(ESMF_KIND_I8), PARAMETER :: SECONDS_PER_DAY = 86400_ESMF_KIND_I8 - call ESMF_TimeGet(time, yy, yy_i8, & - mm, dd, & - d, d_i8, & - h, m, & - s, s_i8, & - ms, us, ns, & - d_r8, h_r8, m_r8, s_r8, & - ms_r8, us_r8, ns_r8, & - sN, sD, & - calendar, calendarType, timeZone, & - timeString, timeStringISOFrac, & - dayOfWeek, midMonth, & - dayOfYear, dayOfYear_r8, & - dayOfYear_intvl, rc) + CALL ESMF_TimeGet(time=time, yy=yy, yy_i8=yy_i8, & + mm=mm, dd=dd, & + d=d, d_i8=d_i8, & + h=h, m=m, & + s=s, s_i8=s_i8, & + ms=ms, us=us, ns=ns, & + d_r8=d_r8, h_r8=h_r8, m_r8=m_r8, s_r8=s_r8, & + ms_r8=ms_r8, us_r8=us_r8, ns_r8=ns_r8, & + sN=sN, sD=sD, & + calendar=calendar, calendarType=calendarType, timeZone=timeZone, & + timeString=timeString, timeStringISOFrac=timeStringISOFrac, & + dayOfWeek=dayOfWeek, midMonth=midMonth, & + dayOfYear=dayOfYear, dayOfYear_R8=dayOfYear_r8, & + dayOfYear_intvl=dayOfYear_intvl, rc=rc) IF ( rc == ESMF_SUCCESS ) THEN IF ( PRESENT( dayOfYear_r8 ) ) THEN ! get seconds since start of year and fractional seconds @@ -473,8 +472,10 @@ CONTAINS ! 64-bit IEEE 754 has 52-bit mantisssa -- only need 25 bits to hold ! number of seconds in a year... rsec = REAL( seconds, ESMF_KIND_R8 ) - IF ( Sd /= 0 ) THEN - rsec = rsec + ( REAL( Sn, ESMF_KIND_R8 ) / REAL( Sd, ESMF_KIND_R8 ) ) + IF ( PRESENT( Sd ) ) THEN + IF ( Sd /= 0 ) THEN + rsec = rsec + ( REAL( Sn, ESMF_KIND_R8 ) / REAL( Sd, ESMF_KIND_R8 ) ) + ENDIF ENDIF dayOfYear_r8 = rsec / REAL( SECONDS_PER_DAY, ESMF_KIND_R8 ) ! start at 1 diff --git a/wrfv2_fire/external/io_grib1/Makefile b/wrfv2_fire/external/io_grib1/Makefile index bca46714..fff11073 100644 --- a/wrfv2_fire/external/io_grib1/Makefile +++ b/wrfv2_fire/external/io_grib1/Makefile @@ -73,11 +73,11 @@ SUB_DIRS = $(LIB_DIRS) $(EXE_DIRS) # Clean up old build files # superclean: - /bin/rm -f *.o > /dev/null 2>&1 + /bin/rm -f *.o *.obj > /dev/null 2>&1 /bin/rm -f *.f90 > /dev/null 2>&1 /bin/rm -f *.mod > /dev/null 2>&1 /bin/rm -f *.a > /dev/null 2>&1 - /bin/rm -f wgrid > /dev/null 2>&1 + /bin/rm -f wgrid.exe > /dev/null 2>&1 ( cd grib1_util ; make clean ) ( cd MEL_grib1 ; make clean ) ( cd WGRIB ; make clean ) diff --git a/wrfv2_fire/external/io_grib1/WGRIB/Makefile b/wrfv2_fire/external/io_grib1/WGRIB/Makefile index 82b9c380..397c902d 100644 --- a/wrfv2_fire/external/io_grib1/WGRIB/Makefile +++ b/wrfv2_fire/external/io_grib1/WGRIB/Makefile @@ -21,9 +21,9 @@ all: wgrib archive: wgrib wgrib: $(obj) - $(CC) -o wgrib $(obj) -lm - ( cd .. ; \rm -f wgrib ; \ln -sf WGRIB/wgrib wgrib ; cd WGRIB ) + $(CC) -o wgrib $(obj) #-lm + ( cd .. ; \rm -f wgrib.exe ; \ln -sf WGRIB/wgrib wgrib.exe ; cd WGRIB ) clean: - \rm -f $(obj) wgrib - ( cd .. ; \rm -f wgrib ; cd WGRIB ) + \rm -f $(obj) *.obj wgrib + ( cd .. ; \rm -f wgrib.exe ; cd WGRIB ) diff --git a/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c index 79c163a2..a98c1273 100644 --- a/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c +++ b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c @@ -1902,9 +1902,8 @@ char *advance_time_str(char startdatein[], int amount, char enddate[]) #ifdef _WIN32 localtime_s(&endtp, &time); #else - localtime_r(&time, &endtp); + localtime_r(&time, &endtp); #endif - localtime_r(&time, &endtp); strftime(enddate,15,"%Y%m%d%H%M%S",&endtp); return enddate; diff --git a/wrfv2_fire/external/io_grib1/io_grib1.F b/wrfv2_fire/external/io_grib1/io_grib1.F index 9f3434ee..eb8535b7 100644 --- a/wrfv2_fire/external/io_grib1/io_grib1.F +++ b/wrfv2_fire/external/io_grib1/io_grib1.F @@ -52,6 +52,7 @@ module gr1_data_info character, dimension(:), pointer :: grid_info integer :: full_xsize, full_ysize integer, dimension(maxDomains) :: domains = -1 + integer :: this_domain = 0 integer :: max_domain = 0 TYPE :: HandleVar @@ -574,6 +575,7 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & IMPLICIT NONE #include "wrf_status_codes.h" #include "wrf_io_flags.h" +#include "wrf_projection.h" INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStrIn CHARACTER(DateStrLen) :: DateStr @@ -616,11 +618,11 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & integer :: def(8) logical :: output = .true. integer :: idx1, idx2, idx3 - integer :: this_domain logical :: new_domain real :: region_center_lat, region_center_lon integer :: dom_xsize, dom_ysize; integer :: ierr + logical :: already_have_domain call wrf_debug ( DEBUG , 'Entering ext_gr1_write_field for parameter'//VarName) @@ -644,17 +646,16 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & ! Check if this is a domain that we haven't seen yet. If so, add it to ! the list of domains. ! - this_domain = 0 new_domain = .false. + already_have_domain = .false. do idx = 1, max_domain - if (DomainDesc .eq. domains(idx)) then - this_domain = idx + if (this_domain .eq. domains(idx)) then + already_have_domain = .true. endif enddo - if (this_domain .eq. 0) then + if (.NOT. already_have_domain) then max_domain = max_domain + 1 - domains(max_domain) = DomainDesc - this_domain = max_domain + domains(max_domain) = this_domain new_domain = .true. endif @@ -666,8 +667,6 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & #ifdef GRIB_ONE_TIME_PER_FILE if (lastDateStr(this_domain) .ne. DateStr) then write(DataFile(DataHandle),'(A8,i2.2,A1,A19)') 'wrfout_d',this_domain,'_',DateStr - print *,'Opening new file: ',trim(DataFile(DataHandle)) - call ext_gr1_ioclose ( DataHandle, Status ) CALL open_file(TRIM(DataFile(DataHandle)), 'w', FileFd(DataHandle), ierr) if (ierr .ne. 0) then @@ -791,6 +790,15 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & dom_ysize = full_ysize endif + ! + ! Handle case of polare stereographic centered on pole. In that case, + ! always set center lon to be the projection central longitude. + ! + if ((projection .eq. WRF_POLAR_STEREO) .AND. & + (abs(center_lat - 90.0) < 0.01)) then + center_lon = proj_central_lon + endif + CALL get_region_center(MemoryOrder, projection, center_lat, center_lon, & dom_xsize, dom_ysize, dx, dy, proj_central_lon, proj_center_flag, & truelat1, truelat2, xsize, ysize, region_center_lat, region_center_lon) @@ -2790,6 +2798,8 @@ SUBROUTINE ext_gr1_put_dom_ti_integer ( DataHandle,Element, Data, Count, & projection = Data(1) else if (Element == 'WG_GRID_ID') then wg_grid_id = Data(1) + else if (Element == 'GRID_ID') then + this_domain = Data(1) endif if (committed(DataHandle)) then diff --git a/wrfv2_fire/external/io_grib_share/Makefile b/wrfv2_fire/external/io_grib_share/Makefile index 82190f2f..f5ec9316 100644 --- a/wrfv2_fire/external/io_grib_share/Makefile +++ b/wrfv2_fire/external/io_grib_share/Makefile @@ -71,7 +71,7 @@ SUB_DIRS = $(LIB_DIRS) $(EXE_DIRS) # Clean up old build files # superclean: - /bin/rm -f *.o > /dev/null 2>&1 + /bin/rm -f *.o *.obj > /dev/null 2>&1 /bin/rm -f *.f90 > /dev/null 2>&1 /bin/rm -f *.mod > /dev/null 2>&1 /bin/rm -f *.a > /dev/null 2>&1 diff --git a/wrfv2_fire/external/io_grib_share/build/library_rules.mk b/wrfv2_fire/external/io_grib_share/build/library_rules.mk index eaf9c243..2499d793 100644 --- a/wrfv2_fire/external/io_grib_share/build/library_rules.mk +++ b/wrfv2_fire/external/io_grib_share/build/library_rules.mk @@ -145,7 +145,7 @@ exe: # object files. # thisdir_clean: thisdir_clean_lib - @/bin/rm -f *.o *.mod *.f90 core so_locations Makefile.bak *~ #*# + @/bin/rm -f *.o *.obj *.mod *.f90 core so_locations Makefile.bak *~ #*# @/bin/rm -fr ii_files @if [ -d utest ] ; then \ echo " Doing make clean on utest subdirectory"; \ diff --git a/wrfv2_fire/external/io_grib_share/gridnav.c b/wrfv2_fire/external/io_grib_share/gridnav.c index 48f5f3e2..e740ec92 100644 --- a/wrfv2_fire/external/io_grib_share/gridnav.c +++ b/wrfv2_fire/external/io_grib_share/gridnav.c @@ -46,6 +46,7 @@ int GRID_init(float central_lat, float central_lon, int projection, int status = 1; + fprintf(stderr,"central_lon: %f\n",central_lon); gridnav->proj.central_lon = central_lon; gridnav->proj.central_lat = central_lat; gridnav->proj.map_proj = projection; @@ -90,6 +91,7 @@ int GRID_to_latlon(GridNav *gridnav, float column, float row, float *lat, */ double X, Y, R; int status = 1; + double eps = 0.00001; switch (gridnav->proj.map_proj) { @@ -121,15 +123,18 @@ int GRID_to_latlon(GridNav *gridnav, float column, float row, float *lat, break; case GRID_POLSTR: - X = (column - gridnav->grid.origin_column)*gridnav->grid.dx; - Y = (row - gridnav->grid.origin_row)*gridnav->grid.dy + - gridnav->proj_transform.parm3; - R = sqrt(X*X + Y*Y); - *lat = gridnav->proj_transform.parm5*90 - 2 * RAD_TO_DEG * - atan((gridnav->proj_transform.parm5*R/EARTH_RAD)/ - (1+cos(gridnav->proj_transform.parm1))); - *lon = gridnav->grid.lon_origin + RAD_TO_DEG * - atan(X/(gridnav->proj_transform.parm5 * -Y)); + X = (column - gridnav->grid.origin_column) * + gridnav->proj_transform.parm3 + + gridnav->proj_transform.parm1; + Y = (row - gridnav->grid.origin_row) * + gridnav->proj_transform.parm3 + + gridnav->proj_transform.parm2 + eps; + *lon = gridnav->proj_transform.parm5 * -1 * + atan(X / Y) * RAD_TO_DEG + gridnav->proj.central_lon; + *lat = 90 - 2 * RAD_TO_DEG * + atan(X / (2 * EARTH_RAD * + sin((*lon - gridnav->proj.central_lon ) / + RAD_TO_DEG) + eps) ); while (*lon > 180) *lon -= 360; while (*lon <= -180) *lon += 360; break; @@ -215,20 +220,18 @@ int GRID_from_latlon(GridNav *gridnav, float lat, float lon, float *column, gridnav->proj_transform.parm6 / gridnav->grid.dx)); break; - case GRID_POLSTR: - Rs = EARTH_RAD * sin((gridnav->proj_transform.parm5 * 90 - lat) - / RAD_TO_DEG)* - ((1 + cos(gridnav->proj_transform.parm1)) / - (1 + cos((gridnav->proj_transform.parm5 * 90 - lat) - / RAD_TO_DEG)) ); - *row = gridnav->grid.origin_row - - (1 / gridnav->grid.dy) * - (gridnav->proj_transform.parm3 + - Rs * cos((lon - gridnav->grid.lon_origin) / RAD_TO_DEG)); - *column = gridnav->grid.origin_column + - gridnav->proj_transform.parm5 * - ((Rs / gridnav->grid.dx) * - sin((lon - gridnav->grid.lon_origin) / RAD_TO_DEG)); + case GRID_POLSTR: + Rs = 2 * EARTH_RAD * tan ( (45 - fabs(lat)/2) / RAD_TO_DEG ); + Y = gridnav->proj_transform.parm5 * -1 * Rs * + cos ((lon - gridnav->proj.central_lon) / RAD_TO_DEG); + X = Rs * sin ((lon - gridnav->proj.central_lon) / RAD_TO_DEG); + + *row = (Y - gridnav->proj_transform.parm2) / + gridnav->proj_transform.parm3 + + gridnav->grid.origin_row; + *column = (X - gridnav->proj_transform.parm1) / + gridnav->proj_transform.parm3 + + gridnav->grid.origin_column; break; case GRID_LATLON: @@ -257,6 +260,8 @@ int fill_proj_parms(GridNav *gridnav) { double orig_lat_rad; double R_orig; + double r_not; + double r_truelat1; int hemifactor; switch (gridnav->proj.map_proj) @@ -333,33 +338,36 @@ int fill_proj_parms(GridNav *gridnav) gridnav->proj.central_lon) / RAD_TO_DEG)); break; case GRID_POLSTR: - if (gridnav->proj.truelat1 > 0) - { - hemifactor = 1; - } - else - { - hemifactor = -1; - } - - /* This is Psi1 in MM5 speak */ - gridnav->proj_transform.parm1 = - hemifactor * (PI/2 - fabs(gridnav->proj.truelat1) / RAD_TO_DEG); + if (gridnav->proj.central_lat > 0) + { + hemifactor = 1; + } + else + { + hemifactor = -1; + } + + /* Calculate X for origin */ + r_not = 2 * EARTH_RAD * + tan((45 - fabs(gridnav->grid.lat_origin) / 2) / RAD_TO_DEG); + gridnav->proj_transform.parm1 = + r_not * + sin ( (gridnav->grid.lon_origin - gridnav->proj.central_lon) / + RAD_TO_DEG); + /* Calculate Y for origin */ gridnav->proj_transform.parm2 = - (1+log10(cos(gridnav->proj.truelat1 / RAD_TO_DEG))) / - ( -log10(tan(45 / RAD_TO_DEG - hemifactor * - gridnav->proj.truelat1 / - (2 * RAD_TO_DEG) )) ); - /* This is Yc in MM5 speak */ + hemifactor * -1 * r_not * + cos ( (gridnav->grid.lon_origin - gridnav->proj.central_lon) / + RAD_TO_DEG); + /* Calculate grid spacing at pole */ + r_truelat1 = 2 * EARTH_RAD * + tan((45 - fabs(gridnav->proj.truelat1) / 2) / RAD_TO_DEG); gridnav->proj_transform.parm3 = - -EARTH_RAD * sin((hemifactor * 90 - - gridnav->grid.lat_origin) / RAD_TO_DEG)* - ( (1 + cos(gridnav->proj_transform.parm1))/ - (1 + cos((hemifactor*90 - gridnav->grid.lat_origin) / - RAD_TO_DEG)) ); - gridnav->proj_transform.parm4 = MISSING; - gridnav->proj_transform.parm5 = hemifactor; - break; + gridnav->grid.dx * r_truelat1 / + ( EARTH_RAD * cos (gridnav->proj.truelat1 / RAD_TO_DEG)); + gridnav->proj_transform.parm4 = MISSING; + gridnav->proj_transform.parm5 = hemifactor; + break; case GRID_LATLON: gridnav->proj_transform.parm1 = MISSING; gridnav->proj_transform.parm2 = MISSING; diff --git a/wrfv2_fire/external/io_netcdf/wrf_io.F90 b/wrfv2_fire/external/io_netcdf/wrf_io.F90 index db2a6b76..d541162b 100644 --- a/wrfv2_fire/external/io_netcdf/wrf_io.F90 +++ b/wrfv2_fire/external/io_netcdf/wrf_io.F90 @@ -40,7 +40,7 @@ module wrf_data integer , parameter :: WARN = 1 integer , parameter :: WrfDataHandleMax = 99 integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS - integer , parameter :: MaxVars = 2000 + integer , parameter :: MaxVars = 3000 integer , parameter :: MaxTimes = 900000 integer , parameter :: DateStrLen = 19 integer , parameter :: VarNameLen = 31 diff --git a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 index f499bf5f..7c58ba8b 100644 --- a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 +++ b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 @@ -41,7 +41,7 @@ module wrf_data_pnc integer , parameter :: WARN = 1 integer , parameter :: WrfDataHandleMax = 99 integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS - integer , parameter :: MaxVars = 2000 + integer , parameter :: MaxVars = 3000 integer , parameter :: MaxTimes = 9000000 integer , parameter :: DateStrLen = 19 integer , parameter :: VarNameLen = 31 diff --git a/wrfv2_fire/frame/Makefile b/wrfv2_fire/frame/Makefile index f89e0ce0..ecf2efcd 100644 --- a/wrfv2_fire/frame/Makefile +++ b/wrfv2_fire/frame/Makefile @@ -8,7 +8,7 @@ RM = rm -f MODULES = module_driver_constants.o \ module_domain_type.o \ - module_alloc_space.o \ + module_streams.o \ module_domain.o \ module_integrate.o \ module_timing.o \ @@ -21,18 +21,49 @@ MODULES = module_driver_constants.o \ module_sm.o \ module_io.o \ module_comm_dm.o \ + module_comm_dm_0.o \ + module_comm_dm_1.o \ + module_comm_dm_2.o \ + module_comm_dm_3.o \ + module_comm_nesting_dm.o \ module_dm.o \ module_quilt_outbuf_ops.o \ module_io_quilt.o - -OBJS = wrf_num_bytes_between.o \ - wrf_shutdown.o \ - wrf_debug.o \ - libmassv.o \ +ALOBJS =\ + module_alloc_space_0.o \ + module_alloc_space_1.o \ + module_alloc_space_2.o \ + module_alloc_space_3.o \ + module_alloc_space_4.o \ + module_alloc_space_5.o \ + module_alloc_space_6.o \ + module_alloc_space_7.o \ + module_alloc_space_8.o \ + module_alloc_space_9.o + +NLOBJS =\ nl_get_0_routines.o \ nl_get_1_routines.o \ + nl_get_2_routines.o \ + nl_get_3_routines.o \ + nl_get_4_routines.o \ + nl_get_5_routines.o \ + nl_get_6_routines.o \ + nl_get_7_routines.o \ nl_set_0_routines.o \ nl_set_1_routines.o \ + nl_set_2_routines.o \ + nl_set_3_routines.o \ + nl_set_4_routines.o \ + nl_set_5_routines.o \ + nl_set_6_routines.o \ + nl_set_7_routines.o + +OBJS = \ + wrf_num_bytes_between.o \ + wrf_shutdown.o \ + wrf_debug.o \ + libmassv.o \ collect_on_comm.o #compile as a .o but do not link into the main library @@ -43,16 +74,95 @@ include ../configure.wrf LIBTARGET = framework TARGETDIR = ./ -$(LIBTARGET) : $(MODULES) $(OBJS) $(SPECIAL) - $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) +$(LIBTARGET) : $(MODULES) $(OBJS) $(SPECIAL) $(NLOBJS) $(ALOBJS) + $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) $(NLOBJS) $(ALOBJS) $(RANLIB) ../main/$(LIBWRFLIB) +nl_set_0_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=0 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx0.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx0.f90 + $(RM) xx0.f90 + +nl_set_1_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=1 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx1.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx1.f90 + $(RM) xx1.f90 + +nl_set_2_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=2 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx2.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx2.f90 + $(RM) xx2.f90 + +nl_set_3_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=3 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx3.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx3.f90 + $(RM) xx3.f90 + +nl_set_4_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=4 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx4.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx4.f90 + $(RM) xx4.f90 + +nl_set_5_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=5 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx5.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx5.f90 + $(RM) xx5.f90 + +nl_set_6_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=6 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx6.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx6.f90 + $(RM) xx6.f90 + +nl_set_7_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=7 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx7.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx7.f90 + $(RM) xx7.f90 + +nl_get_0_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=0 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy0.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy0.f90 + $(RM) yy0.f90 + +nl_get_1_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=1 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy1.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy1.f90 + $(RM) yy1.f90 + +nl_get_2_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=2 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy2.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy2.f90 + $(RM) yy2.f90 + +nl_get_3_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=3 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy3.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy3.f90 + $(RM) yy3.f90 + +nl_get_4_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=4 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy4.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy4.f90 + $(RM) yy4.f90 + +nl_get_5_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=5 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy5.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy5.f90 + $(RM) yy5.f90 + +nl_get_6_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=6 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy6.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy6.f90 + $(RM) yy6.f90 + +nl_get_7_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=7 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy7.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy7.f90 + $(RM) yy7.f90 wrf_num_bytes_between.o : $(CC) -c $(CFLAGS) wrf_num_bytes_between.c pack_utils.o : - $(CC) -c $(CFLAGS) pack_utils.c + $(CC) -c $(CFLAGS) -DIWORDSIZE=$(IWORDSIZE) pack_utils.c module_internal_header_util.o : $(CPP) $(CPPFLAGS) -I../inc module_internal_header_util.F > module_internal_header_util.f90 @@ -75,6 +185,7 @@ md_calls.inc : md_calls.m4 module_configure.o: \ + ../dyn_em/namelist_remappings_em.h \ module_state_description.o \ module_wrf_error.o \ module_driver_constants.o @@ -85,22 +196,51 @@ module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \ module_timing.o \ module_configure.o module_comm_dm.o -module_comm_dm.o: \ +module_comm_dm.o: module_comm_dm_0.o module_comm_dm_1.o module_comm_dm_2.o module_comm_dm_3.o + +module_comm_dm_0.o: module_domain.o module_configure.o +module_comm_dm_1.o: module_domain.o module_configure.o +module_comm_dm_2.o: module_domain.o module_configure.o +module_comm_dm_3.o: module_domain.o module_configure.o + +module_comm_nesting_dm.o: \ module_domain.o \ module_configure.o module_dm_stubs.F: module_domain.o -module_domain.o: module_domain_type.o module_alloc_space.o module_driver_constants.o \ +module_domain.o: module_domain_type.o \ + module_alloc_space_0.o \ + module_alloc_space_1.o \ + module_alloc_space_2.o \ + module_alloc_space_3.o \ + module_alloc_space_4.o \ + module_alloc_space_5.o \ + module_alloc_space_6.o \ + module_alloc_space_7.o \ + module_alloc_space_8.o \ + module_alloc_space_9.o \ + module_driver_constants.o \ module_configure.o \ module_machine.o \ module_state_description.o \ module_wrf_error.o \ $(ESMF_MOD_DEPENDENCE) -module_domain_type.o : module_driver_constants.o $(ESMF_MOD_DEPENDENCE) +module_domain_type.o : module_driver_constants.o module_streams.o $(ESMF_MOD_DEPENDENCE) + +module_alloc_space_0.o : module_domain_type.o module_configure.o +module_alloc_space_1.o : module_domain_type.o module_configure.o +module_alloc_space_2.o : module_domain_type.o module_configure.o +module_alloc_space_3.o : module_domain_type.o module_configure.o +module_alloc_space_4.o : module_domain_type.o module_configure.o +module_alloc_space_5.o : module_domain_type.o module_configure.o +module_alloc_space_6.o : module_domain_type.o module_configure.o +module_alloc_space_7.o : module_domain_type.o module_configure.o +module_alloc_space_8.o : module_domain_type.o module_configure.o +module_alloc_space_9.o : module_domain_type.o module_configure.o -module_alloc_space.o : module_domain_type.o module_configure.o +module_streams.o : module_state_description.o module_driver_constants.o: \ module_state_description.o \ @@ -120,6 +260,7 @@ module_io.o : md_calls.inc \ module_driver_constants.o module_io_quilt.o: module_state_description.o \ + module_configure.o \ module_internal_header_util.o \ module_quilt_outbuf_ops.o diff --git a/wrfv2_fire/frame/collect_on_comm.c b/wrfv2_fire/frame/collect_on_comm.c index 595b898f..15d2c5ef 100644 --- a/wrfv2_fire/frame/collect_on_comm.c +++ b/wrfv2_fire/frame/collect_on_comm.c @@ -190,12 +190,9 @@ dst_on_comm ( int * Fcomm, int * typesize , return(0) ; } -#ifndef MS_SUA +#ifndef _WIN32 #ifndef MACOS # include -# ifndef _WIN32 -# include -# endif # include #endif @@ -229,12 +226,12 @@ rlim_ () getrusage ( RUSAGE_SELF, &r_usage ) ; if ( tock != 0 ) { -#ifndef MS_SUA +#ifndef _WIN32 fprintf(stderr,"sm %ld d %ld s %ld maxrss %ld %d %d %ld\n",r_usage.ru_ixrss/tock,r_usage.ru_idrss/tock,r_usage.ru_isrss/tock, r_usage.ru_maxrss,tick,tock,r_usage.ru_ixrss) ; #endif } minf = mallinfo() ; -#ifndef MS_SUAL +#ifndef _WIN32 fprintf(stderr,"a %ld usm %ld fsm %ld uord %ld ford %ld hblkhd %d\n",minf.arena,minf.usmblks,minf.fsmblks,minf.uordblks,minf.fordblks,minf.hblkhd) ; #endif # if 0 diff --git a/wrfv2_fire/frame/libmassv.F b/wrfv2_fire/frame/libmassv.F index 21add712..9037850d 100644 --- a/wrfv2_fire/frame/libmassv.F +++ b/wrfv2_fire/frame/libmassv.F @@ -302,7 +302,12 @@ subroutine vsacos(y,x,n) real*4 x(*),y(*) do 10 j=1,n +#if defined (G95) +! no reason why g95 should fail - oh well, we don't use this routine anyways + y(j)=asin( sqrt(1-x(j)*x(j)) ) +#else y(j)=acos(x(j)) +#endif 10 continue return end diff --git a/wrfv2_fire/frame/module_comm_dm.F b/wrfv2_fire/frame/module_comm_dm.F index 109fd36f..7f2f91b5 100644 --- a/wrfv2_fire/frame/module_comm_dm.F +++ b/wrfv2_fire/frame/module_comm_dm.F @@ -1,6 +1,11 @@ MODULE module_comm_dm + USE module_comm_dm_0 + USE module_comm_dm_1 + USE module_comm_dm_2 + USE module_comm_dm_3 + IMPLICIT NONE PRIVATE module_comm_dm_dummy @@ -8,7 +13,6 @@ MODULE module_comm_dm #ifdef DM_PARALLEL INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m - LOGICAL, EXTERNAL :: rsl_comm_iter #endif INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7 @@ -16,7 +20,7 @@ MODULE module_comm_dm CONTAINS - ! Avoid complaints about empty CONTAINS from some compilers. + ! Avoid complaints about empty CONTAINS from some compilers. SUBROUTINE module_comm_dm_dummy USE module_domain, ONLY:domain USE module_configure, ONLY:grid_config_rec_type,in_use_for_config @@ -25,7 +29,7 @@ CONTAINS RETURN END SUBROUTINE module_comm_dm_dummy -! Registry-generated communication subroutines. +! Registry-generated communication subroutines. #ifdef DM_PARALLEL #include "REGISTRY_COMM_DM_subs.inc" #endif diff --git a/wrfv2_fire/frame/module_configure.F b/wrfv2_fire/frame/module_configure.F index b7141d09..b4045f20 100644 --- a/wrfv2_fire/frame/module_configure.F +++ b/wrfv2_fire/frame/module_configure.F @@ -166,35 +166,6 @@ CONTAINS #define SOURCE_REC_DEX #include -#ifdef PLANET -!***************** special conversion for timesteps ********************* -! 2004-12-07 ADT Notes -! NB: P2SI needs to defined in multiple places. Right now this -! requirement is a kludge, and if I can find something more elegant -! I will try to implement it later. -! -! Beware: dt as the namelist timestep is now obsolete. The new -! variable "timestep" (which is an *integer* number of seconds), -! with the (optional) additional specification of a fraction (to -! make non-integer timesteps) now acts as the true timestep. -! In share/set_timekeeping.F the integer(s) are converted to a real -! number and put back in dt anyway! -! We will deal with the case of the integer variables in -! share/set_timekeeping.F itself. For now, since they left dt in -! the namelist definition, I will leave this here just in case ... - model_config_rec%dt = dt * P2SI -! All of the following variables are told to be input in *MINUTES* -! These values are converted to units of timesteps in the various -! init routines in phys/module_physics_init.F by dividing by the -! formula STEP = (xxDT*60./dt). So it seems safe to multiply them -! by P2SI here (with the exception of adding roundoff error later). -! See notes in phys/module_radiation_driver for the radt example. - model_config_rec%radt = radt * P2SI - model_config_rec%bldt = bldt * P2SI - model_config_rec%cudt = cudt * P2SI - model_config_rec%gsmdt = gsmdt * P2SI -!************************************************************************ -#endif CLOSE ( UNIT = nml_read_unit , IOSTAT = io_status ) @@ -210,6 +181,10 @@ CONTAINS ENDIF #endif +#if (EM_CORE == 1 && DA_CORE == 0) +# include "../dyn_em/namelist_remappings_em.h" +#endif + RETURN END SUBROUTINE initial_config @@ -375,6 +350,8 @@ CONTAINS ! If there is an error reading the "nml_name" namelist, this routine is ! called to check for namelist variables that have been removed by the ! developers and are still in user's namelists. +! +! The calls to this routine are in registry-generated code: inc/config_reads.inc ! ! IMPLICIT NONE diff --git a/wrfv2_fire/frame/module_dm_stubs.F b/wrfv2_fire/frame/module_dm_stubs.F index f07cdd84..d8538bf5 100644 --- a/wrfv2_fire/frame/module_dm_stubs.F +++ b/wrfv2_fire/frame/module_dm_stubs.F @@ -59,6 +59,24 @@ MODULE module_dm RETURN END SUBROUTINE wrf_dm_minval + SUBROUTINE wrf_dm_maxtile_real ( val , tile) + IMPLICIT NONE + REAL val + INTEGER tile + END SUBROUTINE wrf_dm_maxtile_real + + SUBROUTINE wrf_dm_mintile_double ( val , tile) + IMPLICIT NONE + DOUBLE PRECISION val + INTEGER tile + END SUBROUTINE wrf_dm_mintile_double + + SUBROUTINE wrf_dm_tile_val_int ( val , tile) + IMPLICIT NONE + INTEGER val + INTEGER tile + END SUBROUTINE wrf_dm_tile_val_int + ! stub SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy ) USE module_domain diff --git a/wrfv2_fire/frame/module_domain.F b/wrfv2_fire/frame/module_domain.F index 78d03c25..37f76350 100644 --- a/wrfv2_fire/frame/module_domain.F +++ b/wrfv2_fire/frame/module_domain.F @@ -170,6 +170,7 @@ CONTAINS CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -178,6 +179,7 @@ CONTAINS RETURN END SUBROUTINE adjust_domain_dims_for_move +#if 1 SUBROUTINE get_ijk_from_grid1 ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -319,6 +321,7 @@ CONTAINS kpe0 = kpe RETURN END SUBROUTINE get_ijk_from_subgrid +#endif ! Default version ; Otherwise module containing interface to DM library will provide @@ -553,7 +556,6 @@ CONTAINS ! in share/mediation_wrfmain.F. ! - USE module_alloc_space IMPLICIT NONE ! Input data. @@ -676,7 +678,11 @@ CONTAINS CALL get_bdyzone_y( bdyzone_y ) ALLOCATE ( new_grid ) - ALLOCATE ( new_grid%parents( max_parents ) ) + ALLOCATE( new_grid%head_statevars ) + NULLIFY( new_grid%head_statevars%next) + new_grid%tail_statevars => new_grid%head_statevars + + ALLOCATE ( new_grid%parents( max_parents ) ) ALLOCATE ( new_grid%nests( max_nests ) ) NULLIFY( new_grid%sibling ) DO i = 1, max_nests @@ -740,10 +746,16 @@ CONTAINS new_grid%max_tiles = 0 new_grid%num_tiles_spec = 0 new_grid%nframes = 0 ! initialize the number of frames per file (array assignment) +#if (EM_CORE == 1) + new_grid%stepping_to_time = .FALSE. + new_grid%adaptation_domain = 1 + new_grid%last_step_updated = -1 +#endif CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , & sd1, ed1, sd2, ed2, sd3, ed3, & sm1, em1, sm2, em2, sm3, em3, & + sp1, ep1, sp2, ep2, sp3, ep3, & sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose ) @@ -913,7 +925,232 @@ CONTAINS END SUBROUTINE alloc_and_configure_domain + SUBROUTINE get_fieldstr(ix,c,instr,outstr,noutstr,noerr) + IMPLICIT NONE + INTEGER, INTENT(IN) :: ix + CHARACTER*(*), INTENT(IN) :: c + CHARACTER*(*), INTENT(IN) :: instr + CHARACTER*(*), INTENT(OUT) :: outstr + INTEGER, INTENT(IN) :: noutstr ! length of outstr + LOGICAL, INTENT(INOUT) :: noerr ! status + !local + INTEGER, PARAMETER :: MAX_DEXES = 100 + INTEGER I, PREV, IDEX + INTEGER DEXES(MAX_DEXES) + prev = 1 + dexes(1) = 1 + DO i = 2,MAX_DEXES + idex = INDEX(instr(prev:LEN(TRIM(instr))),c) + IF ( idex .GT. 0 ) THEN + dexes(i) = idex+prev + prev = dexes(i)+1 + ELSE + dexes(i) = LEN(TRIM(instr))+2 + ENDIF + ENDDO + + IF ( (dexes(ix+1)-2)-(dexes(ix)) .GT. noutstr ) THEN + noerr = .FALSE. ! would overwrite + ELSE IF( dexes(ix) .EQ. dexes(ix+1) ) THEN + noerr = .FALSE. ! not found + ELSE + outstr = instr(dexes(ix):(dexes(ix+1)-2)) + noerr = noerr .AND. .TRUE. + ENDIF + END SUBROUTINE get_fieldstr + + SUBROUTINE change_to_lower_case(instr,outstr) + CHARACTER*(*) ,INTENT(IN) :: instr + CHARACTER*(*) ,INTENT(OUT) :: outstr +!Local + CHARACTER*1 :: c + INTEGER ,PARAMETER :: upper_to_lower =IACHAR('a')-IACHAR('A') + INTEGER :: i,n,n1 +! + outstr = ' ' + N = len(instr) + N1 = len(outstr) + N = MIN(N,N1) + outstr(1:N) = instr(1:N) + DO i=1,N + c = instr(i:i) + if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower) + ENDDO + RETURN + END SUBROUTINE change_to_lower_case + ! + SUBROUTINE modify_io_masks ( grid , id ) + IMPLICIT NONE +#include "streams.h" + INTEGER , INTENT(IN ) :: id + TYPE(domain), POINTER, INTENT(INOUT) :: grid + ! Local + TYPE(fieldlist), POINTER :: p, q + INTEGER, PARAMETER :: read_unit = 10 + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*256 :: fname, inln, mess, dname, t1, lookee + CHARACTER*256 :: fieldlst + CHARACTER*1 :: op, strmtyp + CHARACTER*3 :: strmid + INTEGER :: io_status + INTEGER :: lineno, fieldno, istrm, retval + LOGICAL :: keepgoing, noerr, gavewarning, ignorewarning, found + + CALL nl_get_iofields_filename( id, fname ) + + IF ( grid%is_intermediate ) RETURN ! short circuit + IF ( TRIM(fname) .EQ. "NONE_SPECIFIED" ) RETURN ! short circuit + + IF ( wrf_dm_on_monitor() ) THEN + OPEN ( UNIT = read_unit , & + FILE = TRIM(fname) , & + FORM = "FORMATTED" , & + STATUS = "OLD" , & + IOSTAT = io_status ) + IF ( io_status .EQ. 0 ) THEN ! only on success + keepgoing = .TRUE. + lineno = 0 + gavewarning = .FALSE. + DO WHILE ( keepgoing ) + READ(UNIT=read_unit,FMT='(A)',IOSTAT=io_status) inln + keepgoing = io_status .EQ. 0 + lineno = lineno + 1 + IF ( .NOT. LEN(TRIM(inln)) .LT. LEN(inln) ) THEN + WRITE(mess,*)'W A R N I N G : Line ',lineno,' of ',TRIM(fname),' is too long. Limit is ',LEN(inln),' characters.' + gavewarning = .TRUE. + ENDIF + IF ( INDEX(inln,'#') .EQ. 0 ) THEN ! skip comments, which is a # anywhere on line + IF ( keepgoing ) THEN + noerr = .TRUE. + CALL get_fieldstr(1,':',inln,op,1,noerr) ! + is add, - is remove + IF ( TRIM(op) .NE. '+' .AND. TRIM(op) .NE. '-' ) THEN + WRITE(mess,*)'W A R N I N G : unknown operation ',TRIM(op),' (should be + or -). Line ',lineno + gavewarning = .TRUE. + ENDIF + CALL get_fieldstr(2,':',inln,t1,1,noerr) ! i is input, h is history + CALL change_to_lower_case(t1,strmtyp) + CALL get_fieldstr(3,':',inln,strmid,3,noerr) ! number of stream (main input and hist are 0) + READ(strmid,'(I3)') istrm + IF ( istrm .LT. 0 .OR. istrm .GT. last_history ) THEN + WRITE(mess,*)'W A R N I N G : invalid stream id ',istrm,' (should be 0 <= id <= ',last_history,'). Line ',lineno + gavewarning = .TRUE. + ENDIF + CALL get_fieldstr(4,':',inln,fieldlst,1024,noerr) ! get list of fields + IF ( noerr ) THEN + fieldno = 1 + CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr) + CALL change_to_lower_case(t1,lookee) + DO WHILE ( noerr ) ! linear search, blargh... + p => grid%head_statevars + found = .FALSE. + DO WHILE ( ASSOCIATED( p%next ) ) + IF ( p%Ntl .GT. 0 ) THEN + CALL change_to_lower_case(p%DataName(1:LEN(TRIM(p%DataName))-2),dname) + ELSE + CALL change_to_lower_case(p%DataName,dname) + ENDIF + IF ( TRIM(dname) .EQ. TRIM(lookee) ) THEN + found = .TRUE. + IF ( TRIM(strmtyp) .EQ. 'h' ) THEN + IF ( TRIM(op) .EQ. '+' ) THEN + CALL get_mask( p%streams, first_history + istrm - 1, retval ) + IF ( retval .NE. 0 ) THEN + WRITE(mess,*)'W A R N I N G : Variable ',TRIM(lookee),' already on history stream ',istrm, & + '. File: ', TRIM(fname),' at line ',lineno + gavewarning = .TRUE. + ELSE + WRITE(mess,*)'Setting history stream ',istrm,' for ',TRIM(DNAME) ; CALL wrf_debug(1,mess) + CALL set_mask( p%streams, first_history + istrm - 1 ) + ENDIF + ELSE IF ( TRIM(op) .EQ. '-' ) THEN + CALL get_mask( p%streams, first_history + istrm - 1, retval ) + IF ( retval .EQ. 0 ) THEN + WRITE(mess,*)'W A R N I N G : Variable ',TRIM(lookee),' already off history stream ',istrm, & + '. File: ',TRIM(fname),' at line ',lineno + gavewarning = .TRUE. + ELSE + WRITE(mess,*)'Resetting history stream ',istrm,' for ',TRIM(DNAME) ; CALL wrf_debug(1,mess) + CALL reset_mask( p%streams, first_history + istrm - 1) + ENDIF + ENDIF + ELSE IF ( TRIM(strmtyp) .EQ. 'i' ) THEN + IF ( TRIM(op) .EQ. '+' ) THEN + CALL get_mask( p%streams, first_input + istrm - 1, retval ) + IF ( retval .NE. 0 ) THEN + WRITE(mess,*)'W A R N I N G : Variable ',TRIM(lookee),' already on input stream ',istrm, & + '. File: ',TRIM(fname),' at line ',lineno + gavewarning = .TRUE. + ELSE + WRITE(mess,*)'Setting input stream ',istrm,' for ',TRIM(DNAME) ; CALL wrf_debug(1,mess) + CALL set_mask( p%streams, first_input + istrm - 1) + ENDIF + ELSE IF ( TRIM(op) .EQ. '-' ) THEN + CALL get_mask( p%streams, first_input + istrm - 1, retval ) + IF ( retval .EQ. 0 ) THEN + WRITE(mess,*)'W A R N I N G : Variable ',TRIM(lookee),' already off input stream ',istrm, & + '. File: ',TRIM(fname),' at line ',lineno + gavewarning = .TRUE. + ELSE + WRITE(mess,*)'Resetting input stream ',istrm,' for ',TRIM(DNAME) ; CALL wrf_debug(1,mess) + CALL set_mask( p%streams, first_input + istrm - 1) + ENDIF + ENDIF + ELSE + WRITE(mess,*)'W A R N I N G : unknown stream type ',TRIM(strmtyp),'. Line ',lineno + gavewarning = .TRUE. + ENDIF + ENDIF + p => p%next + ENDDO + IF ( .NOT. found ) THEN + WRITE(mess,*)'W A R N I N G : Unable to modify mask for ',TRIM(lookee),& + '. Variable not found. File: ',TRIM(fname),' at line ',lineno + CALL wrf_message(mess) + gavewarning = .TRUE. + ENDIF + fieldno = fieldno + 1 + CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr) + CALL change_to_lower_case(t1,lookee) + ENDDO + ELSE + WRITE(mess,*)'W A R N I N G : Problem reading ',TRIM(fname),' at line ',lineno + CALL wrf_message(mess) + gavewarning = .TRUE. + ENDIF + ENDIF ! keepgoing + ENDIF ! skip comments + ENDDO + ELSE + WRITE(mess,*)'W A R N I N G : Problem opening ',TRIM(fname) + CALL wrf_message(mess) + gavewarning = .TRUE. + ENDIF + CLOSE( read_unit ) + IF ( gavewarning ) THEN + CALL nl_get_ignore_iofields_warning(1,ignorewarning) + IF ( .NOT. ignorewarning ) THEN + WRITE(mess,*)'modify_io_masks: problems reading ',TRIM(fname) + CALL wrf_message(mess) + CALL wrf_error_fatal('Set ignore_iofields_warn to true in namelist to ignore') + ELSE + WRITE(mess,*)'Ignoring problems reading ',TRIM(fname) + CALL wrf_message(mess) + CALL wrf_message('Continuing. To make this a fatal error, set ignore_iofields_warn to false in namelist' ) + ENDIF + ENDIF + ENDIF ! wrf_dm_on_monitor + +#ifdef DM_PARALLEL +! broadcast the new masks to the other tasks + p => grid%head_statevars + DO WHILE ( ASSOCIATED( p%next ) ) + CALL wrf_dm_bcast_integer( p%streams, IO_MASK_SIZE ) + p => p%next + ENDDO +#endif + + END SUBROUTINE ! This routine ALLOCATEs the required space for the meteorological fields ! for a specific domain. The fields are simply ALLOCATEd as an -1. They @@ -924,10 +1161,21 @@ CONTAINS SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - USE module_alloc_space, ONLY : alloc_space_field_core + USE module_alloc_space_0, ONLY : alloc_space_field_core_0 + USE module_alloc_space_1, ONLY : alloc_space_field_core_1 + USE module_alloc_space_2, ONLY : alloc_space_field_core_2 + USE module_alloc_space_3, ONLY : alloc_space_field_core_3 + USE module_alloc_space_4, ONLY : alloc_space_field_core_4 + USE module_alloc_space_5, ONLY : alloc_space_field_core_5 + USE module_alloc_space_6, ONLY : alloc_space_field_core_6 + USE module_alloc_space_7, ONLY : alloc_space_field_core_7 + USE module_alloc_space_8, ONLY : alloc_space_field_core_8 + USE module_alloc_space_9, ONLY : alloc_space_field_core_9 + IMPLICIT NONE ! Input data. @@ -937,6 +1185,7 @@ CONTAINS INTEGER , INTENT(IN) :: setinitval_in ! 3 = everything, 1 = arrays only, 0 = none INTEGER , INTENT(IN) :: sd31, ed31, sd32, ed32, sd33, ed33 INTEGER , INTENT(IN) :: sm31, em31, sm32, em32, sm33, em33 + INTEGER , INTENT(IN) :: sp31, ep31, sp32, ep32, sp33, ep33 INTEGER , INTENT(IN) :: sm31x, em31x, sm32x, em32x, sm33x, em33x INTEGER , INTENT(IN) :: sm31y, em31y, sm32y, em32y, sm33y, em33y @@ -950,12 +1199,69 @@ CONTAINS ! false otherwise (all allocated, modulo tl above) LOGICAL , INTENT(IN) :: inter_domain_in - ! now a separate module in WRFV3 to reduce the size of module_domain that the compiler sees - CALL alloc_space_field_core ( grid, id, setinitval_in , tl_in , inter_domain_in , & + ! now separate modules to reduce the size of module_domain that the compiler sees + CALL alloc_space_field_core_0 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_1 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_2 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_3 ( grid, id, setinitval_in , tl_in , inter_domain_in , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_4 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_5 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_6 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_7 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_8 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + CALL alloc_space_field_core_9 ( grid, id, setinitval_in , tl_in , inter_domain_in , & + sd31, ed31, sd32, ed32, sd33, ed33, & + sm31 , em31 , sm32 , em32 , sm33 , em33 , & + sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & + sm31x, em31x, sm32x, em32x, sm33x, em33x, & + sm31y, em31y, sm32y, em32y, sm33y, em33y ) + + CALL modify_io_masks( grid , id ) END SUBROUTINE alloc_space_field @@ -1022,6 +1328,7 @@ CONTAINS TYPE(domain) , POINTER :: grid CALL dealloc_space_field ( grid ) + CALL dealloc_linked_lists( grid ) DEALLOCATE( grid%parents ) DEALLOCATE( grid%nests ) ! clean up time manager bits @@ -1068,6 +1375,22 @@ CONTAINS END SUBROUTINE domain_destroy + SUBROUTINE dealloc_linked_lists ( grid ) + IMPLICIT NONE + TYPE(domain), POINTER :: grid + TYPE(fieldlist), POINTER :: p, q + p => grid%head_statevars + DO WHILE ( ASSOCIATED( p%next ) ) + q => p ; p => p%next ; DEALLOCATE(q) + ENDDO + NULLIFY(grid%head_statevars) ; NULLIFY( grid%tail_statevars) + IF ( .NOT. grid%is_intermediate ) THEN + ALLOCATE( grid%head_statevars ) + NULLIFY( grid%head_statevars%next) + grid%tail_statevars => grid%head_statevars + ENDIF + END SUBROUTINE dealloc_linked_lists + RECURSIVE SUBROUTINE show_nest_subtree ( grid ) TYPE(domain), POINTER :: grid INTEGER myid @@ -2176,4 +2499,109 @@ SUBROUTINE get_current_grid_name( grid_str ) END SUBROUTINE get_current_grid_name +! moved these outside module domain to avoid circular reference from module_alloc_space which also uses + + SUBROUTINE get_ijk_from_grid_ext ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey ) + USE module_domain + IMPLICIT NONE + TYPE( domain ), INTENT (IN) :: grid + INTEGER, INTENT(OUT) :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey + + CALL get_ijk_from_grid2 ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + data_ordering : SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_XYZ ) + imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ; + ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ; + imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ; + ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ; + CASE ( DATA_ORDER_YXZ ) + imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ; + ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ; + imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ; + ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ; + CASE ( DATA_ORDER_ZXY ) + imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ; + ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ; + imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ; + ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ; + CASE ( DATA_ORDER_ZYX ) + imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ; + ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ; + imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ; + ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ; + CASE ( DATA_ORDER_XZY ) + imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ; + ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ; + imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ; + ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ; + CASE ( DATA_ORDER_YZX ) + imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ; + ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ; + imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ; + ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ; + END SELECT data_ordering + END SUBROUTINE get_ijk_from_grid_ext + +! return the values for subgrid whose refinement is in grid%sr +! note when using this routine, it does not affect K. For K +! (vertical), it just returns what get_ijk_from_grid does + SUBROUTINE get_ijk_from_subgrid_ext ( grid , & + ids0, ide0, jds0, jde0, kds0, kde0, & + ims0, ime0, jms0, jme0, kms0, kme0, & + ips0, ipe0, jps0, jpe0, kps0, kpe0 ) + USE module_domain + IMPLICIT NONE + TYPE( domain ), INTENT (IN) :: grid + INTEGER, INTENT(OUT) :: & + ids0, ide0, jds0, jde0, kds0, kde0, & + ims0, ime0, jms0, jme0, kms0, kme0, & + ips0, ipe0, jps0, jpe0, kps0, kpe0 + ! Local + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + ids0 = ids + ide0 = ide * grid%sr_x + ims0 = (ims-1)*grid%sr_x+1 + ime0 = ime * grid%sr_x + ips0 = (ips-1)*grid%sr_x+1 + ipe0 = ipe * grid%sr_x + + jds0 = jds + jde0 = jde * grid%sr_y + jms0 = (jms-1)*grid%sr_y+1 + jme0 = jme * grid%sr_y + jps0 = (jps-1)*grid%sr_y+1 + jpe0 = jpe * grid%sr_y + + kds0 = kds + kde0 = kde + kms0 = kms + kme0 = kme + kps0 = kps + kpe0 = kpe + RETURN + END SUBROUTINE get_ijk_from_subgrid_ext diff --git a/wrfv2_fire/frame/module_domain_type.F b/wrfv2_fire/frame/module_domain_type.F index c2373642..4620af2b 100644 --- a/wrfv2_fire/frame/module_domain_type.F +++ b/wrfv2_fire/frame/module_domain_type.F @@ -1,7 +1,14 @@ +!WRF:DRIVER_LAYER:DOMAIN_OBJECT MODULE module_domain_type USE module_driver_constants USE module_utility + USE module_streams + + IMPLICIT NONE + +! needed to provide static definition of IO_MASK_SIZE +#include "../inc/streams.h" CHARACTER (LEN=80) program_name @@ -15,25 +22,86 @@ MODULE module_domain_type TYPE(domain), POINTER :: ptr END TYPE domain_ptr - INTEGER, PARAMETER :: HISTORY_ALARM=1, AUXHIST1_ALARM=2, AUXHIST2_ALARM=3, & - AUXHIST3_ALARM=4, AUXHIST4_ALARM=5, AUXHIST5_ALARM=6, & - AUXHIST6_ALARM=7, AUXHIST7_ALARM=8, AUXHIST8_ALARM=9, & - AUXHIST9_ALARM=10, AUXHIST10_ALARM=11, AUXHIST11_ALARM=12, & - AUXINPUT1_ALARM=13, AUXINPUT2_ALARM=14, AUXINPUT3_ALARM=15, & - AUXINPUT4_ALARM=16, AUXINPUT5_ALARM=17, & - AUXINPUT6_ALARM=18, AUXINPUT7_ALARM=19, AUXINPUT8_ALARM=20, & - AUXINPUT9_ALARM=21, AUXINPUT10_ALARM=22, AUXINPUT11_ALARM=23, & - RESTART_ALARM=24, BOUNDARY_ALARM=25, INPUTOUT_ALARM=26, & ! for outputing input (e.g. for 3dvar) - ALARM_SUBTIME=27, & - COMPUTE_VORTEX_CENTER_ALARM=28, & - MAX_WRF_ALARMS=28 ! WARNING: MAX_WRF_ALARMS must be - ! large enough to include all of - ! the alarms declared above. + TYPE fieldlist + CHARACTER*80 :: VarName + CHARACTER*1 :: Type + CHARACTER*80 :: DataName + CHARACTER*80 :: Description + CHARACTER*80 :: Units + CHARACTER*10 :: MemoryOrder + CHARACTER*10 :: Stagger + CHARACTER*80 :: dimname1 + CHARACTER*80 :: dimname2 + CHARACTER*80 :: dimname3 + LOGICAL :: scalar_array + LOGICAL :: boundary_array + LOGICAL :: restart + ! definition of IO_MASK_SIZE comes from build and must be the same as + ! in both definitions of GET_MASK (frame/pack_utils.c and tools/misc.c) + INTEGER, DIMENSION(IO_MASK_SIZE) :: streams + INTEGER :: sd1,ed1,sd2,ed2,sd3,ed3 + INTEGER :: sm1,em1,sm2,em2,sm3,em3 + INTEGER :: sp1,ep1,sp2,ep2,sp3,ep3 + CHARACTER*80 :: MemberOf ! only for 4+D tracer arrays + INTEGER :: Ndim + INTEGER :: Ntl ! 0 single; 1, 2, ... if multi + + INTEGER, POINTER :: num_table(:) + INTEGER, POINTER :: index_table(:,:) + LOGICAL, POINTER :: boundary_table(:,:) + CHARACTER*256, POINTER :: dname_table(:,:) + CHARACTER*256, POINTER :: desc_table(:,:) + CHARACTER*256, POINTER :: units_table(:,:) + + TYPE ( fieldlist ) , POINTER :: next + + REAL, POINTER :: rfield_0d + REAL, POINTER, DIMENSION(:) :: rfield_1d + REAL, POINTER, DIMENSION(:,:) :: rfield_2d + REAL, POINTER, DIMENSION(:,:,:) :: rfield_3d + REAL, POINTER, DIMENSION(:,:,:,:) :: rfield_4d + REAL, POINTER, DIMENSION(:,:,:,:,:) :: rfield_5d + REAL, POINTER, DIMENSION(:,:,:,:,:,:) :: rfield_6d + REAL, POINTER, DIMENSION(:,:,:,:,:,:,:) :: rfield_7d + + DOUBLE PRECISION, POINTER :: dfield_0d + DOUBLE PRECISION, POINTER, DIMENSION(:) :: dfield_1d + DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: dfield_2d + DOUBLE PRECISION, POINTER, DIMENSION(:,:,:) :: dfield_3d + DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:) :: dfield_4d + DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:,:) :: dfield_5d + DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:,:,:) :: dfield_6d + DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:,:,:,:) :: dfield_7d + + INTEGER, POINTER :: ifield_0d + INTEGER, POINTER, DIMENSION(:) :: ifield_1d + INTEGER, POINTER, DIMENSION(:,:) :: ifield_2d + INTEGER, POINTER, DIMENSION(:,:,:) :: ifield_3d + INTEGER, POINTER, DIMENSION(:,:,:,:) :: ifield_4d + INTEGER, POINTER, DIMENSION(:,:,:,:,:) :: ifield_5d + INTEGER, POINTER, DIMENSION(:,:,:,:,:,:) :: ifield_6d + INTEGER, POINTER, DIMENSION(:,:,:,:,:,:,:) :: ifield_7d + + LOGICAL, POINTER :: lfield_0d + LOGICAL, POINTER, DIMENSION(:) :: lfield_1d + LOGICAL, POINTER, DIMENSION(:,:) :: lfield_2d +! save some space; you can still have these but will not be part of list +! so cannot do i/o, etc on 3d or greater logical arrays +! LOGICAL, POINTER, DIMENSION(:,:,:) :: lfield_3d +! LOGICAL, POINTER, DIMENSION(:,:,:,:) :: lfield_4d +! LOGICAL, POINTER, DIMENSION(:,:,:,:,:) :: lfield_5d +! LOGICAL, POINTER, DIMENSION(:,:,:,:,:,:) :: lfield_6d +! LOGICAL, POINTER, DIMENSION(:,:,:,:,:,:,:) :: lfield_7d + + END TYPE fieldlist #include TYPE domain + TYPE ( fieldlist ), POINTER :: head_statevars + TYPE ( fieldlist ), POINTER :: tail_statevars + ! SEE THE INCLUDE FILE FOR DEFINITIONS OF STATE FIELDS WITHIN THE DOMAIN DATA STRUCTURE #include @@ -63,8 +131,8 @@ MODULE module_domain_type INTEGER , DIMENSION( max_parents ) :: child_of_parent INTEGER , DIMENSION( max_nests ) :: active - INTEGER , DIMENSION(0:5) :: nframes ! frames per outfile for history - ! streams (0 is main history) + INTEGER , DIMENSION(MAX_HISTORY) :: nframes ! frames per outfile for history + ! 1 is main history TYPE(domain) , POINTER :: next TYPE(domain) , POINTER :: same_level @@ -117,6 +185,9 @@ MODULE module_domain_type REAL :: max_vert_cfl REAL :: max_horiz_cfl Type(WRFU_TimeInterval) :: last_dtInterval + LOGICAL :: stepping_to_time + LOGICAL :: adapt_this_step_using_child + INTEGER :: last_step_updated ! Time series location information INTEGER :: ntsloc, ntsloc_domain diff --git a/wrfv2_fire/frame/module_integrate.F b/wrfv2_fire/frame/module_integrate.F index 874b4d95..7dd74898 100644 --- a/wrfv2_fire/frame/module_integrate.F +++ b/wrfv2_fire/frame/module_integrate.F @@ -348,7 +348,15 @@ RECURSIVE SUBROUTINE integrate ( grid ) ! Report on the timing for a single time step. IF ( wrf_dm_on_monitor() ) THEN CALL domain_clock_get ( grid, current_timestr=message2 ) - WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id +#if (EM_CORE == 1) + if (config_flags%use_adaptive_time_step) then + WRITE ( message , FMT = '("main (dt=",F6.2,"): time ",A," on domain ",I3)' ) grid%dt, TRIM(message2), grid%id + else + WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id + endif +#else + WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id +#endif CALL end_timing ( TRIM(message) ) END IF CALL med_endup_step ( grid , config_flags ) diff --git a/wrfv2_fire/frame/module_io.F b/wrfv2_fire/frame/module_io.F index b8d74827..83e7e1cf 100644 --- a/wrfv2_fire/frame/module_io.F +++ b/wrfv2_fire/frame/module_io.F @@ -49,6 +49,17 @@ MODULE module_io ! #include "md_calls.inc" +!--- registry-generated routine that gets the io format being used for a dataset + + INTEGER FUNCTION io_form_for_dataset ( DataSet ) + IMPLICIT NONE + CHARACTER*(*), INTENT(IN) :: DataSet + INTEGER :: io_form +#include "io_form_for_dataset.inc" + io_form_for_dataset = io_form + RETURN + END FUNCTION io_form_for_dataset + !--- ioinit SUBROUTINE wrf_ioinit( Status ) @@ -204,67 +215,12 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf CHARACTER*128 :: mess CHARACTER*1028 :: tstr - CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_begin' ) + WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName) + CALL wrf_debug( DEBUG_LVL, mess ) CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) - IF ( DataSet .eq. 'RESTART' ) THEN - CALL nl_get_io_form_restart( 1, io_form ) - ELSE IF ( DataSet .eq. 'INPUT' ) THEN - CALL nl_get_io_form_input( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT1' ) THEN - CALL nl_get_io_form_auxinput1( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT2' ) THEN - CALL nl_get_io_form_auxinput2( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT3' ) THEN - CALL nl_get_io_form_auxinput3( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT4' ) THEN - CALL nl_get_io_form_auxinput4( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT5' ) THEN - CALL nl_get_io_form_auxinput5( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT6' ) THEN - CALL nl_get_io_form_auxinput6( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT7' ) THEN - CALL nl_get_io_form_auxinput7( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT8' ) THEN - CALL nl_get_io_form_auxinput8( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT9' ) THEN - CALL nl_get_io_form_sgfdda( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT10' ) THEN - CALL nl_get_io_form_gfdda( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT11' ) THEN - CALL nl_get_io_form_auxinput11( 1, io_form ) - - ELSE IF ( DataSet .eq. 'HISTORY' ) THEN - CALL nl_get_io_form_history( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST1' ) THEN - CALL nl_get_io_form_auxhist1( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST2' ) THEN - CALL nl_get_io_form_auxhist2( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST3' ) THEN - CALL nl_get_io_form_auxhist3( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST4' ) THEN - CALL nl_get_io_form_auxhist4( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST5' ) THEN - CALL nl_get_io_form_auxhist5( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST6' ) THEN - CALL nl_get_io_form_auxhist6( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST7' ) THEN - CALL nl_get_io_form_auxhist7( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST8' ) THEN - CALL nl_get_io_form_auxhist8( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST9' ) THEN - CALL nl_get_io_form_auxhist9( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST10' ) THEN - CALL nl_get_io_form_auxhist10( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST11' ) THEN - CALL nl_get_io_form_auxhist11( 1, io_form ) - - ELSE IF ( DataSet .eq. 'BOUNDARY' ) THEN - CALL nl_get_io_form_boundary( 1, io_form ) - ELSE ! default if nothing is set in SysDepInfo; use history - CALL nl_get_io_form_history( 1, io_form ) - ENDIF + io_form = io_form_for_dataset( DataSet ) Status = 0 Hndl = -1 @@ -546,63 +502,8 @@ SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_begin' ) CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) - IF ( DataSet .eq. 'RESTART' ) THEN - CALL nl_get_io_form_restart( 1, io_form ) - ELSE IF ( DataSet .eq. 'INPUT' ) THEN - CALL nl_get_io_form_input( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT1' ) THEN - CALL nl_get_io_form_auxinput1( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT2' ) THEN - CALL nl_get_io_form_auxinput2( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT3' ) THEN - CALL nl_get_io_form_auxinput3( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT4' ) THEN - CALL nl_get_io_form_auxinput4( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT5' ) THEN - CALL nl_get_io_form_auxinput5( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT6' ) THEN - CALL nl_get_io_form_auxinput6( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT7' ) THEN - CALL nl_get_io_form_auxinput7( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT8' ) THEN - CALL nl_get_io_form_auxinput8( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT9' ) THEN - CALL nl_get_io_form_sgfdda( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT10' ) THEN - CALL nl_get_io_form_gfdda( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT11' ) THEN - CALL nl_get_io_form_auxinput11( 1, io_form ) - - ELSE IF ( DataSet .eq. 'HISTORY' ) THEN - CALL nl_get_io_form_history( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST1' ) THEN - CALL nl_get_io_form_auxhist1( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST2' ) THEN - CALL nl_get_io_form_auxhist2( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST3' ) THEN - CALL nl_get_io_form_auxhist3( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST4' ) THEN - CALL nl_get_io_form_auxhist4( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST5' ) THEN - CALL nl_get_io_form_auxhist5( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST6' ) THEN - CALL nl_get_io_form_auxhist6( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST7' ) THEN - CALL nl_get_io_form_auxhist7( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST8' ) THEN - CALL nl_get_io_form_auxhist8( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST9' ) THEN - CALL nl_get_io_form_auxhist9( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST10' ) THEN - CALL nl_get_io_form_auxhist10( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST11' ) THEN - CALL nl_get_io_form_auxhist11( 1, io_form ) - - ELSE IF ( DataSet .eq. 'BOUNDARY' ) THEN - CALL nl_get_io_form_boundary( 1, io_form ) - ELSE ! default if nothing is set in SysDepInfo; use history - CALL nl_get_io_form_history( 1, io_form ) - ENDIF + + io_form = io_form_for_dataset( DataSet ) Status = 0 Hndl = -1 @@ -821,64 +722,8 @@ SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read' ) CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) - IF ( DataSet .eq. 'RESTART' ) THEN - CALL nl_get_io_form_restart( 1, io_form ) - ELSE IF ( DataSet .eq. 'INPUT' ) THEN - CALL nl_get_io_form_input( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT1' ) THEN - CALL nl_get_io_form_auxinput1( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT2' ) THEN - CALL nl_get_io_form_auxinput2( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT3' ) THEN - CALL nl_get_io_form_auxinput3( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT4' ) THEN - CALL nl_get_io_form_auxinput4( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT5' ) THEN - CALL nl_get_io_form_auxinput5( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT6' ) THEN - CALL nl_get_io_form_auxinput6( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT7' ) THEN - CALL nl_get_io_form_auxinput7( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT8' ) THEN - CALL nl_get_io_form_auxinput8( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT9' ) THEN - CALL nl_get_io_form_sgfdda( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT10' ) THEN - CALL nl_get_io_form_gfdda( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXINPUT11' ) THEN - CALL nl_get_io_form_auxinput11( 1, io_form ) - - CALL nl_get_io_form_auxinput5( 1, io_form ) - ELSE IF ( DataSet .eq. 'HISTORY' ) THEN - CALL nl_get_io_form_history( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST1' ) THEN - CALL nl_get_io_form_auxhist1( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST2' ) THEN - CALL nl_get_io_form_auxhist2( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST3' ) THEN - CALL nl_get_io_form_auxhist3( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST4' ) THEN - CALL nl_get_io_form_auxhist4( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST5' ) THEN - CALL nl_get_io_form_auxhist5( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST6' ) THEN - CALL nl_get_io_form_auxhist6( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST7' ) THEN - CALL nl_get_io_form_auxhist7( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST8' ) THEN - CALL nl_get_io_form_auxhist8( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST9' ) THEN - CALL nl_get_io_form_auxhist9( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST10' ) THEN - CALL nl_get_io_form_auxhist10( 1, io_form ) - ELSE IF ( DataSet .eq. 'AUXHIST11' ) THEN - CALL nl_get_io_form_auxhist11( 1, io_form ) - - ELSE IF ( DataSet .eq. 'BOUNDARY' ) THEN - CALL nl_get_io_form_boundary( 1, io_form ) - ELSE ! default if nothing is set in SysDepInfo; use history - CALL nl_get_io_form_history( 1, io_form ) - ENDIF + + io_form = io_form_for_dataset( DataSet ) Hndl = -1 Status = 0 @@ -1999,6 +1844,16 @@ SUBROUTINE bdys_are_distributed bdy_dist_flag = .TRUE. END SUBROUTINE bdys_are_distributed +LOGICAL FUNCTION on_stream ( mask , switch ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: mask(*), switch + INTEGER :: result +! get_mask is a C routine defined in frame/pack_utils.c +! switch is decremented from its fortran value so it is zero based + CALL get_mask( mask, switch-1, result ) + on_stream = ( result .NE. 0 ) +END FUNCTION on_stream + END MODULE module_io @@ -4173,10 +4028,12 @@ SUBROUTINE lower_case(MemoryOrder,MemOrd) !Local CHARACTER*1 :: c INTEGER ,PARAMETER :: upper_to_lower =IACHAR('a')-IACHAR('A') - INTEGER :: i,n + INTEGER :: i,n,n1 ! MemOrd = ' ' N = len(MemoryOrder) + N1 = len(MemOrd) + N = MIN(N,N1) MemOrd(1:N) = MemoryOrder(1:N) DO i=1,N c = MemoryOrder(i:i) diff --git a/wrfv2_fire/frame/nl_get_0_routines.F b/wrfv2_fire/frame/nl_get_0_routines.F index 66f9d8f7..b24d607e 100644 --- a/wrfv2_fire/frame/nl_get_0_routines.F +++ b/wrfv2_fire/frame/nl_get_0_routines.F @@ -1,13 +1 @@ -! nl_routines.F - -! these are entirely generated by the registry. One dummy routine is -! defined here to prevent compiler complaining of the include file is -! empty - -SUBROUTINE not_a_real_sub_a -END SUBROUTINE not_a_real_sub_a - -# include - -! end of nl_routines.F - +dummy; make needs this to be happy diff --git a/wrfv2_fire/frame/nl_get_1_routines.F b/wrfv2_fire/frame/nl_get_1_routines.F index e33f1383..b24d607e 100644 --- a/wrfv2_fire/frame/nl_get_1_routines.F +++ b/wrfv2_fire/frame/nl_get_1_routines.F @@ -1,13 +1 @@ -! nl_routines.F - -! these are entirely generated by the registry. One dummy routine is -! defined here to prevent compiler complaining of the include file is -! empty - -SUBROUTINE not_a_real_sub_b -END SUBROUTINE not_a_real_sub_b - -# include - -! end of nl_routines.F - +dummy; make needs this to be happy diff --git a/wrfv2_fire/frame/nl_set_0_routines.F b/wrfv2_fire/frame/nl_set_0_routines.F index 2e21336c..b24d607e 100644 --- a/wrfv2_fire/frame/nl_set_0_routines.F +++ b/wrfv2_fire/frame/nl_set_0_routines.F @@ -1,13 +1 @@ -! nl_routines.F - -! these are entirely generated by the registry. One dummy routine is -! defined here to prevent compiler complaining of the include file is -! empty - -SUBROUTINE not_a_real_sub_c -END SUBROUTINE not_a_real_sub_c - -# include - -! end of nl_routines.F - +dummy; make needs this to be happy diff --git a/wrfv2_fire/frame/nl_set_1_routines.F b/wrfv2_fire/frame/nl_set_1_routines.F index f799dc32..b24d607e 100644 --- a/wrfv2_fire/frame/nl_set_1_routines.F +++ b/wrfv2_fire/frame/nl_set_1_routines.F @@ -1,13 +1 @@ -! nl_routines.F - -! these are entirely generated by the registry. One dummy routine is -! defined here to prevent compiler complaining of the include file is -! empty - -SUBROUTINE not_a_real_sub_d -END SUBROUTINE not_a_real_sub_d - -# include - -! end of nl_routines.F - +dummy; make needs this to be happy diff --git a/wrfv2_fire/frame/pack_utils.c b/wrfv2_fire/frame/pack_utils.c index 6019f860..99695700 100644 --- a/wrfv2_fire/frame/pack_utils.c +++ b/wrfv2_fire/frame/pack_utils.c @@ -3,6 +3,7 @@ # include #endif #include +#include "../inc/streams.h" #ifndef CRAY # ifdef NOUNDERSCORE @@ -16,6 +17,9 @@ # define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field # define PERTURB_REAL perturb_real # define INSPECT_HEADER inspect_header +# define RESET_MASK reset_mask +# define SET_MASK set_mask +# define GET_MASK get_mask # else # ifdef F2CSTYLE # define INT_PACK_DATA int_pack_data__ @@ -28,6 +32,9 @@ # define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field__ # define PERTURB_REAL perturb_real__ # define INSPECT_HEADER inspect_header__ +# define RESET_MASK reset_mask__ +# define SET_MASK set_mask__ +# define GET_MASK get_mask__ # else # define INT_PACK_DATA int_pack_data_ # define INT_GET_TI_HEADER_C int_get_ti_header_c_ @@ -39,6 +46,9 @@ # define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field_ # define PERTURB_REAL perturb_real_ # define INSPECT_HEADER inspect_header_ +# define RESET_MASK reset_mask_ +# define SET_MASK set_mask_ +# define GET_MASK get_mask_ # endif # endif #endif @@ -280,3 +290,53 @@ int INSPECT_HEADER ( char * buf, int * sz, int * line ) return(0) ; } +/* note that these work the same as the routines in tools/misc.c, but are Fortran callable. + They must be kept in sync, functionally. */ + +void +RESET_MASK ( unsigned int * mask , int *e ) +{ + int w ; + unsigned int m, n ; + + w = *e / (8*sizeof(int)-1) ; + n = 1 ; + m = ~( n << *e % (8*sizeof(int)-1) ) ; + if ( w >= 0 && w < IO_MASK_SIZE ) { + mask[w] &= m ; + } +} + +void +SET_MASK ( unsigned int * mask , int *e ) +{ + int w ; + unsigned int m, n ; + + w = *e / (8*sizeof(int)-1) ; + n = 1 ; + m = ( n << *e % (8*sizeof(int)-1) ) ; + if ( w >= 0 && w < IO_MASK_SIZE ) { + mask[w] |= m ; + } +} + +/* this is slightly different from in tools dir since it returns result as argument, not function */ +/* definition of IO_MASK_SIZE comes from build and must be uniform with frame/module_domain_type.F and + version of this function in tools dir */ +void +GET_MASK ( unsigned int * mask , int *e , int * retval ) +{ + int w ; + unsigned int m, n ; + + w = *e / (8*sizeof(int)-1) ; /* 8 is number of bits per byte */ + if ( w >= 0 && w < IO_MASK_SIZE ) { + m = mask[w] ; + n = ( 1 << *e % (8*sizeof(int)-1) ) ;; + *retval = ( (m & n) != 0 ) ; + } else { + *retval = 0 ; + } +} + diff --git a/wrfv2_fire/main/Makefile b/wrfv2_fire/main/Makefile index 80ac1a4e..0f16c5bd 100644 --- a/wrfv2_fire/main/Makefile +++ b/wrfv2_fire/main/Makefile @@ -115,6 +115,7 @@ ndown_em.o: \ nup_em.o: \ ../frame/module_machine.o \ ../frame/module_domain.o \ + ../frame/module_streams.o \ ../frame/module_driver_constants.o \ ../frame/module_configure.o \ ../frame/module_timing.o \ diff --git a/wrfv2_fire/main/ideal.F b/wrfv2_fire/main/ideal.F index 2e054bb5..321caf67 100644 --- a/wrfv2_fire/main/ideal.F +++ b/wrfv2_fire/main/ideal.F @@ -179,12 +179,12 @@ SUBROUTINE med_initialdata_output ( grid , config_flags ) CALL calc_current_date ( grid%id, 0.) CALL construct_filename1 ( inpname , 'wrfinput' , grid%id , 2 ) - CALL open_w_dataset ( id, TRIM(inpname) , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + CALL open_w_dataset ( id, TRIM(inpname) , grid , config_flags , output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN WRITE (wrf_err_message,*)'ideal: error opening wrfinput for writing ',ierr CALL wrf_error_fatal( wrf_err_message ) ENDIF - CALL output_model_input ( id, grid , config_flags , ierr ) + CALL output_input ( id, grid , config_flags , ierr ) CALL close_dataset ( id , config_flags, "DATASET=INPUT" ) diff --git a/wrfv2_fire/main/module_wrf_top.F b/wrfv2_fire/main/module_wrf_top.F index 306d35b3..e2b267cf 100644 --- a/wrfv2_fire/main/module_wrf_top.F +++ b/wrfv2_fire/main/module_wrf_top.F @@ -19,7 +19,7 @@ MODULE module_wrf_top USE module_wrf_error #ifdef DM_PARALLEL - USE module_dm + USE module_dm, ONLY : wrf_dm_initialize #endif IMPLICIT NONE diff --git a/wrfv2_fire/main/ndown_em.F b/wrfv2_fire/main/ndown_em.F index ae7566b0..145cf913 100644 --- a/wrfv2_fire/main/ndown_em.F +++ b/wrfv2_fire/main/ndown_em.F @@ -4,7 +4,9 @@ PROGRAM ndown_em USE module_machine - USE module_domain, ONLY : domain + USE module_domain, ONLY : domain, head_grid, alloc_and_configure_domain, & + domain_clock_set, domain_clock_get, get_ijk_from_grid + USE module_domain_type, ONLY : program_name USE module_initialize_real, ONLY : wrfu_initialize, rebalance_driver USE module_integrate USE module_driver_constants @@ -47,12 +49,17 @@ PROGRAM ndown_em TYPE(domain), POINTER :: parent , nest END SUBROUTINE init_domain_constants_em_ptr - END INTERFACE - + SUBROUTINE vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c) + USE module_domain + USE module_configure + TYPE(domain), POINTER :: nested_grid + INTEGER , INTENT (IN) :: k_dim_c + REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c + REAL , DIMENSION(k_dim_c) , INTENT (IN) :: znw_c,znu_c + END SUBROUTINE vertical_interp -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!new for bc + END INTERFACE INTEGER :: ids , ide , jds , jde , kds , kde INTEGER :: ims , ime , jms , jme , kms , kme INTEGER :: ips , ipe , jps , jpe , kps , kpe @@ -116,11 +123,17 @@ character *19 :: temp19 character *24 :: temp24 , temp24b character(len=24) :: start_date_hold - CHARACTER (LEN=80) :: message + CHARACTER (LEN=256) :: message integer :: ii #include "version_decl" +!!!!!!!!!!!!!!!!!!!!! mousta + integer :: n_ref_m,k_dim_c,k_dim_n +real :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c + REAL , DIMENSION(:) , ALLOCATABLE :: znw_c,znu_c +!!!!!!!!!!!!!!!!!!!!!!!!!!11 + ! Interface block for routine that passes pointers and needs to know that they ! are receiving pointers. @@ -137,6 +150,12 @@ integer :: ii TYPE(domain), POINTER :: parent_grid END SUBROUTINE Setup_Timekeeping + SUBROUTINE vert_cor(parent_grid,znw_c,k_dim_c) + USE module_domain + TYPE(domain), POINTER :: parent_grid + integer , intent(in) :: k_dim_c + real , dimension(k_dim_c), INTENT(IN) :: znw_c + END SUBROUTINE vert_cor END INTERFACE ! Define the name of this program (program_name defined in module_domain) @@ -173,6 +192,19 @@ integer :: ii CALL initial_config #endif +!!!!!!!!!!!!!!! mousta + n_ref_m = model_config_rec % vert_refine_fact + k_dim_c = model_config_rec % e_vert(1) + k_dim_n = k_dim_c + if (n_ref_m .ge. 2) k_dim_n = (k_dim_c - 1) * n_ref_m + 1 + model_config_rec % e_vert(1) = k_dim_n + model_config_rec % e_vert(2) = k_dim_n + ALLOCATE(znw_c(k_dim_c)) + ALLOCATE(znu_c(k_dim_c)) + WRITE ( message , FMT = '(A,3I5)' ) 'KDIM_C', k_dim_c , model_config_rec % e_vert(1) , model_config_rec % e_vert(2) + CALL wrf_debug ( 99,message ) +!!!!!!!!!!!!!!! mousta + ! And here is an instance of using the information in the NAMELIST. CALL nl_get_debug_level ( 1, debug_level ) @@ -290,11 +322,13 @@ integer :: ii ! Which date are we currently soliciting? CALL geth_newdate ( date_string , start_date_char , ( time_loop - 1 ) * NINT ( new_bdy_frq) ) -print *,'-------->>> Processing data: loop=',time_loop,' date/time = ',date_string + WRITE ( message , FMT = '(A,I5," ",A,A)' ) '-------->>> Processing data: loop=',time_loop,' date/time = ',date_string + CALL wrf_debug ( 99,message ) current_date_char = date_string current_date = date_string // '.0000' start_date = date_string // '.0000' -print *,'loopmax = ', time_loop_max, ' ending date = ',end_date_char + WRITE ( message , FMT = '(A,I5," ",A,A)' ) 'loopmax = ', time_loop_max, ' ending date = ',end_date_char + CALL wrf_debug ( 99,message ) CALL domain_clock_set( parent_grid, & current_timestr=current_date(1:19) ) @@ -305,7 +339,9 @@ print *,'loopmax = ', time_loop_max, ' ending date = ',end_date_char get_the_right_time : DO CALL wrf_get_next_time ( fid , date_string , status_next_var ) -print *,'file date/time = ',date_string,' desired date = ',current_date_char,' status = ', status_next_var + WRITE ( message , FMT = '(A,A,A,A,A,I5)' ) 'file date/time = ',date_string,' desired date = ',& + current_date_char,' status = ', status_next_var + CALL wrf_debug ( 99,message ) IF ( status_next_var .NE. 0 ) THEN CALL wrf_debug ( 100 , 'ndown_em main: calling close_dataset for ' // TRIM(eligible_file_name(file_counter)) ) @@ -335,7 +371,28 @@ print *,'file date/time = ',date_string,' desired date = ',current_date_char CALL wrf_debug ( 100 , 'wrf: calling input_history' ) CALL wrf_get_previous_time ( fid , date_string , status_next_var ) - CALL input_history ( fid , head_grid , config_flags, ierr ) + WRITE ( message , * ) 'CFB' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1) + CALL wrf_debug ( 99,message ) + CALL input_history ( fid , head_grid , config_flags, ierr) +!!!!!!!!!!!!!1 mousta + cf1_c = head_grid%cf1 + cf2_c = head_grid%cf2 + cf3_c = head_grid%cf3 + + cfn_c = head_grid%cfn + cfn1_c = head_grid%cfn1 + + do k = 1,k_dim_c + znw_c(k) = head_grid%znw(k) + znu_c(k) = head_grid%znu(k) + enddo + call vert_cor(head_grid,znw_c,k_dim_c) + WRITE ( message , * ) 'CFA' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1) + CALL wrf_debug ( 99,message ) + WRITE ( message , * ) 'CFV' ,head_grid%cf1,head_grid%cf2,head_grid%cf3,head_grid%cfn,head_grid%cfn1,& + head_grid%znw(1),head_grid%znu(1) , head_grid%e_vert , parent_grid%cf1 , parent_grid%znw(1) , parent_grid%znu(1) + CALL wrf_debug ( 99,message ) +!!!!!!!!!!!!!1 mousta CALL wrf_debug ( 100 , 'wrf: back from input_history' ) ! Get the coarse grid info for later transfer to the fine grid domain. @@ -401,7 +458,7 @@ nested_grid%chem_in_opt = parent_grid%chem_in_opt CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfinput' ) CALL construct_filename1( outname , 'wrfinput' , nested_grid%id , 2 ) - CALL open_w_dataset ( fido, TRIM(outname) , nested_grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + CALL open_w_dataset ( fido, TRIM(outname) , nested_grid , config_flags , output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(outname),' for reading ierr=',ierr CALL WRF_ERROR_FATAL ( wrf_err_message ) @@ -472,6 +529,11 @@ nested_grid%chem_in_opt = parent_grid%chem_in_opt nested_grid%imask_xystag = 1 CALL med_interp_domain ( head_grid , nested_grid ) + WRITE ( message , * ) 'MOUSTA_L', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps) + CALL wrf_debug ( 99,message ) + CALL vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c) + WRITE ( message , * ) 'MOUSTA_V', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps) + CALL wrf_debug ( 99,message ) nested_grid%ht_int = nested_grid%ht !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -503,8 +565,8 @@ nested_grid%chem_in_opt = parent_grid%chem_in_opt ! Input data. - CALL wrf_debug ( 100 , 'ndown_em: calling input_aux_model_input2' ) - CALL input_aux_model_input2 ( idsi , nested_grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'ndown_em: calling input_auxinput2' ) + CALL input_auxinput2 ( idsi , nested_grid , config_flags , ierr ) nested_grid%ht_input = nested_grid%ht ! Close this fine grid static input file. @@ -612,7 +674,7 @@ nested_grid%chem_in_opt = parent_grid%chem_in_opt current_timestr=current_date(1:19) ) #ifdef WRF_CHEM ! -! SEP Put in chemistry data +! Put in chemistry data ! IF( nested_grid%chem_opt .NE. 0 ) then ! IF( nested_grid%chem_in_opt .EQ. 0 ) then @@ -623,11 +685,24 @@ nested_grid%chem_in_opt = parent_grid%chem_in_opt ! CALL input_chem_profile ( nested_grid ) + if(nested_grid%biomass_burn_opt == BIOMASSB) THEN + message = 'READING BIOMASS BURNING EMISSIONS DATA ' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_emissopt3 ( nested_grid , config_flags) + end if + + if(nested_grid%dust_opt == 1 .or. nested_grid%dmsemis_opt == 1 & + .or. nested_grid%chem_opt == 300 .or. nested_grid%chem_opt == 301) then + message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS' + CALL wrf_message ( message ) + CALL med_read_wrf_chem_gocart_bg ( nested_grid , config_flags) + end if + if( nested_grid%bio_emiss_opt .eq. 2 )then message = 'READING BEIS3.11 EMISSIONS DATA' CALL wrf_message ( message ) CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags) - else IF( nested_grid%bio_emiss_opt == 3 ) THEN !shc + else if( nested_grid%bio_emiss_opt == 3 ) THEN message = 'READING MEGAN 2 EMISSIONS DATA' CALL wrf_message ( message ) CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags) @@ -641,7 +716,7 @@ nested_grid%chem_in_opt = parent_grid%chem_in_opt ! Output the first time period of the data. - CALL output_model_input ( fido , nested_grid , config_flags , ierr ) + CALL output_input ( fido , nested_grid , config_flags , ierr ) CALL wrf_put_dom_ti_integer ( fido , 'MAP_PROJ' , map_proj , 1 , ierr ) ! CALL wrf_put_dom_ti_real ( fido , 'DX' , dx , 1 , ierr ) @@ -1156,7 +1231,8 @@ print *,'bdy time = ',time_loop-1,' bdy date = ',current_date,' ',start_date ! Process which time now? END DO big_time_loop_thingy - + DEALLOCATE(znw_c) + DEALLOCATE(znu_c) CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) CALL med_shutdown_io ( parent_grid , config_flags ) @@ -1402,6 +1478,60 @@ print *,'points artificially set to water: ',oops2 endif END SUBROUTINE check_consistency2 +!!!!!!!!!!!!!!!!!!!!!!!!!!!11 + SUBROUTINE vert_cor(parent,znw_c,k_dim_c) + USE module_domain + IMPLICIT NONE + TYPE(domain), POINTER :: parent + integer , intent(in) :: k_dim_c + real , dimension(k_dim_c), INTENT(IN) :: znw_c + + integer :: kde_c , kde_n ,n_refine,ii,kkk,k + real :: dznw_m,cof1,cof2 + + kde_c = k_dim_c + kde_n = parent%e_vert + n_refine = parent % vert_refine_fact + + + kkk = 0 + do k = 1 , kde_c-1 + dznw_m = znw_c(k+1) - znw_c(k) + do ii = 1,n_refine + kkk = kkk + 1 + parent%znw(kkk) = znw_c(k) + float(ii-1)/float(n_refine)*dznw_m + enddo + enddo + parent%znw(kde_n) = znw_c(kde_c) + parent%znw(1) = znw_c(1) + + DO k=1, kde_n-1 + parent%dnw(k) = parent%znw(k+1) - parent%znw(k) + parent%rdnw(k) = 1./parent%dnw(k) + parent%znu(k) = 0.5*(parent%znw(k+1)+parent%znw(k)) + END DO + + DO k=2, kde_n-1 + parent%dn(k) = 0.5*(parent%dnw(k)+parent%dnw(k-1)) + parent%rdn(k) = 1./parent%dn(k) + parent%fnp(k) = .5* parent%dnw(k )/parent%dn(k) + parent%fnm(k) = .5* parent%dnw(k-1)/parent%dn(k) + END DO + + cof1 = (2.*parent%dn(2)+parent%dn(3))/(parent%dn(2)+parent%dn(3))*parent%dnw(1)/parent%dn(2) + cof2 = parent%dn(2) /(parent%dn(2)+parent%dn(3))*parent%dnw(1)/parent%dn(3) + + parent%cf1 = parent%fnp(2) + cof1 + parent%cf2 = parent%fnm(2) - cof1 - cof2 + parent%cf3 = cof2 + + parent%cfn = (.5*parent%dnw(kde_n-1)+parent%dn(kde_n-1))/parent%dn(kde_n-1) + parent%cfn1 = -.5*parent%dnw(kde_n-1)/parent%dn(kde_n-1) + + + + END SUBROUTINE vert_cor + SUBROUTINE init_domain_constants_em_ptr ( parent , nest ) USE module_domain @@ -1417,3 +1547,498 @@ SUBROUTINE init_domain_constants_em_ptr ( parent , nest ) END INTERFACE CALL init_domain_constants_em ( parent , nest ) END SUBROUTINE init_domain_constants_em_ptr + + + SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c) + USE module_domain + USE module_configure + IMPLICIT NONE + TYPE(domain), POINTER :: parent_grid + INTEGER , INTENT (IN) :: k_dim_c + REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c + REAL , DIMENSION(k_dim_c) , INTENT (IN) :: znw_c,znu_c + + integer :: kde_c , kde_n ,n_refine,ii,kkk + integer :: i , j, k , itrace + real :: p_top_m , p_surf_m , mu_m , hsca_m , pre_c ,pre_n + + real, allocatable, dimension(:) :: alt_w_c , alt_u_c ,pro_w_c , pro_u_c + real, allocatable, dimension(:) :: alt_w_n , alt_u_n ,pro_w_n , pro_u_n + + INTEGER :: nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe + + + hsca_m = 6.7 + n_refine = model_config_rec % vert_refine_fact + kde_c = k_dim_c + kde_n = parent_grid%e_vert + + CALL get_ijk_from_grid ( parent_grid , & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe ) + + print * , 'MOUSTA_VER ',parent_grid%e_vert , kde_c , kde_n + print *, nids , nide , njds , njde , nkds , nkde + print *, nims , nime , njms , njme , nkms , nkme + print *, nips , nipe , njps , njpe , nkps , nkpe + + + + allocate (alt_w_c(kde_c)) + allocate (alt_u_c(kde_c+1)) + allocate (pro_w_c(kde_c)) + allocate (pro_u_c(kde_c+1)) + + allocate (alt_w_n(kde_n)) + allocate (alt_u_n(kde_n+1)) + allocate (pro_w_n(kde_n)) + allocate (pro_u_n(kde_n+1)) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11111 + p_top_m = parent_grid%p_top + p_surf_m = 1.e5 + mu_m = p_surf_m - p_top_m + print * , 'p_top_m', p_top_m +! parent + do k = 1,kde_c + pre_c = mu_m * znw_c(k) + p_top_m + alt_w_c(k) = -hsca_m * alog(pre_c/p_surf_m) + enddo + do k = 1,kde_c-1 + pre_c = mu_m * znu_c(k) + p_top_m + alt_u_c(k+1) = -hsca_m * alog(pre_c/p_surf_m) + enddo + alt_u_c(1) = alt_w_c(1) + alt_u_c(kde_c+1) = alt_w_c(kde_c) +! nest + do k = 1,kde_n + pre_n = mu_m * parent_grid%znw(k) + p_top_m + alt_w_n(k) = -hsca_m * alog(pre_n/p_surf_m) + enddo + do k = 1,kde_n-1 + pre_n = mu_m * parent_grid%znu(k) + p_top_m + alt_u_n(k+1) = -hsca_m * alog(pre_n/p_surf_m) + enddo + alt_u_n(1) = alt_w_n(1) + alt_u_n(kde_n+1) = alt_w_n(kde_n) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +IF ( SIZE( parent_grid%u_2, 1 ) * SIZE( parent_grid%u_2, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%u_2(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%u_2(i,1,j) & + + cf2_c*parent_grid%u_2(i,2,j) & + + cf3_c*parent_grid%u_2(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%u_2(i,kde_c-1,j) & + + cfn1_c*parent_grid%u_2(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%u_2(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + +IF ( SIZE( parent_grid%v_2, 1 ) * SIZE( parent_grid%v_2, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%v_2(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%v_2(i,1,j) & + + cf2_c*parent_grid%v_2(i,2,j) & + + cf3_c*parent_grid%v_2(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%v_2(i,kde_c-1,j) & + + cfn1_c*parent_grid%v_2(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%v_2(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + +IF ( SIZE( parent_grid%w_2, 1 ) * SIZE( parent_grid%w_2, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c + pro_w_c(k) = parent_grid%w_2(i,k,j) + enddo + call inter(pro_w_c,alt_w_c,kde_c,pro_w_n,alt_w_n,kde_n) + + do k = 1,kde_n + parent_grid%w_2(i,k,j) = pro_w_n(k) + enddo +enddo +enddo +ENDIF + +IF ( SIZE( parent_grid%t_2, 1 ) * SIZE( parent_grid%t_2, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%t_2(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%t_2(i,1,j) & + + cf2_c*parent_grid%t_2(i,2,j) & + + cf3_c*parent_grid%t_2(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%t_2(i,kde_c-1,j) & + + cfn1_c*parent_grid%t_2(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%t_2(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + +DO itrace = PARAM_FIRST_SCALAR, num_moist +IF ( SIZE( parent_grid%moist, 1 ) * SIZE( parent_grid%moist, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%moist(i,k,j,itrace) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%moist(i,1,j,itrace) & + + cf2_c*parent_grid%moist(i,2,j,itrace) & + + cf3_c*parent_grid%moist(i,3,j,itrace) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%moist(i,kde_c-1,j,itrace) & + + cfn1_c*parent_grid%moist(i,kde_c-2,j,itrace) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%moist(i,k,j,itrace) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF +ENDDO + +DO itrace = PARAM_FIRST_SCALAR, num_dfi_moist +IF ( SIZE( parent_grid%dfi_moist, 1 ) * SIZE( parent_grid%dfi_moist, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%dfi_moist(i,k,j,itrace) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%dfi_moist(i,1,j,itrace) & + + cf2_c*parent_grid%dfi_moist(i,2,j,itrace) & + + cf3_c*parent_grid%dfi_moist(i,3,j,itrace) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%dfi_moist(i,kde_c-1,j,itrace) & + + cfn1_c*parent_grid%dfi_moist(i,kde_c-2,j,itrace) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%dfi_moist(i,k,j,itrace) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF +ENDDO + +DO itrace = PARAM_FIRST_SCALAR, num_scalar +IF ( SIZE( parent_grid%scalar, 1 ) * SIZE( parent_grid%scalar, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%scalar(i,k,j,itrace) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%scalar(i,1,j,itrace) & + + cf2_c*parent_grid%scalar(i,2,j,itrace) & + + cf3_c*parent_grid%scalar(i,3,j,itrace) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%scalar(i,kde_c-1,j,itrace) & + + cfn1_c*parent_grid%scalar(i,kde_c-2,j,itrace) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%scalar(i,k,j,itrace) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF +ENDDO + +DO itrace = PARAM_FIRST_SCALAR, num_dfi_scalar +IF ( SIZE( parent_grid%dfi_scalar, 1 ) * SIZE( parent_grid%dfi_scalar, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%dfi_scalar(i,k,j,itrace) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%dfi_scalar(i,1,j,itrace) & + + cf2_c*parent_grid%dfi_scalar(i,2,j,itrace) & + + cf3_c*parent_grid%dfi_scalar(i,3,j,itrace) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%dfi_scalar(i,kde_c-1,j,itrace) & + + cfn1_c*parent_grid%dfi_scalar(i,kde_c-2,j,itrace) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%dfi_scalar(i,k,j,itrace) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF +ENDDO + + + +IF ( SIZE( parent_grid%f_ice_phy, 1 ) * SIZE( parent_grid%f_ice_phy, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%f_ice_phy(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%f_ice_phy(i,1,j) & + + cf2_c*parent_grid%f_ice_phy(i,2,j) & + + cf3_c*parent_grid%f_ice_phy(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%f_ice_phy(i,kde_c-1,j) & + + cfn1_c*parent_grid%f_ice_phy(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%f_ice_phy(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + +IF ( SIZE( parent_grid%f_rain_phy, 1 ) * SIZE( parent_grid%f_rain_phy, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%f_rain_phy(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%f_rain_phy(i,1,j) & + + cf2_c*parent_grid%f_rain_phy(i,2,j) & + + cf3_c*parent_grid%f_rain_phy(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%f_rain_phy(i,kde_c-1,j) & + + cfn1_c*parent_grid%f_rain_phy(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%f_rain_phy(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + + +IF ( SIZE( parent_grid%f_rimef_phy, 1 ) * SIZE( parent_grid%f_rimef_phy, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%f_rimef_phy(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%f_rimef_phy(i,1,j) & + + cf2_c*parent_grid%f_rimef_phy(i,2,j) & + + cf3_c*parent_grid%f_rimef_phy(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%f_rimef_phy(i,kde_c-1,j) & + + cfn1_c*parent_grid%f_rimef_phy(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%f_rimef_phy(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + +IF ( SIZE( parent_grid%h_diabatic, 1 ) * SIZE( parent_grid%h_diabatic, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%h_diabatic(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%h_diabatic(i,1,j) & + + cf2_c*parent_grid%h_diabatic(i,2,j) & + + cf3_c*parent_grid%h_diabatic(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%h_diabatic(i,kde_c-1,j) & + + cfn1_c*parent_grid%h_diabatic(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%h_diabatic(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + +IF ( SIZE( parent_grid%rthraten, 1 ) * SIZE( parent_grid%rthraten, 3 ) .GT. 1 ) THEN +do j = njms , njme +do i = nims , nime + + do k = 1,kde_c-1 + pro_u_c(k+1) = parent_grid%rthraten(i,k,j) + enddo + pro_u_c(1 ) = cf1_c*parent_grid%rthraten(i,1,j) & + + cf2_c*parent_grid%rthraten(i,2,j) & + + cf3_c*parent_grid%rthraten(i,3,j) + + pro_u_c(kde_c+1) = cfn_c *parent_grid%rthraten(i,kde_c-1,j) & + + cfn1_c*parent_grid%rthraten(i,kde_c-2,j) + + call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1) + + do k = 1,kde_n-1 + parent_grid%rthraten(i,k,j) = pro_u_n(k+1) + enddo + +enddo +enddo +ENDIF + + + + + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + deallocate (alt_w_c) + deallocate (alt_u_c) + deallocate (pro_w_c) + deallocate (pro_u_c) + + deallocate (alt_w_n) + deallocate (alt_u_n) + deallocate (pro_w_n) + deallocate (pro_u_n) + + + END SUBROUTINE vertical_interp + +!!!!!!!!!!!!!!!!!!!!!!!!11 + SUBROUTINE inter(pro_c,alt_c,kde_c,pro_n,alt_n,kde_n) + + IMPLICIT NONE + INTEGER , INTENT(IN) :: kde_c,kde_n + REAL , DIMENSION(kde_c) , INTENT(IN ) :: pro_c,alt_c + REAL , DIMENSION(kde_n) , INTENT(IN ) :: alt_n + REAL , DIMENSION(kde_n) , INTENT(OUT) :: pro_n + + real ,dimension(kde_c) :: a,b,c,d + real :: p + integer :: i,j + + + call coeff_mon(alt_c,pro_c,a,b,c,d,kde_c) + + do i = 1,kde_n-1 + + do j=1,kde_c-1 + + if ( (alt_n(i) .ge. alt_c(j)).and.(alt_n(i) .lt. alt_c(j+1)) ) then + p = alt_n(i)-alt_c(j) + pro_n(i) = p*( p*(a(j)*p+b(j))+c(j)) + d(j) + goto 20 + endif + enddo +20 continue + enddo + + pro_n(kde_n) = pro_c(kde_c) + + + END SUBROUTINE inter + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 + + subroutine coeff_mon(x,y,a,b,c,d,n) + + implicit none + + integer :: n + real ,dimension(n) :: x,y,a,b,c,d + real ,dimension(n) :: h,s,p,yp + + integer :: i + + + do i=1,n-1 + h(i) = (x(i+1)-x(i)) + s(i) = (y(i+1)-y(i)) / h(i) + enddo + + do i=2,n-1 + p(i) = (s(i-1)*h(i)+s(i)*h(i-1)) / (h(i-1)+h(i)) + enddo + + p(1) = s(1) + p(n) = s(n-1) + + do i=1,n + yp(i) = p(i) + enddo +!!!!!!!!!!!!!!!!!!!!! + + do i=2,n-1 + yp(i) = (sign(1.,s(i-1))+sign(1.,s(i)))* min( abs(s(i-1)),abs(s(i)),0.5*abs(p(i))) + enddo + + do i = 1,n-1 + a(i) = (yp(i)+yp(i+1)-2.*s(i))/(h(i)*h(i)) + b(i) = (3.*s(i)-2.*yp(i)-yp(i+1))/h(i) + c(i) = yp(i) + d(i) = y(i) + enddo + + end subroutine coeff_mon + + diff --git a/wrfv2_fire/main/nup_em.F b/wrfv2_fire/main/nup_em.F index 28925db6..7c52c910 100644 --- a/wrfv2_fire/main/nup_em.F +++ b/wrfv2_fire/main/nup_em.F @@ -60,8 +60,11 @@ PROGRAM nup_em USE module_machine - USE module_domain, only : domain, wrfu_timeinterval, alloc_and_configure_domain, & - domain_clock_set + USE module_domain, ONLY : domain, wrfu_timeinterval, alloc_and_configure_domain, & + domain_clock_set, domain_get_current_time, domain_get_stop_time, head_grid, & + domain_clock_get, domain_clockadvance + USE module_domain_type, ONLY : program_name + USE module_streams USE module_initialize_real, only : wrfu_initialize USE module_integrate USE module_driver_constants @@ -374,15 +377,15 @@ write(0,*)'after alloc_and_configure_domain ',associated(nested_grid%intermediat EXIT main_loop ENDIF - nested_grid%nframes(0) = nested_grid%nframes(0) + 1 - IF ( nested_grid%nframes(0) >= config_flags%frames_per_outfile ) THEN + nested_grid%nframes(history_only) = nested_grid%nframes(history_only) + 1 + IF ( nested_grid%nframes(history_only) >= config_flags%frames_per_outfile ) THEN CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) CALL close_dataset ( in_id , config_flags , "DATASET=HISTORY" ) CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags ) CALL close_dataset ( out_id , config_flags , "DATASET=HISTORY" ) in_id = 0 out_id = 0 - nested_grid%nframes(0) = 0 + nested_grid%nframes(history_only) = 0 ENDIF CALL WRFU_AlarmRingerOff( nested_grid%alarms( HISTORY_ALARM ), rc=rc ) ENDIF diff --git a/wrfv2_fire/main/real_em.F b/wrfv2_fire/main/real_em.F index 2599bcfa..def86da3 100644 --- a/wrfv2_fire/main/real_em.F +++ b/wrfv2_fire/main/real_em.F @@ -404,8 +404,8 @@ real::t1,t2,t3,t4 ! Input data. - CALL wrf_debug ( 100 , 'med_sidata_input: calling input_aux_model_input1' ) - CALL input_aux_model_input1 ( idsi , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_sidata_input: calling input_auxinput1' ) + CALL input_auxinput1 ( idsi , grid , config_flags , ierr ) CALL cpu_time ( t4 ) WRITE ( wrf_err_message , FMT='(A,I10,A)' ) 'Timing for input ',NINT(t4-t3) ,' s.' CALL wrf_debug( 0, wrf_err_message ) @@ -705,21 +705,21 @@ real::t1,t2 ! Open the wrfinput file. From this program, this is an *output* file. CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 ) - CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( 'real: error opening wrfinput for writing' ) END IF - CALL output_model_input ( id1, grid , config_flags , ierr ) + CALL output_input ( id1, grid , config_flags , ierr ) CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) IF ( time_loop_max .NE. 1 ) THEN IF(sst_update .EQ. 1)THEN CALL construct_filename1( inpname , 'wrflowinp' , grid%id , 2 ) - CALL open_w_dataset ( id4, TRIM(inpname) , grid , config_flags , output_aux_model_input4 , "DATASET=AUXINPUT4", ierr ) + CALL open_w_dataset ( id4, TRIM(inpname) , grid , config_flags , output_auxinput4 , "DATASET=AUXINPUT4", ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( 'real: error opening wrflowinp for writing' ) END IF - CALL output_aux_model_input4 ( id4, grid , config_flags , ierr ) + CALL output_auxinput4 ( id4, grid , config_flags , ierr ) END IF END IF @@ -821,7 +821,7 @@ real::t1,t2 ELSE IF ( loop .GT. 1 ) THEN IF(sst_update .EQ. 1)THEN - CALL output_aux_model_input4 ( id4, grid , config_flags , ierr ) + CALL output_auxinput4 ( id4, grid , config_flags , ierr ) END IF ! Open the boundary and the fdda file. @@ -836,7 +836,7 @@ real::t1,t2 END IF IF(grid_fdda .GE. 1)THEN CALL construct_filename1( inpname , 'wrffdda' , grid%id , 2 ) - CALL open_w_dataset ( id2, TRIM(inpname) , grid , config_flags , output_aux_model_input10 , "DATASET=AUXINPUT10", ierr ) + CALL open_w_dataset ( id2, TRIM(inpname) , grid , config_flags , output_auxinput10 , "DATASET=AUXINPUT10", ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( 'real: error opening wrffdda for writing' ) END IF @@ -1008,7 +1008,7 @@ real::t1,t2 ! Output gridded/analysis FDDA file. IF(grid_fdda .GE. 1) THEN - CALL output_aux_model_input10 ( id2, grid , config_flags , ierr ) + CALL output_auxinput10 ( id2, grid , config_flags , ierr ) END IF current_date = temp24 @@ -1027,11 +1027,11 @@ real::t1,t2 IF ( config_flags%all_ic_times ) THEN CALL construct_filename2a ( inpname , 'wrfinput_d.' , grid%id , 2 , TRIM(current_date) ) - CALL open_w_dataset ( id1, inpname , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) + CALL open_w_dataset ( id1, inpname , grid , config_flags , output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( 'real: error opening' // inpname // ' for writing' ) END IF - CALL output_model_input ( id1, grid , config_flags , ierr ) + CALL output_input ( id1, grid , config_flags , ierr ) CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) END IF diff --git a/wrfv2_fire/main/real_nmm.F b/wrfv2_fire/main/real_nmm.F index 75efbe75..e7a68460 100644 --- a/wrfv2_fire/main/real_nmm.F +++ b/wrfv2_fire/main/real_nmm.F @@ -338,9 +338,9 @@ SUBROUTINE med_sidata_input ( grid , config_flags ) ! Input data. - CALL wrf_debug (100, 'med_sidata_input: call input_aux_model_input1_wrf') + CALL wrf_debug (100, 'med_sidata_input: call input_auxinput1_wrf') - CALL input_aux_model_input1 ( idsi, grid, config_flags, ierr ) + CALL input_auxinput1 ( idsi, grid, config_flags, ierr ) ! Possible optional SI input. This sets flags used by init_domain. @@ -376,47 +376,15 @@ SUBROUTINE med_sidata_input ( grid , config_flags ) write(message,*) 'binary WPS branch' CALL wrf_message(message) - CALL wrf_error_fatal("binary WPS support deferred for initial release") - -! WRITE ( wrf_err_message , FMT='(A,A)' )'med_sidata_input: calling open_r_dataset for ',TRIM(config_flags%auxinput1_inname) -! CALL wrf_debug ( 100 , wrf_err_message ) -! CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , config_flags%io_form_auxinput1 ) -! CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr ) - -! IF ( ierr .NE. 0 ) THEN -! CALL wrf_debug( 1 , 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' ) -! CALL wrf_debug( 1 , 'will try again without the extension' ) -! CALL construct_filename2a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char ) -! CALL open_r_dataset ( idsi, TRIM(si_inpname) , grid , config_flags , "DATASET=AUXINPUT1", ierr ) -! IF ( ierr .NE. 0 ) THEN -! CALL wrf_error_fatal( 'error opening ' // TRIM(si_inpname) // ' for input; bad date in namelist or file not in directory' ) -! ENDIF -! ENDIF - - ! Input data. - -!!! believe problematic as binary data from WPS will be XYZ ordered, while this -!!! version of WRF will read in as XZY. OR read all fields in as unique -!!! Registry items that are XYZ, then swap. More memory, and more overhead, but -!!! better than having a stand alone "read_si" type code?? - -! CALL wrf_debug (100, 'med_sidata_input: call input_aux_model_input1_wrf') -! CALL input_aux_model_input1 ( idsi, grid, config_flags, ierr ) - - ! Possible optional SI input. This sets flags used by init_domain. - -! IF ( loop .EQ. 1 ) THEN -! CALL wrf_debug (100, 'med_sidata_input: call init_module_optional_input' ) -! CALL init_module_optional_input ( grid , config_flags ) -! END IF -! CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_input' ) -! -! CALL optional_input ( grid , idsi , config_flags) -! flag_metgrid=1 - -! -! CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" ) - + current_date_char(11:11)='_' + CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , & + config_flags%io_form_auxinput1 ) + CALL read_wps ( grid, trim(si_inpname), current_date_char, config_flags%num_metgrid_levels ) +!!! bogus set some flags?? + flag_metgrid=1 + flag_soilhgt=1 + + ENDIF #endif @@ -614,8 +582,8 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) INTEGER :: inc_h,inc_v INTEGER :: i , j , k , idts - INTEGER :: id1 , interval_seconds , ierr, rc - INTEGER , SAVE :: id + INTEGER :: id1 , interval_seconds , ierr, rc, sst_update + INTEGER , SAVE :: id ,id4 CHARACTER (LEN=80) :: inpname , bdyname CHARACTER(LEN= 4) :: loop_char CHARACTER(LEN=132) :: message @@ -697,6 +665,7 @@ character *24 :: temp24 , temp24b spec_bdy_width = model_config_rec%spec_bdy_width interval_seconds = model_config_rec%interval_seconds + sst_update = model_config_rec%sst_update !----------------------------------------------------------------------- ! @@ -704,6 +673,18 @@ character *24 :: temp24 , temp24b ! !----------------------------------------------------------------------- + IF ( time_loop_max .NE. 1 ) THEN + IF(sst_update .EQ. 1)THEN + CALL construct_filename1( inpname , 'wrflowinp' , grid%id , 2 ) + CALL open_w_dataset ( id4, TRIM(inpname) , grid , config_flags , output_auxinput4 , "DATASET=AUXINPUT4", ierr ) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal( 'real: error opening wrflowinp for writing' ) + END IF + CALL output_auxinput4 ( id4, grid , config_flags , ierr ) + END IF + END IF + + ! This is the space needed to save the current 3d data for use in computing ! the lateral boundary tendencies. @@ -744,7 +725,7 @@ character *24 :: temp24 , temp24b CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 ) CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , & - output_model_input , "DATASET=INPUT", ierr ) + output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( 'real: error opening wrfinput for writing' ) @@ -753,10 +734,10 @@ character *24 :: temp24 , temp24b ! CALL calc_current_date ( grid%id , 0. ) ! grid%write_metadata = .true. - write(message,*) 'making call to output_model_input' + write(message,*) 'making call to output_input' CALL wrf_message(message) - CALL output_model_input ( id1, grid , config_flags , ierr ) + CALL output_input ( id1, grid , config_flags , ierr ) !*** !*** CLOSE THE WRFINPUT DATASET @@ -962,6 +943,8 @@ character *24 :: temp24 , temp24b ! !----------------------------------------------------------------------- + CALL output_auxinput4 ( id4, grid , config_flags , ierr ) + write(message,*)' assemble_output loop=',loop,' in IF block' call wrf_message(message) @@ -982,7 +965,6 @@ character *24 :: temp24 , temp24b CALL domain_clockadvance( grid ) END IF -! !----------------------------------------------------------------------- !*** SOUTHERN BOUNDARY !----------------------------------------------------------------------- @@ -1207,14 +1189,14 @@ character *24 :: temp24 , temp24b ! start the model at any of the available analysis time periods. ! WRITE ( loop_char , FMT = '(I4.4)' ) loop -! CALL open_w_dataset ( id1, 'wrfinput'//loop_char , grid , config_flags , output_model_input , "DATASET=INPUT", ierr ) +! CALL open_w_dataset ( id1, 'wrfinput'//loop_char , grid , config_flags , output_input , "DATASET=INPUT", ierr ) ! IF ( ierr .NE. 0 ) THEN ! CALL wrf_error_fatal( 'real: error opening wrfinput'//loop_char//' for writing' ) ! ENDIF ! grid%write_metadata = .true. ! CALL calc_current_date ( grid%id , 0. ) -! CALL output_model_input ( id1, grid , config_flags , ierr ) +! CALL output_input ( id1, grid , config_flags , ierr ) ! CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" ) ! Is this or is this not the last time time? We can remove some unnecessary diff --git a/wrfv2_fire/main/tc_em.F b/wrfv2_fire/main/tc_em.F index c383edc4..307db595 100644 --- a/wrfv2_fire/main/tc_em.F +++ b/wrfv2_fire/main/tc_em.F @@ -3,9 +3,9 @@ PROGRAM tc_data USE module_machine USE module_domain, ONLY : domain, alloc_and_configure_domain, & - domain_clock_set, head_grid, program_name, domain_clockprint + domain_clock_set, head_grid, program_name, domain_clockprint, set_current_grid_ptr USE module_io_domain - + USE module_initialize_real, ONLY : wrfu_initialize USE module_driver_constants USE module_configure, ONLY : grid_config_rec_type, model_config_rec, & @@ -352,8 +352,8 @@ SUBROUTINE tc_med_sidata_input ( grid , config_flags, latc_loc, lonc_loc,vmax, r ! Input data. - CALL wrf_debug ( 100 , 'med_sidata_input: calling input_aux_model_input1' ) - CALL input_aux_model_input1 ( idsi , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'med_sidata_input: calling input_auxinput1' ) + CALL input_auxinput1 ( idsi , grid , config_flags , ierr ) WRITE ( wrf_err_message , FMT='(A,I10,A)' ) 'Timing for input ',NINT(t4-t3) ,' s.' CALL wrf_debug( 0, wrf_err_message ) @@ -588,11 +588,11 @@ real::t1,t2,truelat1,truelat2 current_date_char , config_flags%io_form_auxinput1 ) print *,"outfile name from construct filename ",tcoutname - CALL open_w_dataset ( id1, TRIM(tcoutname) , grid , config_flags ,output_aux_model_input1,"DATASET=AUXINPUT1",ierr ) + CALL open_w_dataset ( id1, TRIM(tcoutname) , grid , config_flags ,output_auxinput1,"DATASET=AUXINPUT1",ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( 'tc_em: error opening tc bogus file for writing' ) END IF - CALL output_aux_model_input1( id1, grid , config_flags , ierr ) + CALL output_auxinput1( id1, grid , config_flags , ierr ) CALL close_dataset ( id1 , config_flags , "DATASET=AUXINPUT1" ) diff --git a/wrfv2_fire/main/wrf_ESMFMod.F b/wrfv2_fire/main/wrf_ESMFMod.F index a2699e5a..3318e785 100644 --- a/wrfv2_fire/main/wrf_ESMFMod.F +++ b/wrfv2_fire/main/wrf_ESMFMod.F @@ -72,7 +72,7 @@ CONTAINS timevals(4) = hour timevals(5) = minute timevals(6) = second - CALL ESMF_AttributeSet(state, 'ComponentStartTime', SIZE(timevals), timevals, rc=rc) + CALL ESMF_AttributeSet(state, 'ComponentStartTime', timevals, itemCount=SIZE(timevals), rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'ESMF_AttributeSet(ComponentStartTime) failed' ) ENDIF @@ -88,7 +88,7 @@ CONTAINS timevals(4) = hour timevals(5) = minute timevals(6) = second - CALL ESMF_AttributeSet(state, 'ComponentStopTime', SIZE(timevals), timevals, rc=rc) + CALL ESMF_AttributeSet(state, 'ComponentStopTime', timevals, itemCount=SIZE(timevals), rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'ESMF_AttributeSet(ComponentStopTime) failed' ) ENDIF @@ -104,7 +104,7 @@ CONTAINS timevals(4) = hour timevals(5) = minute timevals(6) = second - CALL ESMF_AttributeSet(state, 'ComponentCouplingInterval', SIZE(timevals), timevals, rc=rc) + CALL ESMF_AttributeSet(state, 'ComponentCouplingInterval', timevals, itemCount=SIZE(timevals), rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'ESMF_AttributeSet(ComponentCouplingInterval) failed' ) ENDIF @@ -117,7 +117,7 @@ CONTAINS ! Update later to use some form of meta-data standards/conventions for ! model "time" meta-data. SUBROUTINE GetTimesFromState( state, startTime, stopTime, couplingInterval, rc ) - TYPE(ESMF_State), INTENT(IN ) :: state + TYPE(ESMF_State), INTENT(INOUT) :: state TYPE(ESMF_Time), INTENT(INOUT) :: startTime TYPE(ESMF_Time), INTENT(INOUT) :: stopTime TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval @@ -125,11 +125,14 @@ CONTAINS ! locals INTEGER :: year, month, day, hour, minute, second INTEGER(ESMF_KIND_I4) :: timevals(6) ! big enough to hold the vars listed above + INTEGER :: thecount ! 'one attribute ... ah ah ah. TWO attributes! ah ah ah!! + CHARACTER*256 mess ! start time - CALL ESMF_AttributeGet(state, 'ComponentStartTime', SIZE(timevals), timevals, rc=rc) + thecount = SIZE(timevals) + CALL ESMF_AttributeGet(state, 'ComponentStartTime', timevals, itemCount=thecount, rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal ( 'ESMF_AttributeSet(ComponentStartTime) failed' ) - !RETURN +!JM return but don't fail; let the caller figure out what to do + RETURN ENDIF year = timevals(1) month = timevals(2) @@ -137,21 +140,18 @@ CONTAINS hour = timevals(4) minute = timevals(5) second = timevals(6) -write(0,*) ' year ',year,__LINE__ -write(0,*) ' month ',month,__LINE__ -write(0,*) ' day ',day,__LINE__ -write(0,*) ' hour ',hour,__LINE__ -write(0,*) ' minute ',minute,__LINE__ -write(0,*) ' second ',second,__LINE__ CALL ESMF_TimeSet(startTime, yy=year, mm=month, dd=day, & h=hour, m=minute, s=second, rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'ESMF_TimeSet(startTime) failed' ) ENDIF ! stop time - CALL ESMF_AttributeGet(state, 'ComponentStopTime', SIZE(timevals), timevals, rc=rc) + thecount = SIZE(timevals) + CALL ESMF_AttributeGet(state, 'ComponentStopTime', timevals, itemCount=thecount, rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal ( 'ESMF_AttributeGet(ComponentStopTime) failed' ) +!JM return but don't fail; let the caller figure out what to do + !CALL wrf_error_fatal ( 'ESMF_AttributeGet(ComponentStopTime) failed' ) + RETURN ENDIF year = timevals(1) month = timevals(2) @@ -159,21 +159,18 @@ write(0,*) ' second ',second,__LINE__ hour = timevals(4) minute = timevals(5) second = timevals(6) -write(0,*) ' year ',year,__LINE__ -write(0,*) ' month ',month,__LINE__ -write(0,*) ' day ',day,__LINE__ -write(0,*) ' hour ',hour,__LINE__ -write(0,*) ' minute ',minute,__LINE__ -write(0,*) ' second ',second,__LINE__ CALL ESMF_TimeSet(stopTime, yy=year, mm=month, dd=day, & h=hour, m=minute, s=second, rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'ESMF_TimeSet(stopTime) failed' ) ENDIF ! coupling time step - CALL ESMF_AttributeGet(state, 'ComponentCouplingInterval', SIZE(timevals), timevals, rc=rc) + thecount = SIZE(timevals) + CALL ESMF_AttributeGet(state, 'ComponentCouplingInterval', timevals, itemCount=thecount, rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal ( 'ESMF_AttributeGet(ComponentCouplingInterval) failed' ) +!JM return but don't fail; let the caller figure out what to do + !CALL wrf_error_fatal ( 'ESMF_AttributeGet(ComponentCouplingInterval) failed' ) + RETURN ENDIF year = timevals(1) month = timevals(2) @@ -181,12 +178,6 @@ write(0,*) ' second ',second,__LINE__ hour = timevals(4) minute = timevals(5) second = timevals(6) -write(0,*) ' year ',year,__LINE__ -write(0,*) ' month ',month,__LINE__ -write(0,*) ' day ',day,__LINE__ -write(0,*) ' hour ',hour,__LINE__ -write(0,*) ' minute ',minute,__LINE__ -write(0,*) ' second ',second,__LINE__ CALL ESMF_TimeIntervalSet(couplingInterval, yy=year, mm=month, d=day, & h=hour, m=minute, s=second, rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN @@ -202,7 +193,7 @@ write(0,*) ' second ',second,__LINE__ ! is made to reconcile them. SUBROUTINE GetTimesFromStates( state, startTime, stopTime, couplingInterval ) USE ESMF_Mod - TYPE(ESMF_State), INTENT(IN ) :: state + TYPE(ESMF_State), INTENT(INOUT) :: state TYPE(ESMF_Time), INTENT(INOUT) :: startTime TYPE(ESMF_Time), INTENT(INOUT) :: stopTime TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval @@ -215,6 +206,7 @@ write(0,*) ' second ',second,__LINE__ TYPE(ESMF_Time), ALLOCATABLE :: startTimes(:) TYPE(ESMF_Time), ALLOCATABLE :: stopTimes(:) TYPE(ESMF_TimeInterval), ALLOCATABLE :: couplingIntervals(:) + CHARACTER (len=132) :: mess ! Unfortunately, implementing this is unnecessarily difficult due ! to lack of Iterators for ESMF_State. @@ -267,8 +259,22 @@ write(0,*) ' second ',second,__LINE__ ENDIF ENDIF ENDDO - CALL ReconcileTimes( startTimes, stopTimes, couplingIntervals, & - startTime, stopTime, couplingInterval ) + IF ( istate .EQ. 1 ) THEN + ! this presupposes that 1 of the child states exist and has + ! valid times in it. Use that one. + CALL write(mess,'WARNING: Only ',TRIM(itemNames(1)), & + ' is valid and has time info in it. Using that.') + CALL wrf_message(mess) + CALL ESMF_StateGet( state, itemName=TRIM(itemNames(1)), & + nestedState=tmpState, rc=rc ) + CALL GetTimesFromState( tmpState, startTime, stopTime, & + couplingInterval , rc ) + ELSE IF ( istate .GT. 1 ) THEN + CALL ReconcileTimes( startTimes, stopTimes, couplingIntervals, & + startTime, stopTime, couplingInterval ) + ELSE + CALL wrf_error_fatal('no valid states with times found. giving up.') + ENDIF ELSE ! there are no nested ESMF_States so use parent state only CALL GetTimesFromState( state, startTime, stopTime, & @@ -296,8 +302,6 @@ write(0,*) ' second ',second,__LINE__ TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval ! locals INTEGER :: numTimes, numTimesTmp, i -character*256 buttwhump -integer rc ! how many sets of time info? numTimes = SIZE(startTimes) @@ -316,28 +320,22 @@ integer rc ! reconcile !TODO: For now this is very simple. Fancy it up later. DO i = 1, numTimes -call esmf_timeget(starttimes(i),timestring=buttwhump,rc=rc) -write(*,*)__LINE__,'startimes',i,trim(buttwhump) -write(0,*)__LINE__,'startimes',i,trim(buttwhump) -call esmf_timeget(stoptimes(i),timestring=buttwhump,rc=rc) -write(*,*)__LINE__,'stoptimes',i,trim(buttwhump) -write(0,*)__LINE__,'stopimes',i,trim(buttwhump) -call esmf_timeintervalget(couplingintervals(i),timestring=buttwhump,rc=rc) -write(*,*)__LINE__,'coupling intervals',i,trim(buttwhump) -write(0,*)__LINE__,'coupling intervals',i,trim(buttwhump) IF ( i == 1 ) THEN startTime = startTimes(i) stopTime = stopTimes(i) couplingInterval = couplingIntervals(i) ELSE IF ( startTimes(i) /= startTime ) THEN - CALL wrf_error_fatal ( 'ReconcileTimes: inconsistent startTimes' ) + CALL wrf_message ( 'ReconcileTimes: inconsistent startTimes. Using first.' ) + startTimes(i) = startTime ENDIF IF ( stopTimes(i) /= stopTime ) THEN - CALL wrf_error_fatal ( 'ReconcileTimes: inconsistent stopTimes' ) + CALL wrf_message ( 'ReconcileTimes: inconsistent stopTimes. Using first.' ) + stopTimes(i) = stopTime ENDIF IF ( couplingIntervals(i) /= couplingInterval ) THEN - CALL wrf_error_fatal ( 'ReconcileTimes: inconsistent couplingIntervals' ) + CALL wrf_message ( 'ReconcileTimes: inconsistent couplingIntervals. Using first.' ) + couplingIntervals(i) = couplingInterval ENDIF ENDIF @@ -365,19 +363,20 @@ write(0,*)__LINE__,'coupling intervals',i,trim(buttwhump) ! big enough to hold the integer values listed above INTEGER(ESMF_KIND_I4) :: intvals(19) ! big enough to hold the logical values listed above - TYPE(ESMF_Logical) :: logvals(4) +! TYPE(ESMF_Logical) :: logvals(4) + logical :: logvals(4) ! first the logicals ! Usually, when writing an API for a target language, it is considered ! good practice to use native types of the target language in the ! interfaces. - logvals = ESMF_FALSE + logvals = .FALSE. DO i = 1, SIZE(bdy_mask) IF (bdy_mask(i)) THEN - logvals(i) = ESMF_TRUE + logvals(i) = .TRUE. ENDIF ENDDO - CALL ESMF_AttributeSet(state, 'DecompositionLogicals', SIZE(logvals), logvals, rc=rc) + CALL ESMF_AttributeSet(state, 'DecompositionLogicals', logvals, itemCount=SIZE(logvals), rc=rc) IF ( rc /= ESMF_SUCCESS) THEN CALL wrf_error_fatal ( 'ESMF_AttributeSet(DecompositionLogicals) failed' ) ENDIF @@ -401,7 +400,7 @@ write(0,*)__LINE__,'coupling intervals',i,trim(buttwhump) intvals(17) = kps intvals(18) = kpe intvals(19) = domdesc - CALL ESMF_AttributeSet(state, 'DecompositionIntegers', SIZE(intvals), intvals, rc=rc) + CALL ESMF_AttributeSet(state, 'DecompositionIntegers', intvals, itemCount=SIZE(intvals), rc=rc) IF ( rc /= ESMF_SUCCESS) THEN CALL wrf_error_fatal ( 'ESMF_AttributeSet(DecompositionIntegers) failed' ) ENDIF @@ -416,7 +415,7 @@ write(0,*)__LINE__,'coupling intervals',i,trim(buttwhump) ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & domdesc, bdy_mask ) - TYPE(ESMF_State), INTENT(IN ) :: state + TYPE(ESMF_State), INTENT(INOUT) :: state INTEGER, INTENT( OUT) :: ids, ide, jds, jde, kds, kde INTEGER, INTENT( OUT) :: ims, ime, jms, jme, kms, kme INTEGER, INTENT( OUT) :: ips, ipe, jps, jpe, kps, kpe @@ -427,10 +426,12 @@ write(0,*)__LINE__,'coupling intervals',i,trim(buttwhump) ! big enough to hold the integer values listed above INTEGER(ESMF_KIND_I4) :: intvals(19) ! big enough to hold the logical values listed above - TYPE(ESMF_Logical) :: logvals(4) + logical :: logvals(4) + integer :: thecount ! ah ah ah ! first the logicals - CALL ESMF_AttributeGet(state, 'DecompositionLogicals', SIZE(logvals), logvals, rc=rc) + thecount = SIZE(logvals) + CALL ESMF_AttributeGet(state, 'DecompositionLogicals', logvals, itemCount=thecount, rc=rc) IF ( rc /= ESMF_SUCCESS) THEN CALL wrf_error_fatal ( 'ESMF_AttributeGet(DecompositionLogicals) failed' ) ENDIF @@ -439,12 +440,13 @@ write(0,*)__LINE__,'coupling intervals',i,trim(buttwhump) ! interfaces. bdy_mask = .FALSE. DO i = 1, SIZE(logvals) - IF (logvals(i) == ESMF_TRUE) THEN + IF (logvals(i) ) THEN bdy_mask(i) = .TRUE. ENDIF ENDDO ! now the integers - CALL ESMF_AttributeGet(state, 'DecompositionIntegers', SIZE(intvals), intvals, rc=rc) + thecount = SIZE(intvals) + CALL ESMF_AttributeGet(state, 'DecompositionIntegers', intvals, itemCount=thecount, rc=rc) IF ( rc /= ESMF_SUCCESS) THEN CALL wrf_error_fatal ( 'ESMF_AttributeGet(DecompositionIntegers) failed' ) ENDIF @@ -484,12 +486,8 @@ MODULE module_wrf_component_top USE ESMF_Mod USE module_wrf_top, ONLY : wrf_init, wrf_run, wrf_finalize - USE module_domain, ONLY : head_grid, auxhist4_alarm, auxhist5_alarm, auxhist3_alarm, auxhist1_alarm, & - auxhist2_alarm, auxhist6_alarm, auxhist10_alarm, auxhist11_alarm, auxhist9_alarm, & - auxhist7_alarm, auxhist8_alarm, auxinput11_alarm, auxinput3_alarm, auxinput4_alarm, & - auxinput2_alarm, io_esmf, auxinput1_alarm, auxinput5_alarm, auxinput9_alarm, & - auxinput10_alarm, auxinput8_alarm, auxinput6_alarm, auxinput7_alarm, & - get_ijk_from_grid + USE module_domain, ONLY : head_grid, get_ijk_from_grid + USE module_streams USE module_esmf_extensions USE module_metadatautils, ONLY: AttachTimesToState, AttachDecompToState @@ -518,6 +516,10 @@ CONTAINS TYPE(ESMF_State), TARGET, INTENT(INOUT) :: importState TYPE(ESMF_State), TARGET, INTENT(INOUT) :: exportState TYPE(ESMF_Clock), TARGET, INTENT(INOUT) :: clock +#ifdef DM_PARALLEL + TYPE(ESMF_VM) :: vm + INTEGER :: mpicomtmp +#endif INTEGER, INTENT( OUT) :: rc ! ! WRF component init routine, phase 1. Passes relevant coupling @@ -567,6 +569,18 @@ CONTAINS CALL ESMF_SetCurrent( gcomp=p_gcomp, importState=p_importState, & exportState=p_exportState, clock=p_clock ) +#ifdef DM_PARALLEL + CALL ESMF_VMGetCurrent(vm, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_component_init1: ESMF_VMGetCurrent failed' ) + ENDIF + CALL ESMF_VMGet(vm, mpiCommunicator=mpicomtmp, rc=rc) + IF ( rc /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal ( 'wrf_component_init1: ESMF_VMGet failed' ) + ENDIF + CALL wrf_set_dm_communicator( mpicomtmp ) +#endif + ! Call WRF "init" routine, which, for a DM_PARALLEL run, will recognize ! that ESMF has already called MPI_INIT and respond appropriately. CALL wrf_init( no_init1=.TRUE. ) @@ -600,6 +614,11 @@ CONTAINS ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & domdesc, bdy_mask ) + CALL AttachDecompToState( importState, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + domdesc, bdy_mask ) END SUBROUTINE wrf_component_init1 @@ -890,6 +909,9 @@ CONTAINS !TODO: Add support for coupling that does not begin immediately later... !TODO: Get rid of duplication once I/O refactoring is finished (and !TODO: auxio streams can be addressed via index). + +!TODO: NOTE THAT THIS ONLY USES THE FIRST 12 STREAMS... EXPAND LATER, AS ABOVE + IF ( .NOT. foundcoupling ) THEN CALL nl_get_io_form_auxinput1( 1, io_form ) IF ( use_package( io_form ) == IO_ESMF ) THEN @@ -978,28 +1000,28 @@ CONTAINS foundcoupling = .TRUE. ENDIF ENDIF - IF ( .NOT. foundcoupling ) THEN - CALL nl_get_io_form_sgfdda( 1, io_form ) - IF ( use_package( io_form ) == IO_ESMF ) THEN - CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT9_ALARM ), & - RingInterval=couplingInterval, rc=rc ) - IF ( rc /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT9_ALARM) failed' ) - ENDIF - foundcoupling = .TRUE. - ENDIF - ENDIF - IF ( .NOT. foundcoupling ) THEN - CALL nl_get_io_form_gfdda( 1, io_form ) - IF ( use_package( io_form ) == IO_ESMF ) THEN - CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT10_ALARM ), & - RingInterval=couplingInterval, rc=rc ) - IF ( rc /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT10_ALARM) failed' ) - ENDIF - foundcoupling = .TRUE. - ENDIF - ENDIF +! IF ( .NOT. foundcoupling ) THEN +! CALL nl_get_io_form_auxinput9( 1, io_form ) +! IF ( use_package( io_form ) == IO_ESMF ) THEN +! CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT9_ALARM ), & +! RingInterval=couplingInterval, rc=rc ) +! IF ( rc /= ESMF_SUCCESS ) THEN +! CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT9_ALARM) failed' ) +! ENDIF +! foundcoupling = .TRUE. +! ENDIF +! ENDIF +! IF ( .NOT. foundcoupling ) THEN +! CALL nl_get_io_form_gfdda( 1, io_form ) +! IF ( use_package( io_form ) == IO_ESMF ) THEN +! CALL ESMF_AlarmGet( head_grid%alarms( AUXINPUT10_ALARM ), & +! RingInterval=couplingInterval, rc=rc ) +! IF ( rc /= ESMF_SUCCESS ) THEN +! CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXINPUT10_ALARM) failed' ) +! ENDIF +! foundcoupling = .TRUE. +! ENDIF +! ENDIF IF ( .NOT. foundcoupling ) THEN CALL nl_get_io_form_auxinput11( 1, io_form ) IF ( use_package( io_form ) == IO_ESMF ) THEN @@ -1101,17 +1123,17 @@ CONTAINS foundcoupling = .TRUE. ENDIF ENDIF - IF ( .NOT. foundcoupling ) THEN - CALL nl_get_io_form_sgfdda( 1, io_form ) - IF ( use_package( io_form ) == IO_ESMF ) THEN - CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST9_ALARM ), & - RingInterval=couplingInterval, rc=rc ) - IF ( rc /= ESMF_SUCCESS ) THEN - CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST9_ALARM) failed' ) - ENDIF - foundcoupling = .TRUE. - ENDIF - ENDIF +! IF ( .NOT. foundcoupling ) THEN +! CALL nl_get_io_form_sgfdda( 1, io_form ) +! IF ( use_package( io_form ) == IO_ESMF ) THEN +! CALL ESMF_AlarmGet( head_grid%alarms( AUXHIST9_ALARM ), & +! RingInterval=couplingInterval, rc=rc ) +! IF ( rc /= ESMF_SUCCESS ) THEN +! CALL wrf_error_fatal ( 'wrf_findCouplingInterval: ESMF_AlarmGet(AUXHIST9_ALARM) failed' ) +! ENDIF +! foundcoupling = .TRUE. +! ENDIF +! ENDIF IF ( .NOT. foundcoupling ) THEN CALL nl_get_io_form_auxhist10( 1, io_form ) IF ( use_package( io_form ) == IO_ESMF ) THEN @@ -1323,22 +1345,22 @@ CONTAINS input_aux_model_input8, ierr ) IF ( ierr /= 0 ) RETURN ENDIF - CALL nl_get_io_form_sgfdda( 1, io_form ) - IF ( use_package( io_form ) == IO_ESMF ) THEN - stream = 9 - CALL open_aux_u( grid, config_flags, stream, AUXINPUT9_ALARM, & - config_flags%sgfdda_inname, grid%auxinput9_oid, & - input_aux_model_input9, ierr ) - IF ( ierr /= 0 ) RETURN - ENDIF - CALL nl_get_io_form_gfdda( 1, io_form ) - IF ( use_package( io_form ) == IO_ESMF ) THEN - stream = 10 - CALL open_aux_u( grid, config_flags, stream, AUXINPUT10_ALARM, & - config_flags%gfdda_inname, grid%auxinput10_oid, & - input_aux_model_input10, ierr ) - IF ( ierr /= 0 ) RETURN - ENDIF +! CALL nl_get_io_form_sgfdda( 1, io_form ) +! IF ( use_package( io_form ) == IO_ESMF ) THEN +! stream = 9 +! CALL open_aux_u( grid, config_flags, stream, AUXINPUT9_ALARM, & +! config_flags%sgfdda_inname, grid%auxinput9_oid, & +! input_aux_model_input9, ierr ) +! IF ( ierr /= 0 ) RETURN +! ENDIF +! CALL nl_get_io_form_gfdda( 1, io_form ) +! IF ( use_package( io_form ) == IO_ESMF ) THEN +! stream = 10 +! CALL open_aux_u( grid, config_flags, stream, AUXINPUT10_ALARM, & +! config_flags%gfdda_inname, grid%auxinput10_oid, & +! input_aux_model_input10, ierr ) +! IF ( ierr /= 0 ) RETURN +! ENDIF CALL nl_get_io_form_auxinput11( 1, io_form ) IF ( use_package( io_form ) == IO_ESMF ) THEN stream = 11 @@ -1424,7 +1446,6 @@ CONTAINS output_aux_hist9, fname, n2, ierr ) IF ( ierr /= 0 ) RETURN ENDIF -#endif CALL nl_get_io_form_auxhist10( 1, io_form ) IF ( use_package( io_form ) == IO_ESMF ) THEN stream = 10 @@ -1441,6 +1462,7 @@ CONTAINS output_aux_hist11, fname, n2, ierr ) IF ( ierr /= 0 ) RETURN ENDIF +#endif END SUBROUTINE wrf_state_populate END MODULE module_wrf_component_top diff --git a/wrfv2_fire/main/wrf_SST_ESMF.F b/wrfv2_fire/main/wrf_SST_ESMF.F index 0d675488..a847643d 100644 --- a/wrfv2_fire/main/wrf_SST_ESMF.F +++ b/wrfv2_fire/main/wrf_SST_ESMF.F @@ -523,7 +523,6 @@ CONTAINS !TODO: MPMD serial operation, we will need to extract serialized domdesc !TODO: from export state metadata and de-serialize it. Similar arguments !TODO: apply to [ij][mp][se] and bdy_mask. -write(0,*)__FILE__,__LINE__,'entered sst_component_init2 ' write(str,*) 'sst_component_init2: calling GetDecompFromState' CALL wrf_debug ( 100 , TRIM(str) ) CALL GetDecompFromState( importState, & @@ -566,24 +565,24 @@ write(0,*)__FILE__,__LINE__,'entered sst_component_init2 ' MemoryStart(2) = jms; MemoryEnd(2) = jme; PatchStart(1) = ips; PatchEnd(1) = ipe; PatchStart(2) = jps; PatchEnd(2) = jpe -write(0,*)__FILE__,__LINE__,'DomainStart ',DomainStart(1:2) -write(0,*)__FILE__,__LINE__,'DomainEnd ',DomainEnd(1:2) -write(0,*)__FILE__,__LINE__,'MemoryStart ',MemoryStart(1:2) -write(0,*)__FILE__,__LINE__,'MemoryEnd ',MemoryEnd(1:2) -write(0,*)__FILE__,__LINE__,'PatchStart ',PatchStart(1:2) -write(0,*)__FILE__,__LINE__,'PatchEnd ',PatchEnd(1:2) +!write(0,*)__FILE__,__LINE__,'DomainStart ',DomainStart(1:2) +!write(0,*)__FILE__,__LINE__,'DomainEnd ',DomainEnd(1:2) +!write(0,*)__FILE__,__LINE__,'MemoryStart ',MemoryStart(1:2) +!write(0,*)__FILE__,__LINE__,'MemoryEnd ',MemoryEnd(1:2) +!write(0,*)__FILE__,__LINE__,'PatchStart ',PatchStart(1:2) +!write(0,*)__FILE__,__LINE__,'PatchEnd ',PatchEnd(1:2) CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: Calling ioesmf_create_grid_int()' ) CALL ioesmf_create_grid_int( esmfgrid, NUMDIMS, & DomainStart, DomainEnd, & MemoryStart, MemoryEnd, & PatchStart, PatchEnd ) -write(0,*)__FILE__,__LINE__ +!write(0,*)__FILE__,__LINE__ CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: back from ioesmf_create_grid_int()' ) ! create ESMF_Fields ! Note use of patch dimension for POINTERs allocated by ESMF. CALL wrf_debug ( 5 , 'DEBUG sst_component_init2: Calling ESMF_GridValidate(esmfgrid)' ) CALL ESMF_GridValidate( esmfgrid, rc=rc ) -write(0,*)__FILE__,__LINE__ +!write(0,*)__FILE__,__LINE__ IF ( rc /= ESMF_SUCCESS ) THEN WRITE( str,* ) 'Error in ESMF_GridValidate ', & __FILE__ , & @@ -596,22 +595,22 @@ write(0,*)__FILE__,__LINE__ !TODO: Once new ESMF 3.0 interfaces have settled down, eliminate "tmp_data_" !TODO: arrays and let ESMF allocate/deallocate them. Assuming of course that !TODO: we can convince ESMF to deallocate safely... -write(0,*)__FILE__,__LINE__ +!write(0,*)__FILE__,__LINE__ ALLOCATE( tmp_data_out_sst(ips:ipe,jps:jpe) ) -write(0,*)__FILE__,__LINE__ +!write(0,*)__FILE__,__LINE__ write(str,*) 'sst_component_init2: tmp_data_out_sst(', & LBOUND(tmp_data_out_sst,1),':',UBOUND(tmp_data_out_sst,1),',',LBOUND(tmp_data_out_sst,2),':',UBOUND(tmp_data_out_sst,2),')' CALL wrf_debug ( 100 , TRIM(str) ) CALL wrf_debug ( 100, 'sst_component_init2: calling ESMF_FieldCreate(out_sst_field)' ) -write(0,*)__FILE__,__LINE__,trim(datanames(sst_indx)) -write(0,*)__FILE__,__LINE__,ips,jps,ipe,jpe +!write(0,*)__FILE__,__LINE__,trim(datanames(sst_indx)) +!write(0,*)__FILE__,__LINE__,ips,jps,ipe,jpe out_sst_field = ESMF_FieldCreate( & esmfgrid, tmp_data_out_sst, & copyflag=ESMF_DATA_REF, & staggerloc=ESMF_STAGGERLOC_CENTER, & name=TRIM(datanames(SST_INDX)), & rc=rc ) -write(0,*)__FILE__,__LINE__,'Creating out_sst_field for exportState of SST component name ',TRIM(datanames(SST_INDX)) +!write(0,*)__FILE__,__LINE__,'Creating out_sst_field for exportState of SST component name ',TRIM(datanames(SST_INDX)) IF ( rc /= ESMF_SUCCESS ) THEN WRITE( str,* ) 'ESMF_FieldCreate(out_sst_field) failed ', & __FILE__ , & @@ -1211,7 +1210,7 @@ TYPE(ESMF_StateItemType) :: metypelist(100) WRITE(str,*) 'WRFSSTCpl_run: calling ESMF_StateGet(importState,name,...)' CALL wrf_debug ( 100 , TRIM(str) ) CALL ESMF_StateGet( importState, name=importStatename, rc=rc ) -write(0,*)__FILE__,__LINE__, 'importStatename ', trim(importStatename), 'rc = ', rc +!write(0,*)__FILE__,__LINE__, 'importStatename ', trim(importStatename), 'rc = ', rc IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_StateGet(importState,name,...) failed' ) ENDIF @@ -1251,24 +1250,24 @@ write(0,*)__FILE__,__LINE__, 'importStatename ', trim(importStatename), 'rc = ', CALL wrf_debug ( 100 , TRIM(str) ) CALL ESMF_StateGet( importState, name=mename, itemCount=mecount, itemNameList=melist, stateitemtypelist=metypelist, rc=rc ) -write(0,*)'importState mename ',trim(mename) -write(0,*)'importState mecount ',mecount -do i = 1,mecount -write(0,*)i,trim(melist(i)) -enddo -do i = 1,mecount -write(0,*)i,metypelist(i) -enddo +!write(0,*)'importState mename ',trim(mename) +!write(0,*)'importState mecount ',mecount +!do i = 1,mecount +!write(0,*)i,trim(melist(i)) +!enddo +!do i = 1,mecount +!write(0,*)i,metypelist(i) +!enddo CALL ESMF_StateGet( importState, TRIM(datanames(1)), src_field, & rc=rc ) -write(0,*)__FILE__,__LINE__, 'from importState: datanames(1) ', TRIM(datanames(1)), ' rc = ', rc +!write(0,*)__FILE__,__LINE__, 'from importState: datanames(1) ', TRIM(datanames(1)), ' rc = ', rc IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_StateGet(importState) failed' ) ENDIF CALL ESMF_FieldGet( src_field, array=src_array, rc=rc ) -write(0,*)__FILE__,__LINE__, 'from fieldget: rc = ', rc +!write(0,*)__FILE__,__LINE__, 'from fieldget: rc = ', rc IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_FieldGet src_array failed' ) ENDIF @@ -1277,14 +1276,14 @@ write(0,*)__FILE__,__LINE__, 'from fieldget: rc = ', rc CALL wrf_debug ( 100 , TRIM(str) ) CALL ESMF_StateGet( exportState, name=mename, itemCount=mecount, itemNameList=melist, stateitemtypelist=metypelist, rc=rc ) -write(0,*)'Exportstate mename ',trim(mename) -write(0,*)'Exportstate mecount ',mecount -do i = 1,mecount -write(0,*)i,trim(melist(i)) -enddo -do i = 1,mecount -write(0,*)i,metypelist(i) -enddo +!write(0,*)'Exportstate mename ',trim(mename) +!write(0,*)'Exportstate mecount ',mecount +!do i = 1,mecount +!write(0,*)i,trim(melist(i)) +!enddo +!do i = 1,mecount +!write(0,*)i,metypelist(i) +!enddo CALL ESMF_StateGet( exportState, TRIM(datanames(1)), dst_field, & rc=rc ) @@ -1326,7 +1325,7 @@ enddo CALL wrf_debug ( 100 , TRIM(str) ) CALL ESMF_ArrayRedistStore( src_array, dst_array, & routehandle=fromSST_rh, rc=rc ) -write(0,*)__FILE__,__LINE__,'rc = ',rc +!write(0,*)__FILE__,__LINE__,'rc = ',rc IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'WRFSSTCpl_run: ESMF_FieldRedistStore(fromSST_rh) failed' ) ENDIF @@ -1590,6 +1589,7 @@ PROGRAM wrf_SST_ESMF ! other misc stuff TYPE(ESMF_State) :: tmpState INTEGER :: timestepdebug + INTEGER :: thecount ! ah ah ah ! Return codes for error checks INTEGER :: rc @@ -1617,19 +1617,19 @@ integer(ESMF_KIND_I4) :: timevals(6) CALL ESMF_SetInitialized() ! eliminate this once ESMF does it internally ! Create the WRF Gridded Component, passing in the default VM. - compGriddedWRF = ESMF_GridCompCreate(parentVm=vm, name="WRF Model", rc=rc) + compGriddedWRF = ESMF_GridCompCreate( name="WRF Model", rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN PRINT *, 'wrf_SST_ESMF: ESMF_GridCompCreate(WRF Model) failed' ENDIF ! Create the SST Gridded Component, passing in the default VM. - compGriddedSST = ESMF_GridCompCreate(parentVm=vm, name="SST Dummy Model", rc=rc) + compGriddedSST = ESMF_GridCompCreate( name="SST Dummy Model", rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN PRINT *, 'wrf_SST_ESMF: ESMF_GridCompCreate(WRF Dummy Model) failed' ENDIF ! Create the WRF-SST Coupler Component, passing in the default VM. - compCplWRFSST = ESMF_CplCompCreate(parentVm=vm, name="WRF-SST Coupler", rc=rc) + compCplWRFSST = ESMF_CplCompCreate( name="WRF-SST Coupler", rc=rc) IF ( rc /= ESMF_SUCCESS ) THEN PRINT *, 'wrf_SST_ESMF: ESMF_CplCompCreate failed' ENDIF @@ -1705,13 +1705,14 @@ integer(ESMF_KIND_I4) :: timevals(6) PRINT *, 'DEBUG wrf_SST_ESMF: calling phase-1 WRF init (wrf_component_init1)' CALL ESMF_GridCompInitialize(compGriddedWRF, importStateWRF, & exportStateWRF, driverClock, phase=1, rc=rc) -call esmf_attributeget(exportstatewrf,'ComponentCouplingInterval',size(timevals),timevals,rc=rc) -write(0,*) 'exportStateWRF year ',timevals(1),__LINE__ -write(0,*) 'exportStateWRF month ',timevals(2),__LINE__ -write(0,*) 'exportStateWRF day ',timevals(3),__LINE__ -write(0,*) 'exportStateWRF hour ',timevals(4),__LINE__ -write(0,*) 'exportStateWRF minute ',timevals(5),__LINE__ -write(0,*) 'exportStateWRF second ',timevals(6),__LINE__ +thecount = size(timevals) +call esmf_attributeget(exportstatewrf,'ComponentCouplingInterval',timevals,itemcount=thecount,rc=rc) +!write(0,*) 'exportStateWRF year ',timevals(1),__LINE__ +!write(0,*) 'exportStateWRF month ',timevals(2),__LINE__ +!write(0,*) 'exportStateWRF day ',timevals(3),__LINE__ +!write(0,*) 'exportStateWRF hour ',timevals(4),__LINE__ +!write(0,*) 'exportStateWRF minute ',timevals(5),__LINE__ +!write(0,*) 'exportStateWRF second ',timevals(6),__LINE__ ! Note: wrf_debug and wrf_error_fatal are now initialized IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompInitialize(WRF phase 1) failed' ) @@ -1723,13 +1724,14 @@ write(0,*) 'exportStateWRF second ',timevals(6),__LINE__ PRINT *, 'DEBUG wrf_SST_ESMF: calling phase-1 SST init (sst_component_init1)' CALL ESMF_GridCompInitialize(compGriddedSST, importStateSST, & exportStateSST, driverClock, phase=1, rc=rc) -call esmf_attributeget(exportstatesst,'ComponentCouplingInterval',size(timevals),timevals,rc=rc) -write(0,*) 'exportStateSST year ',timevals(1),__LINE__ -write(0,*) 'exportStateSST month ',timevals(2),__LINE__ -write(0,*) 'exportStateSST day ',timevals(3),__LINE__ -write(0,*) 'exportStateSST hour ',timevals(4),__LINE__ -write(0,*) 'exportStateSST minute ',timevals(5),__LINE__ -write(0,*) 'exportStateSST second ',timevals(6),__LINE__ +thecount = size(timevals) +call esmf_attributeget(exportstatesst,'ComponentCouplingInterval',timevals,itemcount=thecount,rc=rc) +!write(0,*) 'exportStateSST year ',timevals(1),__LINE__ +!write(0,*) 'exportStateSST month ',timevals(2),__LINE__ +!write(0,*) 'exportStateSST day ',timevals(3),__LINE__ +!write(0,*) 'exportStateSST hour ',timevals(4),__LINE__ +!write(0,*) 'exportStateSST minute ',timevals(5),__LINE__ +!write(0,*) 'exportStateSST second ',timevals(6),__LINE__ IF ( rc /= ESMF_SUCCESS ) THEN CALL wrf_error_fatal ( 'wrf_SST_ESMF: ESMF_GridCompInitialize(SST phase 1) failed' ) ENDIF diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile index eed42df3..5f3401d9 100644 --- a/wrfv2_fire/phys/Makefile +++ b/wrfv2_fire/phys/Makefile @@ -1,4 +1,4 @@ -# + LN = ln -sf MAKE = make -i -r @@ -28,10 +28,12 @@ MODULES = \ module_mp_wsm5.o \ module_mp_wsm6.o \ module_mp_etanew.o \ + module_mp_HWRF.o \ module_mp_thompson.o \ module_mp_thompson07.o \ module_mp_gsfcgce.o \ module_mp_morr_two_moment.o \ + module_mp_milbrandt2mom.o \ module_mp_wdm5.o \ module_mp_wdm6.o \ module_ra_sw.o \ @@ -42,6 +44,7 @@ MODULES = \ module_ra_cam_support.o \ module_ra_cam.o \ module_ra_gfdleta.o \ + module_ra_HWRF.o \ module_ra_hs.o \ module_sf_sfclay.o \ module_sf_gfs.o \ @@ -51,11 +54,15 @@ MODULES = \ module_sf_noahlsm.o \ module_sf_urban.o \ module_sf_bep.o \ + module_sf_bep_bem.o \ + module_sf_bem.o \ module_sf_pxlsm.o \ module_sf_ruclsm.o \ module_sf_sfcdiags.o \ + module_sf_sfcdiags_ruclsm.o \ module_sf_sstskin.o \ module_sf_tmnupdate.o \ + module_sf_oml.o \ module_sf_myjsfc.o \ module_sf_qnsesfc.o \ module_sf_mynn.o \ @@ -79,8 +86,7 @@ MODULES = \ module_fdda_spnudging.o \ module_fddagd_driver.o \ module_fddaobs_rtfdda.o \ - module_fddaobs_driver.o \ - module_force_scm.o + module_fddaobs_driver.o FIRE_MODULES = \ module_fr_sfire_driver.o \ @@ -133,6 +139,10 @@ module_bl_mynn.o: ../share/module_model_constants.o module_sf_mynn.o: module_sf_sfclay.o module_bl_mynn.o \ ../share/module_model_constants.o +module_sf_gfdl.o : \ + module_gfs_machine.o \ + module_gfs_funcphys.o \ + module_gfs_physcons.o module_cu_bmj.o: ../share/module_model_constants.o @@ -151,7 +161,10 @@ module_cu_sas.o: module_gfs_machine.o \ module_gfs_funcphys.o \ module_gfs_physcons.o -module_ra_gfdleta.o: ../frame/module_dm.o +module_ra_gfdleta.o: ../frame/module_dm.o \ + module_mp_etanew.o + +module_ra_HWRF.o: ../frame/module_dm.o module_mp_HWRF.o module_ra_rrtm.o: ../frame/module_wrf_error.o \ ../frame/module_dm.o @@ -163,7 +176,14 @@ module_ra_cam.o: module_ra_cam_support.o \ module_mp_lin.o : ../frame/module_wrf_error.o +module_mp_milbrandt2mom.o : ../frame/module_wrf_error.o \ + ../share/module_model_constants.o + +module_mp_thompson.o : ../frame/module_wrf_error.o \ + ../frame/module_dm.o + module_sf_myjsfc.o: ../share/module_model_constants.o + module_sf_qnsesfc.o: ../share/module_model_constants.o module_sf_gfs.o: module_gfs_machine.o \ @@ -172,11 +192,15 @@ module_sf_gfs.o: module_gfs_machine.o \ module_progtm.o module_sf_noahdrv.o: module_sf_noahlsm.o module_data_gocart_dust.o \ - module_sf_urban.o module_sf_bep.o + module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o module_sf_noahlsm.o: ../share/module_model_constants.o -module_sf_bep.o: ../share/module_model_constants.o +module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o + +module_sf_bep_bem.o: ../share/module_model_constants.o module_sf_bem.o + +module_sf_bem.o: ../share/module_model_constants.o module_sf_ruclsm.o: ../frame/module_wrf_error.o module_data_gocart_dust.o @@ -190,6 +214,7 @@ module_physics_addtendc.o: \ ../frame/module_state_description.o \ ../frame/module_configure.o + module_physics_init.o : \ module_ra_rrtm.o \ module_ra_rrtmg_lw.o \ @@ -199,16 +224,19 @@ module_physics_init.o : \ module_ra_sw.o \ module_ra_gsfcsw.o \ module_ra_gfdleta.o \ + module_ra_HWRF.o \ module_ra_hs.o \ module_sf_sfclay.o \ module_sf_slab.o \ module_sf_myjsfc.o \ module_sf_mynn.o \ + module_sf_urban.o \ module_sf_qnsesfc.o \ module_sf_pxsfclay.o \ module_sf_noahlsm.o \ module_sf_noahdrv.o \ module_sf_bep.o \ + module_sf_bep_bem.o \ module_sf_ruclsm.o \ module_sf_pxlsm.o \ module_bl_ysu.o \ @@ -230,6 +258,7 @@ module_physics_init.o : \ module_mp_wsm5.o \ module_mp_wsm6.o \ module_mp_etanew.o \ + module_mp_HWRF.o \ module_fdda_psufddagd.o \ module_fdda_spnudging.o \ module_fddaobs_rtfdda.o \ @@ -237,12 +266,14 @@ module_physics_init.o : \ module_mp_thompson07.o \ module_mp_gsfcgce.o \ module_mp_morr_two_moment.o \ + module_mp_milbrandt2mom.o \ module_mp_wdm5.o \ module_mp_wdm6.o \ ../frame/module_state_description.o \ ../frame/module_configure.o \ ../frame/module_wrf_error.o \ ../frame/module_dm.o \ + ../share/module_llxy.o \ ../share/module_model_constants.o module_microphysics_driver.o: \ @@ -250,10 +281,12 @@ module_microphysics_driver.o: \ module_mp_kessler.o module_mp_lin.o \ module_mp_wsm3.o module_mp_wsm5.o \ module_mp_wsm6.o module_mp_etanew.o \ + module_mp_HWRF.o \ module_mp_thompson.o \ module_mp_thompson07.o \ module_mp_gsfcgce.o \ module_mp_morr_two_moment.o \ + module_mp_milbrandt2mom.o \ module_mp_wdm5.o module_mp_wdm6.o \ ../frame/module_driver_constants.o \ ../frame/module_state_description.o \ @@ -261,6 +294,7 @@ module_microphysics_driver.o: \ ../frame/module_configure.o \ ../share/module_model_constants.o + module_cumulus_driver.o: \ module_cu_kf.o \ module_cu_g3.o \ @@ -270,6 +304,10 @@ module_cumulus_driver.o: \ module_cu_sas.o \ ../frame/module_state_description.o \ ../frame/module_configure.o \ + ../frame/module_domain.o \ + ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ + ../frame/module_wrf_error.o \ ../share/module_model_constants.o module_pbl_driver.o: \ @@ -300,10 +338,12 @@ module_radiation_driver.o: \ module_ra_rrtmg_sw.o \ module_ra_cam.o \ module_ra_gfdleta.o \ + module_ra_HWRF.o \ module_ra_hs.o \ ../frame/module_driver_constants.o \ ../frame/module_state_description.o \ ../frame/module_dm.o \ + ../frame/module_comm_dm.o \ ../frame/module_domain.o \ ../frame/module_wrf_error.o \ ../frame/module_configure.o \ @@ -322,6 +362,7 @@ module_surface_driver.o: \ module_sf_pxlsm.o \ module_sf_mynn.o \ module_sf_sfcdiags.o \ + module_sf_sfcdiags_ruclsm.o \ module_sf_sstskin.o \ module_sf_tmnupdate.o \ ../frame/module_state_description.o \ @@ -335,10 +376,11 @@ module_mixactivate.o: \ module_radiation_driver.o module_fddagd_driver.o: \ + module_fdda_spnudging.o \ + module_fdda_psufddagd.o \ ../frame/module_state_description.o \ ../frame/module_configure.o \ - ../share/module_model_constants.o \ - module_fdda_psufddagd.o + ../share/module_model_constants.o module_fddaobs_driver.o: \ ../frame/module_domain.o \ @@ -346,13 +388,9 @@ module_fddaobs_driver.o: \ ../share/module_model_constants.o \ module_fddaobs_rtfdda.o -module_fdda_psufddagd.o: - -module_force_scm.o: \ - ../dyn_em/module_init_utilities.o - module_fr_sfire_driver.o: \ ../share/module_model_constants.o \ + ../frame/module_comm_dm.o \ module_fr_sfire_atm.o \ module_fr_sfire_phys.o \ module_fr_sfire_model.o \ @@ -376,6 +414,7 @@ module_fr_sfire_core.o: \ module_fr_sfire_phys.o module_fr_sfire_phys.o: \ + ../share/module_model_constants.o \ fr_sfire_params_args.h \ fr_sfire_params_decl.h \ module_fr_sfire_util.o @@ -385,4 +424,14 @@ module_fire_debug_output.o: \ ../frame/module_configure.o \ ../share/mediation_integrate.o +module_fdda_spnudging.o :\ + ../frame/module_dm.o \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_wrf_error.o + +module_sf_bep.o :\ + module_sf_urban.o + + # DO NOT DELETE diff --git a/wrfv2_fire/phys/module_bl_acm.F b/wrfv2_fire/phys/module_bl_acm.F index 4d75651a..a48c3c13 100755 --- a/wrfv2_fire/phys/module_bl_acm.F +++ b/wrfv2_fire/phys/module_bl_acm.F @@ -166,6 +166,7 @@ CONTAINS ENDDO DSIGFI(kte) = DSIGFI(kte-1) + do j = jts,jte CALL ACM2D(j=J,xtime=XTIME, dtpbl=DTPBL, sigmaf=SIGMAF, sigmah=SIGMAH & ,dsigfi=DSIGFI,dsighi=DSIGHI,dsigh=DSIGH & @@ -207,6 +208,7 @@ CONTAINS ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte ) +! USE module_wrf_error IMPLICIT NONE !.......Arguments @@ -264,6 +266,7 @@ CONTAINS !... Integer INTEGER :: KL, jtf, ktf, itf, KMIX !... + character*256 :: message !-----initialize vertical tendencies and ! do i = its,ite @@ -333,14 +336,14 @@ CONTAINS !... COMPUTE PBL WHERE RICHARDSON NUMBER = RIC (0.25) HOLTSLAG ET AL 1990 DO 100 I = its,ite - if(MOL(I).LT.0.0) then + if(MOL(I).LT.0.0 .AND. XTIME.GT.1) then WSS = (UST(I) ** 3 + 0.6 * WST(I) ** 3) ** 0.33333 - TMPFX = -UST(I) * TSTV(I) - TCONV = 8.5 * TMPFX / WSS + TCONV = -8.5 * UST(I) * TSTV(I) / WSS TH1 = THETAV(I,1) + TCONV else TH1 = THETAV(I,1) endif + 99 KMIX = 1 DO K = 1,kte DTMP = THETAV(I,K) - TH1 @@ -368,13 +371,13 @@ CONTAINS IF (RIB(I,K) .GE. RIC) GO TO 201 ENDDO - print *,' RIB never exceeds RIC, RIB(i,kte) = ',rib(i,5), & + write (message, *)' RIBX never exceeds RIC, RIB(i,kte) = ',rib(i,5), & ' THETAV(i,1) = ',thetav(i,1),' MOL=',mol(i), & ' TCONV = ',TCONV,' WST = ',WST(I), & ' KMIX = ',kmix,' UST = ',UST(I), & ' TST = ',TST(I),' U,V = ',US(I,1),VS(I,1), & ' I,J=',I,J - STOP + CALL wrf_error_fatal ( message ) 201 CONTINUE KPBLH(I) = K diff --git a/wrfv2_fire/phys/module_bl_gfs.F b/wrfv2_fire/phys/module_bl_gfs.F index f747205c..8a715241 100755 --- a/wrfv2_fire/phys/module_bl_gfs.F +++ b/wrfv2_fire/phys/module_bl_gfs.F @@ -5,21 +5,22 @@ MODULE module_bl_gfs CONTAINS !------------------------------------------------------------------- - SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D, P3D,PI3D, & + SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, & RUBLTEN,RVBLTEN,RTHBLTEN, & - RQVBLTEN,RQCBLTEN, & - CP,G,ROVCP,R,ROVG,FLAG_QI, & + RQVBLTEN,RQCBLTEN,RQIBLTEN, & + CP,G,ROVCP,R,ROVG,P_QI,P_FIRST_SCALAR, & dz8w,z,PSFC, & UST,PBL,PSIM,PSIH, & HFX,QFX,TSK,GZ1OZ0,WSPD,BR, & DT,KPBL2D,EP1,KARMAN, & +#if (NMM_CORE==1) + DISHEAT, & +#endif ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - ! optional - qi3d,rqiblten ) + its,ite, jts,jte, kts,kte ) !-------------------------------------------------------------------- - USE MODULE_GFS_MACHINE, ONLY : kind_phys + USE MODULE_GFS_MACHINE , ONLY : kind_phys !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -88,11 +89,14 @@ CONTAINS !-- kte end index for k in tile !------------------------------------------------------------------- +#if (NMM_CORE==1) + LOGICAL , INTENT(IN):: DISHEAT ! gopal's doing +#endif + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - LOGICAL, INTENT(IN) :: flag_qi + its,ite, jts,jte, kts,kte, & + P_QI,P_FIRST_SCALAR REAL, INTENT(IN) :: & CP, & @@ -109,6 +113,7 @@ CONTAINS P3D, & PI3D, & QC3D, & + QI3D, & QV3D, & T3D, & TH3D, & @@ -120,6 +125,7 @@ CONTAINS REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: & RTHBLTEN, & RQCBLTEN, & + RQIBLTEN, & RQVBLTEN, & RUBLTEN, & RVBLTEN @@ -142,14 +148,6 @@ CONTAINS INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: & KPBL2D -!--------------------------- OPTIONAL VARS ------------------------------ - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - OPTIONAL, INTENT(IN) :: & - QI3D - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - OPTIONAL, INTENT(INOUT) :: & - RQIBLTEN !--------------------------- LOCAL VARS ------------------------------ @@ -163,6 +161,7 @@ CONTAINS PRSLK, & T1, & TAU, & + dishx, & U1, & V1 @@ -196,6 +195,7 @@ CONTAINS REAL (kind=kind_phys) :: & CPM, & + cpmikj, & DELTIM, & FMTMP, & RRHOX @@ -221,7 +221,7 @@ CONTAINS KTEP=KTE+1 NTRAC=2 DELTIM=DT - IF (flag_qi) NTRAC=3 + IF (P_QI.ge.P_FIRST_SCALAR) NTRAC=3 DO J=jts,jte @@ -265,6 +265,7 @@ CONTAINS ENDDO ENDDO + DO k=kts+1,kte km=k-1 DO i=its,ite @@ -282,7 +283,7 @@ CONTAINS PHIL(I,KTE)=PHII(I,KTE)-PHIL(I,KTEM)+PHII(I,KTE) ENDDO - IF (flag_QI .AND. PRESENT( QI3D ) ) THEN + IF (P_QI.ge.P_FIRST_SCALAR) THEN DO k=kts,kte DO i=its,ite Q1(I,K,3) = QI3D(i,k,j)/(1.+QI3D(i,k,j)) @@ -303,6 +304,27 @@ CONTAINS SPD1,KPBL,PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL, & DELTIM,DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ) +!============================================================================ +! ADD IN DISSIPATIVE HEATING .... v*dv. This is Bob's doing +!============================================================================ + +#if (NMM_CORE==1) + + IF(DISHEAT)THEN + DO k=kts,kte + DO i=its,ite + dishx(i,k)=u1(i,k)*du(i,k) + v1(i,k)*dv(i,k) + cpmikj=CP*(1.+0.8*QV3D(i,k,j)) + dishx(i,k)=-dishx(i,k)/cpmikj +! IF(k==1)WRITE(0,*)'ADDITIONAL DISSIPATIVE HEATING',tau(i,k),dishx(i,k) + tau(i,k)=tau(i,k)+dishx(i,k) + ENDDO + ENDDO + ENDIF +#endif + +!============================================================================= + DO k=kts,kte DO i=its,ite @@ -314,7 +336,7 @@ CONTAINS ENDDO ENDDO - IF (flag_QI .AND. PRESENT( RQIBLTEN )) THEN + IF (P_QI.ge.P_FIRST_SCALAR) THEN DO k=kts,kte DO i=its,ite RQIBLTEN(I,K,J)=RTG(I,K,3)/(1.-Q1(I,K,3))**2 @@ -337,7 +359,7 @@ CONTAINS !=================================================================== SUBROUTINE gfsinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR, & + RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR, & restart, & allowed_to_read, & ids, ide, jds, jde, kds, kde, & @@ -350,7 +372,7 @@ CONTAINS INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_QI, P_FIRST_SCALAR + INTEGER , INTENT(IN) :: P_QI,P_FIRST_SCALAR REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & RUBLTEN, & @@ -389,6 +411,17 @@ CONTAINS ENDDO ENDIF + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQIBLTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE gfsinit ! -------------------------------------------------------------- @@ -956,7 +989,7 @@ CONTAINS SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2) !sela %INCLUDE DBTRIDI2; ! - USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE MODULE_GFS_MACHINE, ONLY : kind_phys implicit none integer k,n,l,i real(kind=kind_phys) fk @@ -997,7 +1030,7 @@ CONTAINS SUBROUTINE TRIDIN(L,N,nt,CL,CM,CU,R1,R2,AU,A1,A2) !sela %INCLUDE DBTRIDI2; ! - USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE MODULE_GFS_MACHINE, ONLY : kind_phys implicit none integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(L) @@ -1062,7 +1095,7 @@ CONTAINS SUBROUTINE TRIDIT(L,N,nt,CL,CM,CU,RT,AU,AT) !sela %INCLUDE DBTRIDI2; ! - USE MODULE_GFS_MACHINE , ONLY : kind_phys + USE MODULE_GFS_MACHINE, ONLY : kind_phys implicit none integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(L) diff --git a/wrfv2_fire/phys/module_bl_mynn.F b/wrfv2_fire/phys/module_bl_mynn.F index f39df87b..ff484688 100644 --- a/wrfv2_fire/phys/module_bl_mynn.F +++ b/wrfv2_fire/phys/module_bl_mynn.F @@ -1112,7 +1112,6 @@ CONTAINS SUBROUTINE mym_condensation (kts,kte, & - & levflag, & & dz, & & thl, qw, & & p,exner, & @@ -1120,7 +1119,6 @@ CONTAINS & Vt, Vq) INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(in) :: levflag REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & @@ -1741,7 +1739,6 @@ CONTAINS !!!!! CALL mym_condensation ( kts,kte,& - &levflag, & &dz(i,kts:kte,j), & &thl, sqw, & &p(i,kts:kte,j),exner(i,kts:kte,j), & diff --git a/wrfv2_fire/phys/module_bl_ysu.F b/wrfv2_fire/phys/module_bl_ysu.F index 9f5a4cec..d8a403a9 100644 --- a/wrfv2_fire/phys/module_bl_ysu.F +++ b/wrfv2_fire/phys/module_bl_ysu.F @@ -1,4 +1,7 @@ -!wrf:model_layer:physics +!WRf:model_layer:physics +! +! +! ! ! ! @@ -6,18 +9,18 @@ module module_bl_ysu contains ! +! !------------------------------------------------------------------- ! subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & rublten,rvblten,rthblten, & rqvblten,rqcblten,rqiblten,flag_qi, & - cp,g,rovcp,rd,rovg, & - dz8w,z,xlv,rv,psfc, & + cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & + dz8w,psfc, & znu,znw,mut,p_top, & - znt,ust,zol,hol,hpbl,psim,psih, & - xland,hfx,qfx,tsk,gz1oz0,wspd,br, & - dt,dtmin,kpbl2d, & - svp1,svp2,svp3,svpt0,ep1,ep2,karman,eomeg,stbolt, & + znt,ust,hpbl,psim,psih, & + xland,hfx,qfx,gz1oz0,wspd,br, & + dt,kpbl2d, & exch_h, & u10,v10, & ids,ide, jds,jde, kds,kde, & @@ -28,37 +31,6 @@ contains !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- -! -! this code is a revised vertical diffusion package ("ysupbl") -! with a nonlocal turbulent mixing in the pbl after "mrfpbl". -! the ysupbl (hong et al. 2006) is based on the study of noh -! et al.(2003) and accumulated realism of the behavior of the -! troen and mahrt (1986) concept implemented by hong and pan(1996). -! the major ingredient of the ysupbl is the inclusion of an explicit -! treatment of the entrainment processes at the entrainment layer. -! this routine uses an implicit approach for vertical flux -! divergence and does not require "miter" timesteps. -! it includes vertical diffusion in the stable atmosphere -! and moist vertical diffusion in clouds. -! -! mrfpbl: -! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) -! fall 1996 -! -! ysupbl: -! coded by song-you hong (yonsei university) and implemented by -! song-you hong (yonsei university) and jimy dudhia (ncar) -! summer 2002 -! -! references: -! -! hong, noh, and dudhia (2006), mon. wea. rev. -! hong and pan (1996), mon. wea. rev. -! noh, chun, hong, and raasch (2003), boundary layer met. -! troen and mahrt (1986), boundary layer met. -! -!------------------------------------------------------------------- -! !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) !-- th3d 3d potential temperature (k) @@ -89,39 +61,27 @@ contains !-- rd gas constant for dry air (j/kg/k) !-- rovg r/g !-- dz8w dz between full levels (m) -!-- z height above sea level (m) !-- xlv latent heat of vaporization (j/kg) !-- rv gas constant for water vapor (j/kg/k) !-- psfc pressure at the surface (pa) !-- znt roughness length (m) !-- ust u* in similarity theory (m/s) -!-- zol z/l height over monin-obukhov length -!-- hol pbl height over monin-obukhov length !-- hpbl pbl height (m) -!-- regime flag indicating pbl regime (stable, unstable, etc.) !-- psim similarity stability function for momentum !-- psih similarity stability function for heat !-- xland land mask (1 for land, 2 for water) !-- hfx upward heat flux at the surface (w/m^2) !-- qfx upward moisture flux at the surface (kg/m^2/s) -!-- tsk surface temperature (k) !-- gz1oz0 log(z/z0) where z0 is roughness length !-- wspd wind speed at lowest model level (m/s) !-- u10 u-wind speed at 10 m (m/s) !-- v10 v-wind speed at 10 m (m/s) !-- br bulk richardson number in surface layer !-- dt time step (s) -!-- dtmin time step (minute) !-- rvovrd r_v divided by r_d (dimensionless) -!-- svp1 constant for saturation vapor pressure (kpa) -!-- svp2 constant for saturation vapor pressure (dimensionless) -!-- svp3 constant for saturation vapor pressure (k) -!-- svpt0 constant for saturation vapor pressure (k) !-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) !-- ep2 constant for specific humidity calculation !-- karman von karman constant -!-- eomeg angular velocity of earths rotation (rad/s) -!-- stbolt stefan-boltzmann constant (w/m^2/k^4) !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -142,33 +102,34 @@ contains !-- kte end index for k in tile !------------------------------------------------------------------- ! + integer,parameter :: ndiff = 3 + real,parameter :: rcl = 1.0 +! integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! - real, intent(in ) :: dt,dtmin,cp,g,rovcp,rovg,rd,xlv,rv + real, intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv ! - real, intent(in ) :: svp1,svp2,svp3,svpt0 - real, intent(in ) :: ep1,ep2,karman,eomeg,stbolt + real, intent(in ) :: ep1,ep2,karman ! real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: qv3d, & - qc3d, & - qi3d, & - p3d, & - pi3d, & - th3d, & - t3d, & - dz8w, & - z + qc3d, & + qi3d, & + p3d, & + pi3d, & + th3d, & + t3d, & + dz8w real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: p3di ! real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(inout) :: rublten, & - rvblten, & - rthblten, & - rqvblten, & + rvblten, & + rthblten, & + rqvblten, & rqcblten ! real, dimension( ims:ime, kms:kme, jms:jme ) , & @@ -179,22 +140,20 @@ contains ! real, dimension( ims:ime, jms:jme ) , & intent(in ) :: xland, & - hfx, & + hfx, & qfx, & + br, & + psfc + real, dimension( ims:ime, jms:jme ) , & + intent(in ) :: & psim, & psih, & - gz1oz0, & - br, & - psfc, & - tsk -! + gz1oz0 real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: hol, & + intent(inout) :: znt, & ust, & hpbl, & - znt, & - wspd, & - zol + wspd ! real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: u3d, & @@ -225,10 +184,17 @@ contains ! !local integer :: i,j,k - real, dimension( its:ite, kts:kte ) :: rqibl2dt, & - pdh + real, dimension( its:ite, kts:kte*ndiff ) :: rqvbl2dt, & + qv2d + real, dimension( its:ite, kts:kte ) :: pdh real, dimension( its:ite, kts:kte+1 ) :: pdhi + real, dimension( its:ite ) :: & + dusfc, & + dvsfc, & + dtsfc, & + dqsfc ! + qv2d(:,:) = 0.0 do j = jts,jte if(present(mut))then ! For ARW we will replace p and p8w with dry hydrostatic pressure @@ -246,32 +212,36 @@ contains enddo enddo endif + do k = kts,kte + do i = its,ite + qv2d(i,k) = qv3d(i,k,j) + qv2d(i,k+kte) = qc3d(i,k,j) + if(present(rqiblten)) qv2d(i,k+kte+kte) = qi3d(i,k,j) + enddo + enddo ! call ysu2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j) & ,tx=t3d(ims,kms,j) & - ,qx=qv3d(ims,kms,j),qcx=qc3d(ims,kms,j) & - ,qix=qi3d(ims,kms,j) & + ,qx=qv2d(its,kts) & ,p2d=pdh(its,kts),p2di=pdhi(its,kts) & ,pi2d=pi3d(ims,kms,j) & ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j) & - ,ttnp=rthblten(ims,kms,j),qtnp=rqvblten(ims,kms,j) & - ,qctnp=rqcblten(ims,kms,j),qitnp=rqibl2dt(its,kts) & + ,ttnp=rthblten(ims,kms,j),qtnp=rqvbl2dt(its,kts),ndiff=ndiff & ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & - ,dz8w2d=dz8w(ims,kms,j),z2d=z(ims,kms,j) & ,xlv=xlv,rv=rv & + ,ep1=ep1,ep2=ep2,karman=karman & + ,dz8w2d=dz8w(ims,kms,j) & ,psfcpa=psfc(ims,j),znt=znt(ims,j),ust=ust(ims,j) & - ,zol=zol(ims,j),hol=hol(ims,j),hpbl=hpbl(ims,j) & + ,hpbl=hpbl(ims,j) & ,regime=regime(ims,j),psim=psim(ims,j) & ,psih=psih(ims,j),xland=xland(ims,j) & ,hfx=hfx(ims,j),qfx=qfx(ims,j) & - ,tsk=tsk(ims,j),gz1oz0=gz1oz0(ims,j) & ,wspd=wspd(ims,j),br=br(ims,j) & - ,dt=dt,dtmin=dtmin,kpbl1d=kpbl2d(ims,j) & - ,svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0 & - ,ep1=ep1,ep2=ep2,karman=karman,eomeg=eomeg & - ,stbolt=stbolt & + ,dusfc=dusfc,dvsfc=dvsfc,dtsfc=dtsfc,dqsfc=dqsfc & + ,dt=dt,rcl=1.0,kpbl1d=kpbl2d(ims,j) & ,exch_hx=exch_h(ims,kms,j) & ,u10=u10(ims,j),v10=v10(ims,j) & + ,gz1oz0=gz1oz0(ims,j) & ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) @@ -279,7 +249,9 @@ contains do k = kts,kte do i = its,ite rthblten(i,k,j) = rthblten(i,k,j)/pi3d(i,k,j) - if(present(rqiblten)) rqiblten(i,k,j) = rqibl2dt(i,k) + rqvblten(i,k,j) = rqvbl2dt(i,k) + rqcblten(i,k,j) = rqvbl2dt(i,k+kte) + if(present(rqiblten)) rqiblten(i,k,j) = rqvbl2dt(i,k+kte+kte) enddo enddo enddo @@ -288,31 +260,69 @@ contains ! !------------------------------------------------------------------- ! - subroutine ysu2d(j,ux,vx,tx,qx,qcx,qix,p2d,p2di,pi2d, & - utnp,vtnp,ttnp, & - qtnp,qctnp,qitnp, & - cp,g,rovcp,rd,rovg, & - dz8w2d,z2d,xlv,rv,psfcpa, & - znt,ust,zol,hol,hpbl,psim,psih, & - xland,hfx,qfx,tsk,gz1oz0,wspd,br, & - dt,dtmin,kpbl1d, & - svp1,svp2,svp3,svpt0,ep1,ep2,karman,eomeg,stbolt, & + subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp,ndiff, & + cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & + dz8w2d,psfcpa, & + znt,ust,hpbl,psim,psih, & + xland,hfx,qfx,wspd,br, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,rcl,kpbl1d, & exch_hx, & u10,v10, & + gz1oz0, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - !optional + !optional regime ) !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- ! - integer,parameter :: ncloud = 3 +! this code is a revised vertical diffusion package ("ysupbl") +! with a nonlocal turbulent mixing in the pbl after "mrfpbl". +! the ysupbl (hong et al. 2006) is based on the study of noh +! et al.(2003) and accumulated realism of the behavior of the +! troen and mahrt (1986) concept implemented by hong and pan(1996). +! the major ingredient of the ysupbl is the inclusion of an explicit +! treatment of the entrainment processes at the entrainment layer. +! this routine uses an implicit approach for vertical flux +! divergence and does not require "miter" timesteps. +! it includes vertical diffusion in the stable atmosphere +! and moist vertical diffusion in clouds. +! +! mrfpbl: +! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) +! fall 1996 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! further modifications : +! an enhanced stable layer mixing, april 2008 +! ==> increase pbl height when sfc is stable (hong 2007) +! pressure-level diffusion, april 2009 +! ==> negligible differences +! implicit forcing for momentum with clean up, july 2009 +! ==> prevents model blownup when sfc layer is too low +! +! references: +! +! hong (2007, korea meteorological society annual conference) +! hong, noh, and dudhia (2006), mon. wea. rev. +! hong and pan (1996), mon. wea. rev. +! noh, chun, hong, and raasch (2003), boundary layer met. +! troen and mahrt (1986), boundary layer met. +! +!------------------------------------------------------------------- +! real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 - real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0 + real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 real,parameter :: phifac = 8.,sfcfrac = 0.1 real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 real,parameter :: h1 = 0.33333335, h2 = 0.6666667 @@ -320,45 +330,42 @@ contains real,parameter :: tmin=1.e-2 real,parameter :: gamcrt = 3.,gamcrq = 2.e-3 real,parameter :: xka = 2.4e-5 + integer,parameter :: imvdif = 1 ! integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, j + its,ite, jts,jte, kts,kte, & + j,ndiff ! - real, intent(in ) :: dt,dtmin,cp,g,rovcp,rovg,rd,xlv,rv + real, intent(in ) :: dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv ! - real, intent(in ) :: svp1,svp2,svp3,svpt0 - real, intent(in ) :: ep1,ep2,karman,eomeg,stbolt + real, intent(in ) :: ep1,ep2,karman ! real, dimension( ims:ime, kms:kme ), & intent(in) :: dz8w2d, & - z2d + pi2d ! real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: tx, & - qx, & - qcx, & - qix, & - pi2d + intent(in ) :: tx + real, dimension( its:ite, kts:kte*ndiff ) , & + intent(in ) :: qx +! + real, dimension( ims:ime, kms:kme ) , & + intent(inout) :: utnp, & + vtnp, & + ttnp + real, dimension( its:ite, kts:kte*ndiff ) , & + intent(inout) :: qtnp +! real, dimension( its:ite, kts:kte+1 ) , & intent(in ) :: p2di ! real, dimension( its:ite, kts:kte ) , & intent(in ) :: p2d ! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: qitnp -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: utnp, & - vtnp, & - ttnp, & - qtnp, & - qctnp ! real, dimension( ims:ime ) , & - intent(inout) :: hol, & - ust, & + intent(inout) :: ust, & hpbl, & znt real, dimension( ims:ime ) , & @@ -374,8 +381,6 @@ contains real, dimension( ims:ime ), intent(in ) :: gz1oz0 ! real, dimension( ims:ime ), intent(in ) :: psfcpa - real, dimension( ims:ime ), intent(in ) :: tsk - real, dimension( ims:ime ), intent(inout) :: zol integer, dimension( ims:ime ), intent(out ) :: kpbl1d ! real, dimension( ims:ime, kms:kme ) , & @@ -388,43 +393,36 @@ contains ! ! local vars ! + real, dimension( its:ite ) :: hol real, dimension( its:ite, kts:kte+1 ) :: zq ! - real, dimension( its:ite, kts:kte ) :: & - thx,thvx, & - del, & - dza, & - dzq, & - za, & - tvx, & - uxs,vxs, & - thxs,qxs, & - qcxs,qixs -! - real, dimension( its:ite ) :: qixsv,rhox, & - govrth, & - thxsv, & - uxsv,vxsv, & - qxsv,qcxsv, & - qgh,tgdsa,ps + real, dimension( its:ite, kts:kte ) :: & + thx,thvx, & + del, & + dza, & + dzq, & + za ! real, dimension( its:ite ) :: & + rhox, & + govrth, & zl1,thermal, & - wscale,hgamt, & + wscale,hgamt, & hgamq,brdn, & - brup,phim, & - phih,cpm, & - dusfc,dvsfc, & - dtsfc,dqsfc, & - thgb,prpbl, & + brup,phim, & + phih, & + dusfc,dvsfc, & + dtsfc,dqsfc, & + prpbl, & wspd1 ! real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & - f1,f2, & - r1,r2, & + f1,f2, & + r1,r2, & ad,au, & cu, & al, & + xkzq, & zfac ! !jdf added exch_hx @@ -436,26 +434,26 @@ contains v10 real, dimension( its:ite ) :: & brcr, & + sflux, & brcr_sbro ! - real, dimension( its:ite, kts:kte, ncloud) :: r3,f3 + real, dimension( its:ite, kts:kte, ndiff) :: r3,f3 + integer, dimension( its:ite ) :: kpbl ! logical, dimension( its:ite ) :: pblflg, & - sfcflg, & - stable + sfcflg, & + stable ! - integer :: n,i,k,l,nzol,imvdif,ic - integer :: klpbl + integer :: n,i,k,l,ic,is + integer :: klpbl, ktrace1, ktrace2, ktrace3 ! - integer, dimension( its:ite ) :: kpbl ! - real :: zoln,x,y,tvcon,e1,dtstep - real :: zl,tskv,dthvdz,dthvm,vconv,rzol - real :: dtthx,psix,dtg,psiq,ustm real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum real :: xkzo,ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri - real :: brint,dtodsd,rdz,dsdzt,dsdzq,dsdz2,ttend,qtend - real :: utend,vtend,qctend,qitend,tgc,dtodsu,govrthv + real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2 + real :: utend,vtend,ttend,qtend + real :: dtstep,govrthv + real :: cont, conq, conw, conwrc ! real, dimension( its:ite, kts:kte ) :: wscalek, & xkzml,xkzhl, & @@ -469,22 +467,22 @@ contains ufxpbl,vfxpbl, & delta,dthvx real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & - dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon ! !---------------------------------------------------------------------- ! klpbl = kte ! -!-- imvdif imvdif = 1 for moist adiabat vertical diffusion - imvdif = 1 + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) ! -!----convert ground temperature to potential temperature: +! k-start index for tracer diffusion ! - do i = its,ite - tgdsa(i) = tsk(i) - ps(i) = psfcpa(i)/1000. ! ps psfc cb - thgb(i) = tsk(i)*(100./ps(i))**rovcp - enddo + ktrace1 = 0 + ktrace2 = 0 + kte + ktrace3 = 0 + kte*2 ! do k = kts,kte do i = its,ite @@ -492,11 +490,6 @@ contains enddo enddo ! - do i = its,ite - qgh(i) = 0. - cpm(i) = cp - enddo -! do k = kts,kte do i = its,ite tvcon = (1.+ep1*qx(i,k)) @@ -505,9 +498,9 @@ contains enddo ! do i = its,ite - e1 = svp1*exp(svp2*(tgdsa(i)-svpt0)/(tgdsa(i)-svp3)) - qgh(i) = ep2*e1/(ps(i)-e1) - cpm(i) = cp*(1.+0.8*qx(i,1)) + tvcon = (1.+ep1*qx(i,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) enddo ! !-----compute the height of full- and half-sigma levels above ground @@ -515,60 +508,40 @@ contains ! do i = its,ite zq(i,1) = 0. - rhox(i) = ps(i)*1000./(rd*tx(i,1)) - enddo -! - do k = kts,kte - do i = its,ite - zq(i,k+1) = dz8w2d(i,k)+zq(i,k) - enddo - enddo -! - do k = kts,kte - do i = its,ite - za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - enddo - enddo -! - do i = its,ite - dza(i,1) = za(i,1) - enddo -! - do k = kts+1,kte - do i = its,ite - dza(i,k) = za(i,k)-za(i,k-1) - enddo - enddo -! - do i = its,ite - govrth(i) = g/thx(i,1) enddo ! -!-----initialize vertical tendencies and -! - do i = its,ite - do k = kts,kte - utnp(i,k) = 0. - vtnp(i,k) = 0. - ttnp(i,k) = 0. + do k = kts,kte + do i = its,ite + zq(i,k+1) = dz8w2d(i,k)+zq(i,k) enddo enddo -! +! do k = kts,kte do i = its,ite - qtnp(i,k) = 0. + za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) enddo enddo ! - do k = kts,kte + do i = its,ite + dza(i,1) = za(i,1) + enddo +! + do k = kts+1,kte do i = its,ite - qctnp(i,k) = 0. - qitnp(i,k) = 0. + dza(i,k) = za(i,k)-za(i,k-1) enddo enddo ! +! +!-----initialize vertical tendencies and +! + utnp(:,:) = 0. + vtnp(:,:) = 0. + ttnp(:,:) = 0. + qtnp(:,:) = 0. +! do i = its,ite wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 enddo @@ -606,6 +579,13 @@ contains enddo ! do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = its,ite hgamt(i) = 0. hgamq(i) = 0. wscale(i) = 0. @@ -615,6 +595,7 @@ contains thermal(i)= thvx(i,1) pblflg(i) = .true. sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) if(br(i).gt.0.0) sfcflg(i) = .false. enddo ! @@ -666,8 +647,8 @@ contains if(sfcflg(i))then phim(i) = (1.-aphi16*hol1)**(-1./4.) phih(i) = (1.-aphi16*hol1)**(-1./2.) - bfx0 = max(hfx(i)/rhox(i)/cpm(i)+ep1*thx(i,1)*qfx(i)/rhox(i),0.) - hfx0 = max(hfx(i)/rhox(i)/cpm(i),0.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) wstar3(i) = (govrth(i)*bfx0*hpbl(i)) wstar(i) = (wstar3(i))**h1 @@ -687,9 +668,9 @@ contains ! under unstable conditions ! do i = its,ite - if(sfcflg(i))then + if(sfcflg(i).and.sflux(i).gt.0.0)then gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cpm(i),gamcrt) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) hgamq(i) = min(gamfac*qfx(i),gamcrq) vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac thermal(i) = thermal(i)+max(vpert,0.) @@ -887,9 +868,9 @@ contains /(dza(i,k+1)*dza(i,k+1))+1.e-9 govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) - if(imvdif.eq.1)then - if((qcx(i,k)+qix(i,k)).gt.0.01e-3.and.(qcx(i,k+1)+ & - qix(i,k+1)).gt.0.01e-3)then + if(imvdif.eq.1.and.ndiff.ge.3)then + if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.(qx(i & + ,ktrace2+k+1)+qx(i,ktrace3+k+1)).gt.0.01e-3)then ! in cloud qmean = 0.5*(qx(i,k)+qx(i,k+1)) tmean = 0.5*(tx(i,k)+tx(i,k+1)) @@ -924,7 +905,7 @@ contains enddo enddo ! -! compute tridiagonal matrix elements for heat and moisture, and clouds +! compute tridiagonal matrix elements for heat ! do k = kts,kte do i = its,ite @@ -935,7 +916,73 @@ contains enddo enddo ! - do ic = 1,ncloud + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzh(i,k) = max(xkzh(i,k),xkzmin) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_hx(i,k+1) = xkzh(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) +! +! recover tendencies of heat +! + do k = kte,kts,-1 + do i = its,ite + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttnp(i,k)+ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) + enddo + enddo +! +! compute tridiagonal matrix elements for moisture, clouds, and tracers +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff do i = its,ite do k = kts,kte f3(i,k,ic) = 0. @@ -945,65 +992,64 @@ contains ! do i = its,ite ad(i,1) = 1. - f1(i,1) = thx(i,1)-300.+hfx(i)/(rhox(i)*cpm(i))/zq(i,2)*dt2 - f3(i,1,1) = qx(i,1)+qfx(i)/(rhox(i))/zq(i,2)*dt2 + f3(i,1,1) = qx(i,1)+qfx(i)*g/del(i,1)*dt2 enddo ! - if(ncloud.ge.2) then - do ic = 2,ncloud + if(ndiff.ge.2) then + do ic = 2,ndiff + is = (ic-1) * kte do i = its,ite - if(ic.eq.2) then - f3(i,1,ic) = qcx(i,1) - elseif(ic.eq.3) then - f3(i,1,ic) = qix(i,1) - endif + f3(i,1,ic) = qx(i,1+is) enddo enddo endif ! + do k = kts,kte + do i = its,ite + if(k.lt.kpbl(i)) then + xkzq(i,k) = xkzh(i,k)*zfac(i,k)**(pfac_q-pfac) + else + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! do k = kts,kte-1 do i = its,ite dtodsd = dt2/del(i,k) dtodsu = dt2/del(i,k+1) dsig = p2d(i,k)-p2d(i,k+1) rdz = 1./dza(i,k+1) - tem1 = dsig*xkzh(i,k)*rdz + tem1 = dsig*xkzq(i,k)*rdz if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) - dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzh(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzt - f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzmin) - f1(i,k+1) = thx(i,k+1)-300. + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + xkzq(i,k) = max(xkzq(i,k),xkzmin) f3(i,k+1,1) = qx(i,k+1) else - f1(i,k+1) = thx(i,k+1)-300. f3(i,k+1,1) = qx(i,k+1) endif + tem1 = dsig*xkzq(i,k)*rdz dsdz2 = tem1*rdz au(i,k) = -dtodsd*dsdz2 al(i,k) = -dtodsu*dsdz2 ad(i,k) = ad(i,k)-au(i,k) ad(i,k+1) = 1.-al(i,k) - exch_hx(i,k+1) = xkzh(i,k) +! exch_hx(i,k+1) = xkzh(i,k) enddo enddo ! - if(ncloud.ge.2) then - do ic = 2,ncloud + if(ndiff.ge.2) then + do ic = 2,ndiff + is = (ic-1) * kte do k = kts,kte-1 do i = its,ite - if(ic.eq.2) then - f3(i,k+1,ic) = qcx(i,k+1) - elseif(ic.eq.3) then - f3(i,k+1,ic) = qix(i,k+1) - endif + f3(i,k+1,ic) = qx(i,k+1+is) enddo enddo enddo @@ -1014,11 +1060,10 @@ contains do k = kts,kte do i = its,ite cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) enddo enddo ! - do ic = 1,ncloud + do ic = 1,ndiff do k = kts,kte do i = its,ite r3(i,k,ic) = f3(i,k,ic) @@ -1026,32 +1071,27 @@ contains enddo enddo ! -! solve tridiagonal problem for heat and moisture, and clouds +! solve tridiagonal problem for moisture, clouds, and tracers ! - call tridin(al,ad,cu,r1,r3,au,f1,f3,its,ite,kts,kte,ncloud) + call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) ! ! recover tendencies of heat and moisture ! do k = kte,kts,-1 do i = its,ite - ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) qtend = (f3(i,k,1)-qx(i,k))*rdt - ttnp(i,k) = ttnp(i,k)+ttend qtnp(i,k) = qtnp(i,k)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) enddo enddo ! - if(ncloud.ge.2) then - do ic = 2,ncloud + if(ndiff.ge.2) then + do ic = 2,ndiff + is = (ic-1) * kte do k = kte,kts,-1 do i = its,ite - if(ic.eq.2) then - qctend = (f3(i,k,ic)-qcx(i,k))*rdt - qctnp(i,k) = qctnp(i,k)+qctend - elseif(ic.eq.3) then - qitend = (f3(i,k,ic)-qix(i,k))*rdt - qitnp(i,k) = qitnp(i,k)+qitend - endif + qtend = (f3(i,k,ic)-qx(i,k+is))*rdt + qtnp(i,k+is) = qtnp(i,k+is)+qtend enddo enddo enddo @@ -1070,11 +1110,10 @@ contains enddo ! do i = its,ite - ad(i,1) = 1. - f1(i,1) = ux(i,1)-ux(i,1)/wspd1(i)*ust(i)*ust(i)/zq(i,2)*dt2 & - *(wspd1(i)/wspd(i))**2 - f2(i,1) = vx(i,1)-vx(i,1)/wspd1(i)*ust(i)*ust(i)/zq(i,2)*dt2 & - *(wspd1(i)/wspd(i))**2 + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1) + f2(i,1) = vx(i,1) enddo ! do k = kts,kte-1 @@ -1102,6 +1141,7 @@ contains f1(i,k+1) = ux(i,k+1) f2(i,k+1) = vx(i,k+1) endif + tem1 = dsig*xkzm(i,k)*rdz dsdz2 = tem1*rdz au(i,k) = -dtodsd*dsdz2 al(i,k) = -dtodsu*dsdz2 @@ -1122,7 +1162,7 @@ contains ! ! solve tridiagonal problem for momentum ! - call tridin(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) + call tridi1n(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) ! ! recover tendencies of momentum ! @@ -1132,6 +1172,8 @@ contains vtend = (f2(i,k)-vx(i,k))*rdt utnp(i,k) = utnp(i,k)+utend vtnp(i,k) = vtnp(i,k)+vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) enddo enddo ! @@ -1143,7 +1185,7 @@ contains ! end subroutine ysu2d ! - subroutine tridin(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) !---------------------------------------------------------------- implicit none !---------------------------------------------------------------- @@ -1223,7 +1265,68 @@ contains enddo enddo ! - end subroutine tridin + end subroutine tridi1n +! + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!---------------------------------------------------------------- + implicit none +!---------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real, dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real, dimension( its:ite, kts:kte ) , & + intent(in ) :: cm + real, dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real, dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu + real, dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real :: fk + integer :: i,k,l,n,it +! +!---------------------------------------------------------------- +! + l = ite + n = kte +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu ! subroutine ysuinit(rublten,rvblten,rthblten,rqvblten, & rqcblten,rqiblten,p_qi,p_first_scalar, & diff --git a/wrfv2_fire/phys/module_cu_g3.F b/wrfv2_fire/phys/module_cu_g3.F index 538d63d4..762d87cb 100644 --- a/wrfv2_fire/phys/module_cu_g3.F +++ b/wrfv2_fire/phys/module_cu_g3.F @@ -16,18 +16,24 @@ CONTAINS ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS & ,APR_CAPMA,APR_CAPME,APR_CAPMI & ,MASS_FLUX,XF_ENS,PR_ENS,HT,XLAND,gsw,edt_out & - ,GDC,GDC2 & + ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow & + ,ktop_shallow,xmb_shallow & ,cugd_tten,cugd_qvten ,cugd_qcten & ,cugd_ttens,cugd_qvtens,cugd_avedx,imomentum & ,ensdim,maxiens,maxens,maxens2,maxens3,ichoice & - ,ids,ide, jds,jde, kds,kde & + ,ishallow_g3,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,ips,ipe, jps,jpe, kps,kpe & ,its,ite, jts,jte, kts,kte & ,periodic_x,periodic_y & ,RQVCUTEN,RQCCUTEN,RQICUTEN & ,RQVFTEN,RTHFTEN,RTHCUTEN & + ,rqvblten,rthblten & ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & +#if ( WRF_DFI_RADAR == 1 ) + ! Optional CAP suppress option + ,do_capsuppress,cap_suppress_loc & +#endif ) !------------------------------------------------------------- IMPLICIT NONE @@ -44,7 +50,8 @@ CONTAINS integer, intent (in ) :: & ensdim,maxiens,maxens,maxens2,maxens3,ichoice - INTEGER, INTENT(IN ) :: STEPCU, ITIMESTEP,cugd_avedx,imomentum + INTEGER, INTENT(IN ) :: STEPCU, ITIMESTEP,cugd_avedx, & + ishallow_g3,imomentum LOGICAL, INTENT(IN ) :: warm_rain REAL, INTENT(IN ) :: XLV, R_v @@ -68,6 +75,9 @@ CONTAINS GDC,GDC2 REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: GSW,HT,XLAND + INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL + INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT) :: k22_shallow, & + kbcon_shallow,ktop_shallow ! REAL, INTENT(IN ) :: DT, DX ! @@ -75,7 +85,8 @@ CONTAINS REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: pratec,RAINCV, MASS_FLUX, & APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & - edt_out,APR_CAPMA,APR_CAPME,APR_CAPMI,htop,hbot + edt_out,APR_CAPMA,APR_CAPME,APR_CAPMI, & + htop,hbot,xmb_shallow !+lxz ! REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) :: & ! HTOP, &! highest model layer penetrated by cumulus since last reset in radiation_driver @@ -100,6 +111,8 @@ CONTAINS INTENT(INOUT) :: & RTHCUTEN, & RQVCUTEN, & + RQVBLTEN, & + RTHBLTEN, & RQCCUTEN, & RQICUTEN ! @@ -117,6 +130,18 @@ CONTAINS ,F_QS +#if ( WRF_DFI_RADAR == 1 ) +! +! option of cap suppress: +! do_capsuppress = 1 do +! do_capsuppress = other don't +! +! + INTEGER, INTENT(IN ) ,OPTIONAL :: do_capsuppress + REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN ),OPTIONAL :: cap_suppress_loc + REAL, DIMENSION( its:ite ) :: cap_suppress_j +#endif + ! LOCAL VARS real, dimension(ims:ime,jms:jme,1:ensdim),intent(inout) :: & @@ -127,13 +152,13 @@ CONTAINS APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS, & edti_out,APRi_CAPMA,APRi_CAPME,APRi_CAPMI,gswi real, dimension (its:ite,kts:kte) :: & - SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw - real, dimension (its:ite,kts:kte+1) :: phf + SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw,dhdt, & + outts,outqs real, dimension (its:ite) :: & pret, ter11, aa0, fp,xlandi !+lxz integer, dimension (its:ite) :: & - kbcon, ktop + kbcon, ktop,kpbli,k22s,kbcons,ktops !.lxz integer, dimension (its:ite,jts:jte) :: & iact_old_gr @@ -147,24 +172,28 @@ CONTAINS ! convection for this call only and at that particular gridpoint ! real, dimension (its:ite,kts:kte) :: & - T2d,q2d,PO,P2d,US,VS,tn,qo + T2d,q2d,PO,P2d,US,VS,tn,qo,tshall,qshall real, dimension (ips-2:ipe+2,kps:kpe,jps-2:jpe+2) :: & ave_f_t,ave_f_q real, dimension (its:ite,kts:kte,1:ens4) :: & omeg,tx,qx real, dimension (its:ite) :: & - Z1,PSUR,AAEQ,direction,cuten,umean,vmean,pmean + Z1,PSUR,AAEQ,direction,cuten,umean,vmean,pmean,xmbs real, dimension (its:ite,1:ens4) :: & mconv INTEGER :: i,j,k,ICLDCK,ipr,jpr - REAL :: tcrit,dp,dq,sub_spread,subcenter + REAL :: tcrit,tscl_KF,dp,dq,sub_spread,subcenter INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend INTEGER :: high_resolution REAL :: rkbcon,rktop !-lxz ! ruc variable real, dimension (its:ite) :: tkm + ! A. Betts for shallow convection: suggestion for the KF timescale < DELTAX / 25 m/s + tscl_kf=dx/25. + ! +! write(0,*)'ishallow = ',ishallow_g3 high_resolution=0 if(cugd_avedx.gt.1) high_resolution=1 subcenter=0. @@ -202,6 +231,12 @@ CONTAINS jbegc=max(jts,jds+4) jendc=min(jte,jde-5) END IF + do j=jts,jte + do i=its,ite + ktop_shallow(i,j)=0 + xmb_shallow(i,j)=0 + enddo + enddo tcrit=258. ave_f_t=0. ave_f_q=0. @@ -253,6 +288,8 @@ CONTAINS kbcon(i)=0 ktop(i)=0 tkm(i)=0. + HBOT(I,J) =REAL(KTE) + HTOP(I,J) =REAL(KTS) iact_old_gr(i,j)=0 mass_flux(i,j)=0. massi_flx(i,j)=0. @@ -298,42 +335,15 @@ CONTAINS massflni(i,j,k)=0. ENDDO ENDDO -#if ( EM_CORE == 1 ) - ! hydrostatic pressure, first on full levels - DO I=ITS,ITF - phf(i,1) = p8w(i,1,j) - ENDDO - ! integrate up, dp = -rho * g * dz - DO K=kts+1,ktf+1 - DO I=ITS,ITF - phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) - ENDDO - ENDDO - ! scale factor so that pressure is not zero after integration - DO I=ITS,ITF - fp(i) = (p8w(i,kts,j)-p8w(i,kte,j))/(phf(i,kts)-phf(i,kte)) - ENDDO - ! re-integrate up, dp = -rho * g * dz * scale_factor - DO K=kts+1,ktf+1 - DO I=ITS,ITF - phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) * fp(i) - ENDDO - ENDDO ! put hydrostatic pressure on half levels DO K=kts,ktf DO I=ITS,ITF - phh(i,k) = (phf(i,k) + phf(i,k+1))*0.5 + phh(i,k) = p(i,k,j) ENDDO ENDDO -#endif DO I=ITS,ITF -#if ( EM_CORE == 1 ) PSUR(I)=p8w(I,1,J)*.01 -#endif -#if ( NMM_CORE == 1 ) - PSUR(I)=p(I,1,J)*.01 -#endif ! PSUR(I)=p(I,1,J)*.01 TER11(I)=HT(i,j) aaeq(i)=0. @@ -342,16 +352,11 @@ CONTAINS umean(i)=0. vmean(i)=0. pmean(i)=0. + kpbli(i)=kpbl(i,j) ENDDO DO K=kts,ktf DO I=ITS,ITF -#if ( EM_CORE == 1 ) po(i,k)=phh(i,k)*.01 -#endif - -#if ( NMM_CORE == 1 ) - po(i,k)=p(i,k,j)*.01 -#endif subm(i,k)=0. P2d(I,K)=PO(i,k) US(I,K) =u(i,k,j) @@ -364,8 +369,13 @@ CONTAINS OUTT(I,K)=0. OUTQ(I,K)=0. OUTQC(I,K)=0. + OUTTS(I,K)=0. + OUTQS(I,K)=0. TN(I,K)=t2d(i,k)+RTHFTEN(i,k,j)*dt QO(I,K)=q2d(i,k)+RQVFTEN(i,k,j)*dt + TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt + DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j) + QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt if(high_resolution.eq.1)then TN(I,K)=t2d(i,k)+ave_f_t(i,k,j)*dt QO(I,K)=q2d(i,k)+ave_f_q(i,k,j)*dt @@ -436,8 +446,17 @@ CONTAINS ! !---- CALL CUMULUS PARAMETERIZATION ! +#if ( WRF_DFI_RADAR == 1 ) + if(do_capsuppress == 1 ) then + DO I= its,itf + cap_suppress_j(i)=cap_suppress_loc(i,j) + ENDDO + endif +#endif CALL CUP_enss_3d(outqc,j,AAEQ,T2d,Q2d,TER11,subm,TN,QO,PO,PRET,& P2d,OUTT,OUTQ,DT,itimestep,tkm,PSUR,US,VS,tcrit,iens,tx,qx, & + tshall,qshall,kpbli,DHDT,outts,outqs,tscl_kf, & + k22s,kbcons,ktops,xmbs, & mconv,massflni,iact_old_gr,omeg,direction,MASSi_FLX, & maxiens,maxens,maxens2,maxens3,ensdim, & APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS, & @@ -445,12 +464,20 @@ CONTAINS xfi_ens,pri_ens,XLANDi,gswi,edti_out,subt,subq, & ! ruc lv_p,rv_p,cpd_p,g0_p,ichoice,ipr,jpr, & xlv,r_v,cp,g,ichoice,ipr,jpr,ens4,high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) + ishallow_g3,itf,jtf,ktf, & + its,ite, jts,jte, kts,kte & +#if ( WRF_DFI_RADAR == 1 ) + ,do_capsuppress,cap_suppress_j & +#endif + ) if(j.lt.jbegc.or.j.gt.jendc)go to 100 DO I=ibegc,iendc + xmb_shallow(i,j)=xmbs(i) + k22_shallow(i,j)=k22s(i) + kbcon_shallow(i,j)=kbcons(i) + ktop_shallow(i,j)=ktops(i) cuten(i)=0. if(pret(i).gt.0.)then cuten(i)=1. @@ -461,8 +488,10 @@ CONTAINS DO K=kts,ktf cugd_ttens(I,K,J)=subt(i,k)*cuten(i)*sub_spread cugd_qvtens(I,K,J)=subq(i,k)*cuten(i)*sub_spread - cugd_tten(I,K,J)=outt(i,k)*cuten(i) - cugd_qvten(I,K,J)=outq(i,k)*cuten(i) +! cugd_tten(I,K,J)=outt(i,k)*cuten(i) +! cugd_qvten(I,K,J)=outq(i,k)*cuten(i) + cugd_tten(I,K,J)=outts(i,k)+outt(i,k)*cuten(i) + cugd_qvten(I,K,J)=outqs(i,k)+outq(i,k)*cuten(i) cugd_qcten(I,K,J)=outqc(i,k)*cuten(i) ENDDO ENDDO @@ -533,15 +562,23 @@ CONTAINS SUBROUTINE CUP_enss_3d(OUTQC,J,AAEQ,T,Q,Z1,sub_mas, & TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,ktau,tkmax,PSUR,US,VS, & - TCRIT,iens,tx,qx,mconv,massfln,iact, & + TCRIT,iens,tx,qx, & + tshall,qshall,kpbl,dhdt,outts,outqs,tscl_kf, & + k23,kbcon3,ktop3,xmb3, & + mconv,massfln,iact, & omeg,direction,massflx,maxiens, & maxens,maxens2,maxens3,ensdim, & APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,cupclw, & !-lxz xf_ens,pr_ens,xland,gsw,edt_out,subt,subq, & xl,rv,cp,g,ichoice,ipr,jpr,ens4,high_resolution, & - itf,jtf,ktf, & - its,ite, jts,jte, kts,kte ) + ishallow_g3,itf,jtf,ktf, & + its,ite, jts,jte, kts,kte & +#if ( WRF_DFI_RADAR == 1 ) + ! Optional CAP suppress option + ,do_capsuppress,cap_suppress_j & +#endif + ) IMPLICIT NONE @@ -550,7 +587,7 @@ CONTAINS itf,jtf,ktf,ktau, & its,ite, jts,jte, kts,kte,ipr,jpr,ens4,high_resolution integer, intent (in ) :: & - j,ensdim,maxiens,maxens,maxens2,maxens3,ichoice,iens + j,ensdim,maxiens,ishallow_g3,maxens,maxens2,maxens3,ichoice,iens ! ! ! @@ -573,15 +610,16 @@ CONTAINS ! pre = output precip real, dimension (its:ite,kts:kte) & ,intent (inout ) :: & - OUTT,OUTQ,OUTQC,subt,subq,sub_mas,cupclw + DHDT,OUTT,OUTQ,OUTQC,subt,subq,sub_mas,cupclw,outts,outqs real, dimension (its:ite) & ,intent (out ) :: & - pre -!+lxz + pre,xmb3 integer, dimension (its:ite) & ,intent (out ) :: & - kbcon,ktop -!.lxz + kbcon,ktop,k23,kbcon3,ktop3 + integer, dimension (its:ite) & + ,intent (in ) :: & + kpbl ! ! basic environmental input includes moisture convergence (mconv) ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off @@ -589,7 +627,7 @@ CONTAINS ! real, dimension (its:ite,kts:kte) & ,intent (in ) :: & - T,PO,P,US,VS,tn + T,PO,P,US,VS,tn,tshall,qshall real, dimension (its:ite,kts:kte,1:ens4) & ,intent (inout ) :: & omeg,tx,qx @@ -606,8 +644,18 @@ CONTAINS real & ,intent (in ) :: & - dtime,tcrit,xl,cp,rv,g + dtime,tcrit,xl,cp,rv,g,tscl_kf +#if ( WRF_DFI_RADAR == 1 ) +! +! option of cap suppress: +! do_capsuppress = 1 do +! do_capsuppress = other don't +! +! + INTEGER, INTENT(IN ) ,OPTIONAL :: do_capsuppress + REAL, DIMENSION( its:ite ),INTENT(IN ) ,OPTIONAL :: cap_suppress_j +#endif ! ! local ensemble dependent variables in this routine @@ -691,6 +739,15 @@ CONTAINS ! hc = cloud moist static energy ! hkb = moist static energy at originating level ! mentr_rate = entrainment rate + real, dimension (its:ite,kts:kte) :: & + he3,hes3,qes3,z3,zdo3, & + qes3_cup,q3_cup,he3_cup,hes3_cup,z3_cup,gamma3_cup,t3_cup, & + xhe3,xhes3,xqes3,xz3,xt3,xq3, & + xqes3_cup,xq3_cup,xhe3_cup,xhes3_cup,xz3_cup,xgamma3_cup, & + xt3_cup, & + xdby3,xqc3,xhc3,xqrc3,xzu3, & + dby3,qc3,pw3,hc3,qrc3,zu3,cd3,DELLAH3,DELLAQ3, & + dsubt3,dsubq3,DELLAT3,DELLAQC3 real, dimension (its:ite,kts:kte) :: & he,hes,qes,z, & @@ -721,30 +778,36 @@ CONTAINS ! aa1 = cloud work function with forcing effects ! xaa0 = cloud work function with cloud effects (ensemble dependent) ! edt = epsilon + real, dimension (its:ite) :: & - edt,edto,edtx,AA1,AA0,XAA0,HKB,HKBO,aad,XHKB,QKB,QKBO, & - XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,PWEVO,BU,BUO,cap_max,xland1, & - cap_max_increment,closure_n + aa3,hkb3,qkb3,pwav3,bu3,xaa3,xhkb3, & + edt,edto,edtx,AA1,AA0,XAA0,HKB, & + HKBO,aad,XHKB,QKB,QKBO,edt3, & + XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO, & + PWEVO,BU,BUO,cap_max,xland1, & + cap_max_increment,closure_n,cap_max3 real, dimension (its:ite,1:ens4) :: & axx integer, dimension (its:ite) :: & - kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x, & !-lxz - KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX + kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x,jmin3,kdet3, & !-lxz + KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX,ierr5 integer :: & nall,iedt,nens,nens3,ki,I,K,KK,iresult real :: & day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate, & zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop, & - massfld,dh,cap_maxs,trash + massfld,dh,cap_maxs,trash,entr_rate3,mentr_rate3 integer :: jmini logical :: keep_going + real xff_shal(9),blqe,xkshal day=86400. do i=its,itf + xmb3(i)=0. closure_n(i)=16. xland1(i)=1. if(xland(i).gt.1.5)xland1(i)=0. @@ -763,12 +826,14 @@ CONTAINS !--- gross entrainment rate (these may be changed later on in the !--- program, depending what your detrainment is!!) ! - entr_rate=.2/radius + entr_rate =.2/radius + entr_rate3=.2/500. ! !--- entrainment of mass ! mentrd_rate=0. mentr_rate=entr_rate + mentr_rate3=entr_rate3 ! !--- initial detrainmentrates ! @@ -776,7 +841,9 @@ CONTAINS do i=its,itf cupclw(i,k)=0. cd(i,k)=0.01*entr_rate + cd3(i,k)=entr_rate3 cdd(i,k)=0. + zdo3(i,k)=0. enddo enddo ! @@ -797,14 +864,18 @@ CONTAINS cap_maxs=75. DO i=its,itf kbmax(i)=1 + jmin3(i)=0 + kdet3(i)=0 aa0(i)=0. aa1(i)=0. + aa3(i)=0. aad(i)=0. edt(i)=0. kstabm(i)=ktf-1 IERR(i)=0 IERR2(i)=0 IERR3(i)=0 + IERR5(i)=0 if(aaeq(i).lt.-0.1)then ierr(i)=20 endif @@ -812,12 +883,38 @@ CONTAINS ! !--- first check for upstream convection ! +#if ( WRF_DFI_RADAR == 1 ) + if(do_capsuppress == 1) then + do i=its,itf + cap_max(i)=cap_maxs + cap_max3(i)=25. + if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25. + if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then + cap_max(i)=cap_maxs+75. + elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then + cap_max(i)=10.0 + endif + iresult=0 + enddo + else + do i=its,itf + cap_max(i)=cap_maxs + if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25. + iresult=0 + enddo + endif + + do i=its,itf + edt_out(i,j)=cap_max(i) + enddo +#else do i=its,itf cap_max(i)=cap_maxs if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25. iresult=0 enddo +#endif ! !--- max height(m) above ground where updraft air can originate ! @@ -1064,7 +1161,7 @@ CONTAINS ! !--- calculate moisture properties of updraft ! - call cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & + call cup_up_moisture('deep',ierr,z_cup,qc,qrc,pw,pwav, & kbcon,ktop,cd,dby,mentr_rate,clw_all, & q,GAMMA_cup,zu,qes_cup,k22,q_cup,xl, & itf,jtf,ktf, & @@ -1074,7 +1171,7 @@ CONTAINS cupclw(i,k)=qrc(i,k) enddo enddo - call cup_up_moisture(ierr,zo_cup,qco,qrco,pwo,pwavo, & + call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, & kbcon,ktop,cd,dbyo,mentr_rate,clw_all, & qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,& itf,jtf,ktf, & @@ -1097,6 +1194,227 @@ CONTAINS endif endif enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! NEXT section for shallow convection +! + if(ishallow_g3.eq.1)then +! write(0,*)'now do shallow for j = ',j + call cup_env(z3,qes3,he3,hes3,tshall,qshall,po,z1, & + psur,ierr5,tcrit,0,xl,cp, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_env_clev(tshall,qes3,qshall,he3,hes3,z3,po,qes3_cup,q3_cup, & + he3_cup,hes3_cup,z3_cup,po_cup,gamma3_cup,t3_cup,psur, & + ierr5,z1,xl,rv,cp, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + CALL cup_MAXIMI(HE3_CUP,1,kbmax,K23,ierr5, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + DO i=its,itf + if(kpbl(i).gt.1)cap_max3(i)=po_cup(i,kpbl(i)) + IF(ierr5(I).eq.0.)THEN + IF(K23(I).Gt.Kbmax(i))ierr5(i)=2 +! if(kpbl(i).gt.5)k23(i)=kpbl(i) + endif + ENDDO + call cup_kbcon(cap_max_increment,5,k23,kbcon3,he3_cup,hes3_cup, & + ierr5,kbmax,po_cup,cap_max3, & +! ierr5,kpbl,po_cup,cap_max3, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_up_he(k23,hkb3,z3_cup,cd3,mentr_rate3,he3_cup,hc3, & + kbcon3,ierr5,dby3,he3,hes3_cup, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_ktop(1,dby3,kbcon3,ktop3,ierr5, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_up_nms(zu3,z3_cup,mentr_rate3,cd3,kbcon3,ktop3, & + ierr5,k23, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_up_moisture('shallow',ierr5,z3_cup,qc3,qrc3,pw3,pwav3, & + kbcon3,ktop3,cd3,dby3,mentr_rate3,clw_all, & + qshall,GAMMA3_cup,zu3,qes3_cup,k23,q3_cup,xl,& + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_up_aa0(aa3,z3,zu3,dby3,GAMMA3_CUP,t3_cup, & + kbcon3,ktop3,ierr5, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + do i=its,itf + if(ierr5(i).eq.0)then + if(aa3(i).eq.0.)then + ierr5(i)=17 + endif + endif + enddo +! call cup_dellabot('shallow',ipr,jpr,q3_cup,ierr5,z3_cup,po,qrcdo,edto, & +! zdo,cdd,q3,dellaq3,dsubq,j,mentrd_rate,z3,g,& +! itf,jtf,ktf, & +! its,ite, jts,jte, kts,kte) + call cup_dellas_3d(ierr5,z3_cup,po_cup,hcdo,edt3,zdo3,cdd, & + he3,dellah3,dsubt3,j,mentrd_rate,zu3,g, & + cd3,hc3,ktop3,k23,kbcon3,mentr_rate3,jmin,he3_cup,kdet, & + k23,ipr,jpr,'shallow',0, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_dellas_3d(ierr5,z3_cup,po_cup,qrcdo,edt3,zdo3,cdd, & + qshall,dellaq3,dsubq3,j,mentrd_rate,zu3,g, & + cd3,qc3,ktop3,k23,kbcon3,mentr_rate3,jmin,q3_cup,kdet, & + k23,ipr,jpr,'shallow',0, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte ) + mbdt=mbdt_ens(1) + do k=kts,ktf + do i=its,itf + dellat3(i,k)=0. + if(ierr5(i).eq.0)then + trash=dsubt3(i,k) + XHE3(I,K)=(dsubt3(i,k)+DELLAH3(I,K))*MBDT+HE3(I,K) + XQ3(I,K)=(dsubq3(i,k)+DELLAQ3(I,K))*MBDT+QSHALL(I,K) + DELLAT3(I,K)=(1./cp)*(DELLAH3(I,K)-xl*DELLAQ3(I,K)) + dSUBT3(I,K)=(1./cp)*(dsubt3(i,k)-xl*dsubq3(i,k)) + XT3(I,K)= (DELLAT3(I,K)+dsubt3(i,k))*MBDT+TSHALL(I,K) + IF(XQ3(I,K).LE.0.)XQ3(I,K)=1.E-08 + if(i.eq.ipr.and.j.eq.jpr)then + write(0,*)k,trash,DELLAQ3(I,K),dsubq3(I,K),dsubt3(i,k) + endif + ENDIF + enddo + enddo + do i=its,itf + if(ierr5(i).eq.0)then + XHE3(I,ktf)=HE3(I,ktf) + XQ3(I,ktf)=QSHALL(I,ktf) + XT3(I,ktf)=TSHALL(I,ktf) + IF(XQ3(I,ktf).LE.0.)XQ3(I,ktf)=1.E-08 + endif + enddo +! +!--- calculate moist static energy, heights, qes +! + call cup_env(xz3,xqes3,xhe3,xhes3,xt3,xq3,po,z1, & + psur,ierr5,tcrit,2,xl,cp, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) +! +!--- environmental values on cloud levels +! + call cup_env_clev(xt3,xqes3,xq3,xhe3,xhes3,xz3,po,xqes3_cup,xq3_cup, & + xhe3_cup,xhes3_cup,xz3_cup,po_cup,gamma3_cup,xt3_cup,psur, & + ierr5,z1,xl,rv,cp, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) +! +! +!**************************** static control +! +!--- moist static energy inside cloud +! + do i=its,itf + if(ierr5(i).eq.0)then + xhkb3(i)=xhe3(i,k23(i)) + endif + enddo + call cup_up_he(k23,xhkb3,xz3_cup,cd3,mentr_rate3,xhe3_cup,xhc3, & + kbcon3,ierr5,xdby3,xhe3,xhes3_cup, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) +! +!c--- normalized mass flux profile and CWF +! + call cup_up_nms(xzu3,xz3_cup,mentr_rate3,cd3,kbcon3,ktop3,ierr5,k23, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) + call cup_up_aa0(xaa3,xz3,xzu3,xdby3,GAMMA3_CUP,xt3_cup, & + kbcon3,ktop3,ierr5, & + itf,jtf,ktf, & + its,ite, jts,jte, kts,kte) +! +! now for shallow forcing +! + do i=its,itf + xmb3(i)=0. + xff_shal(1:9)=0. + if(ierr5(i).eq.0)then + xkshal=(xaa3(i)-aa0(i))/mbdt + if(xkshal.le.0.and.xkshal.gt.-1.e-6)xkshal=-1.e-6 + if(xkshal.gt.0.and.xkshal.lt.+1.e-6)xkshal=+1.e-6 + xff_shal(1)=max(0.,-(aa3(i)-aa0(i))/(xkshal*dtime)) + xff_shal(2)=max(0.,-(aa3(i)-aa0(i))/(xkshal*dtime)) + xff_shal(3)=max(0.,-(aa3(i)-aa0(i))/(xkshal*dtime)) + xff_shal(4)=max(0.,-aa3(i)/(xkshal*tscl_KF)) + xff_shal(5)=max(0.,-aa3(i)/(xkshal*tscl_KF)) + xff_shal(6)=max(0.,-aa3(i)/(xkshal*tscl_KF)) +! boundary layer QE (from Saulo Freitas) + blqe=0. + if(k23(i).lt.kpbl(i)+1)then + do k=1,kbcon3(i)-1 + blqe=blqe+100.*dhdt(i,k)*(p_cup(i,k)-p_cup(i,k+1))/g + enddo + trash=max((hc3(i,kbcon3(i))-he_cup(i,kbcon3(i))),1.e-4) + xff_shal(7)=max(0.,blqe/trash) + xff_shal(7)=min(0.5,xff_shal(7)) + else + xff_shal(7)=0. + endif + xff_shal(8)= xff_shal(7) + xff_shal(9)= xff_shal(7) + do k=1,9 + xmb3(i)=xmb3(i)+xff_shal(k) + enddo + xmb3(i)=min(.1,xmb3(i)/9.) + if(xmb3(i).eq.0.)ierr5(i)=22 + if(xmb3(i).lt.0.)then + ierr5(i)=21 +! write(0,*)'neg xmb,i,j,xmb3 for shallow = ',i,j,k23(i),ktop3(i),kbcon3(i),kpbl(i) + endif + endif +! if(ierr5(i).eq.0)write(0,*)'i,j,xmb3 for shallow = ',i,j,xmb3(i),k23(i),ktop3(i) +! if(ierr5(i).eq.0.and.i.eq.12.and.j.eq.25)write(0,*)'i,j,xmb3 for shallow = ',k23(i),ktop3(i),kbcon3(i),kpbl(i) +! if(ierr5(i).eq.0)write(0,*)'i,j,xmb3 for shallow = ',i,j,k23(i),ktop3(i),kbcon3(i),kpbl(i) + if(ierr5(i).eq.0)then +! +! got the mass flux, now do feedback + trash=0. +! + do k=2,ktop3(i) + trash=max(trash,86400.*(dsubt3(i,k)+dellat3(i,k))*xmb3(i)) + enddo + if(trash.gt.150.)xmb3(i)=xmb3(i)*150./trash + do k=2,ktop3(i) + outts(i,k)=(dsubt3(i,k)+dellat3(i,k))*xmb3(i) + outqs(i,k)=(dsubq3(i,k)+dellaq3(i,k))*xmb3(i) + enddo + endif + enddo + if(j.eq.-25)then + write(0,*)'!!!!!!!! j = ',j,' !!!!!!!!!!!!!!!!!!!!' + i=12 + write(0,*)k23(i),kbcon3(i),ktop3(i) + write(0,*)kpbl(i),ierr5(i),ierr(i) + write(0,*)xmb3(i),xff_shal(1:9) + write(0,*)xaa3(i),aa1(i),aa0(i),aa3(i) + do k=1,ktf + write(0,*)po(i,k),he3(i,k),hes3(i,k),dellah3(i,k) + enddo + do k=1,ktf + write(0,*)zu3(i,k),hc3(i,k),dsubt3(i,k),dellat3(i,k) + enddo + do k=1,ktop3(i)+1 + blqe=cp*outts(i,k)+xl*outqs(i,k) + write(0,*)outts(i,k),outqs(i,k),blqe + enddo + endif +! +! done shallow +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ENDIF +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call cup_axx(tcrit,kbmax,z1,p,psur,xl,rv,cp,tx,qx,axx,ierr, & cap_max,cap_max_increment,entr_rate,mentr_rate,& j,itf,jtf,ktf, & @@ -1159,11 +1477,11 @@ CONTAINS ! !--- 1. in bottom layer ! - call cup_dellabot(ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, & + call cup_dellabot('deep',ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, & zdo,cdd,heo,dellah,dsubt,j,mentrd_rate,zo,g, & itf,jtf,ktf, & its,ite, jts,jte, kts,kte) - call cup_dellabot(ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, & + call cup_dellabot('deep',ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, & zdo,cdd,qo,dellaq,dsubq,j,mentrd_rate,zo,g,& itf,jtf,ktf, & its,ite, jts,jte, kts,kte) @@ -1299,7 +1617,7 @@ CONTAINS ! !------- MOISTURE updraft ! - call cup_up_moisture(ierr,xz_cup,xqc,xqrc,xpw,xpwav, & + call cup_up_moisture('deep',ierr,xz_cup,xqc,xqrc,xpw,xpwav, & kbcon,ktop,cd,xdby,mentr_rate,clw_all, & xq,GAMMA_cup,xzu,xqes_cup,k22,xq_cup,xl, & itf,jtf,ktf, & @@ -1429,6 +1747,16 @@ CONTAINS its,ite, jts,jte, kts,kte) k=1 do i=its,itf + if(ierr(i).eq.0.and.ierr5(i).eq.0.and.kbcon(i).lt.ktop3(i)+1)then +! write(0,*)'both ier and ier5=0 at i,j=',i,j,kbcon(i),ktop3(i) + if(high_resolution.eq.1)then + outts(i,kts:kte)=0. + outqs(i,kts:kte)=0. + endif + elseif (ierr5(i).eq.0)then +! write(0,*)'ier5=0 at i,j=',i,j,k23(i),ktop3(i) + endif + PRE(I)=MAX(PRE(I),0.) if(i.eq.ipr.and.j.eq.jpr)then write(0,*)'i,j,pre(i),aa0(i),aa1(i)' @@ -1965,7 +2293,7 @@ CONTAINS END SUBROUTINE cup_dd_nms - SUBROUTINE cup_dellabot(ipr,jpr,he_cup,ierr,z_cup,p_cup, & + SUBROUTINE cup_dellabot(name,ipr,jpr,he_cup,ierr,z_cup,p_cup, & hcd,edt,zd,cdd,he,della,subs,j,mentrd_rate,z,g, & itf,jtf,ktf, & its,ite, jts,jte, kts,kte ) @@ -1978,6 +2306,8 @@ CONTAINS its,ite, jts,jte, kts,kte integer, intent (in ) :: & j,ipr,jpr + character *(*), intent (in) :: & + name ! ! ierr error value, maybe modified in this routine ! @@ -2005,6 +2335,10 @@ CONTAINS totmas ! ! +! if(name.eq.'shallow')then +! edt(:)=0. +! cdd(:,:)=0. +! endif do 100 i=its,itf della(i,1)=0. subs(i,1)=0. @@ -2072,22 +2406,27 @@ CONTAINS ! local variables in this routine ! - integer i,k + integer i,k,kstart real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup, & detup,subdown,entdoj,entupk,detupk,totmas ! i=ipr - DO K=kts+1,ktf + kstart=kts+1 + if(name.eq.'shallow')kstart=kts + DO K=kstart,ktf do i=its,itf della(i,k)=0. subs(i,k)=0. enddo enddo ! +! no downdrafts for shallow convection +! DO 100 k=kts+1,ktf-1 DO 100 i=its,ite IF(ierr(i).ne.0)GO TO 100 IF(K.Gt.KTOP(I))GO TO 100 + if(k.lt.k22(i)-1.and.name.eq.'shallow')GO TO 100 ! !--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT !--- WITH ZD CALCULATIONS IN SOUNDD. @@ -2379,13 +2718,13 @@ CONTAINS ! real, dimension (its:ite,kts:kte) & ,intent (in ) :: & - p,t + p,t,q real, dimension (its:ite,kts:kte) & ,intent (out ) :: & he,hes,qes real, dimension (its:ite,kts:kte) & ,intent (inout) :: & - z,q + z real, dimension (its:ite) & ,intent (in ) :: & psur,z1 @@ -2427,7 +2766,8 @@ CONTAINS ! print *, 'P, E = ', P(I,K), E QES(I,K)=.622*E/(100.*P(I,K)-E) IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08 - IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K) + IF(QES(I,K).LT.Q(I,K))QES(I,K)=Q(I,K) +! IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K) TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K) endif enddo @@ -3204,7 +3544,7 @@ CONTAINS 31 CONTINUE KBCON(I)=KBCON(I)+1 IF(KBCON(I).GT.KBMAX(i)+2)THEN - if(iloop.lt.4)ierr(i)=3 + if(iloop.ne.4)ierr(i)=3 ! if(iloop.lt.4)ierr(i)=997 GO TO 27 ENDIF @@ -3217,6 +3557,10 @@ CONTAINS PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I)) plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i)) if(iloop.eq.4)plus=cap_max(i) +! +! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop + if(iloop.eq.5)plus=25. + if(iloop.eq.5.and.cap_max(i).gt.25)pbcdif=-P_cup(I,KBCON(I))+cap_max(i) IF(PBCDIF.GT.plus)THEN K22(I)=K22(I)+1 KBCON(I)=K22(I) @@ -3784,7 +4128,7 @@ CONTAINS END SUBROUTINE cup_up_he - SUBROUTINE cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, & + SUBROUTINE cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & kbcon,ktop,cd,dby,mentr_rate,clw_all, & q,GAMMA_cup,zu,qes_cup,k22,qe_cup,xl, & itf,jtf,ktf, & @@ -3830,6 +4174,8 @@ CONTAINS integer, dimension (its:ite) & ,intent (inout) :: & ierr + character *(*), intent (in) :: & + name ! qc = cloud q (including liquid water) after entrainment ! qrch = saturation q in cloud ! qrc = liquid water content in cloud after rainout @@ -3857,11 +4203,7 @@ CONTAINS ! !--- no precip for small clouds ! - if(mentr_rate.gt.0.)then - radius=.2/mentr_rate - if(radius.lt.900.)c0=0. -! if(radius.lt.900.)iall=0 - endif + if(name.eq.'shallow')c0=0. do i=its,itf pwav(i)=0. enddo diff --git a/wrfv2_fire/phys/module_cu_gd.F b/wrfv2_fire/phys/module_cu_gd.F index 11c1e199..b0720df4 100755 --- a/wrfv2_fire/phys/module_cu_gd.F +++ b/wrfv2_fire/phys/module_cu_gd.F @@ -26,7 +26,8 @@ CONTAINS ,RQVFTEN,RQVBLTEN & ,RTHFTEN,RTHCUTEN,RTHRATEN,RTHBLTEN & ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & - ) + ,CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,f_flux ) + !------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------- @@ -102,6 +103,15 @@ CONTAINS RQVCUTEN, & RQCCUTEN, & RQICUTEN + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + CFU1, & + CFD1, & + DFU1, & + EFU1, & + DFD1, & + EFD1 ! ! Flags relating to the optional tendency arrays declared above ! Models that carry the optional tendencies will provdide the @@ -115,6 +125,7 @@ CONTAINS ,F_QR & ,F_QI & ,F_QS + LOGICAL, intent(in), OPTIONAL :: f_flux @@ -122,8 +133,9 @@ CONTAINS real, dimension ( ims:ime , jms:jme , 1:ensdim) :: & massfln,xf_ens,pr_ens real, dimension (its:ite,kts:kte+1) :: & - OUTT,OUTQ,OUTQC,phh,cupclw - real, dimension (its:ite,kts:kte+1) :: phf + OUTT,OUTQ,OUTQC,phh,cupclw, & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1 + logical :: l_flux real, dimension (its:ite) :: & pret, ter11, aa0, fp !+lxz @@ -149,6 +161,14 @@ CONTAINS INTEGER :: itf,jtf,ktf REAL :: rkbcon,rktop !-lxz + l_flux=.FALSE. + if (present(f_flux)) l_flux=f_flux + if (l_flux) then + l_flux = l_flux .and. present(cfu1) .and. present(cfd1) & + .and. present(dfu1) .and. present(efu1) & + .and. present(dfd1) .and. present(efd1) + endif + ichoice=0 iens=1 ipr=0 @@ -197,40 +217,15 @@ CONTAINS RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j) ENDDO ENDDO - ! hydrostatic pressure, first on full levels - DO I=ITS,ITF - phf(i,1) = p8w(i,1,j) - ENDDO - ! integrate up, dp = -rho * g * dz - DO K=kts+1,ktf+1 - DO I=ITS,ITF - phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) - ENDDO - ENDDO - ! scale factor so that pressure is not zero after integration - DO I=ITS,ITF - fp(i) = (p8w(i,kts,j)-p8w(i,kte,j))/(phf(i,kts)-phf(i,kte)) - ENDDO - ! re-integrate up, dp = -rho * g * dz * scale_factor - DO K=kts+1,ktf+1 - DO I=ITS,ITF - phf(i,k) = phf(i,k-1) - rho(i,k-1,j) * g * dz8w(i,k-1,j) * fp(i) - ENDDO - ENDDO +#endif ! put hydrostatic pressure on half levels DO K=kts,ktf DO I=ITS,ITF - phh(i,k) = (phf(i,k) + phf(i,k+1))*0.5 + phh(i,k) = p(i,k,j) ENDDO ENDDO -#endif DO I=ITS,ITF -#if ( EM_CORE == 1 ) PSUR(I)=p8w(I,1,J)*.01 -#endif -#if ( NMM_CORE == 1 ) - PSUR(I)=p(I,1,J)*.01 -#endif TER11(I)=HT(i,j) mconv(i)=0. aaeq(i)=0. @@ -244,13 +239,7 @@ CONTAINS DO I=ITS,ITF omeg(i,k)=0. ! cupclw(i,k)=0. -#if ( EM_CORE == 1 ) po(i,k)=phh(i,k)*.01 -#endif - -#if ( NMM_CORE == 1 ) - po(i,k)=p(i,k,j)*.01 -#endif P2d(I,K)=PO(i,k) US(I,K) =u(i,k,j) VS(I,K) =v(i,k,j) @@ -305,6 +294,7 @@ CONTAINS APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop, & xf_ens,pr_ens,XLAND,gsw,cupclw, & xlv,r_v,cp,g,ichoice,ipr,jpr, & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,l_flux,& ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -366,6 +356,19 @@ CONTAINS ENDDO ENDIF ENDIF + + if (l_flux) then + DO K=kts,ktf + DO I=its,itf + cfu1(i,k,j)=outcfu1(i,k)*cuten(i) + cfd1(i,k,j)=outcfd1(i,k)*cuten(i) + dfu1(i,k,j)=outdfu1(i,k)*cuten(i) + efu1(i,k,j)=outefu1(i,k)*cuten(i) + dfd1(i,k,j)=outdfd1(i,k)*cuten(i) + efd1(i,k,j)=outefd1(i,k)*cuten(i) + enddo + enddo + endif endif !jbeg,jend 100 continue @@ -382,6 +385,7 @@ CONTAINS APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop, & !-lxz xf_ens,pr_ens,xland,gsw,cupclw, & xl,rv,cp,g,ichoice,ipr,jpr, & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -417,7 +421,9 @@ CONTAINS ! pre = output precip real, dimension (its:ite,kts:kte) & ,intent (out ) :: & - OUTT,OUTQ,OUTQC,CUPCLW + OUTT,OUTQ,OUTQC,CUPCLW, & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1 + logical, intent(in) :: l_flux real, dimension (its:ite) & ,intent (out ) :: & pre @@ -460,6 +466,8 @@ CONTAINS edtc real, dimension (its:ite,kts:kte,1:maxens2) :: & dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens + real, dimension (its:ite,kts:kte,1:maxens2) :: & + CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens ! ! ! @@ -551,7 +559,8 @@ CONTAINS ! dellaq = change of q per unit mass flux of cloud ensemble ! dellaqc = change of qc per unit mass flux of cloud ensemble - cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC + cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC, & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1 ! aa0 cloud work function for downdraft ! edt = epsilon @@ -1010,6 +1019,18 @@ CONTAINS pwo_ens(i,k,iedt)=0. enddo enddo + if (l_flux) then + do k=kts,ktf + do i=its,itf + cfu1_ens(i,k,iedt)=0. + cfd1_ens(i,k,iedt)=0. + dfu1_ens(i,k,iedt)=0. + efu1_ens(i,k,iedt)=0. + dfd1_ens(i,k,iedt)=0. + efd1_ens(i,k,iedt)=0. + enddo + enddo + endif ! do i=its,itf aad(i)=0. @@ -1041,12 +1062,14 @@ CONTAINS !--- 1. in bottom layer ! call cup_dellabot(ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, & - zdo,cdd,heo,dellah,j,mentrd_rate,zo,g, & + zuo,zdo,cdd,heo,dellah,j,mentrd_rate,zo,g, & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) call cup_dellabot(ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, & - zdo,cdd,qo,dellaq,j,mentrd_rate,zo,g,& + zuo,zdo,cdd,qo,dellaq,j,mentrd_rate,zo,g,& + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,.FALSE., & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) @@ -1057,6 +1080,7 @@ CONTAINS heo,dellah,j,mentrd_rate,zuo,g, & cd,hco,ktop,k22,kbcon,mentr_rate,jmin,heo_cup,kdet, & k22,ipr,jpr,'deep', & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) @@ -1087,6 +1111,7 @@ CONTAINS qo,dellaq,j,mentrd_rate,zuo,g, & cd,scr1,ktop,k22,kbcon,mentr_rate,jmin,qo_cup,kdet, & k22,ipr,jpr,'deep', & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,.FALSE., & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1315,6 +1340,28 @@ CONTAINS ! endif enddo enddo + if (l_flux) then + do k=kts,ktf + do i=its,itf + if(ierr(i).eq.0)then + cfu1_ens(i,k,iedt)=cfu1(i,k) + cfd1_ens(i,k,iedt)=cfd1(i,k) + dfu1_ens(i,k,iedt)=dfu1(i,k) + efu1_ens(i,k,iedt)=efu1(i,k) + dfd1_ens(i,k,iedt)=dfd1(i,k) + efd1_ens(i,k,iedt)=efd1(i,k) + else + cfu1_ens(i,k,iedt)=0. + cfd1_ens(i,k,iedt)=0. + dfu1_ens(i,k,iedt)=0. + efu1_ens(i,k,iedt)=0. + dfd1_ens(i,k,iedt)=0. + efd1_ens(i,k,iedt)=0. + end if + end do + end do + end if + 250 continue ! !--- FEEDBACK @@ -1325,6 +1372,9 @@ CONTAINS pr_ens,maxens3,ensdim,massfln, & APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1, & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1, & + CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens, & + l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) @@ -1876,7 +1926,8 @@ CONTAINS SUBROUTINE cup_dellabot(ipr,jpr,he_cup,ierr,z_cup,p_cup, & - hcd,edt,zd,cdd,he,della,j,mentrd_rate,z,g, & + hcd,edt,zu,zd,cdd,he,della,j,mentrd_rate,z,g, & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1898,7 +1949,7 @@ CONTAINS della real, dimension (its:ite,kts:kte) & ,intent (in ) :: & - z_cup,p_cup,hcd,zd,cdd,he,z,he_cup + z_cup,p_cup,hcd,zu,zd,cdd,he,z,he_cup real, dimension (its:ite) & ,intent (in ) :: & edt @@ -1908,6 +1959,10 @@ CONTAINS integer, dimension (its:ite) & ,intent (inout) :: & ierr + real, dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1 + logical, intent(in) :: l_flux ! ! local variables in this routine ! @@ -1924,6 +1979,16 @@ CONTAINS ! ! if(j.eq.jpr)print *,'in cup dellabot ' do 100 i=its,itf + if (l_flux) then + cfu1(i,1)=0. + cfd1(i,1)=0. + cfu1(i,2)=0. + cfd1(i,2)=0. + dfu1(i,1)=0. + efu1(i,1)=0. + dfd1(i,1)=0. + efd1(i,1)=0. + endif della(i,1)=0. if(ierr(i).ne.0)go to 100 dz=z_cup(i,2)-z_cup(i,1) @@ -1937,6 +2002,11 @@ CONTAINS +detdo2*hcd(i,1) & +subin*he_cup(i,2) & -entdo*he(i,1))*g/dp + if (l_flux) then + cfd1(i,2) = -edt(i)*zd(i,2) !only contribution to subin, subdown=0 + dfd1(i,1) = detdo1+detdo2 + efd1(i,1) = -entdo + endif 100 CONTINUE END SUBROUTINE cup_dellabot @@ -1946,6 +2016,7 @@ CONTAINS he,della,j,mentrd_rate,zu,g, & cd,hc,ktop,k22,kbcon,mentr_rate,jmin,he_cup,kdet,kpbl, & ipr,jpr,name, & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1982,6 +2053,10 @@ CONTAINS ierr character *(*), intent (in) :: & name + real, dimension (its:ite,kts:kte) & + ,intent (inout ) :: & + CFU1,CFD1,DFU1,EFU1,DFD1,EFD1 + logical, intent(in) :: l_flux ! ! local variables in this routine ! @@ -2006,6 +2081,22 @@ CONTAINS della(i,k)=0. enddo enddo + if (l_flux) then + DO K=kts+1,ktf-1 + do i=its,itf + cfu1(i,k+1)=0. + cfd1(i,k+1)=0. + enddo + enddo + DO K=kts+1,ktf + do i=its,itf + dfu1(i,k)=0. + efu1(i,k)=0. + dfd1(i,k)=0. + efd1(i,k)=0. + enddo + enddo + endif ! DO 100 k=kts+1,ktf-1 DO 100 i=its,ite @@ -2049,6 +2140,22 @@ CONTAINS if(k.lt.kbcon(i))then detup=0. endif + if (l_flux) then +! z_cup(k+1): zu(k+1), -zd(k+1) ==> subin ==> cf[du]1 (k+1) (full-eta level k+1) +! +! z(k) : detup, detdo, entup, entdo ==> [de]f[du]1 (k) (half-eta level k ) +! +! z_cup(k) : zu(k), -zd(k) ==> subdown ==> cf[du]1 (k) (full-eta level k ) + +! Store downdraft/updraft mass fluxes at full eta level k (z_cup(k)) in cf[ud]1(k): + cfu1(i,k+1) = zu(i,k+1) + cfd1(i,k+1) = -edt(i)*zd(i,k+1) +! Store detrainment/entrainment mass fluxes at half eta level k (z(k)) in [de]f[du]1(k): + dfu1(i,k) = detup+detupk + efu1(i,k) = -(entup+entupk) + dfd1(i,k) = detdo + efd1(i,k) = -(entdo+entdoj) + endif !C !C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT !C @@ -3342,6 +3449,9 @@ CONTAINS maxens3,ensdim,massfln, & APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1, & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1, & + CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens, & + l_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) @@ -3400,6 +3510,14 @@ CONTAINS integer, dimension (its:ite) & ,intent (inout) :: & ierr,ierr2,ierr3 + real, dimension (its:ite,kts:kte,1:ensdim) & + ,intent (in ) :: & + CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens + real, dimension (its:ite,kts:kte) & + ,intent (out) :: & + outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1 + logical, intent(in) :: l_flux + ! ! local variables in this routine ! @@ -3417,6 +3535,7 @@ CONTAINS real, dimension (its:ite,jts:jte):: & pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma, & pr_capme,pr_capmi + integer :: iedt, kk ! character *(*), intent (in) :: & @@ -3565,6 +3684,40 @@ CONTAINS enddo endif ENDDO + if (l_flux) then + if (iens .eq. 1) then ! Only do deep convection mass fluxes + do k=kts,ktf + do i=its,itf + outcfu1(i,k)=0. + outcfd1(i,k)=0. + outdfu1(i,k)=0. + outefu1(i,k)=0. + outdfd1(i,k)=0. + outefd1(i,k)=0. + if (ierr(i) .eq. 0) then + do iedt=1,nx + do kk=1,nx2*maxens3 + n=(iens-1)*nx*nx2*maxens3 + & + (iedt-1)*nx2*maxens3 + kk + outcfu1(i,k)=outcfu1(i,k)+cfu1_ens(i,k,iedt)*xf_ens(i,j,n) + outcfd1(i,k)=outcfd1(i,k)+cfd1_ens(i,k,iedt)*xf_ens(i,j,n) + outdfu1(i,k)=outdfu1(i,k)+dfu1_ens(i,k,iedt)*xf_ens(i,j,n) + outefu1(i,k)=outefu1(i,k)+efu1_ens(i,k,iedt)*xf_ens(i,j,n) + outdfd1(i,k)=outdfd1(i,k)+dfd1_ens(i,k,iedt)*xf_ens(i,j,n) + outefd1(i,k)=outefd1(i,k)+efd1_ens(i,k,iedt)*xf_ens(i,j,n) + end do + end do + outcfu1(i,k)=outcfu1(i,k)/ensdim + outcfd1(i,k)=outcfd1(i,k)/ensdim + outdfu1(i,k)=outdfu1(i,k)/ensdim + outefu1(i,k)=outefu1(i,k)/ensdim + outdfd1(i,k)=outdfd1(i,k)/ensdim + outefd1(i,k)=outefd1(i,k)/ensdim + end if !ierr + end do !i + end do !k + end if !iens .eq. 1 + end if !l_flux END SUBROUTINE cup_output_ens diff --git a/wrfv2_fire/phys/module_cu_sas.F b/wrfv2_fire/phys/module_cu_sas.F index 36415e59..e474800f 100755 --- a/wrfv2_fire/phys/module_cu_sas.F +++ b/wrfv2_fire/phys/module_cu_sas.F @@ -1,24 +1,29 @@ -! -MODULE module_cu_sas +!! +MODULE module_cu_sas CONTAINS !----------------------------------------------------------------- - SUBROUTINE CU_SAS( & - DT,ITIMESTEP,STEPCU & - ,RAINCV,PRATEC,HTOP,HBOT & - ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D & - ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG & - ,CUDT, CURR_SECS, ADAPT_STEP_FLAG & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & - ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN & - ) + SUBROUTINE CU_SAS(DT,ITIMESTEP,STEPCU, & + RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & +#if (NMM_CORE == 1) + RUCUTEN,RVCUTEN, & ! gopal's doing for SAS +#endif + RAINCV,PRATEC,HTOP,HBOT, & + U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D, & + DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG, & + P_QC, & +#if (NMM_CORE == 1) + STORE_RAND,MOMMIX, & ! gopal's doing +#endif + P_QI,P_FIRST_SCALAR, & + CUDT, CURR_SECS, ADAPT_STEP_FLAG, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) !------------------------------------------------------------------- - USE MODULE_GFS_MACHINE , ONLY : kind_phys, kind_evod + USE MODULE_GFS_MACHINE , ONLY : kind_phys USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & &, RV => con_RV, FV => con_fvirt, T0C => con_T0C & @@ -51,6 +56,11 @@ CONTAINS ! PBL parameterization (kg/kg/s) !-- RQIBLTEN Qi tendency due to ! PBL parameterization (kg/kg/s) +! +!-- MOMMIX MOMENTUM MIXING COEFFICIENT (can be set in the namelist) +!-- RUCUTEN U tendency due to Cumulus Momentum Mixing (gopal's doing for SAS) +!-- RVCUTEN V tendency due to Cumulus Momentum Mixing (gopal's doing for SAS) +! !-- CP heat capacity at constant pressure for dry air (J/kg/K) !-- GRAV acceleration due to gravity (m/s^2) !-- ROVCP R/CP @@ -94,16 +104,36 @@ CONTAINS !-- kte end index for k in tile !------------------------------------------------------------------- + INTEGER :: ICLDCK + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - ITIMESTEP, & + ITIMESTEP, & !NSTD + P_FIRST_SCALAR, & + P_QC, & + P_QI, & STEPCU REAL, INTENT(IN) :: & DT + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: & + RQCCUTEN, & + RQICUTEN, & + RQVCUTEN, & + RTHCUTEN +#if (NMM_CORE == 1) + REAL, INTENT(IN) :: MOMMIX + REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) :: & + RUCUTEN, & ! gopal's doing for SAS + RVCUTEN ! gopal's doing for SAS + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN) :: STORE_RAND + +#endif + REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: & XLAND @@ -132,29 +162,6 @@ CONTAINS V3D, & W -!--------------------------- OPTIONAL VARS ---------------------------- - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - OPTIONAL, INTENT(INOUT) :: & - RQCCUTEN, & - RQICUTEN, & - RQVCUTEN, & - RTHCUTEN - -! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! to determine at run-time whether a particular tracer is in -! use or not. -! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS - ! Adaptive time-step variables REAL, INTENT(IN ) :: CUDT REAL, INTENT(IN ) :: CURR_SECS @@ -165,9 +172,6 @@ CONTAINS REAL, DIMENSION(ims:ime, jms:jme) :: & PSFC - REAL (kind=kind_evod),save :: seed0 -! REAL (kind=kind_evod) :: seed0 - REAL (kind=kind_evod) :: wrk REAL (kind=kind_phys) :: & DELT, & @@ -175,9 +179,6 @@ CONTAINS RDELT, & RSEED - REAL (kind=kind_phys), DIMENSION(ids:ide,jds:jde) :: & - RANNUM - REAL (kind=kind_phys), DIMENSION(its:ite) :: & CLDWRK, & PS, & @@ -212,7 +213,7 @@ CONTAINS INTEGER :: & I, & -! IGPVS, & + IGPVS, & IM, & J, & JCAP, & @@ -222,17 +223,9 @@ CONTAINS KX, & NCLOUD - INTEGER :: start_year,start_month,start_day,start_hour - - integer :: iseed -! integer, save :: krsize - integer :: krsize - integer, allocatable :: nrnd(:) - real :: fsec - LOGICAL :: run_param -! DATA IGPVS/0/ + DATA IGPVS/0/ !----------------------------------------------------------------------- ! @@ -245,7 +238,7 @@ CONTAINS else run_param = .FALSE. endif - + else if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 0) then run_param = .TRUE. @@ -274,46 +267,14 @@ CONTAINS NCLOUD=1 - DO J=jts,jte - DO I=its,ite + DO J=jms,jme + DO I=ims,ime PSFC(i,j)=P8w(i,kms,j) ENDDO ENDDO - if(itimestep.eq.0) then - CALL GFUNCPHYS - - CALL nl_get_start_year(1,start_year) - CALL nl_get_start_month(1,start_month) - CALL nl_get_start_day(1,start_day) - CALL nl_get_start_hour(1,start_hour) - - call random_seed(size=krsize) - if (.not. allocated (nrnd)) allocate (nrnd(krsize)) - - seed0 = start_year + start_month + start_day + start_hour - nrnd = start_hour + start_day*24 - call random_seed - call random_seed(put=nrnd) - call random_number(wrk) - seed0 = seed0 + nint(wrk*1000.0) - - endif - - if (adapt_step_flag) then - fsec = CURR_SECS - else - fsec = ITIMESTEP*DT - endif - iseed = mod(100.0*sqrt(fsec),1.0e9) + 1 + seed0 - call random_seed(size=krsize) - if (.not. allocated (nrnd)) allocate (nrnd(krsize)) - nrnd = iseed - call random_seed - call random_seed(put=nrnd) - call random_number(rannum) - -! igpvs=1 + if(igpvs.eq.0) CALL GFUNCPHYS + igpvs=1 !------------- J LOOP (OUTER) -------------------------------------------------- @@ -345,9 +306,21 @@ CONTAINS ! --------------- end compute zi and zl ------------------------------------- -! call random_number(XKT2) + +! Based on some important findings from Morris Bender, XKT2 was defined in +! terms of random number instead of random number based cloud tops +! Also, these random numbers are stored and are changed only once in +! approximately 5 minutes interval now. This is gopal's doing for HWRF. + +! call random_number(XKT2) + +#if (NMM_CORE == 1) + DO i=its,ite + XKT2(i) = STORE_RAND(i,j) + ENDDO +#endif + DO i=its,ite - xkt2(i)=rannum(i,j) PS(i)=PSFC(i,j)*.001 RCS(i)=1. SLIMSK(i)=ABS(XLAND(i,j)-2.) @@ -389,9 +362,10 @@ CONTAINS CALL SASCNV(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL, & QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT, & - KTOP,KUO,SLIMSK,DOT,XKT2,NCLOUD) + KTOP,KUO,SLIMSK,DOT,XKT2,NCLOUD) - CALL SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KUO,Q1,T1,DPSHC) +!!! make more like GFDL ... eliminate shallow convection..... +!!! CALL SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KUO,Q1,T1,DPSHC) DO I=ITS,ITE RAINCV(I,J)=RN(I)*1000./STEPCU @@ -407,40 +381,55 @@ CONTAINS ENDDO ENDDO - IF(PRESENT(RQCCUTEN))THEN - IF ( F_QC ) THEN - DO K=KTS,KTE - DO I=ITS,ITE - RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT - ENDDO +!=============================================================================== +! ADD MOMENTUM MIXING TERM AS TENDENCIES. This is gopal's doing for SAS +! MOMMIX is the reduction factor set to 0.7 by default. Because NMM has +! divergence damping term, a reducion factor for cumulum mixing may be +! required otherwise storms were too weak. +!=============================================================================== +! +#if (NMM_CORE == 1) + DO K=KTS,KTE + DO I=ITS,ITE + RUCUTEN(I,J,K)=MOMMIX*(U1(I,K)-U3D(I,K,J))*RDELT + RVCUTEN(I,J,K)=MOMMIX*(V1(I,K)-V3D(I,K,J))*RDELT + ENDDO + ENDDO +#endif + + + IF(P_QC .ge. P_FIRST_SCALAR)THEN + DO K=KTS,KTE + DO I=ITS,ITE + RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT ENDDO - ENDIF + ENDDO ENDIF - IF(PRESENT(RQICUTEN))THEN - IF ( F_QI ) THEN - DO K=KTS,KTE - DO I=ITS,ITE - RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT - ENDDO + IF(P_QI .ge. P_FIRST_SCALAR)THEN + DO K=KTS,KTE + DO I=ITS,ITE + RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT ENDDO - ENDIF + ENDDO ENDIF - - ENDDO + ENDDO ! Outer most J loop ENDIF END SUBROUTINE CU_SAS !==================================================================== - SUBROUTINE sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - RESTART,P_QC,P_QI,P_FIRST_SCALAR, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) + SUBROUTINE sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & +#if (NMM_CORE == 1) + RUCUTEN,RVCUTEN, & ! gopal's doing for SAS +#endif + RESTART,P_QC,P_QI,P_FIRST_SCALAR, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) !-------------------------------------------------------------------- IMPLICIT NONE !-------------------------------------------------------------------- @@ -455,6 +444,11 @@ CONTAINS RQVCUTEN, & RQCCUTEN, & RQICUTEN +#if (NMM_CORE == 1) + REAL, DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(OUT) :: & + RUCUTEN, & ! gopal's doing for SAS + RVCUTEN +#endif INTEGER :: i, j, k, itf, jtf, ktf @@ -462,12 +456,22 @@ CONTAINS ktf=min0(kte,kde-1) itf=min0(ite,ide-1) +#ifdef HWRF +!zhang's doing + IF(.not.restart .or. .not.allowed_to_read)THEN +!end of zhang's doing +#else IF(.not.restart)THEN +#endif DO j=jts,jtf DO k=kts,ktf DO i=its,itf RTHCUTEN(i,k,j)=0. RQVCUTEN(i,k,j)=0. +#if (NMM_CORE == 1) + RUCUTEN(i,j,k)=0. ! gopal's doing for SAS + RVCUTEN(i,j,k)=0. ! gopal's doing for SAS +#endif ENDDO ENDDO ENDDO @@ -507,7 +511,7 @@ CONTAINS ! & Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK, ! & DOT,xkt2,ncloud) ! - USE MODULE_GFS_MACHINE , ONLY : kind_phys,kind_evod + USE MODULE_GFS_MACHINE , ONLY : kind_phys USE MODULE_GFS_FUNCPHYS ,ONLY : fpvs USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP & &, RV => con_RV, FV => con_fvirt, T0C => con_T0C & @@ -519,7 +523,7 @@ CONTAINS ! include 'constant.h' ! integer IM, IX, KM, JCAP, ncloud, & - & KBOT(IM), KTOP(IM), KUO(IM) + & KBOT(IM), KTOP(IM), KUO(IM), J real(kind=kind_phys) DELT real(kind=kind_phys) PS(IM), DEL(IX,KM), PRSL(IX,KM), & ! real(kind=kind_phys) DEL(IX,KM), PRSL(IX,KM), @@ -654,9 +658,15 @@ CONTAINS betas = .15 BETAl = .05 betas = .05 +! change for hurricane model + BETAl = .5 + betas = .5 ! EVEF = 0.07 evfact = 0.3 evfactl = 0.3 +! change for hurricane model + evfact = 0.6 + evfactl = .6 PDPDWN = 0. PDETRN = 200. xlambu = 1.e-4 diff --git a/wrfv2_fire/phys/module_cumulus_driver.F b/wrfv2_fire/phys/module_cumulus_driver.F index 50c8aef0..8aee2bce 100644 --- a/wrfv2_fire/phys/module_cumulus_driver.F +++ b/wrfv2_fire/phys/module_cumulus_driver.F @@ -33,35 +33,52 @@ CONTAINS ,apr_gr,apr_w,apr_mc,apr_st,apr_as,apr_capma & ,apr_capme,apr_capmi,edt_out,clos_choice & ,mass_flux,xf_ens,pr_ens,cugd_avedx,imomentum & - ,cugd_tten,cugd_qvten,cugd_qcten & + ,ishallow,cugd_tten,cugd_qvten,cugd_qcten & ,cugd_ttens,cugd_qvtens & ,gd_cloud,gd_cloud2 & + ,k22_shallow,kbcon_shallow,ktop_shallow,xmb_shallow & ! Optional moisture and other tendencies ,rqvcuten,rqccuten,rqrcuten & ,rqicuten,rqscuten,rqgcuten & ,rqvblten,rqvften & ,rthcuten,rthraten,rthblten,rthften & +#if (NMM_CORE==1) + ! for hwrf-sas --- 3.2 CLEANUP TODO -- THESE SHOULD BE OPTIONAL, NOT #IF/#ENDIF + ,rucuten,rvcuten,mommix,store_rand & +#endif ! Optional moisture tracer flags ,f_qv,f_qc,f_qr & ,f_qi,f_qs,f_qg & + ,CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,f_flux & +#if ( WRF_DFI_RADAR == 1 ) + ! Optional CAP suppress option --- 3.2 CLEANUP TODO -- THESE SHOULD BE OPTIONAL, NOT #IF/#ENDIF + ,do_capsuppress & +#endif ) !---------------------------------------------------------------------- USE module_model_constants USE module_state_description, ONLY: KFSCHEME,BMJSCHEME & ,KFETASCHEME,GDSCHEME & ,G3SCHEME & + ,P_QC,P_QI,Param_FIRST_SCALAR & ,SASSCHEME ! *** add new modules of schemes here - USE module_cu_kf - USE module_cu_bmj - USE module_dm - USE module_domain, ONLY: domain - USE module_cu_kfeta - USE module_cu_gd, ONLY : GRELLDRV - USE module_cu_g3, ONLY : G3DRV,CONV_GRELL_SPREAD3D + USE module_cu_kf , ONLY : kfcps + USE module_cu_bmj , ONLY : bmjdrv +#ifdef DM_PARALLEL + USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks +# if (EM_CORE == 1) + USE module_comm_dm , ONLY : halo_cup_g3_in_sub, halo_cup_g3_out_sub +# endif +#endif + USE module_domain , ONLY: domain + USE module_cu_kfeta , ONLY : kf_eta_cps + USE module_cu_gd , ONLY : grelldrv + USE module_cu_g3 , ONLY : g3drv,conv_grell_spread3d USE module_cu_sas + USE module_wrf_error , ONLY : wrf_err_message ! This driver calls subroutines for the cumulus parameterizations. ! @@ -270,16 +287,27 @@ CONTAINS REAL, INTENT(IN ) :: DT, DX INTEGER, INTENT(IN ),OPTIONAL :: & - ips,ipe, jps,jpe, kps,kpe,imomentum + ips,ipe, jps,jpe, kps,kpe,imomentum,ishallow REAL, INTENT(IN ),OPTIONAL :: CUDT REAL, INTENT(IN ),OPTIONAL :: CURR_SECS LOGICAL,INTENT(IN ),OPTIONAL :: adapt_step_flag REAL :: cudt_pass, curr_secs_pass LOGICAL :: adapt_step_flag_pass +#if (NMM_CORE==1) + REAL, DIMENSION( ims:ime, jms:jme, kms:kme ), & + INTENT(INOUT) :: rucuten,rvcuten + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN) :: STORE_RAND + REAL, INTENT(INOUT) :: mommix +#endif + ! ! optional arguments ! + INTEGER, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + k22_shallow,kbcon_shallow,ktop_shallow REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, INTENT(INOUT) :: & ! optional moisture tracers @@ -303,7 +331,7 @@ CONTAINS OPTIONAL, & INTENT(INOUT) :: & apr_gr,apr_w,apr_mc,apr_st,apr_as,apr_capma & - ,apr_capme,apr_capmi,edt_out & + ,apr_capme,apr_capmi,edt_out,xmb_shallow & , MASS_FLUX REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, INTENT(INOUT) :: & @@ -311,6 +339,15 @@ CONTAINS REAL, DIMENSION( ims:ime , jms:jme , 1:ensdim ), & OPTIONAL, & INTENT(INOUT) :: XF_ENS, PR_ENS + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + CFU1, & + CFD1, & + DFU1, & + EFU1, & + DFD1, & + EFD1 ! ! Flags relating to the optional tendency arrays declared above @@ -326,14 +363,28 @@ CONTAINS ,f_qi & ,f_qs & ,f_qg + LOGICAL, INTENT(IN), OPTIONAL :: f_flux +#if ( WRF_DFI_RADAR == 1 ) +! +! option of cap suppress: +! do_capsuppress = 1 do +! do_capsuppress = other don't +! +! + INTEGER, INTENT(IN ) ,OPTIONAL :: do_capsuppress + REAL, DIMENSION( ims:ime, jms:jme ) :: cap_suppress_loc +#endif ! LOCAL VAR INTEGER :: i,j,k,its,ite,jts,jte,ij + logical :: l_flux !----------------------------------------------------------------- + l_flux=.FALSE. + if (present(f_flux)) l_flux=f_flux if (.not. PRESENT(CURR_SECS)) then curr_secs_pass = -1 else @@ -360,7 +411,6 @@ CONTAINS tmppratec(:,:) = 0. end if - IF (cu_physics .eq. 0) return #if ( EM_CORE == 1 ) if(cu_physics .eq. 5 ) then @@ -526,7 +576,10 @@ CONTAINS ,RQVBLTEN=RQVBLTEN & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs & - ) + ,CFU1=CFU1,CFD1=CFD1,DFU1=DFU1,EFU1=EFU1 & + ,DFD1=DFD1,EFD1=EFD1,f_flux=l_flux ) + CALL wrf_debug(200,'back from grelldrv') + CASE (SASSCHEME) IF ( adapt_step_flag_pass ) THEN @@ -536,25 +589,43 @@ CONTAINS CALL wrf_debug(100,'in cu_sas') CALL CU_SAS( & DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU & + ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN & + ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN & +#if (NMM_CORE==1) + ,RUCUTEN=RUCUTEN, RVCUTEN=RVCUTEN & +#endif ,RAINCV=RAINCV,PRATEC=tmpPRATEC,HTOP=HTOP,HBOT=HBOT & - ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & + ,U3D=u,V3D=v,W=w,T3D=t & ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR & + ,PI3D=pi,RHO3D=rho & ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND & ,CU_ACT_FLAG=CU_ACT_FLAG & + ,P_QC=p_qc & +#if (NMM_CORE==1) + ,store_rand=store_rand & + ,MOMMIX=MOMMIX & +#endif + ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar & ,CUDT=cudt_pass & ,CURR_SECS=curr_secs_pass & ,ADAPT_STEP_FLAG=adapt_step_flag_pass & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & - ! optionals - ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN & - ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN & - ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & - ,F_QI=f_qi,F_QS=f_qs & ) CASE (G3SCHEME) CALL wrf_debug(100,'in grelldrv') +#if ( WRF_DFI_RADAR == 1 ) + if (do_capsuppress == 1) then + WRITE( wrf_err_message , * ) 'G3 do CAP suppress',its,jts,min( jte,jde-1 ),min( ite,ide-1 ),kte + CALL wrf_debug(200, wrf_err_message) + DO j = jts, min( jte,jde-1 ) + DO i = its, min( ite,ide-1 ) + cap_suppress_loc(i,j) = grid%dfi_tten_rad(i,kte,j) + ENDDO + ENDDO + endif +#endif CALL G3DRV( & DT=dt, ITIMESTEP=itimestep, DX=dx & ,U=u,V=v,T=t,W=w ,RHO=rho & @@ -566,11 +637,15 @@ CONTAINS ,APR_CAPMI=apr_capmi,MASS_FLUX=mass_flux & ,XF_ENS=xf_ens,PR_ENS=pr_ens,HT=ht & ,xland=xland,gsw=gsw,edt_out=edt_out & - ,GDC=gd_cloud,GDC2=gd_cloud2 & + ,GDC=gd_cloud,GDC2=gd_cloud2,kpbl=kpbl & + ,k22_shallow=k22_shallow & + ,kbcon_shallow=kbcon_shallow & + ,ktop_shallow=ktop_shallow & + ,xmb_shallow=xmb_shallow & ,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten & ,cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens & ,cugd_qcten=cugd_qcten,cugd_avedx=cugd_avedx & - ,imomentum=imomentum & + ,imomentum=imomentum,ishallow_g3=ishallow & ,ENSDIM=ensdim,MAXIENS=maxiens,MAXENS=maxens & ,MAXENS2=maxens2,MAXENS3=maxens3,ichoice=clos_choice & ,STEPCU=STEPCU,htop=htop,hbot=hbot & @@ -587,10 +662,16 @@ CONTAINS #else ,RTHCUTEN=RTHCUTEN ,RTHFTEN=RTHFTEN & ,RQICUTEN=RQICUTEN ,RQVFTEN=RQVFTEN & + ,rqvblten=rqvblten,rthblten=rthblten & #endif ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs & +#if ( WRF_DFI_RADAR == 1 ) + ! Optional CAP suppress option + ,do_capsuppress=do_capsuppress & + ,cap_suppress_loc=cap_suppress_loc & +#endif ) CASE DEFAULT @@ -638,6 +719,7 @@ CONTAINS if (PRESENT(PRATEC)) then pratec(:,:) = tmppratec(:,:) endif + CALL wrf_debug(200,'returning from cumulus_driver') END SUBROUTINE cumulus_driver END MODULE module_cumulus_driver diff --git a/wrfv2_fire/phys/module_diagnostics.F b/wrfv2_fire/phys/module_diagnostics.F index f82b3372..1375b91f 100644 --- a/wrfv2_fire/phys/module_diagnostics.F +++ b/wrfv2_fire/phys/module_diagnostics.F @@ -351,6 +351,8 @@ CONTAINS sfcevp_sum = 0. hfx_sum = 0. lh_sum = 0. + raincmax = 0. + rainncmax = 0. DO j = jps, min(jpe,jde-1) DO i = ips, min(ipe,ide-1) diff --git a/wrfv2_fire/phys/module_fddagd_driver.F b/wrfv2_fire/phys/module_fddagd_driver.F index c93fd941..a2fcdd1d 100644 --- a/wrfv2_fire/phys/module_fddagd_driver.F +++ b/wrfv2_fire/phys/module_fddagd_driver.F @@ -360,8 +360,8 @@ CONTAINS CALL FDDAGD(itimestep,dx,dt,xtime, & id, & - config_flags%gfdda_interval_m, & - config_flags%gfdda_end_h, & + config_flags%auxinput10_interval_m, & + config_flags%auxinput10_end_h, & config_flags%if_no_pbl_nudging_uv, & config_flags%if_no_pbl_nudging_t, & config_flags%if_no_pbl_nudging_q, & @@ -375,8 +375,8 @@ CONTAINS config_flags%gt, config_flags%gq, & config_flags%if_ramping, config_flags%dtramp_min, & config_flags%grid_sfdda, & - config_flags%sgfdda_interval_m, & - config_flags%sgfdda_end_h, & + config_flags%auxinput10_interval_m, & + config_flags%auxinput10_end_h, & config_flags%guv_sfc, & config_flags%gt_sfc, config_flags%gq_sfc, config_flags%rinblw, & u3d,v3d,th_phy,t_phy, & @@ -401,8 +401,8 @@ CONTAINS CALL wrf_debug(100,'in SPECTRAL NUDGING scheme') CALL SPECTRAL_NUDGING(grid,itimestep,dt,xtime, & id, & - config_flags%gfdda_interval_m, & - config_flags%gfdda_end_h, & + config_flags%auxinput10_interval_m, & + config_flags%auxinput10_end_h, & config_flags%if_no_pbl_nudging_uv, & config_flags%if_no_pbl_nudging_t, & config_flags%if_no_pbl_nudging_ph, & diff --git a/wrfv2_fire/phys/module_fddaobs_driver.F b/wrfv2_fire/phys/module_fddaobs_driver.F index acf35071..5bb8f80e 100644 --- a/wrfv2_fire/phys/module_fddaobs_driver.F +++ b/wrfv2_fire/phys/module_fddaobs_driver.F @@ -36,6 +36,7 @@ CONTAINS !----------------------------------------------------------------------- SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & + config_flags, & nudge_opt, iprt_errob, iprt_nudob, & fdasta, fdaend, & nudge_wind, nudge_temp, nudge_mois, & @@ -45,6 +46,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & npfi, ionf, & obs_prt_max, obs_prt_freq, idynin, dtramp, & parent_grid_ratio, maxdom, itimestep, & + xtime, & dt, gmt, julday, & #if ( EM_CORE == 1 ) fdob, & @@ -56,6 +58,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & ub, vb, tb, qvb, pbase, ptop, pp, phb, ph, & uratx, vratx, tratx, ru_tendf, rv_tendf, & moist_tend, savwt, & + regime, pblh, z_at_w, z, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte ) ! tile dims @@ -93,6 +96,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & INTEGER, intent(in) :: domid(maxdom) ! Domain IDs INTEGER, intent(in) :: parid(maxdom) ! Parent domain IDs LOGICAL, intent(in) :: restart + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, intent(in) :: itimestep INTEGER, intent(in) :: nudge_opt LOGICAL, intent(in) :: iprt_errob @@ -116,6 +120,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & INTEGER, intent(in) :: idynin REAL, intent(inout) :: dtramp INTEGER, intent(in) :: parent_grid_ratio + REAL, intent(in) :: xtime ! forecast time in minutes REAL, intent(in) :: dt REAL, intent(in) :: gmt INTEGER, intent(in) :: julday @@ -142,6 +147,10 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & REAL, INTENT(INOUT) :: t_tendf( ims:ime, kms:kme, jms:jme ) REAL, INTENT(IN) :: t0 REAL, INTENT(INOUT) :: savwt( nobs_ndg_vars, ims:ime, kms:kme, jms:jme ) + REAL, INTENT(INOUT) :: regime( ims:ime, jms:jme ) + REAL, INTENT(IN) :: pblh( ims:ime, jms:jme ) + REAL, INTENT(IN) :: z_at_w( ims:ime, kms:kme, jms:jme ) + REAL, INTENT(IN) :: z( ims:ime, kms:kme, jms:jme ) ! Model ht above sea-level #if ( EM_CORE == 1 ) TYPE(fdob_type), intent(inout) :: fdob @@ -166,7 +175,6 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & ! Local variables logical :: nudge_flag ! Flag for doing nudging integer :: KTAU ! Forecast timestep - real :: xtime ! Forecast time in minutes real :: dtmin ! dt in minutes integer :: i, j, k ! Loop counters. integer :: idom ! Loop counter. @@ -175,10 +183,17 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & integer :: idarst ! Flag for calling sub errob on restart real :: dtr ! Abs value of dtramp (for dynamic init) real :: tconst ! Reciprocal of dtr - integer :: KPBLJ(its:ite) ! 1D temp array. + real :: vih_uv(its:ite,jts:jte,2) ! Vert infl heights abv grd for LML obs (wind) + real :: vih_t (its:ite,jts:jte,2) ! Vert infl heights abv grd for LML obs (temp) + real :: vih_q (its:ite,jts:jte,2) ! Vert infl heights abv grd for LML obs (mois) + integer :: vik_uv(its:ite,jts:jte,2) ! Vert infl k-levels for LML obs (wind) + integer :: vik_t (its:ite,jts:jte,2) ! Vert infl k-levels for LML obs (temp) + integer :: vik_q (its:ite,jts:jte,2) ! Vert infl k-levels for LML obs (mois) + real :: z_at_p( kms:kme ) ! Height at p levels #ifdef RAL - real :: HTIJ(ids:ide, jds:jde) = 0. ! Terrain ht on global grid. + real :: HTIJ(ids:ide, jds:jde) = 0. ! Terrain ht on global grid #endif + character(len=200) :: msg ! Argument to wrf_message #if ( EM_CORE == 1 ) nudge_flag = (nudge_opt .eq. 1) @@ -190,15 +205,15 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & ! Calculate forecast time. dtmin = dt/60. - xtime = dtmin*(itimestep-1) ktau = itimestep - 1 !ktau corresponds to xtime -! DEFINE NSTA WHEN NOT NUDGING TO IND. OBS. -! print *,'in fddaobs_driver, xtime=',xtime +! Set NSTA to zero on startup, or else retrieve value from last pass. IF(ktau.EQ.fdob%ktaur) THEN - IF (iprt_nudob) PRINT *,3333,fdob%domain_tot -! print *,'ktau,ktaur,inest=',ktau,fdob%ktaur,inest -3333 FORMAT(1X,'IN fddaobs_driver: I4DITOT = ',I2) + if (iprt_nudob) then + write(msg,'(a,i2,a)') 'OBS NUDGING is requested on a total of ', & + fdob%domain_tot,' domain(s).' + call wrf_message(msg) + endif nsta=0. ELSE nsta=fdob%nstat @@ -209,12 +224,62 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & idarst = 0 IF(restart .AND. ktau.EQ.fdob%ktaur) idarst=1 + CALL wrf_debug(100,'in PSU FDDA scheme') + +! Make sure regime array is set over entire grid +! (ajb: Copied code from fddagd) + IF( config_flags%bl_pbl_physics /= 1 & + .AND. config_flags%bl_pbl_physics /= 5 & + .AND. config_flags%bl_pbl_physics /= 6 & + .AND. config_flags%bl_pbl_physics /= 7 & + .AND. config_flags%bl_pbl_physics /= 99 ) THEN + DO j = jts, jte + DO i = its, ite + IF( pblh(i,j) > z_at_w(i,1,j)-ht(i,j) ) THEN + regime(i,j) = 4.0 + ELSE + regime(i,j) = 1.0 + ENDIF + ENDDO + ENDDO + ENDIF + +! Compute VIF heights for each grid column (used for LML obs) + if(nudge_wind.EQ.1 .AND. NSTA.GT.0) then + CALL compute_VIH( fdob%vif_uv, fdob%vif_max, & + fdob%vif_fullmin, fdob%vif_rampmin, & + regime, pblh, & + ht, z, vih_uv, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + if(nudge_temp.EQ.1 .AND. NSTA.GT.0) then + CALL compute_VIH( fdob%vif_t, fdob%vif_max, & + fdob%vif_fullmin, fdob%vif_rampmin, & + regime, pblh, & + ht, z, vih_t, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + if(nudge_mois.EQ.1 .AND. NSTA.GT.0) then + CALL compute_VIH( fdob%vif_q, fdob%vif_max, & + fdob%vif_fullmin, fdob%vif_rampmin, & + regime, pblh, & + ht, z, vih_q, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif +!********************* END AJB MOVE TO SLAB *************************** + ! COMPUTE ERROR BETWEEN OBSERVATIONS and MODEL IF( nsta.GT.0 ) THEN IF( MOD(ktau,infr).EQ.0 .OR. idarst.EQ.1) THEN CALL errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rcp, & - phb, ph, g, & + z_at_w, & uratx, vratx, tratx, kpbl, & nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & fdob%levidn, parid, fdob%nstat, fdob%nstaw, & @@ -273,10 +338,6 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & ! STORE ROUGHNESS AND REGIME FOR EACH J SLICE AFTER THE CALL TO ! HIRPBL FOR LATER USE IN BLNUDGD. ! - DO I=its,ite - KPBLJ(I)=KPBL(I,J) - ENDDO -! !--- OBS NUDGING FOR TEMP AND MOISTURE ! NSTA=NSTAT @@ -284,7 +345,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & IF(nudge_temp.EQ.1 .AND. NSTA.GT.0) & THEN ! write(6,*) 'calling nudob: IVAR=3, J = ',j - CALL NUDOB(J, 3, t_tendf(ims,kms,j), & + CALL nudob(J, 3, t_tendf(ims,kms,j), & inest, restart, ktau, fdob%ktaur, xtime, & mut(ims,j), msftx(ims,j), msfty(ims,j), & nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & @@ -299,7 +360,9 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & pbase(ims,kms,j), ptop, pp(ims,kms,j), & nudge_wind, nudge_temp, nudge_mois, & coef_wind, coef_temp, coef_mois, & - savwt(1,ims,kms,j), kpblj, 0, & + savwt(1,ims,kms,j), kpbl(ims,j), 0, & + vih_t(its,j,1), vih_t(its,j,2), ht(ims,j), & + z(ims,kms,j), & iprt_nudob, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -310,7 +373,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & IF(nudge_mois.EQ.1 .AND. NSTA.GT.0) & THEN ! write(6,*) 'calling nudob: IVAR=4, J = ',j - CALL NUDOB(J, 4, moist_tend(ims,kms,j), & + CALL nudob(J, 4, moist_tend(ims,kms,j), & inest, restart, ktau, fdob%ktaur, xtime, & mut(ims,j), msftx(ims,j), msfty(ims,j), & nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & @@ -325,7 +388,9 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & pbase(ims,kms,j), ptop, pp(ims,kms,j), & nudge_wind, nudge_temp, nudge_mois, & coef_wind, coef_temp, coef_mois, & - savwt(1,ims,kms,j), kpblj, 0, & + savwt(1,ims,kms,j), kpbl(ims,j), 0, & + vih_q(its,j,1), vih_q(its,j,2), ht(ims,j), & + z(ims,kms,j), & iprt_nudob, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -336,8 +401,8 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & IF(nudge_wind.EQ.1 .AND. NSTA.GT.0) & THEN -! write(6,*) 'calling nudob: IVAR=1, J = ',j - CALL NUDOB(J, 1, ru_tendf(ims,kms,j), & +! write(6,*) 'calling nudob: IVAR=1, J = ',j + CALL nudob(J, 1, ru_tendf(ims,kms,j), & inest, restart, ktau, fdob%ktaur, xtime, & muu(ims,j), msfux(ims,j), msfuy(ims,j), & nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & @@ -352,7 +417,9 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & pbase(ims,kms,j), ptop, pp(ims,kms,j), & nudge_wind, nudge_temp, nudge_mois, & coef_wind, coef_temp, coef_mois, & - savwt(1,ims,kms,j), kpblj, 0, & + savwt(1,ims,kms,j), kpbl(ims,j), 0, & + vih_uv(its,j,1), vih_uv(its,j,2), ht(ims,j), & + z(ims,kms,j), & iprt_nudob, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -360,7 +427,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & ! write(6,*) 'return from nudob: IVAR=1, J = ',j ! write(6,*) 'calling nudob: IVAR=2, J = ',j - CALL NUDOB(J, 2, rv_tendf(ims,kms,j), & + CALL nudob(J, 2, rv_tendf(ims,kms,j), & inest, restart, ktau, fdob%ktaur, xtime, & muv(ims,j), msfvx(ims,j), msfvy(ims,j), & nobs_ndg_vars, nobs_err_flds, max_obs, maxdom, & @@ -375,7 +442,9 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & pbase(ims,kms,j), ptop, pp(ims,kms,j), & nudge_wind, nudge_temp, nudge_mois, & coef_wind, coef_temp, coef_mois, & - savwt(1,ims,kms,j), kpblj, 0, & + savwt(1,ims,kms,j), kpbl(ims,j), 0, & + vih_uv(its,j,1), vih_uv(its,j,2), ht(ims,j), & + z(ims,kms,j), & iprt_nudob, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -390,4 +459,172 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart, & #endif END SUBROUTINE fddaobs_driver + SUBROUTINE compute_VIH(vif, hmax, fullmin, rampmin, & + regime, pblh, terrh, z, vih, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + + USE module_fddaobs_rtfdda + + IMPLICIT NONE +!******************************************************************************* +!***** COMPUTE HEIGHTS FOR SURFACE OBS VERTICAL INFLUENCE FUNCTION ***** +!******************************************************************************* + + REAL, INTENT(IN) :: vif(6) ! Vert infl params for regimes + REAL, INTENT(IN) :: hmax ! Max height to apply nudging + REAL, INTENT(IN) :: fullmin ! Min height of full nudging + REAL, INTENT(IN) :: rampmin ! Min height to ramp full-to-0 + REAL, INTENT(IN) :: regime(ims:ime,jms:jme) ! Stability regime + REAL, INTENT(IN) :: pblh(ims:ime,jms:jme) ! PBL height (m) + REAL, INTENT(IN) :: terrh(ims:ime,jms:jme) ! Terrain ht (m) + REAL, INTENT(IN) :: z(ims:ime,kms:kme,jms:jme) ! Ht (m) above sl (half levs) + REAL, INTENT(OUT) :: vih(its:ite,jts:jte,2) ! Vt infl hts abv grd for LML obs +! INTEGER, INTENT(OUT) :: vik(its:ite,jts:jte,2) ! Vert infl k-levels for LML obs + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde ! domain dims. + INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme ! memory dims. + INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte ! tile dims. + +! Local variables + real :: fullr(its:ite) ! Height up to full vertical weighting + real :: rampr(its:ite) ! Height of ramp-down to zero weighting + character(len=200) :: msg ! Argument to wrf_message + integer:: i, j ! Loop counters + + integer k ! ajb test + +! Do J-slabs + do j = jts, jte + +! Set fullr and rampr values according to regimes + do i = its, ite + + if(regime(i,j).eq.1.0) then ! REGIME 1 + fullr(i) = vif(1) + rampr(i) = vif(2) + elseif(regime(i,j).eq.2.0) then ! REGIME 2 + fullr(i) = vif(3) + rampr(i) = vif(4) + elseif(regime(i,j).eq.3.0 .or. regime(i,j).eq.4.0) then ! REGIME 4 + fullr(i) = vif(5) + rampr(i) = vif(6) + else + write(msg,'(a,f5.1,2(a,i4))') 'Unknown regime type ', regime(i,j), & + ' at grid coordinate i = ',i,' j = ',j + call wrf_message(msg) + call wrf_error_fatal ( 'fddaobs_driver: compute_VIH STOP' ) + + endif + + enddo + +! Get vert infl heights for LML obs, from fullr, rampr, and pblh + CALL get_vif_hts_slab(fullr, rampr, pblh(ims,j), & + hmax, fullmin, rampmin, & + vih(its,j,1), vih(its,j,2), & + ims,ime, its,ite) + enddo + END SUBROUTINE compute_VIH + + SUBROUTINE get_vif_hts_slab(fullr, rampr, pblh, hmax, fullmin, rampmin, & + ht1, ht2, ims,ime, its,ite) +! Compute VIF heights + + IMPLICIT NONE + + REAL, INTENT(IN) :: fullr(its:ite) ! Height up to full vertical weighting + REAL, INTENT(IN) :: rampr(its:ite) ! Height of ramp-down to zero weighting + REAL, INTENT(IN) :: pblh(ims:ime) ! PBL height (m) + REAL, INTENT(IN) :: hmax ! Max height to apply nudging + REAL, INTENT(IN) :: fullmin ! Min height of full nudging + REAL, INTENT(IN) :: rampmin ! Min height to ramp full-to-0 + REAL, INTENT(OUT) :: ht1(its:ite) ! Vert infl fcn height 1 + REAL, INTENT(OUT) :: ht2(its:ite) ! Vert infl fcn height 2 + INTEGER, INTENT(IN) :: ims,ime ! Memory dims. + INTEGER, INTENT(IN) :: its,ite ! Tile dims. + +! Local variables + integer :: i + + do i = its, ite + +! Determine lower height (below which the VIF=1 for full weighting) + if(fullr(i).ge.0.0) then ! fullr is height from ground + ht1(i) = fullr(i) + else ! fullr is relative to pbl (-5000 bias) + ht1(i) = pblh(i) - (fullr(i)+5000.) + endif + +! Height ht1 can be no smaller than fullmin + ht1(i) = max(fullmin,ht1(i)) + +! Determine upper height (to which the VIF ramps down to zero weighting) +! NOTE: Height of ramp-down (ht2-ht1) can be no smaller than rampmin + + if(rampr(i).ge.0.0) then +! rampr is height from ht1 + ht2(i) = ht1(i) + max(rampmin,rampr(i)) + else +! rampr is relative to pbl (-5000 bias) + ht2(i) = max( ht1(i)+rampmin, pblh(i)-(rampr(i)+5000.) ) + endif + +! Apply hmax + ht1(i) = min(ht1(i), hmax-rampmin) + ht2(i) = min(ht2(i), hmax) + enddo + END SUBROUTINE get_vif_hts_slab + + SUBROUTINE get_vik_slab( h, hlevs, ht, vik, ims,ime, kms,kme, its,ite, kts,kte ) + +! Compute VIK values from heights on j-slab + + IMPLICIT NONE + + REAL, INTENT(IN) :: h(its:ite) ! height (m) above ground, on j-slab + REAL, INTENT(IN) :: hlevs(ims:ime,kms:kme) ! hgt (m) abv grd at modl levs (slab) + REAL, INTENT(IN) :: ht(ims:ime) ! terrain height (m) (slab) + INTEGER, INTENT(OUT):: vik(its:ite) ! vert infl k levels (slab) + INTEGER, INTENT(IN) :: ims,ime, kms,kme ! memory dims + INTEGER, INTENT(IN) :: its,ite, kts,kte ! tile dims + +! Local variables + integer :: i + integer :: k + real :: ht_ag(kts:kte) + + do i = its, ite + +! Get column of height-above-ground values for this i coord + do k = kts,kte + ht_ag(k) = hlevs(i,k) - ht(i) + enddo +! Get k levels that correspond to height values + vik(i) = ht_to_k( h(i), ht_ag, kts,kte ) + enddo + END SUBROUTINE get_vik_slab + + INTEGER FUNCTION ht_to_k( h, hlevs, kts,kte ) + IMPLICIT NONE + + REAL, INTENT(IN) :: h ! height value (m) + REAL, INTENT(IN) :: hlevs(kts:kte) ! model height levels + INTEGER, INTENT(IN) :: kts,kte ! tile dims + +! Local variables + INTEGER :: k ! loop counter + INTEGER :: klo ! lower k bound + + KLEVS: do k = kts, kte + klo = k-1 + if(h .le. hlevs(k)) then + EXIT KLEVS + endif + enddo KLEVS + klo = max0(1,klo) + ht_to_k = min0(kte,klo) + RETURN + END FUNCTION ht_to_k + END MODULE module_fddaobs_driver diff --git a/wrfv2_fire/phys/module_fddaobs_rtfdda.F b/wrfv2_fire/phys/module_fddaobs_rtfdda.F index 2756fbb4..70a6d056 100644 --- a/wrfv2_fire/phys/module_fddaobs_rtfdda.F +++ b/wrfv2_fire/phys/module_fddaobs_rtfdda.F @@ -45,8 +45,19 @@ CONTAINS no_pbl_nudge_t, & no_pbl_nudge_q, & sfcfact, sfcfacr, dpsmx, & - lml_ht1, lml_ht2, & + nudgezfullr1_uv, nudgezrampr1_uv, & + nudgezfullr2_uv, nudgezrampr2_uv, & + nudgezfullr4_uv, nudgezrampr4_uv, & + nudgezfullr1_t, nudgezrampr1_t, & + nudgezfullr2_t, nudgezrampr2_t, & + nudgezfullr4_t, nudgezrampr4_t, & + nudgezfullr1_q, nudgezrampr1_q, & + nudgezfullr2_q, nudgezrampr2_q, & + nudgezfullr4_q, nudgezrampr4_q, & + nudgezfullmin, nudgezrampmin, nudgezmax, & xlat, xlong, & + start_year, start_month, start_day, & + start_hour, start_minute, start_second, & p00, t00, tlp, & znu, p_top, & #if ( EM_CORE == 1 ) @@ -90,10 +101,35 @@ CONTAINS REAL, intent(in) :: sfcfact ! scale factor applied to time window for surface obs REAL, intent(in) :: sfcfacr ! scale fac applied to horiz rad of infl for sfc obs REAL, intent(in) :: dpsmx ! max press change allowed within hor rad of infl - REAL, INTENT(IN) :: lml_ht1 ! height 1 for spreading of lowest model level obs - REAL, INTENT(IN) :: lml_ht2 ! height 2 for spreading of lowest model level obs + REAL, INTENT(IN) :: nudgezfullr1_uv ! vert infl fcn, regime=1 full-wt hght, winds + REAL, INTENT(IN) :: nudgezrampr1_uv ! vert infl fcn, regime=1 ramp down hght, winds + REAL, INTENT(IN) :: nudgezfullr2_uv ! vert infl fcn, regime=2 full-wt hght, winds + REAL, INTENT(IN) :: nudgezrampr2_uv ! vert infl fcn, regime=2 ramp down hght, winds + REAL, INTENT(IN) :: nudgezfullr4_uv ! vert infl fcn, regime=4 full-wt hght, winds + REAL, INTENT(IN) :: nudgezrampr4_uv ! vert infl fcn, regime=4 ramp down hght, winds + REAL, INTENT(IN) :: nudgezfullr1_t ! vert infl fcn, regime=1 full-wt hght, temp + REAL, INTENT(IN) :: nudgezrampr1_t ! vert infl fcn, regime=1 ramp down hght, temp + REAL, INTENT(IN) :: nudgezfullr2_t ! vert infl fcn, regime=2 full-wt hght, temp + REAL, INTENT(IN) :: nudgezrampr2_t ! vert infl fcn, regime=2 ramp down hght, temp + REAL, INTENT(IN) :: nudgezfullr4_t ! vert infl fcn, regime=4 full-wt hght, temp + REAL, INTENT(IN) :: nudgezrampr4_t ! vert infl fcn, regime=4 ramp down hght, temp + REAL, INTENT(IN) :: nudgezfullr1_q ! vert infl fcn, regime=1 full-wt hght, mois + REAL, INTENT(IN) :: nudgezrampr1_q ! vert infl fcn, regime=1 ramp down hght, mois + REAL, INTENT(IN) :: nudgezfullr2_q ! vert infl fcn, regime=2 full-wt hght, mois + REAL, INTENT(IN) :: nudgezrampr2_q ! vert infl fcn, regime=2 ramp down hght, mois + REAL, INTENT(IN) :: nudgezfullr4_q ! vert infl fcn, regime=4 full-wt hght, mois + REAL, INTENT(IN) :: nudgezrampr4_q ! vert infl fcn, regime=4 ramp down hght, mois + REAL, INTENT(IN) :: nudgezfullmin ! min dpth thru which vert infl fcn remains 1.0 (m) + REAL, INTENT(IN) :: nudgezrampmin ! min dpth thru which vif decreases 1.0 to 0.0 (m) + REAL, INTENT(IN) :: nudgezmax ! max dpth in which vif is nonzero (m) REAL, INTENT(IN) :: xlat ( ims:ime, jms:jme ) ! latitudes on mass-point grid REAL, INTENT(IN) :: xlong( ims:ime, jms:jme ) ! longitudes on mass-point grid + INTEGER, intent(in) :: start_year ! Model start year + INTEGER, intent(in) :: start_month ! Model start month + INTEGER, intent(in) :: start_day ! Model start day + INTEGER, intent(in) :: start_hour ! Model start hour + INTEGER, intent(in) :: start_minute ! Model start minute + INTEGER, intent(in) :: start_second ! Model start second REAL, INTENT(IN) :: p00 ! base state pressure REAL, INTENT(IN) :: t00 ! base state temperature REAL, INTENT(IN) :: tlp ! base state lapse rate @@ -118,10 +154,30 @@ CONTAINS real :: known_lon ! Longitude of domain point (i,j)=(1,1) character(len=200) :: msg ! Argument to wrf_message real :: z_at_p( kms:kme ) ! height at p levels - integer :: k ! loop counter + integer :: i,j,k ! loop counters #if ( EM_CORE == 1 ) +! Check to see if the nudging flag has been set. If not, +! simply RETURN. + nudge_flag = (nudge_opt(inest) .eq. 1) + if (.not. nudge_flag) return + + call wrf_message("") + write(msg,'(a,i2)') ' OBSERVATION NUDGING IS ACTIVATED FOR MESH ',inest + call wrf_message(msg) + + ktau = itimestep + if(restart) then + fdob%ktaur = ktau + else + fdob%ktaur = 0 + endif + +! Create character string containing model starting-date + CALL date_string(start_year, start_month, start_day, start_hour, & + start_minute, start_second, fdob%sdate) + ! Set flag for nudging on pressure (not sigma) surfaces. fdob%iwtsig = 0 @@ -207,8 +263,11 @@ CONTAINS call wrf_error_fatal('fddaobs_init: Namelist variable dpsmx must be greater than zero!') endif -! Initialize flags for vertical nudging settings - +! Calculate and store base-state heights at half (mass) levels. + CALL get_base_state_height_column( p_top, p00, t00, tlp, g, r_d, znu, & + fdob%base_state, kts, kte, kds,kde, kms,kme ) + +! Initialize flags for nudging within PBL. fdob%nudge_uv_pbl = .true. fdob%nudge_t_pbl = .true. fdob%nudge_q_pbl = .true. @@ -216,6 +275,125 @@ CONTAINS if(no_pbl_nudge_t(inest) .eq. 1) fdob%nudge_t_pbl = .false. if(no_pbl_nudge_q(inest) .eq. 1) fdob%nudge_q_pbl = .false. + if(no_pbl_nudge_uv(inest) .eq. 1) then + fdob%nudge_uv_pbl = .false. + write(msg,*) ' --> Obs nudging for U/V is turned off in PBL' + call wrf_message(msg) + endif + if(no_pbl_nudge_t(inest) .eq. 1) then + fdob%nudge_t_pbl = .false. + write(msg,*) ' --> Obs nudging for T is turned off in PBL' + call wrf_message(msg) + endif + if(no_pbl_nudge_q(inest) .eq. 1) then + fdob%nudge_q_pbl = .false. + write(msg,*) ' --> Obs nudging for Q is turned off in PBL' + call wrf_message(msg) + endif + +! Initialize vertical influence fcn for LML obs + fdob%vif_uv(1) = nudgezfullr1_uv + fdob%vif_uv(2) = nudgezrampr1_uv + fdob%vif_uv(3) = nudgezfullr2_uv + fdob%vif_uv(4) = nudgezrampr2_uv + fdob%vif_uv(5) = nudgezfullr4_uv + fdob%vif_uv(6) = nudgezrampr4_uv + fdob%vif_t (1) = nudgezfullr1_t + fdob%vif_t (2) = nudgezrampr1_t + fdob%vif_t (3) = nudgezfullr2_t + fdob%vif_t (4) = nudgezrampr2_t + fdob%vif_t (5) = nudgezfullr4_t + fdob%vif_t (6) = nudgezrampr4_t + fdob%vif_q (1) = nudgezfullr1_q + fdob%vif_q (2) = nudgezrampr1_q + fdob%vif_q (3) = nudgezfullr2_q + fdob%vif_q (4) = nudgezrampr2_q + fdob%vif_q (5) = nudgezfullr4_q + fdob%vif_q (6) = nudgezrampr4_q + +! Sanity checks + if(nudgezmax.le.0.) then + write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezmax MUST BE GREATER THAN ZERO.' + call wrf_message(msg) + write(msg,*) 'THE NAMELIST VALUE IS',nudgezmax + call wrf_message(msg) + call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgemax value' ) + endif + if(nudgezfullmin.lt.0.) then + write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezfullmin MUST BE NONNEGATIVE.' + call wrf_message(msg) + write(msg,*) 'THE NAMELIST VALUE IS',nudgezfullmin + call wrf_message(msg) + call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgefullmin value' ) + endif + if(nudgezrampmin.lt.0.) then + write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezrampmin MUST BE NONNEGATIVE.' + call wrf_message(msg) + write(msg,*) 'THE NAMELIST VALUE IS',nudgezrampmin + call wrf_message(msg) + call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgerampmin value' ) + endif + if(nudgezmax.lt.nudgezfullmin+nudgezrampmin) then + write(msg,*) 'STOP! INCONSISTENT OBS NAMELIST INPUTS.' + call wrf_message(msg) + write(msg,'(3(a,f12.3))') 'obs_nudgezmax = ',nudgezmax, & + ' obs_nudgezfullmin = ',nudgezfullmin, & + ' obs_nudgezrampmin = ',nudgezrampmin + call wrf_message(msg) + write(msg,*) 'REQUIRE NUDGEZMAX >= NUDGEZFULLMIN + NUDGEZRAMPMIN' + call wrf_message(msg) + call wrf_error_fatal ( 'fddaobs_init: STOP on inconsistent namelist values' ) + endif + + fdob%vif_fullmin = nudgezfullmin + fdob%vif_rampmin = nudgezrampmin + fdob%vif_max = nudgezmax + +! Check to make sure that if nudgzfullmin > 0, then it must be at least as large as the +! first model half-level will be anywhere in the domain at any time within the simulation. +! We use 1.1 times the base-state value fdob%base_state(1) for this purpose. + + if(nudgezfullmin.gt.0.0) then + if(nudgezfullmin .lt. 1.1*fdob%base_state(1)) then + fdob%vif_fullmin = 1.1*fdob%base_state(1) + endif + endif + + call wrf_message("") + call wrf_message("*** SETUP DESCRIPTION FOR SURFACE OBS NUDGING:") + call wrf_message("") + write(msg,'(a,i5,a)') ' NUDGEZMAX: The maximum height at which nudging will be'// & + ' applied from surface obs is ', nint(nudgezmax),' m AGL.' + call wrf_message(msg) + call wrf_message("") + write(msg,'(a,i3,a)') ' NUDGEZFULLMIN: The minimum height of full nudging weight'// & + ' for surface obs is ', nint(fdob%vif_fullmin),' m.' + call wrf_message(msg) + if(nudgezfullmin.lt.fdob%vif_fullmin) then + write(msg,'(a,i3,a)') ' ***WARNING***: NUDGEZFULLMIN has been increased from'// & + ' the user-input value of ',nint(nudgezfullmin),' m.' + call wrf_message(msg) + write(msg,'(a,i3,a)') ' to ensure that at least the bottom model level is'// & + ' included in full nudging.' + call wrf_message(msg) + endif + call wrf_message("") + write(msg,'(a,i3,a)') ' NUDGEZRAMPMIN: The minimum height to ramp from full to no'// & + ' nudging for surface obs is ', nint(nudgezrampmin),' m.' + call wrf_message(msg) + call wrf_message("") + +! Print vif settings + call print_vif_var('wind', fdob%vif_uv, nudgezfullmin, nudgezrampmin) + call wrf_message("") + call print_vif_var('temp', fdob%vif_t, nudgezfullmin, nudgezrampmin) + call wrf_message("") + call print_vif_var('mois', fdob%vif_q, nudgezfullmin, nudgezrampmin) + + call wrf_message("") + call wrf_message("*** END SETUP DESCRIPTION FOR SURFACE OBS NUDGING") + call wrf_message("") + ! Set parameters. fdob%pfree = 50.0 fdob%rinfmn = 1.0 @@ -253,38 +431,22 @@ CONTAINS endif enddo -! Check to see if the nudging flag has been set. If not, -! simply RETURN. - nudge_flag = (nudge_opt(inest) .eq. 1) - if (.not. nudge_flag) return - ktau = itimestep - if(restart) then - fdob%ktaur = ktau - else - fdob%ktaur = 0 - endif - -! Get heights at p levels using base-state calculation. +! fdob%LML_OBS_HT1_LEV = kte +! HT1: do k = kte, kts, -1 +! if( LML_HT1 .gt. z_at_p(k) ) then +! fdob%LML_OBS_HT1_LEV = k +! EXIT HT1 +! endif +! enddo HT1 - CALL get_base_state_height_column( p_top, p00, t00, tlp, g, r_d, znu, & - z_at_p, kts, kte, kds,kde, kms,kme ) - - fdob%LML_OBS_HT1_LEV = kte - HT1: do k = kte, kts, -1 - if( LML_HT1 .gt. z_at_p(k) ) then - fdob%LML_OBS_HT1_LEV = k - EXIT HT1 - endif - enddo HT1 - - fdob%LML_OBS_HT2_LEV = kte - HT2: do k = kte, kts, -1 - if( LML_HT2 .gt. z_at_p(k) ) then - fdob%LML_OBS_HT2_LEV = k - EXIT HT2 - endif - enddo HT2 +! fdob%LML_OBS_HT2_LEV = kte +! HT2: do k = kte, kts, -1 +! if( LML_HT2 .gt. z_at_p(k) ) then +! fdob%LML_OBS_HT2_LEV = k +! EXIT HT2 +! endif +! enddo HT2 RETURN #endif END SUBROUTINE fddaobs_init @@ -292,7 +454,7 @@ CONTAINS #if ( EM_CORE == 1 ) !----------------------------------------------------------------------- SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & - phb, ph, g, & + z_at_w, & uratx, vratx, tratx, kpbl, & nndgv, nerrf, niobf, maxdom, & levidn, parid, nstat, nstaw, & @@ -389,9 +551,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & REAL, INTENT(IN) :: pbase( ims:ime, kms:kme, jms:jme ) REAL, INTENT(IN) :: pp( ims:ime, kms:kme, jms:jme ) ! Press. perturbation (Pa) REAL, INTENT(IN) :: rovcp - REAL, INTENT(IN) :: phb( ims:ime, kms:kme, jms:jme ) ! geopotential (base) - REAL, INTENT(IN) :: ph( ims:ime, kms:kme, jms:jme ) ! geopotential (perturbation) - REAL, INTENT(IN) :: g ! gravity constant + REAL, INTENT(IN) :: z_at_w( ims:ime, kms:kme, jms:jme ) REAL, INTENT(IN) :: uratx( ims:ime, jms:jme ) ! U to U10 ratio on mass points. REAL, INTENT(IN) :: vratx( ims:ime, jms:jme ) ! V to V10 ratio on mass points. REAL, INTENT(IN) :: tratx( ims:ime, jms:jme ) ! T to TH2 ratio on mass points. @@ -458,6 +618,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & LOGICAL MP_LOCAL_VOBMASK(NIOBF) ! Dot-point mask LOGICAL MP_LOCAL_COBMASK(NIOBF) ! Cross-point mask #endif + ! LOGICAL, EXTERNAL :: TILE_MASK NSTA=NSTAT @@ -576,7 +737,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & if(pob .eq.-888888.) then hob = varobs(6,n) if(hob .gt. -800000. ) then - pob = ht_to_p( hob, ppbo, pbbo, phb, ph, g, iob_ms, job_ms, & + pob = ht_to_p( hob, ppbo, pbbo, z_at_w, iob_ms, job_ms, & dxob_ms, dyob_ms, k_start, k_end, kds,kde, & ims,ime, jms,jme, kms,kme ) endif @@ -684,7 +845,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & if(pob .eq.-888888.) then hob = varobs(6,n) if(hob .gt. -800000. ) then - pob = ht_to_p( hob, ppbo, pbbo, phb, ph, g, iob_ms, job_ms, & + pob = ht_to_p( hob, ppbo, pbbo, z_at_w, iob_ms, job_ms, & dxob_ms, dyob_ms, k_start, k_end, kds,kde, & ims,ime, jms,jme, kms,kme ) endif @@ -1287,6 +1448,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & timeob, varobs, errf, pbase, ptop, pp, & iswind, istemp, ismois, giv, git, giq, & savwt, kpblt, nscan, & + vih1, vih2, terrh, zslab, & iprt, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -1405,8 +1567,14 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & REAL, intent(in) :: giq ! Coefficient for moisture REAL, INTENT(INOUT) :: aten( ims:ime, kms:kme) REAL, INTENT(INOUT) :: savwt( nndgv, ims:ime, kms:kme ) - INTEGER, INTENT(IN) :: kpblt(its:ite) + INTEGER, INTENT(IN) :: kpblt(ims:ime) INTEGER, INTENT(IN) :: nscan ! number of scans + REAL, INTENT(IN) :: vih1(its:ite) ! Vert infl ht (m) abv grd for full wts + REAL, INTENT(IN) :: vih2(its:ite) ! Vert infl ht (m) abv grd for ramp + REAL, INTENT(IN) :: terrh(ims:ime) ! Terrain height (m) +! INTEGER, INTENT(IN) :: vik1(its:ite) ! Vertical infl k-level for full wts +! INTEGER, INTENT(IN) :: vik2(its:ite) ! Vertical infl k-level for ramp + REAL, INTENT(IN) :: zslab(ims:ime, kms:kme) ! model ht above ground (m) LOGICAL, INTENT(IN) :: iprt ! print flag ! Local variables @@ -1435,8 +1603,9 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & real :: gfactor,rfactor,gridx,gridy,rindx,ris real :: grfacx,grfacy real :: timewt,pob - real :: ri,rj,rx,ry,rsq,wtij,pdfac,erfivr,dk,slope,rinfac + real :: ri,rj,rx,ry,rsq,wtij,pdfac,erfivr,slope,rinfac real :: rinprs,pijk,pobhi,poblo,pdiffj,w2eowt,gitq + real :: dz_ramp ! For ramping weights for surface obs real :: scratch integer :: kk !ajb temp @@ -1704,46 +1873,64 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & ! DSQ=D*D ! WTIJ=(RIS-DSQ)/(RIS+DSQ) wtij=(ris-rsq)/(ris+rsq) - scratch = (abs(psurf(n)-.001*pbase(i,1))*fdob%DCON) + +! if(n.le.1000 .and. j.eq.14) then +! write(6,'(a,2i3,i2,2f7.2,4i4,3f7.3,2f6.1)') & +! 'sfc: n,i,ivar,ra,rb,mini,maxi,minj,maxj,wtij,ris,rsq,psurf,pbase = ', & +! n,i,ivar,ra(n),rb(n),mini,maxi,minj,maxj,wtij,ris,rsq, & +! psurf(n),.001*pbase(i,1) +! endif + + scratch = (abs (psurf(n)-.001*pbase(i,1))*fdob%DCON) pdfac=1.-AMIN1(1.0,scratch) wtij=wtij*pdfac WTIJ=AMAX1(0.0,WTIJ) -! try making sfc obs weighting go thru pbl -! jc kpbl is at dot or cross only - need to interpolate? -! wtsig(1)=1. - komax=max0(3,kpblt(i)) +!ajb Add weights to sum only if nudge_pbl switch is on. + if(nudge_pbl) then -! jc arbitrary check here - IF (iprt) THEN - if (kpblt(i).gt.25 .and. ktau.ne.0) then - write(msg,552)inest,i,j,kpblt(i) - call wrf_message(msg) - endif - ENDIF -552 FORMAT('kpblt is gt 25, inest,i,j,kpblt=',4i4) +! Here we calculate weights in the vertical coordinate, based on vih1 and vih2. +! In the equation for wtsig(k), Z=zslab(i,k)-terrh(i) contains the model Z-values +! (height above ground in meters) on a J-slab. The equation produces wtsig = 1.0 at +! levels 1 to K, where z(K) < vih1 < z(K+1). For the example below, in the equation +! for wtsig(k), the expression vih1(i)-Z(i,k) is strictly positive for k=1,2,3 since +! levels 1, 2, and 3 are below vih1. So xtsig(k)=min(1.0, 1.0-x) where x > 0 ==> +! wtsig(k)=1 for k=1,2,3. +! +! For levels K+1 and up, wtsig will decrease linearly with height, with values +! along the ramp that has value 1.0 at vih1 and 0.0 at vih2. In the example: +! +! dz_ramp = 1/(200-150) = 1/50 +! xtsig(4) = 1 + (150-175)/50 = 1 - 1/2 = 1/2 +! +! WTSIG +! 1 -|* * * * * * +! | +! | * +! | +! | * +! | +! | * +! 0 -|--|-------|-----------|------|----|----|---------|----> Z = HT ABOVE +! 15 55 115 150 175 200 250 GROUND +! k=1 k=2 k=3 vih1 k=4 vih2 k=5 + + dz_ramp = 1.0 / max( 1.0, vih2(i)-vih1(i) ) ! vih2 >= vih1 by construct - if(kpblt(i).gt.25) komax=3 - komin=1 - dk=float(komax) + LML: do k = kts, kte + wtsig(k) = min( 1.0, 1.0 + ( vih1(i)-zslab(i,k)+terrh(i) ) * dz_ramp ) + wtsig(k) = max( 0.0, wtsig(k)) -!ajb Add weights to sum only if nudge_pbl switch is on. - if(nudge_pbl) then - do k=komin,komax - - wtsig(k)=float(komax-k+1)/dk + if(wtsig(k).le.0.0) EXIT LML WT(I,K)=WT(I,K)+TIMEWT*WTSIG(K)*WTIJ - WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ*WTIJ*WTSIG(K) & *WTSIG(K)*ERFIVR - enddo + enddo LML endif - ENDDO - -! print *, " Surface " + ENDDO ! end i-loop endif ! end check for obs in domain -! END SURFACE-LAYER U OR V OBS NUDGING +! END SURFACE-LAYER OBS NUDGING ELSE @@ -1828,6 +2015,15 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & RSQ=RX*RX+RY*RY ! yliu test: for upper-air data, keep D1 influence radii WTIJ=(RIS-RSQ)/(RIS+RSQ) + +! if(n.le.1000 .and. j.eq.14) then +! kk = int(rko(n)) +! write(6,'(a,2i3,i2,2f7.2,4i4,3f8.3,i3,f6.2,2f6.1)') & +! 'upp: n,i,ivar,ra,rb,mini,maxi,minj,maxj,wtij,ris,rsq,kk,rko(n),pob,pbase = ', & +! n,i,ivar,ra(n),rb(n),mini,maxi,minj,maxj,wtij,ris,rsq, & +! kk,rko(n),pob,.001*pbase(i,kk) +! endif + WTIJ=AMAX1(0.0,WTIJ) ! weight ob in vertical with +- 50 mb ! yliu: 75 hba for single upper-air, 30hba for multi-level soundings @@ -1838,7 +2034,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & rinprs=3.0 endif ! yliu end -! + !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ! --- HANDLE 1-LEVEL and MULTI-LEVEL OBSERVATIONS SEPARATELY --- !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ @@ -1887,7 +2083,6 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & enddo OBS_K if(kobs.gt.kpbl_obs(n)) then -! if(kobs.gt.kpblt(i)) then ! Obs will act only above the PBL top komin=max0(kobs, komin) ! kobs here is kpblt(i)+1 else ! Obs acts below PBL top @@ -2120,6 +2315,9 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & W2EOWT=WT2ERR(I,K)/WT(I,K) ELSE W2EOWT=SAVWT(IPL,I,K) + +! write(6,'(a,4i4,f8.3)') 'i,j,k,ipl,W2EOWT = ',i,j,k,ipl,W2EOWT + ENDIF ! if(ivar .eq. 1 .and. i.eq.38 .and. j.eq.78 .and. k.eq.1) then @@ -2160,6 +2358,8 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & DO K=1,kte DO I=its,ite SAVWT(IPL,I,K)=WT2ERR(I,K)/WT(I,K) + +! write(6,'(a,4i4,f8.3)') 'i,j,k,ipl,savwt = ',i,j,k,ipl,savwt(ipl,i,k) ENDDO ENDDO ENDIF @@ -2233,6 +2433,39 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & RETURN END SUBROUTINE nudob + SUBROUTINE date_string(year, month, day, hour, minute, second, cdate) +!----------------------------------------------------------------------- +! PURPOSE: Form a date string (YYYY-MM-DD_hh:mm:ss) from integer +! components. +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: year + INTEGER, INTENT(IN) :: month + INTEGER, INTENT(IN) :: day + INTEGER, INTENT(IN) :: hour + INTEGER, INTENT(IN) :: minute + INTEGER, INTENT(IN) :: second + CHARACTER*19, INTENT(INOUT) :: cdate + +! Local variables + integer :: ic ! loop counter + + cdate(1:19) = "0000-00-00_00:00:00" + write(cdate( 1: 4),'(i4)') year + write(cdate( 6: 7),'(i2)') month + write(cdate( 9:10),'(i2)') day + write(cdate(12:13),'(i2)') hour + write(cdate(15:16),'(i2)') minute + write(cdate(18:19),'(i2)') second + do ic = 1,19 + if(cdate(ic:ic) .eq. " ") cdate(ic:ic) = "0" + enddo + + RETURN + END SUBROUTINE date_string + SUBROUTINE calc_rcouple_scales(a, msf, rscale, ims,ime, its,ite) !----------------------------------------------------------------------- IMPLICIT NONE @@ -2382,17 +2615,16 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & endif END SUBROUTINE print_obs_info - REAL FUNCTION ht_to_p( h, pbbc, ppbc, phb, ph, g, ic, jc, dx, dy, & + REAL FUNCTION ht_to_p( h, pbbc, ppbc, z_at_w, ic, jc, dx, dy, & k_start, k_end, kds,kde, ims,ime, jms,jme, kms,kme ) -!************************************************************************* -! Purpose: Interpolate pressure at a specific x, y, height coordinate. -! The input pressure column (base and perturbation) is already -! horizontally interpolated to the x, y position. The input -! geopotential field (base: phb, pert: ph) is 3d, and must be -! horizontally interpolated (to iob, job) to get a height column (z_at_p) -! before p is vertically interpolated. -!************************************************************************* +!****************************************************************************** +! Purpose: Interpolate pressure at a specified x (ic), y (jc), and height (h). +! The input pressure column pbbc+ppbc (base and perturbn) must already +! be horizontally interpolated to the x, y position. The subroutine +! get_height_column is called here to horizontally interpolated the +! 3D height field z_at_w to get a height column at (iob, job). +!****************************************************************************** IMPLICIT NONE @@ -2402,9 +2634,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme ! memory dims. REAL, INTENT(IN) :: pbbc(kds:kde) ! column base pressure (cb) REAL, INTENT(IN) :: ppbc(kds:kde) ! column pressure perturbation (cb) - REAL, INTENT(IN) :: phb( ims:ime, kms:kme, jms:jme ) ! geopotential (base) - REAL, INTENT(IN) :: ph( ims:ime, kms:kme, jms:jme ) ! geopotential (perturbation) - REAL, INTENT(IN) :: g ! gravity constant + REAL, INTENT(IN) :: z_at_w( ims:ime, kms:kme, jms:jme ) ! height (m) on full (w) levels INTEGER, INTENT(IN) :: ic ! i-coord of desired p INTEGER, INTENT(IN) :: jc ! j-coord of desired p REAL, INTENT(IN) :: dx ! interp. fraction (x dir) @@ -2422,41 +2652,41 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & REAL :: z_at_p( kms:kme ) ! height at p levels ! Calculate z at p levels. - call get_height_column(phb, ph, g, ic, jc, dx, dy, z_at_p, & + call get_height_column(z_at_w, ic, jc, dx, dy, z_at_p, & k_start, k_end, kds,kde, & ims,ime, jms,jme, kms,kme ) ! Now we have pbbc, ppbc, z_at_p, so compute p at h. First, find ! bounding layers klo and khi so that z_at_p(klo) <= h <= z_at_p(khi) - ZLEVS: do k = k_start+1, k_end - klo = k-1 - if(h .le. z_at_p(k)) then - EXIT ZLEVS - endif - enddo ZLEVS + ZLEVS: do k = k_start+1, k_end + klo = k-1 + if(h .le. z_at_p(k)) then + EXIT ZLEVS + endif + enddo ZLEVS - zlo = z_at_p(klo) - zhi = z_at_p(klo+1) + zlo = z_at_p(klo) + zhi = z_at_p(klo+1) ! Interpolate natural log of pressure - ln_plo = log( pbbc(klo+1) + ppbc(klo+1) ) - ln_phi = log( pbbc(klo) + ppbc(klo) ) - if(h.le.zlo) then - ln_p = ln_phi ! set to k=1 pressure - else if (h.ge.zhi) then - ln_p = ln_plo ! set to k=k_end pressure - else - ln_p = ln_plo + (ln_phi-ln_plo)*((zhi-h)/(zhi-zlo)) - endif + ln_plo = log( pbbc(klo+1) + ppbc(klo+1) ) + ln_phi = log( pbbc(klo) + ppbc(klo) ) + if(h.le.zlo) then + ln_p = ln_phi ! set to k=1 pressure + else if (h.ge.zhi) then + ln_p = ln_plo ! set to k=k_end pressure + else + ln_p = ln_plo + (ln_phi-ln_plo)*((zhi-h)/(zhi-zlo)) + endif ! Return pressure - p = exp(ln_p) - ht_to_p = p + p = exp(ln_p) + ht_to_p = p RETURN END FUNCTION ht_to_p - SUBROUTINE get_height_column( phb, ph, g, ic, jc, dx, dy, z_at_p, & + SUBROUTINE get_height_column( z_at_w, ic, jc, dx, dy, z_at_p, & k_start, k_end, kds,kde, & ims,ime, jms,jme, kms,kme ) !************************************************************************* @@ -2468,9 +2698,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & INTEGER, INTENT(IN) :: k_start, k_end ! Loop bounds INTEGER, INTENT(IN) :: kds,kde ! vertical dim. INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme ! memory dims. - REAL, INTENT(IN) :: phb( ims:ime, kms:kme, jms:jme ) ! geopotential (base) - REAL, INTENT(IN) :: ph( ims:ime, kms:kme, jms:jme ) ! geopotential (perturbation) - REAL, INTENT(IN) :: g ! gravity constant + REAL, INTENT(IN) :: z_at_w( ims:ime, kms:kme, jms:jme ) ! ht(m) on full (w) levels INTEGER, INTENT(IN) :: ic ! i-coord of desired p INTEGER, INTENT(IN) :: jc ! j-coord of desired p REAL, INTENT(IN) :: dx ! interp. fraction (x dir) @@ -2479,28 +2707,19 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & ! Local variables INTEGER :: k ! loop counter - REAL :: phbc(kds:kde) ! column geopotential (base) - REAL :: phc(kds:kde) ! column geopotential (perturbation) - REAL :: z_at_w(kds:kde) ! column height at w levels + REAL :: zw_int(kds:kde) ! horizonatlly interpolated column height at w levels do k = kds, kde - phbc(k) = & - (1.-DY)*( (1.-DX)*phb(IC,K,JC) + & - DX *phb(IC+1,K,JC) ) + & - DY* ( (1.-DX)*phb(IC,K,JC+1) + & - DX *phb(IC+1,K,JC+1) ) - phc(k) = & - (1.-DY)*( (1.-DX)*ph(IC,K,JC) + & - DX *ph(IC+1,K,JC) ) + & - DY* ( (1.-DX)*ph(IC,K,JC+1) + & - DX *ph(IC+1,K,JC+1) ) - - z_at_w(k) = (phbc(k)+phc(k))/g + zw_int(k) = & + (1.-DY)*( (1.-DX)*z_at_w(IC,K,JC) + & + DX *z_at_w(IC+1,K,JC) ) + & + DY* ( (1.-DX)*z_at_w(IC,K,JC+1) + & + DX *z_at_w(IC+1,K,JC+1) ) enddo do k = k_start, k_end - z_at_p(k) = 0.5*(z_at_w(k) +z_at_w(k+1)) + z_at_p(k) = 0.5*(zw_int(k) +zw_int(k+1)) enddo END SUBROUTINE get_height_column @@ -2592,6 +2811,115 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp, & ENDIF get_timewt = timewt END FUNCTION get_timewt + + SUBROUTINE print_vif_var(var, vif, nfullmin, nrampmin ) +!******************************************************** +! Purpose: Print a description of the vertical influence +! function for a given variable. +!******************************************************** + IMPLICIT NONE + + character(len=4), intent(in) :: var ! Variable (wind, temp, mois) + real, intent(in) :: vif(6) ! Vertical influence function + real, intent(in) :: nfullmin ! Vert infl fcn full nudge min + real, intent(in) :: nrampmin ! Vert infl fcn ramp decr min + +! Local variables + character(len=200) :: msg1, msg2 + character(len=8) :: regime + real :: nfullr1, nrampr1 + real :: nfullr2, nrampr2 + real :: nfullr4, nrampr4 + + nfullr1 = vif(1) + nrampr1 = vif(2) + nfullr2 = vif(3) + nrampr2 = vif(4) + nfullr4 = vif(5) + nrampr4 = vif(6) + + if(var.eq.'wind') then + write(msg1,'(a)') ' For winds:' + elseif (var.eq.'temp') then + write(msg1,'(a)') ' For temperature:' + elseif (var.eq.'mois') then + write(msg1,'(a)') ' For moisture:' + else + write(msg1,'(a,a4)') 'Unknown variable type: ',var + call wrf_error_fatal ( 'print_vif_var: module_fddaobs_rtfdda STOP' ) + endif + + call wrf_message(msg1) + +! For this variable, print a description of the vif for each regime + call print_vif_regime(1, nfullr1, nrampr1, nfullmin, nrampmin) + call print_vif_regime(2, nfullr2, nrampr2, nfullmin, nrampmin) + call print_vif_regime(4, nfullr4, nrampr4, nfullmin, nrampmin) + + END SUBROUTINE print_vif_var + + SUBROUTINE print_vif_regime(reg, nfullr, nrampr, nfullmin, nrampmin ) +!******************************************************** +! Purpose: Print a description of the vertical influence +! function for a given regime. +!******************************************************** + IMPLICIT NONE + + integer, intent(in) :: reg ! Regime number (1, 2, 4) + real, intent(in) :: nfullr ! Full nudge range for regime + real, intent(in) :: nrampr ! Rampdown range for regime + real, intent(in) :: nfullmin ! Vert infl fcn full nudge min + real, intent(in) :: nrampmin ! Vert infl fcn ramp decr min + +! Local variables + character(len=200) :: msg1, msg2 + character(len=8) :: regime + + if(reg.eq.1) then + write(regime,'(a)') 'Regime 1' + elseif (reg.eq.2) then + write(regime,'(a)') 'Regime 2' + elseif (reg.eq.4) then + write(regime,'(a)') 'Regime 4' + else + write(msg1,'(a,i3)') 'Unknown regime number: ',reg + call wrf_error_fatal ( 'print_vif_regime: module_fddaobs_rtfdda STOP' ) + endif + +!Set msg1 for description of full weighting range + if(nfullr.lt.0) then + if(nfullr.eq.-5000) then + write(msg1,'(2x,a8,a)') regime, ': Full weighting to the PBL top' + elseif (nfullr.lt.-5000) then + write(msg1,'(2x,a8,a,i4,a)') regime, ': Full weighting to ',int(-5000.-nfullr), & + ' m above the PBL top' + else + write(msg1,'(2x,a8,a,i4,a)') regime, ': Full weighting to ',int(nfullr+5000.), & + ' m below the PBL top' + endif + else + write(msg1,'(2x,a8,a,i4,a)') regime, ': Full weighting through ', & + int(max(nfullr,nfullmin)),' m' + endif + +!Set msg2 for description of rampdown range + if(nrampr.lt.0) then + if(nrampr.eq.-5000) then + write(msg2,'(a)') ' and a vertical rampdown up to the PBL top.' + elseif (nrampr.lt.-5000) then + write(msg2,'(a,i4,a)') ' and a vertical rampdown to ',int(-5000.-nrampr), & + ' m above the PBL top.' + else + write(msg2,'(a,i4,a)') ' and a vertical rampdown to ',int(nrampr+5000.), & + ' m below the PBL top.' + endif + else + write(msg2,'(a,i4,a)') ' and a vertical rampdown in the next ', & + int(max(nrampr,nrampmin)),' m.' + endif + call wrf_message(TRIM(msg1)//msg2) + + END SUBROUTINE print_vif_regime #endif END MODULE module_fddaobs_rtfdda diff --git a/wrfv2_fire/phys/module_fr_sfire_driver.F b/wrfv2_fire/phys/module_fr_sfire_driver.F index 5963ddc6..026911bf 100644 --- a/wrfv2_fire/phys/module_fr_sfire_driver.F +++ b/wrfv2_fire/phys/module_fr_sfire_driver.F @@ -73,7 +73,12 @@ subroutine sfire_driver_em ( grid , config_flags & USE module_driver_constants USE module_machine USE module_tiles - USE module_dm +#ifdef DM_PARALLEL + USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks + USE module_comm_dm , ONLY : halo_fire_lfn_sub,halo_fire_longlat_sub,halo_fire_ht_sub & + ,halo_fire_zsf_sub, halo_fire_fuel_sub,halo_fire_wind_a_sub & + ,halo_fire_wind_f_sub,halo_fire_tign_sub +#endif implicit none !*** arguments diff --git a/wrfv2_fire/phys/module_microphysics_driver.F b/wrfv2_fire/phys/module_microphysics_driver.F index 769d923a..b8fea6ad 100644 --- a/wrfv2_fire/phys/module_microphysics_driver.F +++ b/wrfv2_fire/phys/module_microphysics_driver.F @@ -23,24 +23,38 @@ SUBROUTINE microphysics_driver( & ,i_start,i_end,j_start,j_end,kts,kte & ,num_tiles, naer & ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr & - ,qndrop_curr,qni_curr & - ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr & + ,qndrop_curr,qni_curr,qh_curr,qnh_curr & + ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr & + ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr & ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni & - ,f_qns,f_qnr,f_qng,f_qnc,f_qnn & - ,qrcuten, qscuten, qicuten, mu & + ,f_qns,f_qnr,f_qng,f_qnc,f_qnn,f_qh,f_qnh & + , f_qzr,f_qzi,f_qzs,f_qzg,f_qzh & + ,qrcuten, qscuten, qicuten, mu & ,qt_curr,f_qt & ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew - ,hail,ice2 & ! for gsfcgce + ,hail,ice2 & ! for mp_gsfcgce +! ,ccntype & ! for mp_milbrandt2mom ,w ,z & - ,rainnc, rainncv & - ,snownc, snowncv & + ,rainnc, rainncv & + ,snownc, snowncv & + ,hailnc, hailncv & ,graupelnc, graupelncv & + ,refl_10cm & ! HM, 9/22/09, add for refl ) ! Framework +#if(NMM_CORE==1) USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, THOMPSON, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, THOMPSON07 + ,WSM6SCHEME, ETAMPNEW, etamp_HWRF,THOMPSON, MORR_TWO_MOMENT & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, THOMPSON07 & + ,MILBRANDT2MOM !,MILBRANDT3MOM +#else + USE module_state_description, ONLY : & + KESSLERSCHEME, LINSCHEME, WSM3SCHEME, WSM5SCHEME & + ,WSM6SCHEME, ETAMPNEW,THOMPSON, MORR_TWO_MOMENT & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, THOMPSON07 & + ,MILBRANDT2MOM !,MILBRANDT3MOM +#endif ! Model Layer USE module_model_constants @@ -57,10 +71,13 @@ SUBROUTINE microphysics_driver( & USE module_mp_thompson USE module_mp_thompson07 USE module_mp_gsfcgce - USE module_mp_morr_two_moment + USE module_mp_morr_two_moment USE module_mp_wdm5 USE module_mp_wdm6 + USE module_mp_milbrandt2mom +! USE module_mp_milbrandt3mom + USE module_mp_HWRF USE module_mixactivate, only: prescribe_aerosol_mixactivate !---------------------------------------------------------------------- @@ -74,22 +91,23 @@ SUBROUTINE microphysics_driver( & ! WRF Single-Moment 5-class, Hong, Dudhia and Chen (2004) ! WRF Single-Moment 6-class, Lim and Hong (2003 WRF workshop) ! Eta Grid-scale Cloud and Precipitation scheme (EGCP01, Ferrier) - ! + ! Milbrandt and Yau (2005) + !---------------------------------------------------------------------- IMPLICIT NONE !====================================================================== ! Grid structure in physics part of WRF -!---------------------------------------------------------------------- +!---------------------------------------------------------------------- ! The horizontal velocities used in the physics are unstaggered ! relative to temperature/moisture variables. All predicted ! variables are carried at half levels except w, which is at full ! levels. Some arrays with names (*8w) are at w (full) levels. ! -!---------------------------------------------------------------------- -! In WRF, kms (smallest number) is the bottom level and kme (largest -! number) is the top level. In your scheme, if 1 is at the top level, +!---------------------------------------------------------------------- +! In WRF, kms (smallest number) is the bottom level and kme (largest +! number) is the top level. In your scheme, if 1 is at the top level, ! then you have to reverse the order in the k direction. -! +! ! kme - half level (no data at this level) ! kme ----- full level ! kme-1 - half level @@ -109,16 +127,25 @@ SUBROUTINE microphysics_driver( & !----------- ! Rho_d dry density (kg/m^3) ! Theta_m moist potential temperature (K) -! Qv water vapor mixing ratio (kg/kg) -! Qc cloud water mixing ratio (kg/kg) -! Qr rain water mixing ratio (kg/kg) -! Qi cloud ice mixing ratio (kg/kg) -! Qs snow mixing ratio (kg/kg) +! Qv water vapor mixing ratio (kg/kg) +! Qc cloud water mixing ratio (kg/kg) +! Qr rain water mixing ratio (kg/kg) +! Qi cloud ice mixing ratio (kg/kg) +! Qs snow mixing ratio (kg/kg) +! Qg graupel mixing ratio (kg/kg) +! Qh hail mixing ratio (kg/kg) ! Qndrop droplet number mixing ratio (#/kg) ! Qni cloud ice number concentration (#/kg) -! Qns snow number concentration (#/kg), -! Qnr rain number concentration (#/kg), -! Qng graupel number concentration (#/kg), +! Qns snow number concentration (#/kg) +! Qnr rain number concentration (#/kg) +! Qng graupel number concentration (#/kg) +! Qnh hail number concentration (#/kg) + +! Qzr rain reflectivity (m6/kg) +! Qzi ice reflectivity (m6/kg) +! Qzs snow reflectivity (m6/kg) +! Qzg graupel reflectivity (m6/kg) +! Qzh hail reflectivity (m6/kg) ! !---------------------------------------------------------------------- @@ -134,6 +161,8 @@ SUBROUTINE microphysics_driver( & !-- SNOWNCV one time step grid scale snow and ice (mm/step) !-- GRAUPELNC grid scale graupel (mm) !-- GRAUPELNCV one time step grid scale graupel (mm/step) +!-- HAILNC grid scale hail (mm) +!-- HAILNCV one time step grid scale hail (mm/step) !-- SR one time step mass ratio of snow to total precip !-- z Height above sea level (m) !-- dt Time step (s) @@ -163,11 +192,18 @@ SUBROUTINE microphysics_driver( & !-- P_QI species index for cloud ice !-- P_QS species index for snow !-- P_QG species index for graupel +!-- P_QH species index for hail !-- P_QNDROP species index for cloud drop mixing ratio +!-- P_QNR species index for rain number concentration, !-- P_QNI species index for cloud ice number concentration -!-- P_QNS species index for snow number concentration, -!-- P_QNR species index for rain number concentration, -!-- P_QNG species index for graupel number concentration, +!-- P_QNS species index for snow number concentration, +!-- P_QNG species index for graupel number concentration, +!-- P_QNH species index for hail number concentration, +!-- P_QZR species index for rain reflectivity +!-- P_QZI species index for ice reflectivity +!-- P_QZS species index for snow reflectivity +!-- P_QZG species index for graupel reflectivity +!-- P_QZH species index for hail reflectivity !-- id grid id number !-- ids start index for i in domain !-- ide end index for i in domain @@ -198,7 +234,7 @@ SUBROUTINE microphysics_driver( & INTEGER, INTENT(IN ) :: mp_physics LOGICAL, INTENT(IN ) :: specified INTEGER, OPTIONAL, INTENT(IN ) :: chem_opt, progn - INTEGER, OPTIONAL, INTENT(IN ) :: hail, ice2 + INTEGER, OPTIONAL, INTENT(IN ) :: hail, ice2 !, ccntype ! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme @@ -251,23 +287,26 @@ SUBROUTINE microphysics_driver( & ! ! Optional ! + REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT) :: refl_10cm + LOGICAL, OPTIONAL, INTENT(IN ) :: channel_switch REAL, OPTIONAL, INTENT(INOUT ) :: naer ! aerosol number concentration (/kg) REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & INTENT(INOUT ) :: & - w, z, t8w & + w, z, t8w & ,cldfra, cldfra_old, exch_h & ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr & - ,qt_curr,qndrop_curr,qni_curr & - ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr + ,qt_curr,qndrop_curr,qni_curr,qh_curr,qnh_curr & + ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr & + ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, & - INTENT(IN) :: qrcuten, qscuten, qicuten - REAL, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, & - INTENT(IN) :: mu + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(IN) :: qrcuten, qscuten, qicuten + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, & + INTENT(IN) :: mu REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & @@ -284,7 +323,9 @@ SUBROUTINE microphysics_driver( & ,SNOWNC & ,SNOWNCV & ,GRAUPELNC & - ,GRAUPELNCV + ,GRAUPELNCV & + ,HAILNC & + ,HAILNCV INTEGER,OPTIONAL,INTENT(IN ) :: id REAL , DIMENSION( ims:ime , jms:jme ) , OPTIONAL , & @@ -294,8 +335,9 @@ SUBROUTINE microphysics_driver( & ,tbpvs_state,tbpvs0_state ! - LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni,f_qt & - ,f_qns,f_qnr,f_qng,f_qnn,f_qnc + LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni,f_qt & + ,f_qns,f_qnr,f_qng,f_qnn,f_qnc,f_qh,f_qnh,f_qzr & + ,f_qzi,f_qzs,f_qzg,f_qzh ! LOCAL VAR @@ -303,7 +345,7 @@ SUBROUTINE microphysics_driver( & LOGICAL :: channel !--------------------------------------------------------------------- -! check for microphysics type. We need a clean way to +! check for microphysics type. We need a clean way to ! specify these things! !--------------------------------------------------------------------- @@ -345,7 +387,12 @@ SUBROUTINE microphysics_driver( & #endif +! 2009-06009 rce - zero all these for safety IF( PRESENT(qlsink) ) qlsink(its:ite,kts:kte,jts:jte) = 0. + IF( PRESENT(precr ) ) precr(its:ite,kts:kte,jts:jte) = 0. + IF( PRESENT(preci ) ) preci(its:ite,kts:kte,jts:jte) = 0. + IF( PRESENT(precs ) ) precs(its:ite,kts:kte,jts:jte) = 0. + IF( PRESENT(precg ) ) precg(its:ite,kts:kte,jts:jte) = 0. !----------- IF( PRESENT(chem_opt) .AND. PRESENT(progn) ) THEN @@ -391,7 +438,7 @@ SUBROUTINE microphysics_driver( & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) - ELSE + ELSE CALL wrf_error_fatal ( 'arguments not present for calling kessler' ) ENDIF @@ -444,7 +491,7 @@ SUBROUTINE microphysics_driver( & PRESENT (QNR_CURR) .AND. PRESENT (QNG_CURR).AND. & PRESENT (MU) .AND. PRESENT (QSCUTEN).AND. & PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. & - PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & + PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & PRESENT (Z ) .AND.PRESENT ( W ) ) THEN CALL mp_morr_two_moment( & ITIMESTEP=itimestep, & !* @@ -460,19 +507,19 @@ SUBROUTINE microphysics_driver( & NR=qnr_curr, & !* ! VVT NG=qng_curr, & !* ! VVT RHO=rho, & !* - PII=pi_phy, & !* + PII=pi_phy, & !* P=p, & !* DT_IN=dt, & !* - DZ=dz8w, & !* !hm + DZ=dz8w, & !* !hm HT=ht, & !* W=w & !* - ,RAINNC=RAINNC & !* + ,RAINNC=RAINNC & !* ,RAINNCV=RAINNCV & !* - ,SR=SR & !* !hm + ,SR=SR & !* !hm ,qrcuten=qrcuten & ! hm - ,qscuten=qscuten & ! hm - ,qicuten=qicuten & ! hm - ,mu=mu & ! hm + ,qscuten=qscuten & ! hm + ,qicuten=qicuten & ! hm + ,mu=mu & ! hm ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -481,6 +528,112 @@ SUBROUTINE microphysics_driver( & Call wrf_error_fatal( 'arguments not present for calling morrison two moment') ENDIF + + CASE (MILBRANDT2MOM) + CALL wrf_debug(100, 'microphysics_driver: calling milbrandt2mom') + IF (PRESENT (QV_CURR) .AND. & + PRESENT (QC_CURR) .AND. PRESENT (QNC_CURR) .AND. & + PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & + PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & + PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & + PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & + PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & + PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & + PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & + PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & + PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & + PRESENT (Z ) .AND. PRESENT ( W ) ) THEN +! PRESENT (ccntype) & + + CALL mp_milbrandt2mom_driver( & + ITIMESTEP=itimestep, & + TH=th, & + QV=qv_curr, & + QC=qc_curr, & + QR=qr_curr, & + QI=qi_curr, & + QS=qs_curr, & + QG=qg_curr, & + QH=qh_curr, & + NC=qnc_curr, & + NR=qnr_curr, & + NI=qni_curr, & + NS=qns_curr, & + NG=qng_curr, & + NH=qnh_curr, & + PII=pi_phy, & + P=p, & + DT_IN=dt, & + DZ=dz8w, & + W=w, & + RAINNC = RAINNC, & + RAINNCV = RAINNCV, & + SNOWNC = SNOWNC, & + SNOWNCV = SNOWNCV, & + HAILNC = HAILNC, & + HAILNCV = HAILNCV, & + GRPLNC = GRAUPELNC, & + GRPLNCV = GRAUPELNCV, & + SR=SR, & +! ccntype = ccntype, & + Zet = refl_10cm, & ! HM, 9/22/09 for refl + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + Call wrf_error_fatal( 'arguments not present for calling milbrandt2mom') + ENDIF + + +! CASE (MILBRANDT3MOM) +! CALL wrf_debug(100, 'microphysics_driver: calling milbrandt3mom') +! IF (PRESENT (QV_CURR) .AND. & +! PRESENT (QC_CURR) .AND. PRESENT (QNC_CURR) .AND. & +! PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. PRESENT (QZR_CURR) .AND. & +! PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. PRESENT (QZI_CURR) .AND. & +! PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. PRESENT (QZS_CURR) .AND. & +! PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. PRESENT (QZG_CURR) .AND. & +! PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. PRESENT (QZH_CURR) .AND. & +! PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & +! PRESENT (Z ) .AND. PRESENT ( W ) ) THEN +! CALL mp_milbrandt3mom_driver( & +! ITIMESTEP=itimestep, & !* +! TH=th, & !* +! QV=qv_curr, & !* +! QC=qc_curr, & !* +! QR=qr_curr, & !* +! QI=qi_curr, & !* +! QS=qs_curr, & !* +! QG=qg_curr, & !* +! QH=qh_curr, & !* +! NC=qnc_curr, & !* +! NR=qnr_curr, & !* +! NI=qni_curr, & !* +! NS=qns_curr, & !* +! NG=qng_curr, & !* +! NH=qnh_curr, & !* +! ZR=qzr_curr, & !* +! ZI=qzi_curr, & !* +! ZS=qzs_curr, & !* +! ZG=qzg_curr, & !* +! ZH=qzh_curr, & !* +! PII=pi_phy, & !* +! P=p, & !* +! DT_IN=dt, & !* +! DZ=dz8w, & !* ! h +! W=w & !* +! ,RAINNC=RAINNC & !* +! ,RAINNCV=RAINNCV & !* +! ,SR=SR & !* !hm +! ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & +! ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & +! ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & +! ) +! ELSE +! Call wrf_error_fatal( 'arguments not present for calling milbrandt3mom') +! ENDIF + ! CASE (GSFCGCESCHEME) CALL wrf_debug ( 100 , 'microphysics_driver: calling GSFCGCE' ) @@ -553,7 +706,7 @@ SUBROUTINE microphysics_driver( & ,QG=qg_curr & ,QNDROP=qndrop_curr & ) - ELSE + ELSE CALL wrf_error_fatal ( 'arguments not present for calling lin_et_al' ) ENDIF @@ -582,7 +735,7 @@ SUBROUTINE microphysics_driver( & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) - ELSE + ELSE CALL wrf_error_fatal ( 'arguments not present for calling wsm3' ) ENDIF @@ -677,6 +830,7 @@ SUBROUTINE microphysics_driver( & ,RAIN=rainnc ,RAINNCV=rainncv & ,SNOW=snownc ,SNOWNCV=snowncv & ,SR=sr & + ,ITIMESTEP=itimestep & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -715,6 +869,7 @@ SUBROUTINE microphysics_driver( & ,SNOW=snownc ,SNOWNCV=snowncv & ,SR=sr & ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & + ,ITIMESTEP=itimestep & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -722,7 +877,34 @@ SUBROUTINE microphysics_driver( & ELSE CALL wrf_error_fatal ( 'arguments not present for calling wdm6') ENDIF +#if(NMM_CORE==1) + CASE (ETAMP_HWRF) + CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew_HWRF') + IF ( PRESENT( qv_curr ) .AND. PRESENT( qt_curr ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( mp_restart_state ) .AND. & + PRESENT( tbpvs_state ) .AND. & + PRESENT( tbpvs0_state ) ) THEN + + CALL ETAMP_NEW_HWRF( & + ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy, GID=id & + ,RAINNC=rainnc,RAINNCV=rainncv & + ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & + ,QV=qv_curr & + ,QT=qt_curr & + ,LOWLYR=LOWLYR,SR=SR & + ,F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY & + ,F_RIMEF_PHY=F_RIMEF_PHY & + ,QC=qc_curr,QR=Qr_curr,QI=Qi_curr & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling etampnew' ) + ENDIF +#endif CASE (ETAMPNEW) CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew') @@ -736,7 +918,7 @@ SUBROUTINE microphysics_driver( & ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & ,QV=qv_curr & ,QC=qc_curr & - ,QS=qs_curr & + ,QS=qs_curr & ,QR=qr_curr & ,QT=qt_curr & ,LOWLYR=LOWLYR,SR=SR & @@ -784,12 +966,12 @@ SUBROUTINE microphysics_driver( & CALL wrf_error_fatal ( 'arguments not present for calling thompson07' ) ENDIF - CASE DEFAULT + CASE DEFAULT WRITE( wrf_err_message , * ) 'The microphysics option does not exist: mp_physics = ', mp_physics CALL wrf_error_fatal ( wrf_err_message ) - END SELECT micro_select + END SELECT micro_select ENDDO #ifndef RUN_ON_GPU diff --git a/wrfv2_fire/phys/module_mixactivate.F b/wrfv2_fire/phys/module_mixactivate.F index 3e156ba6..c8a76257 100644 --- a/wrfv2_fire/phys/module_mixactivate.F +++ b/wrfv2_fire/phys/module_mixactivate.F @@ -1104,7 +1104,7 @@ OLD_CLOUD_NSUBMIX_LOOP: do nsub=1,nsubmix qndrop3d(i,k,j) = max(qndrop(k),1.e-6) if(qndrop3d(i,k,j).lt.-10.e6.or.qndrop3d(i,k,j).gt.1.E20)then - write(6,'(a,g12.2,a,3i5)')'after qndrop=',qndrop3d(i,k,j),' for i,k,j=',i,k,j + write(6,'(a,g12.2,a,3i5)')'after qndrop3d=',qndrop3d(i,k,j),' for i,k,j=',i,k,j endif if(qc(i,k,j).lt.-1..or.qc(i,k,j).gt.1.)then write(6,'(a,g12.2,a,3i5)')'qc=',qc(i,k,j),' for i,k,j=',i,k,j diff --git a/wrfv2_fire/phys/module_mp_lin.F b/wrfv2_fire/phys/module_mp_lin.F index 3d9ac58c..89d01d42 100644 --- a/wrfv2_fire/phys/module_mp_lin.F +++ b/wrfv2_fire/phys/module_mp_lin.F @@ -455,19 +455,19 @@ CONTAINS ! REAL :: tmp_tem, tmp_temcc !bloss ! + real :: liqconc, dis, beta, kappa, p0, xc, capn,rhocgs !sg: begin -! liqconc = liquid water content in gcm^-3 -! capn = droplet number concentration cm^-3 +! liqconc = liquid water content (g cm^-3) +! capn = droplet number concentration (# cm^-3) ! dis = relative dispersion (dimensionless) between 0.2 and 1. ! Written by Yangang Liu based on Liu et al., GRL 32, 2005. -! Autoconversion rate P = P0*T -! p0 = rate function -! kappa = constant in Long kernel -! beta = Condensation rate constant +! Autoconversion rate p = p0 * (threshold function) +! p0 = "base" autoconversion rate (g cm^-3 s^-1) +! kappa = constant in Long kernel = [kappa2 * (3/(4*pi*rhow))^3] in Liu papers +! beta = Condensation rate constant = (beta6)^6 in Liu papers ! xc = Normalized critical mass ! *********************************************************** - real liqconc, dis, beta, kappa, p0, xc, capn,rhocgs if(flag_qndrop)then dis = 0.5 ! droplet dispersion, set to 0.5 per SG 8-Nov-2006 ! Give empirical constants @@ -1415,16 +1415,16 @@ CONTAINS if( qndropz(k) >= 1. ) then ! Liu et al. autoconversion scheme rhocgs=rho(k)*1.e-3 - liqconc=rhocgs*qlz(k) - capn=1.e-03*rhocgs*qndropz(k) + liqconc=rhocgs*qlz(k) ! (kg/kg) to (g/cm3) + capn=1.0e-3*rhocgs*qndropz(k) ! (#/kg) to (#/cm3) ! rate function if(liqconc.gt.1.e-10)then - p0=kappa*beta/capn*(liqconc*liqconc*liqconc) + p0=(kappa*beta/capn)*(liqconc*liqconc*liqconc) xc=9.7d-17*capn*sqrt(capn)/(liqconc*liqconc) ! Calculate autoconversion rate (g/g/s) if(xc.lt.10.)then - praut(k)=p0/rhocgs*0.5d0*(xc*xc+2*xc+2.0d0)* & - (1.0d0+xc)*dexp(-2.0d0*xc) + praut(k)=(p0/rhocgs) * ( 0.5d0*(xc*xc+2*xc+2.0d0)* & + (1.0d0+xc)*exp(-2.0d0*xc) ) endif endif endif diff --git a/wrfv2_fire/phys/module_mp_morr_two_moment.F b/wrfv2_fire/phys/module_mp_morr_two_moment.F index 144f84fc..bd3e0717 100644 --- a/wrfv2_fire/phys/module_mp_morr_two_moment.F +++ b/wrfv2_fire/phys/module_mp_morr_two_moment.F @@ -2,8 +2,19 @@ ! ! THIS MODULE CONTAINS THE TWO-MOMENT MICROPHYSICS CODE DESCRIBED BY -! MORRISON ET AL. 2005 JAS; MORRISON AND PINTO 2005 JAS. -! ADDITIONAL CHANGES ARE DESCRIBED IN DETAIL BY MORRISON, THOMPSON, TATARSKII (MWR, SUBMITTED) +! MORRISON ET AL. (2009, MWR) + +! CHANGES FOR V3.2, RELATIVE TO MOST RECENT (BUG-FIX) CODE FOR V3.1 + +! 1) ADDED ACCELERATED MELTING OF GRAUPEL/SNOW DUE TO COLLISION WITH RAIN, FOLLOWING LIN ET AL. (1983) +! 2) INCREASED MINIMUM LAMBDA FOR RAIN, AND ADDED RAIN DROP BREAKUP FOLLOWING MODIFIED VERSION +! OF VERLINDE AND COTTON (1993) +! 3) CHANGE MINIMUM ALLOWED MIXING RATIOS IN DRY CONDITIONS (RH < 90%), THIS IMPROVES RADAR REFLECTIIVITY +! IN LOW REFLECTIVITY REGIONS +! 4) BUG FIX TO MAXIMUM ALLOWED PARTICLE FALLSPEEDS AS A FUNCTION OF AIR DENSITY +! 5) BUG FIX TO CALCULATION OF LIQUID WATER SATURATION VAPOR PRESSURE (CHANGE IS VERY MINOR) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING ! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES: @@ -120,6 +131,8 @@ MODULE MODULE_MP_MORR_TWO_MOMENT REAL, PRIVATE :: EII ! COLLECTION EFFICIENCY, ICE-ICE COLLISIONS REAL, PRIVATE :: ECI ! COLLECTION EFFICIENCY, ICE-DROPLET COLLISIONS REAL, PRIVATE :: RIN ! RADIUS OF CONTACT NUCLEI (M) +! hm, add for V3.2 + REAL, PRIVATE :: CPW ! SPECIFIC HEAT OF LIQUID WATER ! CCN SPECTRA FOR IACT = 1 @@ -302,6 +315,8 @@ SUBROUTINE MORR_TWO_MOMENT_INIT QSMALL = 1.E-14 EII = 0.1 ECI = 0.7 +! HM, ADD FOR V3.2 + CPW = 4218. ! SIZE DISTRIBUTION PARAMETERS @@ -322,7 +337,10 @@ SUBROUTINE MORR_TWO_MOMENT_INIT LAMMAXI = 1./1.E-6 LAMMINI = 1./(2.*DCS+100.E-6) LAMMAXR = 1./20.E-6 - LAMMINR = 1./500.E-6 +! LAMMINR = 1./500.E-6 +! sensitivity + LAMMINR = 1./2800.E-6 + LAMMAXS = 1./10.E-6 LAMMINS = 1./2000.E-6 LAMMAXG = 1./20.E-6 @@ -1085,14 +1103,15 @@ END SUBROUTINE MP_MORR_TWO_MOMENT END IF ! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER +! hm modify 7/0/09 change limit to 1.e-8 IF (QVQVS(K).LT.0.9) THEN - IF (QR3D(K).LT.1.E-6) THEN + IF (QR3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QR3D(K) T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) QR3D(K)=0. END IF - IF (QC3D(K).LT.1.E-6) THEN + IF (QC3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QC3D(K) T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) QC3D(K)=0. @@ -1100,17 +1119,17 @@ END SUBROUTINE MP_MORR_TWO_MOMENT END IF IF (QVQVSI(K).LT.0.9) THEN - IF (QI3D(K).LT.1.E-6) THEN + IF (QI3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QI3D(K) T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) QI3D(K)=0. END IF - IF (QNI3D(K).LT.1.E-6) THEN + IF (QNI3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QNI3D(K) T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) QNI3D(K)=0. END IF - IF (QG3D(K).LT.1.E-6) THEN + IF (QG3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QG3D(K) T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) QG3D(K)=0. @@ -1445,10 +1464,13 @@ END SUBROUTINE MP_MORR_TWO_MOMENT UNR = ARN(K)*CONS6/LAMR(K)**BR ! SET REASLISTIC LIMITS ON FALLSPEEDS - UMS=MIN(UMS,1.2) - UNS=MIN(UNS,1.2) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) + +! bug fix, 10/08/09 + dum=(rhosu/rho(k))**0.54 + UMS=MIN(UMS,1.2*dum) + UNS=MIN(UNS,1.2*dum) + UMR=MIN(UMR,9.1*dum) + UNR=MIN(UNR,9.1*dum) PRACS(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+ & 0.08*UMS*UMR)**0.5*RHO(K)* & @@ -1477,13 +1499,15 @@ END SUBROUTINE MP_MORR_TWO_MOMENT UNR = ARN(K)*CONS6/LAMR(K)**BR ! SET REASLISTIC LIMITS ON FALLSPEEDS - UMG=MIN(UMG,20.) - UNG=MIN(UNG,20.) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - -! DUM IS MIXING RATIO OF RAIN PER SEC COLLECTED BY GRAUPEL/HAIL - DUM = CONS41*(((1.2*UMR-0.95*UMG)**2+ & +! bug fix, 10/08/09 + dum=(rhosu/rho(k))**0.54 + UMG=MIN(UMG,20.*dum) + UNG=MIN(UNG,20.*dum) + UMR=MIN(UMR,9.1*dum) + UNR=MIN(UNR,9.1*dum) + +! PRACG IS MIXING RATIO OF RAIN PER SEC COLLECTED BY GRAUPEL/HAIL + PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+ & 0.08*UMG*UMR)**0.5*RHO(K)* & N0RR(K)*N0G(K)/LAMR(K)**3* & (5./(LAMR(K)**3*LAMG(K))+ & @@ -1492,7 +1516,7 @@ END SUBROUTINE MP_MORR_TWO_MOMENT ! ASSUME 1 MM DROPS ARE SHED, GET NUMBER SHED PER SEC - DUM = DUM/5.2E-7 + DUM = PRACG(K)/5.2E-7 NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+ & 0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)* & @@ -1526,7 +1550,15 @@ END SUBROUTINE MP_MORR_TWO_MOMENT ! AS DESCRINED ABOVE FOR AUTOCONVERSION IF (QR3D(K).GE.1.E-8) THEN - NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) +! include breakup add 10/09/09 + dum1=300.e-6 + if (1./lamr(k).lt.dum1) then + dum=1. + else if (1./lamr(k).ge.dum1) then + dum=2.-exp(2300.*(1./lamr(k)-dum1)) + end if +! NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) + NRAGG(K) = -5.78*dum*NR3D(K)*QR3D(K)*RHO(K) END IF !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC @@ -1559,11 +1591,14 @@ END SUBROUTINE MP_MORR_TWO_MOMENT IF (QNI3D(K).GE.1.E-8) THEN +! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN + DUM = -CPW/XLF(K)*T3D(K)*PRACS(K) + PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(273.15-T3D(K))/ & XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+ & F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35)) + (LAMS(K)**CONS35))+DUM ! IN WATER SUBSATURATION, SNOW MELTS AND EVAPORATES @@ -1588,11 +1623,14 @@ END SUBROUTINE MP_MORR_TWO_MOMENT IF (QG3D(K).GE.1.E-8) THEN +! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN + DUM = -CPW/XLF(K)*T3D(K)*PRACG(K) + PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(273.15-T3D(K))/ & XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+ & F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36)) + (LAMG(K)**CONS36))+DUM ! IN WATER SUBSATURATION, GRAUPEL MELTS AND EVAPORATES @@ -1609,6 +1647,14 @@ END SUBROUTINE MP_MORR_TWO_MOMENT END IF END IF +! HM, V3.2 +! RESET PRACG AND PRACS TO ZERO, THIS IS DONE BECAUSE THERE IS NO +! TRANSFER OF MASS FROM SNOW AND GRAUPEL TO RAIN DIRECTLY FROM COLLECTION +! ABOVE FREEZING, IT IS ONLY USED FOR ENHANCEMENT OF MELTING AND SHEDDING + + PRACG(K) = 0. + PRACS(K) = 0. + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! FOR CLOUD ICE, ONLY PROCESSES OPERATING AT T > 273.15 IS @@ -2159,10 +2205,13 @@ END SUBROUTINE MP_MORR_TWO_MOMENT UNR = ARN(K)*CONS6/LAMR(K)**BR ! SET REASLISTIC LIMITS ON FALLSPEEDS - UMS=MIN(UMS,1.2) - UNS=MIN(UNS,1.2) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) + +! bug fix, 10/08/09 + dum=(rhosu/rho(k))**0.54 + UMS=MIN(UMS,1.2*dum) + UNS=MIN(UNS,1.2*dum) + UMR=MIN(UMR,9.1*dum) + UNR=MIN(UNR,9.1*dum) PRACS(K) = CONS41*(((1.2*UMR-0.95*UMS)**2+ & 0.08*UMS*UMR)**0.5*RHO(K)* & @@ -2214,10 +2263,12 @@ END SUBROUTINE MP_MORR_TWO_MOMENT UNR = ARN(K)*CONS6/LAMR(K)**BR ! SET REASLISTIC LIMITS ON FALLSPEEDS - UMG=MIN(UMG,20.) - UNG=MIN(UNG,20.) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) +! bug fix, 10/08/09 + dum=(rhosu/rho(k))**0.54 + UMG=MIN(UMG,20.*dum) + UNG=MIN(UNG,20.*dum) + UMR=MIN(UMR,9.1*dum) + UNR=MIN(UNR,9.1*dum) PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+ & 0.08*UMG*UMR)**0.5*RHO(K)* & @@ -2460,7 +2511,15 @@ END SUBROUTINE MP_MORR_TWO_MOMENT ! AS DESCRINED ABOVE FOR AUTOCONVERSION IF (QR3D(K).GE.1.E-8) THEN - NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) +! include breakup add 10/09/09 + dum1=300.e-6 + if (1./lamr(k).lt.dum1) then + dum=1. + else if (1./lamr(k).ge.dum1) then + dum=2.-exp(2300.*(1./lamr(k)-dum1)) + end if +! NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) + NRAGG(K) = -5.78*dum*NR3D(K)*QR3D(K)*RHO(K) END IF !....................................................................... @@ -3097,14 +3156,16 @@ END SUBROUTINE MP_MORR_TWO_MOMENT ! SET REALISTIC LIMITS ON FALLSPEED - UMS=MIN(UMS,1.2) - UNS=MIN(UNS,1.2) - UMI=MIN(UMI,1.2) - UNI=MIN(UNI,1.2) - UMR=MIN(UMR,9.1) - UNR=MIN(UNR,9.1) - UMG=MIN(UMG,20.) - UNG=MIN(UNG,20.) +! bug fix, 10/08/09 + dum=(rhosu/rho(k))**0.54 + UMS=MIN(UMS,1.2*dum) + UNS=MIN(UNS,1.2*dum) + UMI=MIN(UMI,1.2*dum) + UNI=MIN(UNI,1.2*dum) + UMR=MIN(UMR,9.1*dum) + UNR=MIN(UNR,9.1*dum) + UMG=MIN(UMG,20.*dum) + UNG=MIN(UNG,20.*dum) FR(K) = UMR FI(K) = UMI @@ -3297,14 +3358,15 @@ END SUBROUTINE MP_MORR_TWO_MOMENT QVQVSI(K) = QV3D(K)/QVI(K) ! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER +! hm 7/9/09 change limit to 1.e-8 IF (QVQVS(K).LT.0.9) THEN - IF (QR3D(K).LT.1.E-6) THEN + IF (QR3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QR3D(K) T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) QR3D(K)=0. END IF - IF (QC3D(K).LT.1.E-6) THEN + IF (QC3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QC3D(K) T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) QC3D(K)=0. @@ -3312,17 +3374,17 @@ END SUBROUTINE MP_MORR_TWO_MOMENT END IF IF (QVQVSI(K).LT.0.9) THEN - IF (QI3D(K).LT.1.E-6) THEN + IF (QI3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QI3D(K) T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) QI3D(K)=0. END IF - IF (QNI3D(K).LT.1.E-6) THEN + IF (QNI3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QNI3D(K) T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) QNI3D(K)=0. END IF - IF (QG3D(K).LT.1.E-6) THEN + IF (QG3D(K).LT.1.E-8) THEN QV3D(K)=QV3D(K)+QG3D(K) T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) QG3D(K)=0. @@ -3634,7 +3696,7 @@ END SUBROUTINE MP_MORR_TWO_MOMENT ! T IS INPUT IN UNITS OF K. ! TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1) -! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM MARAT KHROUTDINOV +! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN) IMPLICIT NONE @@ -3650,10 +3712,12 @@ END SUBROUTINE MP_MORR_TWO_MOMENT ! liquid real a0,a1,a2,a3,a4,a5,a6,a7,a8 + +! V1.7 data a0,a1,a2,a3,a4,a5,a6,a7,a8 /& - 6.105851, 0.4440316, 0.1430341e-1, & - 0.2641412e-3, 0.2995057e-5, 0.2031998e-7, & - 0.6936113e-10, 0.2564861e-13,-0.3704404e-15/ + 6.11239921, 0.443987641, 0.142986287e-1, & + 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, & + 0.640689451e-10,-0.952447341e-13,-0.976195544e-15/ real dt ! ICE diff --git a/wrfv2_fire/phys/module_mp_thompson.F b/wrfv2_fire/phys/module_mp_thompson.F index 5d9b11cd..204cb604 100644 --- a/wrfv2_fire/phys/module_mp_thompson.F +++ b/wrfv2_fire/phys/module_mp_thompson.F @@ -27,7 +27,7 @@ !.. Remaining values should probably be left alone. !.. !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 30 Jan 2009 +!..Last modified: 09 Nov 2009 !+---+-----------------------------------------------------------------+ !wrft:model_layer:physics !+---+-----------------------------------------------------------------+ @@ -81,7 +81,7 @@ !.. y-intercept for an exponential distrib and proper values are !.. computed based on same mixing ratio and total number concentration. REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4 - REAL, PARAMETER, PRIVATE:: gonv_max = 5.E6 + REAL, PARAMETER, PRIVATE:: gonv_max = 3.E6 !..Mass power law relations: mass = am*D**bm !.. Snow from Field et al. (2005), others assume spherical form. @@ -118,7 +118,7 @@ !.. number. REAL, PARAMETER, PRIVATE:: Ef_si = 0.05 REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95 - REAL, PARAMETER, PRIVATE:: Ef_rg = 0.95 + REAL, PARAMETER, PRIVATE:: Ef_rg = 0.75 REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95 !..Minimum microphys values @@ -130,7 +130,7 @@ REAL, PARAMETER, PRIVATE:: eps = 1.E-29 !..Constants in Cooper curve relation for cloud ice number. - REAL, PARAMETER, PRIVATE:: TNO = 5.0 * 0.2 + REAL, PARAMETER, PRIVATE:: TNO = 5.0 REAL, PARAMETER, PRIVATE:: ATO = 0.304 !..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment. @@ -176,10 +176,11 @@ INTEGER, PARAMETER, PRIVATE:: ntb_r = 37 INTEGER, PARAMETER, PRIVATE:: ntb_s = 28 INTEGER, PARAMETER, PRIVATE:: ntb_g = 28 + INTEGER, PARAMETER, PRIVATE:: ntb_g1 = 28 INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37 INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 - INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2 + INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3 DOUBLE PRECISION, DIMENSION(nbins+1):: xDx DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc @@ -238,6 +239,13 @@ 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, & 1.e10/) +!..Lookup tables for graupel y-intercept parameter (/m**4). + REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: & + N0g_exp = (/1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, & + 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, & + 1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, & + 1.e7/) + !..Lookup tables for ice number concentration (/m**3). REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: & Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, & @@ -263,24 +271,25 @@ !..Lookup tables for various accretion/collection terms. !.. ntb_x refers to the number of elements for rain, snow, graupel, !.. and temperature array indices. Variables beginning with t-p/c/m/n -!.. represent lookup tables. -! These are now allocatable, 20090612, JM - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:):: & - tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & +!.. represent lookup tables. Save compile-time memory by making +!.. allocatable (2009Jun12, J. Michalakes). + INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & + tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, & tnr_racg, tnr_gacr - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:):: & - tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & - tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: & + tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, & + tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, & tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2 - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: & + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & tpi_qcfz, tni_qcfz - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:):: & + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: & tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:):: & + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: & tps_iaus, tni_iaus, tpi_ide - REAL, ALLOCATABLE, DIMENSION(:,:):: t_Efrw - REAL, ALLOCATABLE, DIMENSION(:,:):: t_Efsw - DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :, :):: tnr_rev + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw + REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev !..Variables holding a bunch of exponents and gamma values (cloud water, !.. cloud ice, rain, snow, then graupel). @@ -288,7 +297,7 @@ REAL, PRIVATE:: ocg1, ocg2 REAL, DIMENSION(6), PRIVATE:: cie, cig REAL, PRIVATE:: oig1, oig2, obmi - REAL, DIMENSION(12), PRIVATE:: cre, crg + REAL, DIMENSION(13), PRIVATE:: cre, crg REAL, PRIVATE:: ore1, org1, org2, org3, obmr REAL, DIMENSION(18), PRIVATE:: cse, csg REAL, PRIVATE:: oams, obms, ocms @@ -308,7 +317,7 @@ !..END DECLARATIONS !+---+-----------------------------------------------------------------+ !+---+ -! +!ctrlL CONTAINS @@ -316,399 +325,395 @@ IMPLICIT NONE - INTEGER :: i, j, k, m, n + INTEGER:: i, j, k, m, n + LOGICAL:: micro_init - LOGICAL :: do_init +!..Allocate space for lookup tables (J. Michalakes 2009Jun08). + micro_init = .FALSE. -! -!jm allocate the lookup tables -! - ! use whether the first lookup table has been allocated to also determine whether - ! to initialize them all. - do_init = .FALSE. - IF ( .NOT. ALLOCATED( tcg_racg ) ) THEN - ALLOCATE( tcg_racg(ntb_g,ntb_r1,ntb_r) ) - do_init = .TRUE. - ENDIF + if (.NOT. ALLOCATED(tcg_racg) ) then + ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + micro_init = .TRUE. + endif - IF ( .NOT. ALLOCATED( tmr_racg ) ) ALLOCATE( tmr_racg(ntb_g,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tcr_gacr ) ) ALLOCATE( tcr_gacr(ntb_g,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tmg_gacr ) ) ALLOCATE( tmg_gacr(ntb_g,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tnr_racg ) ) ALLOCATE( tnr_racg(ntb_g,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tnr_gacr ) ) ALLOCATE( tnr_gacr(ntb_g,ntb_r1,ntb_r) ) - - IF ( .NOT. ALLOCATED( tcs_racs1 ) ) ALLOCATE( tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tmr_racs1 ) ) ALLOCATE( tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tcs_racs2 ) ) ALLOCATE( tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tmr_racs2 ) ) ALLOCATE( tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tcr_sacr1 ) ) ALLOCATE( tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tms_sacr1 ) ) ALLOCATE( tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tcr_sacr2 ) ) ALLOCATE( tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tms_sacr2 ) ) ALLOCATE( tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tnr_racs1 ) ) ALLOCATE( tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tnr_racs2 ) ) ALLOCATE( tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tnr_sacr1 ) ) ALLOCATE( tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r) ) - IF ( .NOT. ALLOCATED( tnr_sacr2 ) ) ALLOCATE( tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r) ) - - IF ( .NOT. ALLOCATED( tpi_qcfz ) ) ALLOCATE( tpi_qcfz(ntb_c,45) ) - IF ( .NOT. ALLOCATED( tni_qcfz ) ) ALLOCATE( tni_qcfz(ntb_c,45) ) - - IF ( .NOT. ALLOCATED( tpi_qrfz) ) ALLOCATE( tpi_qrfz(ntb_r,ntb_r1,45) ) - IF ( .NOT. ALLOCATED( tpg_qrfz) ) ALLOCATE( tpg_qrfz(ntb_r,ntb_r1,45) ) - IF ( .NOT. ALLOCATED( tni_qrfz) ) ALLOCATE( tni_qrfz(ntb_r,ntb_r1,45) ) - IF ( .NOT. ALLOCATED( tnr_qrfz) ) ALLOCATE( tnr_qrfz(ntb_r,ntb_r1,45) ) - - IF ( .NOT. ALLOCATED( tps_iaus ) ) ALLOCATE( tps_iaus(ntb_i,ntb_i1) ) - IF ( .NOT. ALLOCATED( tni_iaus ) ) ALLOCATE( tni_iaus(ntb_i,ntb_i1) ) - IF ( .NOT. ALLOCATED( tpi_ide ) ) ALLOCATE( tpi_ide(ntb_i,ntb_i1) ) - - IF ( .NOT. ALLOCATED( t_Efrw ) ) ALLOCATE( t_Efrw(nbr,nbc) ) - IF ( .NOT. ALLOCATED( t_Efsw ) ) ALLOCATE( t_Efsw(nbs,nbc) ) - - IF ( .NOT. ALLOCATED( tnr_rev ) ) ALLOCATE( tnr_rev(nbr, ntb_r1, ntb_r) ) - - IF ( do_init ) THEN -! -!jm end mods 20090608 -! + if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + + if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,45)) + if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,45)) + + if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45)) + if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45)) + if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45)) + if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45)) + + if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1)) + if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1)) + if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1)) + + if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc)) + if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc)) + + if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r)) + + if (micro_init) then !..From Martin et al. (1994), assign gamma shape parameter mu for cloud !.. drops according to general dispersion characteristics (disp=~0.25 !.. for Maritime and 0.45 for Continental). !.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime !.. to 2 for really dirty air. - mu_c = MIN(15., (1000.E6/Nt_c + 2.)) + mu_c = MIN(15., (1000.E6/Nt_c + 2.)) !..Schmidt number to one-third used numerous times. - Sc3 = Sc**(1./3.) + Sc3 = Sc**(1./3.) !..Compute min ice diam from mass, min snow/graupel mass from diam. - D0i = (xm0i/am_i)**(1./bm_i) - xm0s = am_s * D0s**bm_s - xm0g = am_g * D0g**bm_g + D0i = (xm0i/am_i)**(1./bm_i) + xm0s = am_s * D0s**bm_s + xm0g = am_g * D0g**bm_g !..These constants various exponents and gamma() assoc with cloud, !.. rain, snow, and graupel. - cce(1) = mu_c + 1. - cce(2) = bm_r + mu_c + 1. - cce(3) = bm_r + mu_c + 4. - ccg(1) = WGAMMA(cce(1)) - ccg(2) = WGAMMA(cce(2)) - ccg(3) = WGAMMA(cce(3)) - ocg1 = 1./ccg(1) - ocg2 = 1./ccg(2) - - cie(1) = mu_i + 1. - cie(2) = bm_i + mu_i + 1. - cie(3) = bm_i + mu_i + bv_i + 1. - cie(4) = mu_i + bv_i + 1. - cie(5) = mu_i + 2. - cie(6) = bm_i + bv_i - cig(1) = WGAMMA(cie(1)) - cig(2) = WGAMMA(cie(2)) - cig(3) = WGAMMA(cie(3)) - cig(4) = WGAMMA(cie(4)) - cig(5) = WGAMMA(cie(5)) - cig(6) = WGAMMA(cie(6)) - oig1 = 1./cig(1) - oig2 = 1./cig(2) - obmi = 1./bm_i - - cre(1) = bm_r + 1. - cre(2) = mu_r + 1. - cre(3) = bm_r + mu_r + 1. - cre(4) = bm_r*2. + mu_r + 1. - cre(5) = mu_r + bv_r + 1. - cre(6) = bm_r + mu_r + bv_r + 1. - cre(7) = bm_r*0.5 + mu_r + bv_r + 1. - cre(8) = bm_r + mu_r + bv_r + 3. - cre(9) = mu_r + bv_r + 3. - cre(10) = mu_r + 2. - cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) - cre(12) = bm_r*0.5 + mu_r + 1. - do n = 1, 12 - crg(n) = WGAMMA(cre(n)) - enddo - obmr = 1./bm_r - ore1 = 1./cre(1) - org1 = 1./crg(1) - org2 = 1./crg(2) - org3 = 1./crg(3) - - cse(1) = bm_s + 1. - cse(2) = bm_s + 2. - cse(3) = bm_s*2. - cse(4) = bm_s + bv_s + 1. - cse(5) = bm_s + bv_s + 2. - cse(6) = bm_s + bv_s + 3. - cse(7) = bm_s + mu_s + 1. - cse(8) = bm_s + mu_s + 2. - cse(9) = bm_s + mu_s + 3. - cse(10) = bm_s + mu_s + bv_s + 1. - cse(11) = bm_s + mu_s + bv_s + 2. - cse(12) = bm_s*2. + mu_s + 1. - cse(13) = bv_s + 2. - cse(14) = bm_s + bv_s - cse(15) = mu_s + 1. - cse(16) = 1.0 + (1.0 + bv_s)/2. - cse(17) = cse(16) + mu_s + 1. - cse(18) = bv_s + mu_s + 3. - do n = 1, 18 - csg(n) = WGAMMA(cse(n)) - enddo - oams = 1./am_s - obms = 1./bm_s - ocms = oams**obms - - cge(1) = bm_g + 1. - cge(2) = mu_g + 1. - cge(3) = bm_g + mu_g + 1. - cge(4) = bm_g*2. + mu_g + 1. - cge(5) = bm_g + mu_g + 3. - cge(6) = bm_g + mu_g + bv_g + 1. - cge(7) = bm_g + mu_g + bv_g + 2. - cge(8) = bm_g + mu_g + bv_g + 3. - cge(9) = mu_g + bv_g + 3. - cge(10) = mu_g + 2. - cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) - cge(12) = 0.5*(bv_g + 5.) + mu_g - do n = 1, 12 - cgg(n) = WGAMMA(cge(n)) - enddo - oamg = 1./am_g - obmg = 1./bm_g - ocmg = oamg**obmg - oge1 = 1./cge(1) - ogg1 = 1./cgg(1) - ogg2 = 1./cgg(2) - ogg3 = 1./cgg(3) + cce(1) = mu_c + 1. + cce(2) = bm_r + mu_c + 1. + cce(3) = bm_r + mu_c + 4. + ccg(1) = WGAMMA(cce(1)) + ccg(2) = WGAMMA(cce(2)) + ccg(3) = WGAMMA(cce(3)) + ocg1 = 1./ccg(1) + ocg2 = 1./ccg(2) + + cie(1) = mu_i + 1. + cie(2) = bm_i + mu_i + 1. + cie(3) = bm_i + mu_i + bv_i + 1. + cie(4) = mu_i + bv_i + 1. + cie(5) = mu_i + 2. + cie(6) = bm_i + bv_i + cig(1) = WGAMMA(cie(1)) + cig(2) = WGAMMA(cie(2)) + cig(3) = WGAMMA(cie(3)) + cig(4) = WGAMMA(cie(4)) + cig(5) = WGAMMA(cie(5)) + cig(6) = WGAMMA(cie(6)) + oig1 = 1./cig(1) + oig2 = 1./cig(2) + obmi = 1./bm_i + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r*2. + mu_r + 1. + cre(5) = mu_r + bv_r + 1. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r*0.5 + mu_r + bv_r + 1. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r*0.5 + mu_r + 1. + cre(13) = bm_r*2. + mu_r + bv_r + 1. + do n = 1, 13 + crg(n) = WGAMMA(cre(n)) + enddo + obmr = 1./bm_r + ore1 = 1./cre(1) + org1 = 1./crg(1) + org2 = 1./crg(2) + org3 = 1./crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s*2. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s*2. + bv_s + 1. + cse(6) = bm_s*2. + 1. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s*2. + mu_s + bv_s + 2. + cse(12) = bm_s*2. + mu_s + 1. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = mu_s + 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + cse(17) = cse(16) + mu_s + 1. + cse(18) = bv_s + mu_s + 3. + do n = 1, 18 + csg(n) = WGAMMA(cse(n)) + enddo + oams = 1./am_s + obms = 1./bm_s + ocms = oams**obms + + cge(1) = bm_g + 1. + cge(2) = mu_g + 1. + cge(3) = bm_g + mu_g + 1. + cge(4) = bm_g*2. + mu_g + 1. + cge(5) = bm_g*2. + mu_g + bv_g + 1. + cge(6) = bm_g + mu_g + bv_g + 1. + cge(7) = bm_g + mu_g + bv_g + 2. + cge(8) = bm_g + mu_g + bv_g + 3. + cge(9) = mu_g + bv_g + 3. + cge(10) = mu_g + 2. + cge(11) = 0.5*(bv_g + 5. + 2.*mu_g) + cge(12) = 0.5*(bv_g + 5.) + mu_g + do n = 1, 12 + cgg(n) = WGAMMA(cge(n)) + enddo + oamg = 1./am_g + obmg = 1./bm_g + ocmg = oamg**obmg + oge1 = 1./cge(1) + ogg1 = 1./cgg(1) + ogg2 = 1./cgg(2) + ogg3 = 1./cgg(3) !+---+-----------------------------------------------------------------+ !..Simplify various rate eqns the best we can now. !+---+-----------------------------------------------------------------+ !..Rain collecting cloud water and cloud ice - t1_qr_qc = PI*.25*av_r * crg(9) - t1_qr_qi = PI*.25*av_r * crg(9) - t2_qr_qi = PI*.25*am_r*av_r * crg(8) + t1_qr_qc = PI*.25*av_r * crg(9) + t1_qr_qi = PI*.25*av_r * crg(9) + t2_qr_qi = PI*.25*am_r*av_r * crg(8) !..Graupel collecting cloud water - t1_qg_qc = PI*.25*av_g * cgg(9) + t1_qg_qc = PI*.25*av_g * cgg(9) !..Snow collecting cloud water - t1_qs_qc = PI*.25*av_s + t1_qs_qc = PI*.25*av_s !..Snow collecting cloud ice - t1_qs_qi = PI*.25*av_s + t1_qs_qi = PI*.25*av_s !..Evaporation of rain; ignore depositional growth of rain. - t1_qr_ev = 0.78 * crg(10) - t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) + t1_qr_ev = 0.78 * crg(10) + t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) !..Sublimation/depositional growth of snow - t1_qs_sd = 0.86 - t2_qs_sd = 0.28*Sc3*SQRT(av_s) + t1_qs_sd = 0.86 + t2_qs_sd = 0.28*Sc3*SQRT(av_s) !..Melting of snow - t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 - t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) + t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 + t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) !..Sublimation/depositional growth of graupel - t1_qg_sd = 0.86 * cgg(10) - t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) + t1_qg_sd = 0.86 * cgg(10) + t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) !..Melting of graupel - t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) - t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) + t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) + t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) !..Constants for helping find lookup table indexes. - nic2 = NINT(ALOG10(r_c(1))) - nii2 = NINT(ALOG10(r_i(1))) - nii3 = NINT(ALOG10(Nt_i(1))) - nir2 = NINT(ALOG10(r_r(1))) - nir3 = NINT(ALOG10(N0r_exp(1))) - nis2 = NINT(ALOG10(r_s(1))) - nig2 = NINT(ALOG10(r_g(1))) + nic2 = NINT(ALOG10(r_c(1))) + nii2 = NINT(ALOG10(r_i(1))) + nii3 = NINT(ALOG10(Nt_i(1))) + nir2 = NINT(ALOG10(r_r(1))) + nir3 = NINT(ALOG10(N0r_exp(1))) + nis2 = NINT(ALOG10(r_s(1))) + nig2 = NINT(ALOG10(r_g(1))) + nig3 = NINT(ALOG10(N0g_exp(1))) !..Create bins of cloud water (from min diameter up to 100 microns). - Dc(1) = D0c*1.0d0 - dtc(1) = D0c*1.0d0 - DO n = 2, nbc - Dc(n) = Dc(n-1) + 1.0D-6 - dtc(n) = (Dc(n) - Dc(n-1)) - ENDDO + Dc(1) = D0c*1.0d0 + dtc(1) = D0c*1.0d0 + do n = 2, nbc + Dc(n) = Dc(n-1) + 1.0D-6 + dtc(n) = (Dc(n) - Dc(n-1)) + enddo !..Create bins of cloud ice (from min diameter up to 5x min snow size). - xDx(1) = D0i*1.0d0 - xDx(nbi+1) = 5.0d0*D0s - DO n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & - *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) - ENDDO - DO n = 1, nbi - Di(n) = DSQRT(xDx(n)*xDx(n+1)) - dti(n) = xDx(n+1) - xDx(n) - ENDDO + xDx(1) = D0i*1.0d0 + xDx(nbi+1) = 5.0d0*D0s + do n = 2, nbi + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & + *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbi + Di(n) = DSQRT(xDx(n)*xDx(n+1)) + dti(n) = xDx(n+1) - xDx(n) + enddo !..Create bins of rain (from min diameter up to 5 mm). - xDx(1) = D0r*1.0d0 - xDx(nbr+1) = 0.005d0 - DO n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & - *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) - ENDDO - DO n = 1, nbr - Dr(n) = DSQRT(xDx(n)*xDx(n+1)) - dtr(n) = xDx(n+1) - xDx(n) - ENDDO + xDx(1) = D0r*1.0d0 + xDx(nbr+1) = 0.005d0 + do n = 2, nbr + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & + *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbr + Dr(n) = DSQRT(xDx(n)*xDx(n+1)) + dtr(n) = xDx(n+1) - xDx(n) + enddo !..Create bins of snow (from min diameter up to 2 cm). - xDx(1) = D0s*1.0d0 - xDx(nbs+1) = 0.02d0 - DO n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & - *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) - ENDDO - DO n = 1, nbs - Ds(n) = DSQRT(xDx(n)*xDx(n+1)) - dts(n) = xDx(n+1) - xDx(n) - ENDDO + xDx(1) = D0s*1.0d0 + xDx(nbs+1) = 0.02d0 + do n = 2, nbs + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & + *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbs + Ds(n) = DSQRT(xDx(n)*xDx(n+1)) + dts(n) = xDx(n+1) - xDx(n) + enddo !..Create bins of graupel (from min diameter up to 5 cm). - xDx(1) = D0g*1.0d0 - xDx(nbg+1) = 0.05d0 - DO n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & - *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) - ENDDO - DO n = 1, nbg - Dg(n) = DSQRT(xDx(n)*xDx(n+1)) - dtg(n) = xDx(n+1) - xDx(n) - ENDDO + xDx(1) = D0g*1.0d0 + xDx(nbg+1) = 0.05d0 + do n = 2, nbg + xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & + *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) + enddo + do n = 1, nbg + Dg(n) = DSQRT(xDx(n)*xDx(n+1)) + dtg(n) = xDx(n+1) - xDx(n) + enddo !+---+-----------------------------------------------------------------+ !..Create lookup tables for most costly calculations. !+---+-----------------------------------------------------------------+ - DO k = 1, ntb_r - DO j = 1, ntb_r1 - DO i = 1, ntb_g - tcg_racg(i,j,k) = 0.0d0 - tmr_racg(i,j,k) = 0.0d0 - tcr_gacr(i,j,k) = 0.0d0 - tmg_gacr(i,j,k) = 0.0d0 - tnr_racg(i,j,k) = 0.0d0 - tnr_gacr(i,j,k) = 0.0d0 - ENDDO - ENDDO - ENDDO - - DO m = 1, ntb_r - DO k = 1, ntb_r1 - DO j = 1, ntb_t - DO i = 1, ntb_s - tcs_racs1(i,j,k,m) = 0.0d0 - tmr_racs1(i,j,k,m) = 0.0d0 - tcs_racs2(i,j,k,m) = 0.0d0 - tmr_racs2(i,j,k,m) = 0.0d0 - tcr_sacr1(i,j,k,m) = 0.0d0 - tms_sacr1(i,j,k,m) = 0.0d0 - tcr_sacr2(i,j,k,m) = 0.0d0 - tms_sacr2(i,j,k,m) = 0.0d0 - tnr_racs1(i,j,k,m) = 0.0d0 - tnr_racs2(i,j,k,m) = 0.0d0 - tnr_sacr1(i,j,k,m) = 0.0d0 - tnr_sacr2(i,j,k,m) = 0.0d0 - ENDDO - ENDDO - ENDDO - ENDDO - - DO k = 1, 45 - DO j = 1, ntb_r1 - DO i = 1, ntb_r - tpi_qrfz(i,j,k) = 0.0d0 - tni_qrfz(i,j,k) = 0.0d0 - tpg_qrfz(i,j,k) = 0.0d0 - tnr_qrfz(i,j,k) = 0.0d0 - ENDDO - ENDDO - DO i = 1, ntb_c - tpi_qcfz(i,k) = 0.0d0 - tni_qcfz(i,k) = 0.0d0 - ENDDO - ENDDO - - DO j = 1, ntb_i1 - DO i = 1, ntb_i - tps_iaus(i,j) = 0.0d0 - tni_iaus(i,j) = 0.0d0 - tpi_ide(i,j) = 0.0d0 - ENDDO - ENDDO - - DO j = 1, nbc - DO i = 1, nbr - t_Efrw(i,j) = 0.0 - ENDDO - DO i = 1, nbs - t_Efsw(i,j) = 0.0 - ENDDO - ENDDO - - DO k = 1, ntb_r - DO j = 1, ntb_r1 - DO i = 1, nbr - tnr_rev(i,j,k) = 0.0d0 - ENDDO - ENDDO - ENDDO - - CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ') - WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & - ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g - CALL wrf_debug(150, wrf_err_message) + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_g + do i = 1, ntb_g1 + tcg_racg(i,j,k,m) = 0.0d0 + tmr_racg(i,j,k,m) = 0.0d0 + tcr_gacr(i,j,k,m) = 0.0d0 + tmg_gacr(i,j,k,m) = 0.0d0 + tnr_racg(i,j,k,m) = 0.0d0 + tnr_gacr(i,j,k,m) = 0.0d0 + enddo + enddo + enddo + enddo + + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_t + do i = 1, ntb_s + tcs_racs1(i,j,k,m) = 0.0d0 + tmr_racs1(i,j,k,m) = 0.0d0 + tcs_racs2(i,j,k,m) = 0.0d0 + tmr_racs2(i,j,k,m) = 0.0d0 + tcr_sacr1(i,j,k,m) = 0.0d0 + tms_sacr1(i,j,k,m) = 0.0d0 + tcr_sacr2(i,j,k,m) = 0.0d0 + tms_sacr2(i,j,k,m) = 0.0d0 + tnr_racs1(i,j,k,m) = 0.0d0 + tnr_racs2(i,j,k,m) = 0.0d0 + tnr_sacr1(i,j,k,m) = 0.0d0 + tnr_sacr2(i,j,k,m) = 0.0d0 + enddo + enddo + enddo + enddo + + do k = 1, 45 + do j = 1, ntb_r1 + do i = 1, ntb_r + tpi_qrfz(i,j,k) = 0.0d0 + tni_qrfz(i,j,k) = 0.0d0 + tpg_qrfz(i,j,k) = 0.0d0 + tnr_qrfz(i,j,k) = 0.0d0 + enddo + enddo + do i = 1, ntb_c + tpi_qcfz(i,k) = 0.0d0 + tni_qcfz(i,k) = 0.0d0 + enddo + enddo + + do j = 1, ntb_i1 + do i = 1, ntb_i + tps_iaus(i,j) = 0.0d0 + tni_iaus(i,j) = 0.0d0 + tpi_ide(i,j) = 0.0d0 + enddo + enddo + + do j = 1, nbc + do i = 1, nbr + t_Efrw(i,j) = 0.0 + enddo + do i = 1, nbs + t_Efsw(i,j) = 0.0 + enddo + enddo + + do k = 1, ntb_r + do j = 1, ntb_r1 + do i = 1, nbr + tnr_rev(i,j,k) = 0.0d0 + enddo + enddo + enddo + + CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ') + WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & + ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g + CALL wrf_debug(150, wrf_err_message) !..Collision efficiency between rain/snow and cloud water. - CALL wrf_debug(200, ' creating qc collision eff tables') - CALL table_Efrw - CALL table_Efsw + CALL wrf_debug(200, ' creating qc collision eff tables') + call table_Efrw + call table_Efsw !..Drop evaporation. -! CALL wrf_debug(200, ' creating rain evap table') -! CALL table_dropEvap +! CALL wrf_debug(200, ' creating rain evap table') +! call table_dropEvap !..Initialize various constants for computing radar reflectivity. -! CALL radar_init +! call radar_init - IF (.not. iiwarm) THEN + if (.not. iiwarm) then !..Rain collecting graupel & graupel collecting rain. - CALL wrf_debug(200, ' creating rain collecting graupel table') - call qr_acr_qg + CALL wrf_debug(200, ' creating rain collecting graupel table') + call qr_acr_qg !..Rain collecting snow & snow collecting rain. - CALL wrf_debug(200, ' creating rain collecting snow table') - call qr_acr_qs + CALL wrf_debug(200, ' creating rain collecting snow table') + call qr_acr_qs !..Cloud water and rain freezing (Bigg, 1953). - CALL wrf_debug(200, ' creating freezing of water drops table') - call freezeH2O + CALL wrf_debug(200, ' creating freezing of water drops table') + call freezeH2O !..Conversion of some ice mass into snow category. - CALL wrf_debug(200, ' creating ice converting to snow table') - CALL qi_aut_qs + CALL wrf_debug(200, ' creating ice converting to snow table') + call qi_aut_qs - ENDIF + endif - CALL wrf_debug(150, ' ... DONE microphysical lookup tables') + CALL wrf_debug(150, ' ... DONE microphysical lookup tables') - END IF ! do_init -! jm + endif END SUBROUTINE thompson_init !+---+-----------------------------------------------------------------+ -! +!ctrlL !+---+-----------------------------------------------------------------+ !..This is a wrapper routine designed to transfer values from 3D to 1D. !+---+-----------------------------------------------------------------+ @@ -717,8 +722,8 @@ RAINNC, RAINNCV, & SNOWNC, SNOWNCV, & GRAUPELNC, GRAUPELNCV, & - SR, & -! refl_10cm, grid_clock, grid_alarms, & + SR, & +! refl_10cm, grid_clock, grid_alarms, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte) ! tile dims @@ -735,9 +740,8 @@ pii, p, dz REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & RAINNC, RAINNCV, SR - REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & + REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV - ! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! refl_10cm REAL, INTENT(IN):: dt_in @@ -826,10 +830,10 @@ pptice = 0. RAINNCV(i,j) = 0. IF ( PRESENT (snowncv) ) THEN - SNOWNCV(i,j) = 0. + SNOWNCV(i,j) = 0. ENDIF IF ( PRESENT (graupelncv) ) THEN - GRAUPELNCV(i,j) = 0. + GRAUPELNCV(i,j) = 0. ENDIF SR(i,j) = 0. @@ -858,13 +862,13 @@ pcp_ic(i,j) = pptice RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice - IF ( PRESENT (snowncv) .AND. PRESENT (snownc) ) THEN - SNOWNCV(i,j) = pptsnow + pptice - SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice + IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN + SNOWNCV(i,j) = pptsnow + pptice + SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice ENDIF - IF ( PRESENT (graupelncv) .AND. PRESENT (graupelnc) ) THEN - GRAUPELNCV(i,j) = pptgraul - GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul + IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN + GRAUPELNCV(i,j) = pptgraul + GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul ENDIF SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) @@ -961,8 +965,8 @@ enddo ! if (dBZ_tstep) then -! call calc_refl10cm (qv1d, qr1d, nr1d, qs1d, qg1d, t1d, p1d, & -! dBZ, kts, kte, i, j) +! call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & +! t1d, p1d, dBZ, kts, kte, i, j) ! do k = kts, kte ! refl_10cm(i,k,j) = MAX(-35., dBZ(k)) ! enddo @@ -990,7 +994,7 @@ END SUBROUTINE mp_gt_driver !+---+-----------------------------------------------------------------+ -! +!ctrlL !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ !.. This subroutine computes the moisture tendencies of water vapor, @@ -1077,13 +1081,13 @@ REAL:: clap, fcd, dfcd REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl REAL:: r_frac, g_frac - REAL:: Ef_rw, Ef_sw, Ef_gw + REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr REAL:: dtsave, odts, odt, odzq INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq INTEGER, DIMENSION(4):: ksed1 INTEGER:: nir, nis, nig, nii, nic - INTEGER:: idx_tc,idx_t,idx_s,idx_g,idx_r1,idx_r,idx_i1,idx_i,idx_c - INTEGER:: idx, idx_d + INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, & + idx_i1, idx_i, idx_c, idx, idx_d LOGICAL:: melti, no_micro LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg LOGICAL:: debug_flag @@ -1091,7 +1095,7 @@ !+---+ debug_flag = .false. -! if (ii.eq.280 .and. jj.eq.1) debug_flag = .true. +! if (ii.eq.319 .and. jj.eq.39) debug_flag = .true. no_micro = .true. dtsave = dt @@ -1203,9 +1207,9 @@ lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 - ni(k) = MIN(250.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + if (xDi.lt. 20.E-6) then + lami = cie(2)/20.E-6 + ni(k) = MIN(500.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -1405,16 +1409,13 @@ !+---+-----------------------------------------------------------------+ !..Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - N0_min = gonv_max do k = kte, kts, -1 -!-GT if (.not. L_qg(k)) CYCLE -!-GT N0_exp = 100.0*rho(k)/rg(k) -!-GT N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) N0_exp = (gonv_max-gonv_min)*0.5D0 & - * tanh((0.15E-3-rg(k))/0.15E-3) & + * tanh((0.01E-3-(rc(k)+rr(k)))/0.75E-3) & + (gonv_max+gonv_min)*0.5D0 - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min +! N0_exp = (gonv_max-gonv_min)*0.5D0 & +! * tanh((-15.-(temp(k)-273.15))/7.5) & +! + (gonv_max+gonv_min)*0.5D0 lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -1439,10 +1440,15 @@ do k = kts, kte -!..Rain self-collection (follows Seifert 1994 - checked against my own -!.. explicit/bin scheme and appears very good). RAIN2M +!..Rain self-collection follows Seifert, 1994 and drop break-up +!.. follows Verlinde and Cotton, 1993. RAIN2M if (L_qr(k) .and. mvd_r(k).gt. D0r) then - pnr_rcr(k) = 8.*nr(k)*rr(k) + if (mvd_r(k) .le. 1750.0E-6) then + Ef_rr = 1.0 + else + Ef_rr = 2.0 - EXP(2300.0*(mvd_r(k)-1750.0E-6)) + endif + pnr_rcr(k) = Ef_rr * 8.*nr(k)*rr(k) endif if (.not. L_qc(k)) CYCLE @@ -1592,8 +1598,22 @@ 147 continue idx_g = INT(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2) idx_g = MAX(1, MIN(idx_g, ntb_g)) + + lamg = 1./ilamg(k) + lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g + N0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1) + nig = NINT(DLOG10(N0_exp)) + do nn = nig-1, nig+1 + n = nn + if ( (N0_exp/10.**nn).ge.1.0 .and. & + (N0_exp/10.**nn).lt.10.0) goto 148 + enddo + 148 continue + idx_g1 = INT(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3) + idx_g1 = MAX(1, MIN(idx_g1, ntb_g1)) else idx_g = 1 + idx_g1 = ntb_g1 endif !..Deposition/sublimation prefactor (from Srivastava & Coen 1992). @@ -1686,15 +1706,15 @@ !.. results in lookup table. if (rg(k).ge. r_g(1)) then if (temp(k).lt.T_0) then - prg_rcg(k) = tmr_racg(idx_g,idx_r1,idx_r) & - + tcr_gacr(idx_g,idx_r1,idx_r) + prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) & + + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r) prg_rcg(k) = MIN(DBLE(rr(k)*odts), prg_rcg(k)) prr_rcg(k) = -prg_rcg(k) - pnr_rcg(k) = tnr_racg(idx_g,idx_r1,idx_r) & ! RAIN2M - + tnr_gacr(idx_g,idx_r1,idx_r) + pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M + + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) pnr_rcg(k) = MIN(DBLE(nr(k)*odts), pnr_rcg(k)) else - prr_rcg(k) = tcg_racg(idx_g,idx_r1,idx_r) + prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r) prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k)) prg_rcg(k) = -prr_rcg(k) endif @@ -1871,6 +1891,7 @@ prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k)) pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.50*tempc) ! RAIN2M pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) + if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0 if (ssati(k).lt. 0.) then prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & @@ -1889,6 +1910,7 @@ prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k)) pnr_gml(k) = (N0_g(k) / (cgg(1)*am_g*N0_g(k)/rg(k))**oge1) & ! RAIN2M / rg(k) * prr_gml(k) * 10.0**(-0.35*tempc) + if (rg(k).lt.0.005E-3) pnr_gml(k)=0.0 if (ssati(k).lt. 0.) then prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & @@ -1989,6 +2011,20 @@ prg_rcg(k) = prg_rcg(k) * ratio endif +!..Re-enforce proper mass conservation for subsequent elements in case +!.. any of the above terms were altered. Thanks P. Blossey. 2009Sep28 + pri_ihm(k) = prs_ihm(k) + prg_ihm(k) + ratio = MIN( ABS(prr_rcg(k)), ABS(prg_rcg(k)) ) + prr_rcg(k) = ratio * SIGN(1.0, SNGL(prr_rcg(k))) + prg_rcg(k) = -prr_rcg(k) + if (temp(k).lt.T_0) then + prg_rcs(k) = prs_rcs(k) + prr_rcs(k) + else + ratio = MIN( ABS(prr_rcs(k)), ABS(prs_rcs(k)) ) + prr_rcs(k) = ratio * SIGN(1.0, SNGL(prr_rcs(k))) + prs_rcs(k) = -prr_rcs(k) + endif + enddo !+---+-----------------------------------------------------------------+ @@ -2023,16 +2059,16 @@ * orho !..Cloud ice mass/number balance; keep mass-wt mean size between -!.. 30 and 300 microns. Also no more than 250 xtals per liter. +!.. 20 and 300 microns. Also no more than 500 xtals per liter. xri=MAX(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k)) xni=MAX(1.,(ni1d(k) + niten(k)*dtsave)*rho(k)) if (xri.gt. R1) then lami = (am_i*cig(2)*oig1*xni/xri)**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 - xni = MIN(250.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + if (xDi.lt. 20.E-6) then + lami = cie(2)/20.E-6 + xni = MIN(500.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -2043,8 +2079,8 @@ niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.250.E3) & - niten(k) = (250.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.500.E3) & + niten(k) = (500.E3-ni1d(k)*rho(k))*odts*orho !..Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -2258,16 +2294,10 @@ !+---+-----------------------------------------------------------------+ !..Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ - N0_min = gonv_max do k = kte, kts, -1 - if (.not. L_qg(k)) CYCLE -!-GT N0_exp = 100.0*rho(k)/rg(k) -!-GT N0_exp = MAX(DBLE(gonv_min), MIN(N0_exp, DBLE(gonv_max))) N0_exp = (gonv_max-gonv_min)*0.5D0 & - * tanh((0.15E-3-rg(k))/0.15E-3) & + * tanh((0.01E-3-(rc(k)+rr(k)))/0.75E-3) & + (gonv_max+gonv_min)*0.5D0 - N0_min = MIN(N0_exp, N0_min) - N0_exp = N0_min lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1 lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg ilamg(k) = 1./lamg @@ -2379,11 +2409,14 @@ endif !+---+-----------------------------------------------------------------+ -! if( debug_flag .and. k.lt.32) then -! if (k.eq.1) write(*,'13x,a') 'pnr_wau, pnr_rcr, pnr_rcg, pnr_rcs, pnr_rci, pnr_gml, pnr_sml, pnr_rfz, pnr_rev, Nr' -! write(*,'(a, 10(1x,e13.6,1x))') 'TEND-UPDT: ', & -! pnr_wau(k), -pnr_rcr(k), -pnr_rcg(k), -pnr_rcs(k), -pnr_rci(k),& -! pnr_gml(k), pnr_sml(k), -pnr_rfz(k), -pnr_rev(k), nr(k) +! if( debug_flag .and. k.lt.42) then +! if (k.eq.1) write(mp_debug,*) 'DEBUG-GT: prg_scw, prg_rfz, prg_gde, prg_rcg, prg_gcw, prg_rci, prg_rcs, prg_ihm, prr_gml, rg, N0_g, ilamg' +! if (k.eq.1) CALL wrf_debug(0, mp_debug) +! write(mp_debug, 'a, i2, 1x, 12(1x,e13.6,1x)') ' GT,k= ', k, & +! prg_scw(k), prg_rfz(k), prg_gde(k), prg_rcg(k), prg_gcw(k), & +! prg_rci(k), prg_rcs(k), prg_ihm(k), prr_gml(k), & +! rg(k), N0_g(k), ilamg(k) +! CALL wrf_debug(0, mp_debug) ! endif !+---+-----------------------------------------------------------------+ enddo @@ -2397,8 +2430,8 @@ !.. graupel species thus making code faster with credit to J. Schmidt. !+---+-----------------------------------------------------------------+ nstep = 0 - onstep(1) = 1.0 - ksed1(1) = 0 + onstep(:) = 1.0 + ksed1(:) = 1 do k = kte+1, kts, -1 vtrk(k) = 0. vtnrk(k) = 0. @@ -2440,8 +2473,6 @@ if (.not. iiwarm) then nstep = 0 - onstep(2) = 1.0 - ksed1(2) = 0 do k = kte, kts, -1 vti = 0. @@ -2466,8 +2497,6 @@ !+---+-----------------------------------------------------------------+ nstep = 0 - onstep(3) = 1.0 - ksed1(3) = 0 do k = kte, kts, -1 vts = 0. @@ -2502,8 +2531,6 @@ !+---+-----------------------------------------------------------------+ nstep = 0 - onstep(4) = 1.0 - ksed1(4) = 0 do k = kte, kts, -1 vtg = 0. @@ -2651,7 +2678,7 @@ xri = MAX(0.0, qi1d(k) + qiten(k)*DT) if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then qcten(k) = qcten(k) + xri*odt - qiten(k) = -qi1d(k)*odt + qiten(k) = qiten(k) - xri*odt niten(k) = -ni1d(k)*odt tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) endif @@ -2660,8 +2687,8 @@ if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then lfus2 = lsub - lvap(k) qiten(k) = qiten(k) + xrc*odt - niten(k) = niten(k) + xrc/(2.*xm0i)*odt - qcten(k) = -xrc*odt + niten(k) = niten(k) + xrc/xm0i * odt + qcten(k) = qcten(k) - xrc*odt tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) endif enddo @@ -2685,8 +2712,8 @@ lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 30.E-6) then - lami = cie(2)/30.E-6 + if (xDi.lt. 20.E-6) then + lami = cie(2)/20.E-6 elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 endif @@ -2694,7 +2721,7 @@ lami = cie(2)/D0s endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 250.D3/rho(k)) + 500.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = nr1d(k) + nrten(k)*DT @@ -2728,7 +2755,7 @@ end subroutine mp_thompson !+---+-----------------------------------------------------------------+ -! +!ctrlL !+---+-----------------------------------------------------------------+ !..Creation of the lookup tables and support functions found below here. !+---+-----------------------------------------------------------------+ @@ -2740,7 +2767,8 @@ implicit none !..Local variables - INTEGER:: i, j, k, n, n2 + INTEGER:: i, j, k, m, n, n2 + INTEGER:: km, km_s, km_e DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r DOUBLE PRECISION:: N0_exp, N0_r, N0_g, lam_exp, lamg, lamr @@ -2749,78 +2777,100 @@ !+---+ do n2 = 1, nbr - vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) +! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) + vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & + + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & + - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) enddo do n = 1, nbg vg(n) = av_g*Dg(n)**bv_g enddo - do k = 1, ntb_r - do j = 1, ntb_r1 +!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for +!.. fortran indices. J. Michalakes, 2009Oct30. - lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1 - lamr = lam_exp * (crg(3)*org2*org1)**obmr - N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2) - do n2 = 1, nbr - N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) +#else + km_s = 0 + km_e = ntb_r*ntb_r1 - 1 +#endif + + do km = km_s, km_e + m = km / ntb_r1 + 1 + k = mod( km , ntb_r1 ) + 1 + + lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 + lamr = lam_exp * (crg(3)*org2*org1)**obmr + N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) + do n2 = 1, nbr + N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2) + enddo + + do j = 1, ntb_g + do i = 1, ntb_g1 + lam_exp = (N0g_exp(i)*am_g*cgg(1)/r_g(j))**oge1 + lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg + N0_g = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + do n = 1, nbg + N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) enddo - do i = 1, ntb_g -!-GT N0_exp = 100.0d0/r_g(i) -!-GT N0_exp = DMAX1(gonv_min*1.d0,DMIN1(N0_exp,gonv_max*1.d0)) - N0_exp = (gonv_max-gonv_min)*0.5D0 & - * tanh((0.15E-3-r_g(i))/0.15E-3) & - + (gonv_max+gonv_min)*0.5D0 - lam_exp = (N0_exp*am_g*cgg(1)/r_g(i))**oge1 - lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg - N0_g = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) + t1 = 0.0d0 + t2 = 0.0d0 + z1 = 0.0d0 + z2 = 0.0d0 + y1 = 0.0d0 + y2 = 0.0d0 + do n2 = 1, nbr + massr = am_r * Dr(n2)**bm_r do n = 1, nbg - N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n) - enddo - - t1 = 0.0d0 - t2 = 0.0d0 - z1 = 0.0d0 - z2 = 0.0d0 - y1 = 0.0d0 - y2 = 0.0d0 - do n2 = 1, nbr - massr = am_r * Dr(n2)**bm_r - do n = 1, nbg - massg = am_g * Dg(n)**bm_g - - dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) - dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) - - t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massg * N_g(n)* N_r(n2) - z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg*massr * N_g(n)* N_r(n2) - y1 = y1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvg * N_g(n)* N_r(n2) - - t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massr * N_g(n)* N_r(n2) - y2 = y2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr * N_g(n)* N_r(n2) - z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & - *dvr*massg * N_g(n)* N_r(n2) - enddo - 97 continue + massg = am_g * Dg(n)**bm_g + + dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n))) + dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2))) + + t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvg*massg * N_g(n)* N_r(n2) + z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvg*massr * N_g(n)* N_r(n2) + y1 = y1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvg * N_g(n)* N_r(n2) + + t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvr*massr * N_g(n)* N_r(n2) + y2 = y2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvr * N_g(n)* N_r(n2) + z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) & + *dvr*massg * N_g(n)* N_r(n2) enddo - tcg_racg(i,j,k) = t1 - tmr_racg(i,j,k) = DMIN1(z1, r_r(k)*1.0d0) - tcr_gacr(i,j,k) = t2 - tmg_gacr(i,j,k) = z2 - tnr_racg(i,j,k) = y1 - tnr_gacr(i,j,k) = y2 + 97 continue enddo + tcg_racg(i,j,k,m) = t1 + tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) + tcr_gacr(i,j,k,m) = t2 + tmg_gacr(i,j,k,m) = z2 + tnr_racg(i,j,k,m) = y1 + tnr_gacr(i,j,k,m) = y2 + enddo enddo enddo +!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30). + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + CALL wrf_dm_gatherv(tcg_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmg_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) +#endif + + end subroutine qr_acr_qg !+---+-----------------------------------------------------------------+ -! +!ctrlL !+---+-----------------------------------------------------------------+ !..Rain collecting snow (and inverse). Explicit CE integration. !+---+-----------------------------------------------------------------+ @@ -2831,6 +2881,7 @@ !..Local variables INTEGER:: i, j, k, m, n, n2 + INTEGER:: km, km_s, km_e DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3 @@ -2842,15 +2893,30 @@ !+---+ do n2 = 1, nbr - vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) +! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) + vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & + + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & + - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) D1(n2) = (vr(n2)/av_s)**(1./bv_s) enddo do n = 1, nbs vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) enddo - do m = 1, ntb_r - do k = 1, ntb_r1 +!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for +!.. fortran indices. J. Michalakes, 2009Oct30. + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) +#else + km_s = 0 + km_e = ntb_r*ntb_r1 - 1 +#endif + + do km = km_s, km_e + m = km / ntb_r1 + 1 + k = mod( km , ntb_r1 ) + 1 + lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1 lamr = lam_exp * (crg(3)*org2*org1)**obmr N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2) @@ -2926,7 +2992,7 @@ dvs = 0.5d0*((vr(n2) - vs(n)) + DABS(vr(n2)-vs(n))) dvr = 0.5d0*((vs(n) - vr(n2)) + DABS(vs(n)-vr(n2))) - if (massr .gt. masss) then + if (massr .gt. 2.5*masss) then t1 = t1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & *dvs*masss * N_s(n)* N_r(n2) z1 = z1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & @@ -2942,7 +3008,7 @@ *dvs * N_s(n)* N_r(n2) endif - if (massr .gt. masss) then + if (massr .gt. 2.5*masss) then t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & *dvr*massr * N_s(n)* N_r(n2) y2 = y2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) & @@ -2975,11 +3041,28 @@ enddo enddo enddo - enddo + +!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30). + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + CALL wrf_dm_gatherv(tcs_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcs_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tms_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tms_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) +#endif + end subroutine qr_acr_qs !+---+-----------------------------------------------------------------+ -! +!ctrlL !+---+-----------------------------------------------------------------+ !..This is a literal adaptation of Bigg (1954) probability of drops of !..a particular volume freezing. Given this probability, simply freeze @@ -3061,7 +3144,7 @@ end subroutine freezeH2O !+---+-----------------------------------------------------------------+ -! +!ctrlL !+---+-----------------------------------------------------------------+ !..Cloud ice converting to snow since portion greater than min snow !.. size. Given cloud ice content (kg/m**3), number concentration @@ -3100,7 +3183,13 @@ t2 = 0.0D0 tpi_ide(i,j) = 1.0D0 else - tpi_ide(i,j) = GAMMP(mu_i+2.0, SNGL(lami)*D0s) * 1.0D0 +#if (DWORDSIZE == 8 && RWORDSIZE == 8) + tpi_ide(i,j) = GAMMP(mu_i+2.0, REAL(lami,KIND=8)*D0s) * 1.0D0 +#elif (DWORDSIZE == 8 && RWORDSIZE == 4) + tpi_ide(i,j) = GAMMP(mu_i+2.0, REAL(lami,KIND=4)*D0s) * 1.0D0 +#else + This is a temporary hack assuming double precision is 8 bytes. +#endif do n2 = 1, nbi N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) if (Di(n2).ge.D0s) then @@ -3115,7 +3204,7 @@ enddo end subroutine qi_aut_qs -! +!ctrlL !+---+-----------------------------------------------------------------+ !..Variable collision efficiency for rain collecting cloud water using !.. method of Beard and Grover, 1974 if a/A less than 0.25; otherwise @@ -3179,7 +3268,7 @@ enddo end subroutine table_Efrw -! +!ctrlL !+---+-----------------------------------------------------------------+ !..Variable collision efficiency for snow collecting cloud water using !.. method of Wang and Ji, 2000 except equate melted snow diameter to @@ -3223,7 +3312,7 @@ enddo end subroutine table_Efsw -! +!ctrlL !+---+-----------------------------------------------------------------+ !..Integrate rain size distribution from zero to D-star to compute the !.. number of drops smaller than D-star that evaporate in a single @@ -3247,7 +3336,13 @@ Nt_r = N0 * crg(2) / lam**cre(2) do i = 1, nbr - tnr_rev(i,j,k) = GAMMP(mu_r+1.0, SNGL(Dr(i)*lam)) * Nt_r +#if (DWORDSIZE == 8 && RWORDSIZE == 8) + tnr_rev(i,j,k) = GAMMP(mu_r+1.0, REAL(Dr(i)*lam,KIND=8)) * Nt_r +#elif (DWORDSIZE == 8 && RWORDSIZE == 4) + tnr_rev(i,j,k) = GAMMP(mu_r+1.0, REAL(Dr(i)*lam,KIND=4)) * Nt_r +#else + This is a temporary hack assuming double precision is 8 bytes. +#endif enddo enddo @@ -3289,7 +3384,7 @@ ! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M ! * odts)) ! -! +!ctrlL !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ SUBROUTINE GCF(GAMMCF,A,X,GLN) @@ -3439,16 +3534,15 @@ ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) RSLF=.622*ESL/(P-ESL) - END FUNCTION RSLF -! ! ALTERNATIVE ! ; Source: Murphy and Koop, Review of the vapour pressure of ice and ! supercooled water for atmospheric applications, Q. J. R. ! Meteorol. Soc (2005), 131, pp. 1539-1565. -! Psat = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T -! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 -! / T - 9.44523 * ALOG(T) + 0.014025 * T)) -! +! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T +! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22 +! / T - 9.44523 * ALOG(T) + 0.014025 * T)) + + END FUNCTION RSLF !+---+-----------------------------------------------------------------+ ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A ! FUNCTION OF TEMPERATURE AND PRESSURE @@ -3472,15 +3566,15 @@ ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) RSIF=.622*ESI/(P-ESI) - END FUNCTION RSIF -! ! ALTERNATIVE ! ; Source: Murphy and Koop, Review of the vapour pressure of ice and ! supercooled water for atmospheric applications, Q. J. R. ! Meteorol. Soc (2005), 131, pp. 1539-1565. ! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T) -! + + END FUNCTION RSIF !+---+-----------------------------------------------------------------+ + !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson !+---+-----------------------------------------------------------------+ diff --git a/wrfv2_fire/phys/module_mp_thompson07.F b/wrfv2_fire/phys/module_mp_thompson07.F index 67090e59..e81ae17d 100644 --- a/wrfv2_fire/phys/module_mp_thompson07.F +++ b/wrfv2_fire/phys/module_mp_thompson07.F @@ -2903,7 +2903,13 @@ t2 = 0.0D0 tpi_ide(i,j) = 1.0D0 else - tpi_ide(i,j) = GAMMP(mu_i+2.0, SNGL(lami)*D0s) * 1.0D0 +#if (DWORDSIZE == 8 && RWORDSIZE == 8) + tpi_ide(i,j) = GAMMP(mu_i+2.0, REAL(lami,KIND=8)*D0s) * 1.0D0 +#elif (DWORDSIZE == 8 && RWORDSIZE == 4) + tpi_ide(i,j) = GAMMP(mu_i+2.0, REAL(lami,KIND=4)*D0s) * 1.0D0 +#else + This is a temporary hack assuming double precision is 8 bytes. +#endif do n2 = 1, nbi N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2) if (Di(n2).ge.D0s) then diff --git a/wrfv2_fire/phys/module_mp_wdm5.F b/wrfv2_fire/phys/module_mp_wdm5.F index 466f3dad..ac76ff98 100644 --- a/wrfv2_fire/phys/module_mp_wdm5.F +++ b/wrfv2_fire/phys/module_mp_wdm5.F @@ -5,10 +5,11 @@ # define VREC vrec # define VSQRT vsqrt #endif - +! !Including inline expansion statistical function MODULE module_mp_wdm5 ! +! REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain @@ -46,12 +47,11 @@ MODULE module_mp_wdm5 REAL, PARAMETER, PRIVATE :: di2000 = 20.e-4 ! parameter related with accretion and collection of cloud drops REAL, PARAMETER, PRIVATE :: di82 = 82.e-6 ! dimater related with raindrops evaporation REAL, PARAMETER, PRIVATE :: di15 = 15.e-6 ! auto conversion takes place beyond this diameter - REAL, SAVE :: & qc0, qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4, & bvtr5,bvtr7,bvtr2o5,bvtr3o5,g1pbr,g2pbr, & g3pbr,g4pbr,g5pbr,g7pbr,g5pbro2,g7pbro2, & - pvtr,pvtrn,eacrr,pacrr, & + pvtr,pvtrn,eacrr,pacrr, pi, & precr1,precr2,xmmax,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & @@ -77,6 +77,7 @@ CONTAINS ,rain, rainncv & ,snow, snowncv & ,sr & + ,itimestep & ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & @@ -102,7 +103,7 @@ CONTAINS ! ! Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008 ! -! Reference) Lim and Hong (LH, 2009) Manuscript in preperation +! Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. ! Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. ! Cohard and Pinty (CP, 2000) Quart. J. Roy. Meteor. Soc. @@ -152,15 +153,14 @@ CONTAINS cice, & psat, & denr + INTEGER, INTENT(IN ) :: itimestep REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: rain, & rainncv, & sr - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv - ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte ) :: t REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci, qrs @@ -168,10 +168,18 @@ CONTAINS CHARACTER*256 :: emess INTEGER :: mkx_test INTEGER :: i,j,k - !------------------------------------------------------------------- - #ifndef RUN_ON_GPU + IF (itimestep .eq. 1) THEN + DO j=jms,jme + DO k=kms,kme + DO i=ims,ime + nn(i,k,j) = ccn0 + ENDDO + ENDDO + ENDDO + ENDIF +! DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -185,10 +193,8 @@ CONTAINS ncr(i,k,3) = nr(i,k,j) ENDDO ENDDO - ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. - CALL wdm52D(t, q(ims,kms,j), qci, qrs, ncr & ,den(ims,kms,j) & ,p(ims,kms,j), delz(ims,kms,j) & @@ -204,7 +210,6 @@ CONTAINS ,its,ite, jts,jte, kts,kte & ,snow(ims,j),snowncv(ims,j) & ) - DO K=kts,kte DO I=its,ite th(i,k,j)=t(i,k)/pii(i,k,j) @@ -240,7 +245,6 @@ CONTAINS ,its, ite, jts, jte, kts, kte & ) #endif - END SUBROUTINE wdm5 !=================================================================== ! @@ -305,15 +309,13 @@ CONTAINS INTENT(INOUT) :: rain, & rainncv, & sr - REAL, DIMENSION( ims:ime ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv - ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte , 2) :: & rh, qs, rslope, rslope2, rslope3, rslopeb, & - falk, fall, work1 + falk, fall, work1, qrs_tmp REAL, DIMENSION( its:ite , kts:kte ) :: & rslopec, rslopec2,rslopec3 REAL, DIMENSION( its:ite , kts:kte, 2) :: & @@ -321,12 +323,18 @@ CONTAINS REAL, DIMENSION( its:ite , kts:kte ) :: & workn,falln,falkn REAL, DIMENSION( its:ite , kts:kte ) :: & + works + REAL, DIMENSION( its:ite , kts:kte ) :: & + den_tmp, delz_tmp, ncr_tmp + REAL, DIMENSION( its:ite , kts:kte ) :: & falkc, work1c, work2c, fallc REAL, DIMENSION( its:ite , kts:kte ) :: & pcact, praut, psaut, prevp, psdep, pracw, psaci, psacw, & pigen, pidep, pcond, prevp_s, & xl, cpm, work2, psmlt, psevp, denfac, xni, & - n0sfac + n0sfac, denqrs2, denqci + REAL, DIMENSION( its:ite ) :: & + delqrs2, delqi REAL, DIMENSION( its:ite , kts:kte ) :: & nraut, nracw, nrevp, ncevp, nccol, nrcol, & nsacw, nseml, ncact @@ -336,7 +344,6 @@ CONTAINS #ifdef WSM_NO_CONDITIONAL_IN_VECTOR REAL, DIMENSION(its:ite) :: xal, xbl #endif - ! variables for optimization REAL, DIMENSION( its:ite ) :: tvec1 INTEGER, DIMENSION( its:ite ) :: mnstep, numndt @@ -344,8 +351,8 @@ CONTAINS REAL, DIMENSION(its:ite) :: rmstep REAL dtcldden, rdelz, rdtcld LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdac, lamdar, lamdas, diffus, & + REAL :: & + cpmcal, xlcal, lamdac, diffus, & viscos, xka, venfac, conden, diffac, & x, y, z, a, b, c, d, e, & ndt, qdt, holdrr, holdrs, supcol, supcolt, pvt, & @@ -359,7 +366,7 @@ CONTAINS REAL :: temp REAL :: holdc, holdci INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim ! Temporaries used for inlining fpvs function REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp REAL :: logtr @@ -375,8 +382,6 @@ CONTAINS ! ! Optimizatin : A**B => exp(log(A)*(B)) lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333))) - lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 ! !---------------------------------------------------------------- ! diffus: diffusion coefficient of the water vapor @@ -390,7 +395,8 @@ CONTAINS ! conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) ! ! - pi = 4. * atan(1.) + idim = ite-its+1 + kdim = kte-kts+1 ! !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics @@ -415,6 +421,8 @@ CONTAINS do i = its, ite cpm(i,k) = cpmcal(q(i,k)) xl(i,k) = xlcal(t(i,k)) + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) enddo enddo ! @@ -462,7 +470,6 @@ CONTAINS dldti=cvap-cice xai=-dldti/rv xbi=xai+hsub/(rv*ttp) - ! this is for compilers where the conditional inhibits vectorization #ifdef WSM_NO_CONDITIONAL_IN_VECTOR do k = kts, kte @@ -512,6 +519,7 @@ CONTAINS !---------------------------------------------------------------- ! initialize the variables for microphysical physics ! +! do k = kts, kte do i = its, ite prevp(i,k) = 0. @@ -555,22 +563,6 @@ CONTAINS ! do k = kts, kte do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin)then rslopec(i,k) = rslopecmax rslopec2(i,k) = rslopec2max @@ -580,17 +572,6 @@ CONTAINS rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif !------------------------------------------------------------- ! Ni: ice crystal number concentraiton [HDC 5c] !------------------------------------------------------------- @@ -601,188 +582,178 @@ CONTAINS xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) enddo enddo -! - mstepmax = 1 - numndt = 1 - do k = kte, kts, -1 - do i = its, ite - workn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - numndt(i) = max(nint(workn(i,k)*dtcld+.5),1) - if(numndt(i).ge.mnstep(i)) mnstep(i) = numndt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mnstep(i)) mstepmax = mnstep(i) - enddo -! - do n = 1, mstepmax - k = kte + do k = kts, kte do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k) & - *dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + ncr_tmp(i,k) = ncr(i,k,3) enddo enddo + call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!---------------------------------------------------------------- ! +! vt update for qr and nr mstepmax = 1 numdt = 1 do k = kte, kts, -1 do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - numdt(i) = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1) + work1(i,k,1) = work1(i,k,1)/delz(i,k) + workn(i,k) = workn(i,k)/delz(i,k) + numdt(i) = max(nint(max(work1(i,k,1),workn(i,k))*dtcld+.5),1) if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo do i = its, ite if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - rmstep(i) = 1./mstep(i) enddo ! do n = 1, mstepmax k = kte do i = its, ite if(n.le.mstep(i)) then -! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) -! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) -! qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) -! qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - dtcldden = dtcld/den(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcldden,0.) - endif - enddo + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) + falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i) + fall(i,k,1) = fall(i,k,1)+falk(i,k,1) + falln(i,k) = falln(i,k)+falkn(i,k) + qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) + ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k)*dtcld,0.) + endif + enddo do k = kte-1, kts, -1 do i = its, ite if(n.le.mstep(i)) then -! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) -! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) + falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) + falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i) fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) -! qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & -! *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) -! qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & -! *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - dtcldden = dtcld/den(i,k) - rdelz = 1./delz(i,k) + falln(i,k) = falln(i,k)+falkn(i,k) qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)*rdelz)*dtcldden,0.) + *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1)*delz(i,k+1) & + /delz(i,k))*dtcld,0.) endif enddo enddo + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qrs(i,k,1) + ncr_tmp(i,k) = ncr(i,k,3) + enddo + enddo + call slope_rain(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) do k = kte, kts, -1 do i = its, ite - if(n.le.mstep(i)) then - if(t(i,k).gt.t0c .and. qrs(i,k,2).gt.0.) then + work1(i,k,1) = work1(i,k,1)/delz(i,k) + workn(i,k) = workn(i,k)/delz(i,k) + enddo + enddo + enddo +! for semi + do k = kte, kts, -1 + do i = its, ite + works(i,k) = work1(i,k,2) + denqrs2(i,k) = den(i,k)*qrs(i,k,2) + if(qrs(i,k,2).le.0.0) works(i,k) = 0.0 + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,works,denqrs2, & + delqrs2,dtcld,2,1) + do k = kts, kte + do i = its, ite + qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) + fall(i,k,2) = denqrs2(i,k)*works(i,k)/delz(i,k) + enddo + enddo + do i = its, ite + fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld + enddo + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + ncr_tmp(i,k) = ncr(i,k,3) + enddo + enddo + call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).gt.t0c.and.qrs(i,k,2).gt.0.) then !---------------------------------------------------------------- ! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) +! (T>T0: QS->QR) !---------------------------------------------------------------- - xlf = xlf0 -! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) - work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & - *exp(log(t(i,k))*(1.81))/p(i,k)))) & - *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & - *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & - *sqrt(sqrt(den0/(den(i,k))))) - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) -! psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & -! *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & -! *work2(i,k)*coeres) - psmlt(i,k) = (1.414e3*(1.496e-6 * ((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)))*(den(i,k)))/xlf & - *(t0c-t(i,k))*pi/2.*n0sfac(i,k) & - *(precs1*rslope2(i,k,2)+precs2*work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & - /mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + xlf = xlf0 +! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) + work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & + /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & + *exp(log(t(i,k))*(1.81))/p(i,k)))) & + *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & + *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & + *sqrt(sqrt(den0/(den(i,k))))) + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) +! psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & +! *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & +! *work2(i,k)*coeres) + psmlt(i,k) = (1.414e3*(1.496e-6 * ((t(i,k))*sqrt(t(i,k))) & + /((t(i,k))+120.)/(den(i,k)))*(den(i,k)))/xlf & + *(t0c-t(i,k))*pi/2.*n0sfac(i,k) & + *(precs1*rslope2(i,k,2)+precs2*work2(i,k)*coeres) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & + /mstep(i)),0.) !------------------------------------------------------------------- -! nsmlt: melgin of snow +! nsmlt: melgin of snow [LH A27] ! (T>T0: ->NR) !------------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) - ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k) - endif - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif + if(qrs(i,k,2).gt.qcrmin) then + sfac = rslope(i,k,2)*n0s*n0sfac(i,k)*mstep(i)/qrs(i,k,2) + ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k) endif - enddo + qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif enddo enddo !--------------------------------------------------------------- ! Vice [ms-1] : fallout of ice crystal [HDC 5a] !--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 do k = kte, kts, -1 do i = its, ite if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. + work1c(i,k) = 0. else xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - work2c(i,k) = work1c(i,k)/delz(i,k) endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo ! - do n = 1, mstepmax - k = kte +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif + denqci(i,k) = den(i,k)*qci(i,k,2) enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1)*delz(i,k+1) & - /delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) enddo enddo -! + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo ! !---------------------------------------------------------------- ! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf @@ -809,7 +780,7 @@ CONTAINS ! !--------------------------------------------------------------- ! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) +! (T>T0: QI->QC) !--------------------------------------------------------------- do k = kts, kte do i = its, ite @@ -819,24 +790,21 @@ CONTAINS if(supcol.lt.0 .and. qci(i,k,2).gt.0.) then qci(i,k,1) = qci(i,k,1)+qci(i,k,2) !--------------------------------------------------------------- -! nimlt: instantaneous melting of cloud ice +! nimlt: instantaneous melting of cloud ice [LH A18] ! (T>T0: ->NC) !-------------------------------------------------------------- - if(qci(i,k,2).gt.qmin) then - ifac = xni(i,k)/qci(i,k,2) - ncr(i,k,2) = ncr(i,k,2)+ifac*qci(i,k,2) - endif + ncr(i,k,2) = ncr(i,k,2) + xni(i,k) t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) qci(i,k,2) = 0. endif !--------------------------------------------------------------- ! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) +! (T<-40C: QC->QI) !--------------------------------------------------------------- if(supcol.gt.40. .and. qci(i,k,1).gt.0.) then qci(i,k,2) = qci(i,k,2) + qci(i,k,1) !--------------------------------------------------------------- -! nihmf: homogeneous of cloud water below -40c [HL A45] +! nihmf: homogeneous of cloud water below -40c [LH A17] ! (T<-40C: NC->) !--------------------------------------------------------------- if(ncr(i,k,2).gt.0.) ncr(i,k,2) = 0. @@ -845,14 +813,14 @@ CONTAINS endif !--------------------------------------------------------------- ! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) +! (T0>T>-40C: QC->QI) !--------------------------------------------------------------- if(supcol.gt.0. .and. qci(i,k,1).gt.0.) then supcolt=min(supcol,70.) pfrzdtc = min(pi*pi*pfrz1*(exp(pfrz2*supcolt)-1.)*denr/den(i,k) & *ncr(i,k,2)*rslopec3(i,k)*rslopec3(i,k)/18.*dtcld,qci(i,k,1)) !--------------------------------------------------------------- -! nihtf: heterogeneous of cloud water +! nihtf: heterogeneous of cloud water [LH A16] ! (T0>T>-40C: NC->) !--------------------------------------------------------------- if(ncr(i,k,2).gt.ncmin) then @@ -866,7 +834,7 @@ CONTAINS endif !--------------------------------------------------------------- ! psfrz: freezing of rain water [HL A20] [LFO 45] -! (TS) +! (TQS) !--------------------------------------------------------------- if(supcol.gt.0. .and. qrs(i,k,1).gt.0.) then supcolt=min(supcol,70.) @@ -874,7 +842,7 @@ CONTAINS *(exp(pfrz2*supcolt)-1.)*rslope3(i,k,1)*rslope3(i,k,1) & *dtcld,qrs(i,k,1)) !--------------------------------------------------------------- -! nsfrz: freezing of rain water +! nsfrz: freezing of rain water [LH A26] ! (T ) !--------------------------------------------------------------- if(ncr(i,k,3).gt.nrmin) then @@ -895,33 +863,26 @@ CONTAINS ncr(i,k,3) = max(ncr(i,k,3),0.0) enddo enddo -! !---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) +! update the slope parameters for microphysics computation ! do k = kts, kte do i = its, ite - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif -! -! compute the mean-volume drop diameter for raindrop distribution + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + ncr_tmp(i,k) = ncr(i,k,3) + enddo + enddo + call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) + do k = kts, kte + do i = its, ite +!----------------------------------------------------------------- +! compute the mean-volume drop diameter [LH A10] +! for raindrop distribution +!----------------------------------------------------------------- avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333)) -! - if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin)then + if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin) then rslopec(i,k) = rslopecmax rslopec2(i,k) = rslopec2max rslopec3(i,k) = rslopec3max @@ -930,25 +891,18 @@ CONTAINS rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) endif -! -! compute the mean-volume drop diameter for cloud-droplet distribution +!-------------------------------------------------------------------- +! compute the mean-volume drop diameter [LH A7] +! for cloud-droplet distribution +!-------------------------------------------------------------------- avedia(i,k,1) = rslopec(i,k) -! - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else -! rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2)) & - *(den(i,k)))))) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif enddo enddo +!---------------------------------------------------------------- +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) ! do k = kts, kte do i = its, ite @@ -984,18 +938,18 @@ CONTAINS supsat = max(q(i,k),qmin)-qs(i,k,1) satdt = supsat/dtcld !--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [CP 17] -! (C->R) +! praut: auto conversion rate from cloud to rain [LH 9] [CP 17] +! (QC->QR) !--------------------------------------------------------------- lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & - *rslopec2(i,k)-0.4) + *rslopec2(i,k)-0.4) lenconcr = max(1.2*lencon,qcrmin) if(avedia(i,k,1).gt.di15) then taucon = 3.7/den(i,k)/qci(i,k,1)/(0.5e6*rslopec(i,k)-7.5) praut(i,k) = lencon/taucon praut(i,k) = min(max(praut(i,k),0.),qci(i,k,1)/dtcld) !--------------------------------------------------------------- -! nraut: auto conversion rate from cloud to rain [CP 18 & 19] +! nraut: auto conversion rate from cloud to rain [LH A6][CP 18 & 19] ! (NC->NR) !--------------------------------------------------------------- nraut(i,k) = 3.5e9*den(i,k)*praut(i,k) @@ -1004,9 +958,9 @@ CONTAINS nraut(i,k) = min(nraut(i,k),ncr(i,k,2)/dtcld) endif !--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [CP 22 & 23] -! (C->R) -! nracw: accretion of cloud water by rain +! pracw: accretion of cloud water by rain [LH 10][CP 22 & 23] +! (QC->QR) +! nracw: accretion of cloud water by rain [LH A9] ! (NC->) !--------------------------------------------------------------- if(qrs(i,k,1).ge.lenconcr) then @@ -1027,7 +981,7 @@ CONTAINS endif endif !---------------------------------------------------------------- -! nccol: self collection of cloud water [CP 24 & 25] +! nccol: self collection of cloud water [LH A8][CP 24 & 25] ! (NC->) !---------------------------------------------------------------- if(avedia(i,k,1).ge.di100) then @@ -1037,7 +991,7 @@ CONTAINS *rslopec3(i,k) endif !---------------------------------------------------------------- -! nrcol: self collection of rain-drops and break-up [CP 24 & 25] +! nrcol: self collection of rain-drops and break-up [LH A21][CP 24 & 25] ! (NR->) !---------------------------------------------------------------- if(qrs(i,k,1).ge.lenconcr) then @@ -1055,8 +1009,8 @@ CONTAINS endif endif !--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain -! (V->R or R->V) +! prevp: evaporation/condensation rate of rain [HL A41] +! (QV->QR or QR->QV) !--------------------------------------------------------------- if(qrs(i,k,1).gt.0.) then coeres = rslope(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) @@ -1066,14 +1020,14 @@ CONTAINS prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) prevp(i,k) = max(prevp(i,k),satdt/2) !---------------------------------------------------------------- -! Nrevp: evaporation/condensation rate of rain [CP ] +! Nrevp: evaporation/condensation rate of rain [LH A14] ! (NR->NC) !---------------------------------------------------------------- if(avedia(i,k,2).le.di82) then nrevp(i,k) = ncr(i,k,3)/dtcld !---------------------------------------------------------------- -! Prevp_s: evaporation/condensation rate of rain [KK 23] -! (R->C) +! Prevp_s: evaporation/condensation rate of rain [LH A15] [KK 23] +! (QR->QC) !---------------------------------------------------------------- prevp_s(i,k) = qrs(i,k,1)/dtcld endif @@ -1102,6 +1056,7 @@ CONTAINS do k = kts, kte do i = its, ite supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) supsat = max(q(i,k),qmin)-qs(i,k,2) satdt = supsat/dtcld ifsat = 0 @@ -1123,7 +1078,7 @@ CONTAINS vt2s = pvts*rslopeb(i,k,2)*denfac(i,k) !------------------------------------------------------------- ! psaci: Accretion of cloud ice by rain [HDC 10] -! (TS) +! (TQS) !------------------------------------------------------------- acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & + diameter**2*rslope(i,k,2) @@ -1133,14 +1088,14 @@ CONTAINS endif !------------------------------------------------------------- ! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) +! (TQS, and T>=T0: QC->QR) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin .and. qci(i,k,1).gt.qmin) then psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & *qci(i,k,1)*denfac(i,k),qci(i,k,1)*rdtcld) endif !------------------------------------------------------------- -! nsacw: Accretion of cloud water by snow +! nsacw: Accretion of cloud water by snow [LH A12] ! (NC ->) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then @@ -1150,7 +1105,7 @@ CONTAINS if(supcol.le.0) then xlf = xlf0 !-------------------------------------------------------------- -! nseml: Enhanced melting of snow by accretion of water +! nseml: Enhanced melting of snow by accretion of water [LH A29] ! (T>=T0: ->NR) !-------------------------------------------------------------- if (qrs(i,k,2).gt.qcrmin) then @@ -1162,7 +1117,7 @@ CONTAINS if(supcol.gt.0) then !------------------------------------------------------------- ! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) +! (TQI or QI->QV) !------------------------------------------------------------- if(qci(i,k,2).gt.0 .and. ifsat.ne.1) then xmi = den(i,k)*qci(i,k,2)/xni(i,k) @@ -1182,7 +1137,7 @@ CONTAINS endif !------------------------------------------------------------- ! psdep: deposition/sublimation rate of snow [HDC 14] -! (V->S or S->V) +! (QV->QS or QS->QV) !------------------------------------------------------------- if(qrs(i,k,2).gt.0. .and. ifsat.ne.1) then coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) @@ -1202,7 +1157,7 @@ CONTAINS endif !------------------------------------------------------------- ! pigen: generation(nucleation) of ice from vapor [HL A50] [HDC 7-8] -! (TI) +! (TQI) !------------------------------------------------------------- if(supsat.gt.0 .and. ifsat.ne.1) then supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) @@ -1214,7 +1169,7 @@ CONTAINS ! !------------------------------------------------------------- ! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) +! (TQS) !------------------------------------------------------------- if(qci(i,k,2).gt.0.) then qimax = roqimax/den(i,k) @@ -1224,7 +1179,7 @@ CONTAINS endif !------------------------------------------------------------- ! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>T0: S->V) +! (T>T0: QS->QV) !------------------------------------------------------------- if(supcol.lt.0.) then if(qrs(i,k,2).gt.0. .and. rh(i,k,1).lt.1.) & @@ -1444,14 +1399,11 @@ CONTAINS ! do k = kts, kte do i = its, ite -!--------------------------------------------------------------- -! put the inital CCN number concentration -! - if(ncr(i,k,1).eq.0.) ncr(i,k,1) = ccn0 -!--------------------------------------------------------------- +!------------------------------------------------------------------- ! rate of change of cloud drop concentration due to CCN activation -! pcact: V -> C [KK 14] -! ncact: NCCN -> NC [KK 12] +! pcact: QV -> QC [LH 8] [KK 14] +! ncact: NCCN -> NC [LH A2] [KK 12] +!------------------------------------------------------------------- if(rh(i,k,1).gt.1.) then ncact(i,k) = max(0.,((ncr(i,k,1)+ncr(i,k,2)) & *min(1.,(rh(i,k,1)/satmax)**actk) - ncr(i,k,2)))/dtcld @@ -1464,10 +1416,12 @@ CONTAINS ncr(i,k,2) = max(ncr(i,k,2)+ncact(i,k)*dtcld,0.) t(i,k) = t(i,k)+pcact(i,k)*xl(i,k)/cpm(i,k)*dtcld endif -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +!--------------------------------------------------------------------- +! pcond:condensational/evaporational rate of cloud water [HL A46] [RH83 A6] ! if there exists additional water vapor condensated/if ! evaporation of cloud water is not enough to remove subsaturation +! (QV->QC or QC->QV) +!--------------------------------------------------------------------- tr=ttp/t(i,k) qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) @@ -1479,9 +1433,10 @@ CONTAINS pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) if(qci(i,k,1).gt.0. .and. work1(i,k,1).lt.0.) & pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld -!--------------------------------------------------------------- -! ncevp: evpration of Cloud number concentration -! +!---------------------------------------------------------------------- +! ncevp: evpration of Cloud number concentration [LH A3] +! (NC->NCCN) +!---------------------------------------------------------------------- if(pcond(i,k).eq.-qci(i,k,1)/dtcld) then ncr(i,k,2) = 0. ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,2) @@ -1558,7 +1513,6 @@ CONTAINS !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0 LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi ! pi = 4.*atan(1.) xlv1 = cl-cpv @@ -1622,4 +1576,413 @@ CONTAINS rslopes3max = rslopes2max * rslopesmax ! END SUBROUTINE wdm5init +!------------------------------------------------------------------------------ + subroutine slope_wdm5(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,vtn,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte,2) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + REAL, DIMENSION( its:ite , kts:kte) :: & + ncr, & + vtn, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, lamdas, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! +! Optimizatin : A**B => exp(log(A)*(B)) + lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin .or. ncr(i,k).le.nrmin ) then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = min(1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k)),1.e-3) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin) then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) + vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) + vtn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k) + if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 + if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 + if(ncr(i,k).le.0.0) vtn(i,k) = 0.0 + enddo + enddo + END subroutine slope_wdm5 +!----------------------------------------------------------------------------- + subroutine slope_rain(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,vtn,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + ncr, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + vtn, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) +! + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin .or. ncr(i,k).le.nrmin) then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = min(1./lamdar(qrs(i,k),den(i,k),ncr(i,k)),1.e-3) + rslopeb(i,k) = rslope(i,k)**bvtr + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + vtn(i,k) = pvtrn*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + if(ncr(i,k).le.0.0) vtn(i,k) = 0.0 + enddo + enddo + END subroutine slope_rain +!------------------------------------------------------------------------------ + subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdas, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = rslope(i,k)**bvts + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_snow +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop 2: snow +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then +! if (id.eq.1) then +! +! call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) +! else + call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) +! endif + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm END MODULE module_mp_wdm5 diff --git a/wrfv2_fire/phys/module_mp_wdm6.F b/wrfv2_fire/phys/module_mp_wdm6.F index 48ea69e0..9ee0e0da 100644 --- a/wrfv2_fire/phys/module_mp_wdm6.F +++ b/wrfv2_fire/phys/module_mp_wdm6.F @@ -5,7 +5,7 @@ # define VREC vrec # define VSQRT vsqrt #endif -! + MODULE module_mp_wdm6 ! ! @@ -58,7 +58,7 @@ MODULE module_mp_wdm6 qc0,qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4,bvtr5, & bvtr6,bvtr7, bvtr2o5,bvtr3o5, & g1pbr,g2pbr,g3pbr,g4pbr,g5pbr,g6pbr,g7pbr, & - g5pbro2,g7pbro2, & + g5pbro2,g7pbro2,pi, & pvtr,pvtrn,eacrr,pacrr,pidn0r,pidnr, & precr1,precr2,xmmax,roqimax,bvts1,bvts2, & bvts3,bvts4,g1pbs,g3pbs,g4pbs,g5pbso2, & @@ -84,6 +84,7 @@ CONTAINS snow, snowncv, & sr, & graupel, graupelncv, & + itimestep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -110,7 +111,7 @@ CONTAINS ! ! Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008 ! -! Reference) Lim and Hong (LH, 2009) Manuscript in preperation +! Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. ! Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. ! Cohard and Pinty (CP, 2000) Quart. J. Roy. Meteor. Soc. @@ -161,10 +162,11 @@ CONTAINS cice, & psat, & denr + INTEGER, INTENT(IN ) :: itimestep REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: rain, & rainncv, & - sr + sr REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv @@ -177,6 +179,16 @@ CONTAINS REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs, ncr INTEGER :: i,j,k !------------------------------------------------------------------- + IF (itimestep .eq. 1) THEN + DO j=jms,jme + DO k=kms,kme + DO i=ims,ime + nn(i,k,j) = ccn0 + ENDDO + ENDDO + ENDDO + ENDIF +! DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -193,7 +205,6 @@ CONTAINS ENDDO ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. - CALL wdm62D(t, q(ims,kms,j), qci, qrs, ncr & ,den(ims,kms,j) & ,p(ims,kms,j), delz(ims,kms,j) & @@ -208,7 +219,7 @@ CONTAINS ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & ,snow(ims,j),snowncv(ims,j) & - ,graupel(ims,j),graupelncv(ims,j) & + ,graupel(ims,j),graupelncv(ims,j) & ) DO K=kts,kte DO I=its,ite @@ -298,7 +309,7 @@ CONTAINS ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte , 3) :: & rh, qs, rslope, rslope2, rslope3, rslopeb, & - falk, fall, work1 + falk, fall, work1, qrs_tmp REAL, DIMENSION( its:ite , kts:kte ) :: & rslopec, rslopec2,rslopec3 REAL, DIMENSION( its:ite , kts:kte, 2) :: & @@ -306,7 +317,9 @@ CONTAINS REAL, DIMENSION( its:ite , kts:kte ) :: & workn,falln,falkn REAL, DIMENSION( its:ite , kts:kte ) :: & - worka + worka,workr + REAL, DIMENSION( its:ite , kts:kte ) :: & + den_tmp, delz_tmp, ncr_tmp REAL, DIMENSION( its:ite , kts:kte ) :: & falkc, work1c, work2c, fallc REAL, DIMENSION( its:ite , kts:kte ) :: & @@ -320,16 +333,19 @@ CONTAINS nseml, ngeml, ncact REAL, DIMENSION( its:ite , kts:kte ) :: & pigen, pidep, pcond, xl, cpm, work2, psmlt, psevp, & - denfac, xni, pgevp,n0sfac, qsum - REAL :: ifac, gfac, sfac + denfac, xni, pgevp,n0sfac, qsum, & + denqrs1, denqr1, denqrs2, denqrs3, denncr3, denqci + REAL, DIMENSION( its:ite ) :: & + delqrs1, delqrs2, delqrs3, delncr3, delqi + REAL :: gfac, sfac ! variables for optimization REAL, DIMENSION( its:ite ) :: tvec1 REAL :: temp INTEGER, DIMENSION( its:ite ) :: mnstep, numndt INTEGER, DIMENSION( its:ite ) :: mstep, numdt LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdac, lamdar, lamdas, lamdag, & + REAL :: & + cpmcal, xlcal, lamdac, & diffus, & viscos, xka, venfac, conden, diffac, & x, y, z, a, b, c, d, e, & @@ -346,7 +362,7 @@ CONTAINS REAL :: holdc, holdci ! INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim ! Temporaries used for inlining fpvs function REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp ! @@ -361,10 +377,6 @@ CONTAINS ! ! Optimizatin : A**B => exp(log(A)*(B)) lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333))) - lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! !---------------------------------------------------------------- ! diffus: diffusion coefficient of the water vapor ! viscos: kinematic viscosity(m2s-1) @@ -377,8 +389,8 @@ CONTAINS /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) ! - pi = 4. * atan(1.) -! + idim = ite-its+1 + kdim = kte-kts+1 ! !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics @@ -407,6 +419,12 @@ CONTAINS xl(i,k) = xlcal(t(i,k)) enddo enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo ! !---------------------------------------------------------------- ! compute the minor time steps. @@ -529,29 +547,8 @@ CONTAINS ncevp(i,k) = 0. enddo enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! do k = kts, kte do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin ) then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin ) then rslopec(i,k) = rslopecmax rslopec2(i,k) = rslopec2max @@ -561,28 +558,6 @@ CONTAINS rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) endif - if(qrs(i,k,2).le.qcrmin) then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin) then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif !------------------------------------------------------------- ! Ni: ice crystal number concentraiton [HDC 5c] !------------------------------------------------------------- @@ -591,56 +566,29 @@ CONTAINS xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) enddo enddo -! - mstepmax = 1 - numndt = 1 - do k = kte, kts, -1 - do i = its, ite - workn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - numndt(i) = max(nint(workn(i,k)*dtcld+.5),1) - if(numndt(i).ge.mnstep(i)) mnstep(i) = numndt(i) - enddo - enddo - do i = its, ite - if(mstepmax.le.mnstep(i)) mstepmax = mnstep(i) - enddo -! - do n = 1, mstepmax - k = kte +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!---------------------------------------------------------------- + do k = kts, kte do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mnstep(i)) then - falkn(i,k) = den(i,k)*ncr(i,k,3)*workn(i,k)/mnstep(i) - falln(i,k) = falln(i,k)+falkn(i,k) - ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1)*delz(i,k+1) & - /delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + qrs_tmp(i,k,3) = qrs(i,k,3) + ncr_tmp(i,k) = ncr(i,k,3) enddo enddo + call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) ! +! vt update for qr and nr mstepmax = 1 numdt = 1 do k = kte, kts, -1 do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - work1(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)/delz(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.e-15) - if (qsum(i,k) .gt. 1.e-15) then - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - else - worka(i,k) = 0. - endif - numdt(i) = max(nint(max(work1(i,k,1),worka(i,k))*dtcld+.5),1) + work1(i,k,1) = work1(i,k,1)/delz(i,k) + workn(i,k) = workn(i,k)/delz(i,k) + numdt(i) = max(nint(max(work1(i,k,1),workn(i,k))*dtcld+.5),1) if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo @@ -653,137 +601,168 @@ CONTAINS do i = its, ite if(n.le.mstep(i)) then falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) + falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i) fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) + falln(i,k) = falln(i,k)+falkn(i,k) qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-falk(i,k,3)*dtcld/den(i,k),0.) + ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k)*dtcld,0.) endif enddo do k = kte-1, kts, -1 do i = its, ite if(n.le.mstep(i)) then falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) + falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i) fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) + falln(i,k) = falln(i,k)+falkn(i,k) qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-(falk(i,k,3)-falk(i,k+1,3) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) + ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1)*delz(i,k+1) & + /delz(i,k))*dtcld,0.) endif enddo enddo + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qrs(i,k,1) + ncr_tmp(i,k) = ncr(i,k,3) + enddo + enddo + call slope_rain(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) do k = kte, kts, -1 do i = its, ite - if(n.le.mstep(i) .and. t(i,k).gt.t0c) then + work1(i,k,1) = work1(i,k,1)/delz(i,k) + workn(i,k) = workn(i,k)/delz(i,k) + enddo + enddo + enddo +! for semi + do k = kte, kts, -1 + do i = its, ite + qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) + if(qsum(i,k) .gt. 1.e-15 ) then + worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & + /qsum(i,k) + else + worka(i,k) = 0. + endif + denqrs2(i,k) = den(i,k)*qrs(i,k,2) + denqrs3(i,k) = den(i,k)*qrs(i,k,3) + enddo + enddo + call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & + denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) + do k = kts, kte + do i = its, ite + qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) + qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.) + fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) + fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) + enddo + enddo + do i = its, ite + fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld + fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld + enddo + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + qrs_tmp(i,k,3) = qrs(i,k,3) + ncr_tmp(i,k) = ncr(i,k,3) + enddo + enddo + call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).gt.t0c) then !--------------------------------------------------------------- ! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) +! (T>T0: QS->QR) !--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & - /mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + xlf = xlf0 + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + if(qrs(i,k,2).gt.0.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2) & + +precs2*work2(i,k)*coeres) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & + /mstep(i)),0.) + qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) !------------------------------------------------------------------- -! nsmlt: melting of snow +! nsmlt: melting of snow [LH A27] ! (T>T0: ->NR) !------------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) - ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k) - endif - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + if(qrs(i,k,2).gt.qcrmin) then + sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2) + ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k) endif + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif !--------------------------------------------------------------- ! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) +! (T>T0: QG->QR) !--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*(precg1 & - *rslope2(i,k,3) + precg2*work2(i,k)*coeres) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) + if(qrs(i,k,3).gt.0.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*(precg1 & + *rslope2(i,k,3) + precg2*work2(i,k)*coeres) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,3)/mstep(i)),0.) + qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) !------------------------------------------------------------------- -! ngmlt: melting of graupel -! (T>T0: ->R) +! ngmlt: melting of graupel [LH A28] +! (T>T0: ->NR) !------------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - gfac = rslope(i,k,3)*n0g/qrs(i,k,3) - ncr(i,k,3) = ncr(i,k,3) - gfac*pgmlt(i,k) - endif - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) + if(qrs(i,k,3).gt.qcrmin) then + gfac = rslope(i,k,3)*n0g/qrs(i,k,3) + ncr(i,k,3) = ncr(i,k,3) - gfac*pgmlt(i,k) endif + t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) endif - enddo + endif enddo enddo !--------------------------------------------------------------- ! Vice [ms-1] : fallout of ice crystal [HDC 5a] !--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 do k = kte, kts, -1 do i = its, ite if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. + work1c(i,k) = 0. else xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*diameter**1.31 - work2c(i,k) = work1c(i,k)/delz(i,k) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo ! - do n = 1, mstepmax - k = kte +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif + denqci(i,k) = den(i,k)*qci(i,k,2) enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1)*delz(i,k+1) & - /delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + enddo + call nislfv_rain_plmr(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci,denqci, & + delqi,dtcld,1,0,0) + do k = kts, kte + do i = its, ite + qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) enddo enddo + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo ! !---------------------------------------------------------------- ! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf @@ -819,7 +798,7 @@ CONTAINS ! !--------------------------------------------------------------- ! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) +! (T>T0: QI->QC) !--------------------------------------------------------------- do k = kts, kte do i = its, ite @@ -829,24 +808,21 @@ CONTAINS if(supcol.lt.0 .and. qci(i,k,2).gt.0.) then qci(i,k,1) = qci(i,k,1) + qci(i,k,2) !--------------------------------------------------------------- -! nimlt: instantaneous melting of cloud ice +! nimlt: instantaneous melting of cloud ice [LH A18] ! (T>T0: ->NC) !-------------------------------------------------------------- - if(qci(i,k,2).gt.qmin) then - ifac = xni(i,k)/qci(i,k,2) - ncr(i,k,2) = ncr(i,k,2) + ifac*qci(i,k,2) - endif + ncr(i,k,2) = ncr(i,k,2) + xni(i,k) t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) qci(i,k,2) = 0. endif !--------------------------------------------------------------- ! pihmf: homogeneous of cloud water below -40c [HL A45] -! (T<-40C: C->I) +! (T<-40C: QC->QI) !--------------------------------------------------------------- if(supcol.gt.40. .and. qci(i,k,1).gt.0.) then qci(i,k,2) = qci(i,k,2) + qci(i,k,1) !--------------------------------------------------------------- -! nihmf: homogeneous of cloud water below -40c [HL A45] +! nihmf: homogeneous of cloud water below -40c [LH A17] ! (T<-40C: NC->) !--------------------------------------------------------------- if(ncr(i,k,2).gt.0.) ncr(i,k,2) = 0. @@ -855,7 +831,7 @@ CONTAINS endif !--------------------------------------------------------------- ! pihtf: heterogeneous of cloud water [HL A44] -! (T0>T>-40C: C->I) +! (T0>T>-40C: QC->QI) !--------------------------------------------------------------- if(supcol.gt.0. .and. qci(i,k,1).gt.qmin) then supcolt=min(supcol,70.) @@ -863,7 +839,7 @@ CONTAINS *ncr(i,k,2)*rslopec3(i,k)*rslopec3(i,k)/18.*dtcld & ,qci(i,k,1)) !--------------------------------------------------------------- -! nihtf: heterogeneous of cloud water +! nihtf: heterogeneous of cloud water [LH A16] ! (T0>T>-40C: NC->) !--------------------------------------------------------------- if(ncr(i,k,2).gt.ncmin) then @@ -877,7 +853,7 @@ CONTAINS endif !--------------------------------------------------------------- ! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) +! (TQG) !--------------------------------------------------------------- if(supcol.gt.0. .and. qrs(i,k,1).gt.0.) then supcolt=min(supcol,70.) @@ -885,7 +861,7 @@ CONTAINS *(exp(pfrz2*supcolt)-1.)*rslope3(i,k,1)*rslope3(i,k,1) & *dtcld,qrs(i,k,1)) !--------------------------------------------------------------- -! ngfrz: freezing of rain water +! ngfrz: freezing of rain water [LH A26] ! (T ) !--------------------------------------------------------------- if(ncr(i,k,3).gt.nrmin) then @@ -907,30 +883,25 @@ CONTAINS enddo enddo ! -! !---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) +! update the slope parameters for microphysics computation ! do k = kts, kte do i = its, ite - if(qrs(i,k,1).le.qcrmin .or. ncr(i,k,3).le.nrmin ) then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k,3)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif -! -! compute the mean-volume drop diameter for raindrop distribution + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + qrs_tmp(i,k,3) = qrs(i,k,3) + ncr_tmp(i,k) = ncr(i,k,3) + enddo + enddo + call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & + rslope3,work1,workn,its,ite,kts,kte) + do k = kts, kte + do i = its, ite +!----------------------------------------------------------------- +! compute the mean-volume drop diameter [LH A10] +! for raindrop distribution +!----------------------------------------------------------------- avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333)) ! if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin) then @@ -942,32 +913,11 @@ CONTAINS rslopec2(i,k) = rslopec(i,k)*rslopec(i,k) rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k) endif -! -! compute the mean-volume drop diameter for cloud-droplet distribution +!-------------------------------------------------------------------- +! compute the mean-volume drop diameter [LH A7] +! for cloud-droplet distribution +!-------------------------------------------------------------------- avedia(i,k,1) = rslopec(i,k) -! - if(qrs(i,k,2).le.qcrmin) then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin) then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif enddo enddo ! @@ -992,10 +942,10 @@ CONTAINS supsat = max(q(i,k),qmin)-qs(i,k,1) satdt = supsat/dtcld !--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [CP 17] -! (C->R) +! praut: auto conversion rate from cloud to rain [LH 9] [CP 17] +! (QC->QR) !-------------------------------------------------------------- - lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & + lencon = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k) & *rslopec2(i,k)-0.4) lenconcr = max(1.2*lencon, qcrmin) if(avedia(i,k,1).gt.di15) then @@ -1003,7 +953,7 @@ CONTAINS praut(i,k) = lencon/taucon praut(i,k) = min(max(praut(i,k),0.),qci(i,k,1)/dtcld) !--------------------------------------------------------------- -! nraut: auto conversion rate from cloud to rain [CP 18 & 19] +! nraut: auto conversion rate from cloud to rain [LH A6] [CP 18 & 19] ! (NC->NR) !--------------------------------------------------------------- nraut(i,k) = 3.5e9*den(i,k)*praut(i,k) @@ -1012,9 +962,9 @@ CONTAINS nraut(i,k) = min(nraut(i,k),ncr(i,k,2)/dtcld) endif !--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [CP 22 & 23] -! (C->R) -! nracw: accretion of cloud water by rain +! pracw: accretion of cloud water by rain [LH 10] [CP 22 & 23] +! (QC->QR) +! nracw: accretion of cloud water by rain [LH A9] ! (NC->) !--------------------------------------------------------------- if(qrs(i,k,1).ge.lenconcr) then @@ -1035,7 +985,7 @@ CONTAINS endif endif !---------------------------------------------------------------- -! nccol: self collection of cloud water [CP 24 & 25] +! nccol: self collection of cloud water [LH A8] [CP 24 & 25] ! (NC->) !---------------------------------------------------------------- if(avedia(i,k,1).ge.di100) then @@ -1045,7 +995,7 @@ CONTAINS *rslopec3(i,k) endif !---------------------------------------------------------------- -! nrcol: self collection of rain-drops and break-up [CP 24 & 25] +! nrcol: self collection of rain-drops and break-up [LH A21] [CP 24 & 25] ! (NR->) !---------------------------------------------------------------- if(qrs(i,k,1).ge.lenconcr) then @@ -1063,8 +1013,8 @@ CONTAINS endif endif !--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain -! (V->R or R->V) +! prevp: evaporation/condensation rate of rain [HL A41] +! (QV->QR or QR->QV) !--------------------------------------------------------------- if(qrs(i,k,1).gt.0.) then coeres = rslope(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) @@ -1074,14 +1024,14 @@ CONTAINS prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) prevp(i,k) = max(prevp(i,k),satdt/2) !---------------------------------------------------------------- -! Nrevp: evaporation/condensation rate of rain [CP ] +! Nrevp: evaporation/condensation rate of rain [LH A14] ! (NR->NC) !---------------------------------------------------------------- if(avedia(i,k,2).le.di82) then nrevp(i,k) = ncr(i,k,3)/dtcld !---------------------------------------------------------------- -! Prevp_s: evaporation/condensation rate of rain [KK 23] -! (R->C) +! Prevp_s: evaporation/condensation rate of rain [LH A15] [KK 23] +! (QR->QC) !---------------------------------------------------------------- prevp_s(i,k) = qrs(i,k,1)/dtcld endif @@ -1109,6 +1059,7 @@ CONTAINS do k = kts, kte do i = its, ite supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) supsat = max(q(i,k),qmin)-qs(i,k,2) satdt = supsat/dtcld ifsat = 0 @@ -1138,14 +1089,14 @@ CONTAINS if(qrs(i,k,1).gt.qcrmin) then !------------------------------------------------------------- ! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) +! (TQR) !------------------------------------------------------------- acrfac = 6.*rslope2(i,k,1)+4.*diameter*rslope(i,k,1) + diameter**2 praci(i,k) = pi*qci(i,k,2)*ncr(i,k,3)*abs(vt2r-vt2i)*acrfac/4. praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) !------------------------------------------------------------- ! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) +! (TQS or QR->QG) !------------------------------------------------------------- piacr(i,k) = pi*pi*avtr*ncr(i,k,3)*denr*xni(i,k)*denfac(i,k) & *g7pbr*rslope3(i,k,1)*rslope2(i,k,1)*rslopeb(i,k,1) & @@ -1153,7 +1104,7 @@ CONTAINS piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) endif !------------------------------------------------------------- -! niacr: Accretion of rain by cloud ice +! niacr: Accretion of rain by cloud ice [LH A25] ! (T) !------------------------------------------------------------- if(ncr(i,k,3).gt.nrmin) then @@ -1163,7 +1114,7 @@ CONTAINS endif !------------------------------------------------------------- ! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) +! (TQS) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin) then acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & @@ -1174,7 +1125,7 @@ CONTAINS endif !------------------------------------------------------------- ! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) +! (TQG) !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin) then egi = exp(0.07*(-supcol)) @@ -1186,14 +1137,14 @@ CONTAINS endif !------------------------------------------------------------- ! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) +! (TQS, and T>=T0: QC->QR) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin .and. qci(i,k,1).gt.qmin) then psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) endif !------------------------------------------------------------- -! nsacw: Accretion of cloud water by snow +! nsacw: Accretion of cloud water by snow [LH A12] ! (NC ->) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then @@ -1202,14 +1153,14 @@ CONTAINS endif !------------------------------------------------------------- ! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) +! (TQG, and T>=T0: QC->QR) !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin .and. qci(i,k,1).gt.qmin) then pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3)*qci(i,k,1) & *denfac(i,k),qci(i,k,1)/dtcld) endif !------------------------------------------------------------- -! ngacw: Accretion of cloud water by graupel +! ngacw: Accretion of cloud water by graupel [LH A13] ! (NC-> !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then @@ -1218,7 +1169,7 @@ CONTAINS endif !------------------------------------------------------------- ! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) +! (TQG or QS, and T>=T0: QC->QR) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin .and. qrs(i,k,3).gt.qcrmin) then paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k))/(qsum(i,k)) @@ -1230,7 +1181,7 @@ CONTAINS endif !------------------------------------------------------------- ! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) +! (TQG) !------------------------------------------------------------- if(qrs(i,k,2).gt.qcrmin .and. qrs(i,k,1).gt.qcrmin) then if(supcol.gt.0) then @@ -1243,7 +1194,7 @@ CONTAINS endif !------------------------------------------------------------- ! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) +! (TQS or QR->QG) (T>=T0: enhance melting of snow) !------------------------------------------------------------- acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,2) & + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & @@ -1254,7 +1205,7 @@ CONTAINS endif if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,3).gt.nrmin) then !------------------------------------------------------------- -! nsacr: Accretion of rain by snow +! nsacr: Accretion of rain by snow [LH A23] ! (T) !------------------------------------------------------------- acrfac = 1.5*rslope2(i,k,1)*rslope(i,k,2) & @@ -1265,7 +1216,7 @@ CONTAINS endif !------------------------------------------------------------- ! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) +! (TQG) (T>=T0: enhance melting of graupel) !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,1).gt.qcrmin) then acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,3) & @@ -1276,7 +1227,7 @@ CONTAINS pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) endif !------------------------------------------------------------- -! ngacr: Accretion of rain by graupel +! ngacr: Accretion of rain by graupel [LH A24] ! (T) !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin .and. ncr(i,k,3).gt.nrmin) then @@ -1288,7 +1239,7 @@ CONTAINS ! !------------------------------------------------------------- ! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G) : This process is eliminated in V3.0 with the +! (QS->QG) : This process is eliminated in V3.0 with the ! new combined snow/graupel fall speeds !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,2).gt.qcrmin) then @@ -1298,13 +1249,13 @@ CONTAINS xlf = xlf0 !------------------------------------------------------------- ! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) +! (T>=T0: QS->QR) !------------------------------------------------------------- if(qrs(i,k,2).gt.0.) & pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & /xlf,-qrs(i,k,2)/dtcld),0.) !-------------------------------------------------------------- -! nseml: Enhanced melting of snow by accretion of water +! nseml: Enhanced melting of snow by accretion of water [LH A29] ! (T>=T0: ->NR) !-------------------------------------------------------------- if (qrs(i,k,2).gt.qcrmin) then @@ -1313,13 +1264,13 @@ CONTAINS endif !------------------------------------------------------------- ! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) +! (T>=T0: QG->QR) !------------------------------------------------------------- if(qrs(i,k,3).gt.0.) & pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k))/xlf & ,-qrs(i,k,3)/dtcld),0.) !-------------------------------------------------------------- -! ngeml: Enhanced melting of graupel by accretion of water +! ngeml: Enhanced melting of graupel by accretion of water [LH A30] ! (T>=T0: -> NR) !-------------------------------------------------------------- if (qrs(i,k,3).gt.qcrmin) then @@ -1330,7 +1281,7 @@ CONTAINS if(supcol.gt.0) then !------------------------------------------------------------- ! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) +! (TQI or QI->QV) !------------------------------------------------------------- if(qci(i,k,2).gt.0. .and. ifsat.ne.1) then pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) @@ -1345,7 +1296,7 @@ CONTAINS endif !------------------------------------------------------------- ! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) +! (TQS or QS->QV) !------------------------------------------------------------- if(qrs(i,k,2).gt.0. .and. ifsat.ne.1) then coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) @@ -1362,7 +1313,7 @@ CONTAINS endif !------------------------------------------------------------- ! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) +! (TQG or QG->QV) !------------------------------------------------------------- if(qrs(i,k,3).gt.0. .and. ifsat.ne.1) then coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) @@ -1380,7 +1331,7 @@ CONTAINS endif !------------------------------------------------------------- ! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) +! (TQI) !------------------------------------------------------------- if(supsat.gt.0. .and. ifsat.ne.1) then supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) @@ -1392,7 +1343,7 @@ CONTAINS ! !------------------------------------------------------------- ! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) +! (TQS) !------------------------------------------------------------- if(qci(i,k,2).gt.0.) then qimax = roqimax/den(i,k) @@ -1401,7 +1352,7 @@ CONTAINS ! !------------------------------------------------------------- ! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) +! (TQG) !------------------------------------------------------------- if(qrs(i,k,2).gt.0.) then alpha2 = 1.e-3*exp(0.09*(-supcol)) @@ -1411,7 +1362,7 @@ CONTAINS ! !------------------------------------------------------------- ! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) +! (T>=T0: QS->QV) !------------------------------------------------------------- if(supcol.lt.0.) then if(qrs(i,k,2).gt.0. .and. rh(i,k,1).lt.1.) then @@ -1422,7 +1373,7 @@ CONTAINS endif !------------------------------------------------------------- ! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) +! (T>=T0: QG->QV) !------------------------------------------------------------- if(qrs(i,k,3).gt.0. .and. rh(i,k,1).lt.1.) then coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) @@ -1732,13 +1683,10 @@ CONTAINS do k = kts, kte do i = its, ite !--------------------------------------------------------------- -! put the inital CCN number concentration -! - if(ncr(i,k,1).eq.0.) ncr(i,k,1) = ccn0 -!--------------------------------------------------------------- ! rate of change of cloud drop concentration due to CCN activation -! pcact: V -> C [KK 14] -! ncact: NCCN -> NC [KK 12] +! pcact: QV -> QC [LH 8] [KK 14] +! ncact: NCCN -> NC [LH A2] [KK 12] +!--------------------------------------------------------------- if(rh(i,k,1).gt.1.) then ncact(i,k) = max(0.,((ncr(i,k,1)+ncr(i,k,2)) & *min(1.,(rh(i,k,1)/satmax)**actk) - ncr(i,k,2)))/dtcld @@ -1751,10 +1699,12 @@ CONTAINS ncr(i,k,2) = max(ncr(i,k,2)+ncact(i,k)*dtcld,0.) t(i,k) = t(i,k)+pcact(i,k)*xl(i,k)/cpm(i,k)*dtcld endif -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +!--------------------------------------------------------------- +! pcond:condensational/evaporational rate of cloud water [HL A46] [RH83 A6] ! if there exists additional water vapor condensated/if ! evaporation of cloud water is not enough to remove subsaturation +! (QV->QC or QC->QV) +!--------------------------------------------------------------- tr=ttp/t(i,k) qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) @@ -1764,9 +1714,10 @@ CONTAINS pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) if(qci(i,k,1).gt.0. .and. work1(i,k,1).lt.0.) & pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld -!--------------------------------------------------------------- -! ncevp: evpration of Cloud number concentration [CP ] -! +!---------------------------------------------------------------- +! ncevp: evpration of Cloud number concentration [LH A3] +! (NC->NCCN) +!---------------------------------------------------------------- if(pcond(i,k).eq.-qci(i,k,1)/dtcld) then ncr(i,k,2) = 0. ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,2) @@ -1843,7 +1794,6 @@ CONTAINS !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0 LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi ! pi = 4.*atan(1.) xlv1 = cl-cpv @@ -1929,4 +1879,747 @@ CONTAINS rslopeg3max = rslopeg2max * rslopegmax ! END SUBROUTINE wdm6init +!------------------------------------------------------------------------------ + subroutine slope_wdm6(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,vtn,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte,3) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + REAL, DIMENSION( its:ite , kts:kte) :: & + ncr, & + vtn, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, lamdas, lamdag, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! +! Optimizatin : A**B => exp(log(A)*(B)) + lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin .or. ncr(i,k).le.nrmin ) then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = min(1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k)),1.e-3) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin) then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + if(qrs(i,k,3).le.qcrmin) then + rslope(i,k,3) = rslopegmax + rslopeb(i,k,3) = rslopegbmax + rslope2(i,k,3) = rslopeg2max + rslope3(i,k,3) = rslopeg3max + else + rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) + rslopeb(i,k,3) = rslope(i,k,3)**bvtg + rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) + rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) + endif + vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) + vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) + vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) + vtn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k) + if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 + if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 + if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 + if(ncr(i,k).le.0.0) vtn(i,k) = 0.0 + enddo + enddo + END subroutine slope_wdm6 +!----------------------------------------------------------------------------- + subroutine slope_rain(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,vtn,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + ncr, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + vtn, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333))) +! + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin .or. ncr(i,k).le.nrmin) then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = min(1./lamdar(qrs(i,k),den(i,k),ncr(i,k)),1.e-3) + rslopeb(i,k) = rslope(i,k)**bvtr + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + vtn(i,k) = pvtrn*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + if(ncr(i,k).le.0.0) vtn(i,k) = 0.0 + enddo + enddo + END subroutine slope_rain +!------------------------------------------------------------------------------ + subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdas, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = rslope(i,k)**bvts + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_snow +!---------------------------------------------------------------------------------- + subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdag, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 +! + do k = kts, kte + do i = its, ite +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopegmax + rslopeb(i,k) = rslopegbmax + rslope2(i,k) = rslopeg2max + rslope3(i,k) = rslopeg3max + else + rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtg + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_graup +!--------------------------------------------------------------------------------- +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plmr(im,km,denl,denfacl,tkl,dzl,wwl,rql,rnl,precip,dt,id,iter,rid) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! rid : 1 for number 0 for mixing ratio +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),rnl(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter,rid + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), nr(km), wd(km), wa(km), wa2(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + nr(:) = rnl(i,:) + if(rid .eq. 1) nr(:) = rnl(i,:)/denl(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + if(rid .eq. 1) qr(k) = qa(K) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + if(rid.eq.1) then + call slope_rain(nr,qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,wa2,1,1,1,km) + else + call slope_rain(qr,nr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,wa2,1,1,1,km) + endif + if(rid.eq.1) wa(:) = wa2(:) + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plmr +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter,ist + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 + precip1(:) = 0.0 + precip2(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + qq2(:) = rql2(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qa2(k) = qq2(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + qr2(k) = qa2(k)/den(k) + enddo + qa(km+1) = 0.0 + qa2(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) + do k = 1, km + tmp(k) = max((qr(k)+qr2(k)), 1.E-15) + IF ( tmp(k) .gt. 1.e-15 ) THEN + wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) + ELSE + wa(k) = 0. + ENDIF + enddo + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & +! ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif + ist_loop : do ist = 1, 2 + if (ist.eq.2) then + qa(:) = qa2(:) + endif +! + precip(i) = 0. +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + if(ist.eq.1) then + rql(i,:) = qn(:) + precip1(i) = precip(i) + else + rql2(i,:) = qn(:) + precip2(i) = precip(i) + endif + enddo ist_loop +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm6 END MODULE module_mp_wdm6 diff --git a/wrfv2_fire/phys/module_mp_wsm3.F b/wrfv2_fire/phys/module_mp_wsm3.F index 46be6576..08371a19 100644 --- a/wrfv2_fire/phys/module_mp_wsm3.F +++ b/wrfv2_fire/phys/module_mp_wsm3.F @@ -34,7 +34,7 @@ MODULE module_mp_wsm3 precr1,precr2,xmmax,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1, & + pidn0s,xlv1,pi, & rslopermax,rslopesmax,rslopegmax, & rsloperbmax,rslopesbmax,rslopegbmax, & rsloper2max,rslopes2max,rslopeg2max, & @@ -62,29 +62,6 @@ CONTAINS IMPLICIT NONE !------------------------------------------------------------------- ! -! -! This code is a 3-class simple ice microphyiscs scheme (WSM3) of the WRF -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! Production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM3 cloud scheme -! -! Coded by Song-You Hong (Yonsei Univ.) -! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) -! Summer 2002 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2003 -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Dudhia (D89, 1989) J. Atmos. Sci. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte @@ -100,7 +77,6 @@ CONTAINS pii, & p, & delz - REAL, INTENT(IN ) :: delt, & g, & rd, & @@ -122,12 +98,10 @@ CONTAINS REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: rain, & rainncv - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv, & sr - ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte ) :: t INTEGER :: i,j,k @@ -162,7 +136,8 @@ CONTAINS END SUBROUTINE wsm3 !=================================================================== ! - SUBROUTINE wsm32D(t, q, qci, qrs,w, den, p, delz & + SUBROUTINE wsm32D(t, q & + ,qci, qrs,w, den, p, delz & ,delt,g, cpd, cpv, rd, rv, t0c & ,ep1, ep2, qmin & ,XLS, XLV0, XLF0, den0, denr & @@ -178,6 +153,33 @@ CONTAINS !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- +! +! This code is a 3-class simple ice microphyiscs scheme (WSM3) of the +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! Production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM3 cloud scheme +! +! Developed by Song-You Hong (Yonsei Univ.), Jimy Dudhia (NCAR) +! and Shu-Hua Chen (UC Davis) +! Summer 2002 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2003 +! +! History : semi-lagrangian scheme sedimentation(JH), and clean up +! Hong, August 2009 +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Dudhia (D89, 1989) J. Atmos. Sci. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! Juang and Hong (JH, 2010) Mon. Wea. Rev. +! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -216,7 +218,6 @@ CONTAINS REAL, DIMENSION( ims:ime ), & INTENT(INOUT) :: rain, & rainncv - REAL, DIMENSION( ims:ime ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv, & @@ -229,6 +230,9 @@ CONTAINS rslope, & rslope2, & rslope3, & + qrs_tmp, & + den_tmp, & + delz_tmp, & rslopeb REAL, DIMENSION( its:ite , kts:kte ) :: & pgen, & @@ -246,21 +250,22 @@ CONTAINS work2, & xni, & qs0, & - n0sfac - REAL, DIMENSION( its:ite , kts:kte ) :: & + denqci, & + denqrs, & + n0sfac, & falkc, & work1c, & work2c, & fallc - + REAL, DIMENSION( its:ite ) :: delqrs,& + delqi INTEGER, DIMENSION( its:ite ) :: kwork1,& kwork2 - INTEGER, DIMENSION( its:ite ) :: mstep, & numdt LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdar, lamdas, diffus, & + REAL :: & + cpmcal, xlcal, diffus, & viscos, xka, venfac, conden, diffac, & x, y, z, a, b, c, d, e, & fallsum, fallsum_qsi, vt2i,vt2s,acrfac, & @@ -269,7 +274,7 @@ CONTAINS supsat, dtcld, xmi, qciik, delqci, eacrs, satdt, & qimax, diameter, xni0, roqi0, supice,holdc, holdci INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, kk, n + iprt, latd, lond, loop, loops, ifsat, kk, n, idim, kdim ! Temporaries used for inlining fpvs function REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp ! variables for optimization @@ -281,28 +286,20 @@ CONTAINS cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv xlcal(x) = xlv0-xlv1*(x-t0c) !---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! -!---------------------------------------------------------------- ! diffus: diffusion coefficient of the water vapor ! viscos: kinematic viscosity(m2s-1) +! Optimizatin : A**B => exp(log(A)*(B)) ! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y xka(x,y) = 1.414e3*viscos(x,y)*y diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) -! venfac(a,b,c) = (viscos(b,c)/diffus(b,a))**(.3333333) & -! /viscos(b,c)**(.5)*(den0/c)**0.25 venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) ! - pi = 4. * atan(1.) + idim = ite-its+1 + kdim = kte-kts+1 ! !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics @@ -325,6 +322,12 @@ CONTAINS xl(i,k) = xlcal(t(i,k)) enddo enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo ! !---------------------------------------------------------------- ! compute the minor time steps. @@ -339,15 +342,9 @@ CONTAINS ! initialize the large scale variables ! do i = its, ite - mstep(i) = 1 flgcld(i) = .true. enddo ! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo do k = kts, kte CALL VREC( tvec1(its), den(its,k), ite-its+1) do i = its, ite @@ -371,13 +368,6 @@ CONTAINS xbi=xai+hsub/(rv*ttp) do k = kts, kte do i = its, ite -! tr=ttp/t(i,k) -! if(t(i,k).lt.ttp) then -! qs(i,k) =psat*(tr**xai)*exp(xbi*(1.-tr)) -! else -! qs(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) -! endif -! qs0(i,k) =psat*(tr**xa)*exp(xb*(1.-tr)) tr=ttp/t(i,k) if(t(i,k).lt.ttp) then qs(i,k) =psat*(exp(log(tr)*(xai)))*exp(xbi*(1.-tr)) @@ -411,151 +401,79 @@ CONTAINS xni(i,k) = 1.e3 enddo enddo +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- + do k = kts, kte + do i = its, ite + xni(i,k) = min(max(5.38e7 & + *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + enddo + enddo ! !---------------------------------------------------------------- ! compute the fallout term: ! first, vertical terminal velosity for minor loops !--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- do k = kts, kte do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).ge.t0c) then - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) -! rslopeb(i,k) = rslope(i,k)**bvtr - rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - else - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) -! rslopeb(i,k) = rslope(i,k)**bvts - rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - endif -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7 & -! *(den(i,k)*max(qci(i,k),qmin))**0.75,1.e3),1.e6) - xni(i,k) = min(max(5.38e7 & - *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + qrs_tmp(i,k) = qrs(i,k) enddo enddo + call slope_wsm3(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! +! +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) ! - mstepmax = 1 - numdt = 1 do k = kte, kts, -1 do i = its, ite - if(t(i,k).lt.t0c) then - pvt = pvts - else - pvt = pvtr - endif - work1(i,k) = pvt*rslopeb(i,k)*denfac(i,k) - work2(i,k) = work1(i,k)/delz(i,k) - numdt(i) = max(nint(work2(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + denqrs(i,k) = den(i,k)*qrs(i,k) enddo enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo -! - do n = 1, mstepmax - k = kte + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1,denqrs, & + delqrs,dtcld,1,1) + do k = kts, kte do i = its, ite - if(n.le.mstep(i)) then - falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) - hold = falk(i,k) - fall(i,k) = fall(i,k)+falk(i,k) - holdrs = qrs(i,k) - qrs(i,k) = max(qrs(i,k)-falk(i,k)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k) = den(i,k)*qrs(i,k)*work2(i,k)/mstep(i) - hold = falk(i,k) - fall(i,k) = fall(i,k)+falk(i,k) - holdrs = qrs(i,k) - qrs(i,k) = max(qrs(i,k)-(falk(i,k) & - -falk(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + qrs(i,k) = max(denqrs(i,k)/den(i,k),0.) + fall(i,k) = denqrs(i,k)*work1(i,k)/delz(i,k) enddo enddo + do i = its, ite + fall(i,1) = delqrs(i)/delz(i,1)/dtcld + enddo !--------------------------------------------------------------- ! Vice [ms-1] : fallout of ice crystal [HDC 5a] !--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 do k = kte, kts, -1 do i = its, ite if(t(i,k).lt.t0c.and.qci(i,k).gt.0.) then xmi = den(i,k)*qci(i,k)/xni(i,k) -! diameter = dicon * sqrt(xmi) -! work1c(i,k) = 1.49e4*diameter**1.31 diameter = max(dicon * sqrt(xmi), 1.e-25) work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) else work1c(i,k) = 0. endif - if(qci(i,k).le.0.) then - work2c(i,k) = 0. - else - work2c(i,k) = work1c(i,k)/delz(i,k) - endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo ! - do n = 1, mstepmax - k = kte +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 do i = its, ite - if (n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k) - qci(i,k) = max(qci(i,k)-falkc(i,k)*dtcld/den(i,k),0.) - endif + denqci(i,k) = den(i,k)*qci(i,k) enddo - do k = kte-1, kts, -1 - do i = its, ite - if (n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k) - qci(i,k) = max(qci(i,k)-(falkc(i,k) & - -falkc(i,k+1)*delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qci(i,k) = max(denqci(i,k)/den(i,k),0.) enddo enddo + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo ! !---------------------------------------------------------------- ! compute the freezing/melting term. [D89 B16-B17] @@ -631,42 +549,19 @@ CONTAINS enddo ! !---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) +! update the slope parameters for microphysics computation ! do k = kts, kte do i = its, ite - if(t(i,k).ge.t0c) then - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - else - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - endif + qrs_tmp(i,k) = qrs(i,k) enddo enddo + call slope_wsm3(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! work2: parameter associated with the ventilation effects(y93) ! do k = kts, kte do i = its, ite @@ -740,21 +635,18 @@ CONTAINS !=============================================================== ! supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) ifsat = 0 !------------------------------------------------------------- ! Ni: ice crystal number concentraiton [HDC 5c] !------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7 & -! *(den(i,k)*max(qci(i,k),qmin))**0.75,1.e3),1.e6) xni(i,k) = min(max(5.38e7 & - *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) + *exp(log((den(i,k)*max(qci(i,k),qmin)))*(0.75)),1.e3),1.e6) eacrs = exp(0.07*(-supcol)) -! if(qrs(i,k).gt.qcrmin.and.qci(i,k).gt.qmin) then xmi = den(i,k)*qci(i,k)/xni(i,k) diameter = min(dicon * sqrt(xmi),dimax) vt2i = 1.49e4*diameter**1.31 -! vt2i = 1.49e4*exp((log(diameter))*(1.31)) vt2s = pvts*rslopeb(i,k)*denfac(i,k) !------------------------------------------------------------- ! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] @@ -805,7 +697,6 @@ CONTAINS if(supsat.gt.0.and.ifsat.ne.1) then supice = satdt-pisd(i,k)-pres(i,k) xni0 = 1.e3*exp(0.1*supcol) -! roqi0 = 4.92e-11*xni0**1.33 roqi0 = 4.92e-11*exp(log(xni0)*(1.33)) pgen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k),0.))/dtcld) pgen(i,k) = min(min(pgen(i,k),satdt),supice) @@ -871,7 +762,6 @@ CONTAINS do k = kts, kte do i = its, ite tr=ttp/t(i,k) -! qs(i,k)=psat*(tr**xa)*exp(xb*(1.-tr)) qs(i,k)=psat*(exp(log(tr)*(xa)))*exp(xb*(1.-tr)) qs(i,k) = ep2 * qs(i,k) / (p(i,k) - qs(i,k)) qs(i,k) = max(qs(i,k),qmin) @@ -903,6 +793,7 @@ CONTAINS do k = kts, kte do i = its, ite if(qci(i,k).le.qmin) qci(i,k) = 0.0 + if(qrs(i,k).le.qcrmin) qrs(i,k) = 0.0 enddo enddo ! @@ -962,14 +853,13 @@ CONTAINS !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi -! +! pi = 4.*atan(1.) xlv1 = cl-cpv -! +! qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 -! +! bvtr1 = 1.+bvtr bvtr2 = 2.5+.5*bvtr bvtr3 = 3.+bvtr @@ -1011,4 +901,503 @@ CONTAINS rslopes3max = rslopes2max * rslopesmax ! END SUBROUTINE wsm3init +! + subroutine slope_wsm3(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte ) :: & + qrs, & + den, & + denfac, & + t, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar,lamdas,x, y, z, supcol, pvt + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. +! + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + if(t(i,k).ge.t0c) then + pvt = pvtr + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = exp(log(rslope(i,k))*(bvtr)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + else + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + pvt = pvts + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = exp(log(rslope(i,k))*(bvts)) + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + endif + vt(i,k) = pvt*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_wsm3 +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_pcm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real zsumt,qsumt,zsumb,qsumb + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! pcm is 1st order, we should use 2nd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_wsm3(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.eq.2 ) wa(1:km) = 0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt +! compute q with piecewise constant method + if( kt-kb.eq.1 ) then + qn(k) = qa(kb) + else if( kt-kb.ge.2 ) then + zsumb = za(kb+1)-zi(k) + qsumb = qa(kb) * zsumb + zsumt = zi(k+1)-za(kt-1) + qsumt = qa(kt-1) * zsumt + qsum = 0.0 + zsum = 0.0 + if( kt-kb.ge.3 ) then + do m=kb+1,kt-2 + qsum = qsum + qa(m) * dza(m) + zsum = zsum + dza(m) + enddo + endif + qn(k) = (qsumb+qsum+qsumt)/(zsumb+zsum+zsumt) + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_pcm +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_wsm3(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm +! END MODULE module_mp_wsm3 diff --git a/wrfv2_fire/phys/module_mp_wsm5.F b/wrfv2_fire/phys/module_mp_wsm5.F index 06e3dc69..dba7bf97 100644 --- a/wrfv2_fire/phys/module_mp_wsm5.F +++ b/wrfv2_fire/phys/module_mp_wsm5.F @@ -38,7 +38,7 @@ MODULE module_mp_wsm5 precr1,precr2,xmmax,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc, & + pidn0s,xlv1,pacrc,pi, & rslopermax,rslopesmax,rslopegmax, & rsloperbmax,rslopesbmax,rslopegbmax, & rsloper2max,rslopes2max,rslopeg2max, & @@ -66,28 +66,6 @@ CONTAINS IMPLICIT NONE !------------------------------------------------------------------- ! -! This code is a 5-class mixed ice microphyiscs scheme (WSM5) of the WRF -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! Production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM5 cloud scheme -! -! Coded by Song-You Hong (Yonsei Univ.) -! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) -! Summer 2002 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2003 -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte @@ -127,18 +105,15 @@ CONTAINS INTENT(INOUT) :: rain, & rainncv, & sr - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv - ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte ) :: t REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci, qrs CHARACTER*256 :: emess INTEGER :: mkx_test INTEGER :: i,j,k - !------------------------------------------------------------------- #ifndef RUN_ON_GPU @@ -152,10 +127,8 @@ CONTAINS qrs(i,k,2) = qs(i,k,j) ENDDO ENDDO - ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. - CALL wsm52D(t, q(ims,kms,j), qci, qrs & ,den(ims,kms,j) & ,p(ims,kms,j), delz(ims,kms,j) & @@ -171,7 +144,6 @@ CONTAINS ,its,ite, jts,jte, kts,kte & ,snow,snowncv & ) - DO K=kts,kte DO I=its,ite th(i,k,j)=t(i,k)/pii(i,k,j) @@ -208,7 +180,8 @@ CONTAINS END SUBROUTINE wsm5 !=================================================================== ! - SUBROUTINE wsm52D(t, q, qci, qrs, den, p, delz & + SUBROUTINE wsm52D(t, q & + ,qci, qrs, den, p, delz & ,delt,g, cpd, cpv, rd, rv, t0c & ,ep1, ep2, qmin & ,XLS, XLV0, XLF0, den0, denr & @@ -224,13 +197,36 @@ CONTAINS !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- +! +! This code is a 5-class mixed ice microphyiscs scheme (WSM5) of the +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! Production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM5 cloud scheme +! +! Coded by Song-You Hong (Yonsei Univ.) +! Jimy Dudhia (NCAR) and Shu-Hua Chen (UC Davis) +! Summer 2002 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2003 +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte, & lat REAL, DIMENSION( its:ite , kts:kte ), & INTENT(INOUT) :: & - t + t REAL, DIMENSION( its:ite , kts:kte, 2 ), & INTENT(INOUT) :: & qci, & @@ -265,11 +261,9 @@ CONTAINS INTENT(INOUT) :: rain, & rainncv, & sr - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv - ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte , 2) :: & rh, & @@ -278,10 +272,10 @@ CONTAINS rslope2, & rslope3, & rslopeb, & + qrs_tmp, & falk, & fall, & work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & falkc, & fallc, & @@ -289,11 +283,22 @@ CONTAINS cpm, & denfac, & xni, & + denqrs1, & + denqrs2, & + denqci, & n0sfac, & work2, & + workr, & + works, & work1c, & work2c - + REAL, DIMENSION( its:ite , kts:kte ) :: & + den_tmp, & + delz_tmp + REAL, DIMENSION( its:ite ) :: & + delqrs1, & + delqrs2, & + delqi REAL, DIMENSION( its:ite , kts:kte ) :: & pigen, & pidep, & @@ -313,14 +318,12 @@ CONTAINS REAL, DIMENSION(its:ite) :: rmstep REAL dtcldden, rdelz, rdtcld LOGICAL, DIMENSION( its:ite ) :: flgcld - #define WSM_NO_CONDITIONAL_IN_VECTOR #ifdef WSM_NO_CONDITIONAL_IN_VECTOR REAL, DIMENSION(its:ite) :: xal, xbl #endif - - REAL :: pi, & - cpmcal, xlcal, lamdar, lamdas, diffus, & + REAL :: & + cpmcal, xlcal, diffus, & viscos, xka, venfac, conden, diffac, & x, y, z, a, b, c, d, e, & qdt, holdrr, holdrs, supcol, supcolt, pvt, & @@ -333,7 +336,7 @@ CONTAINS REAL, DIMENSION( its:ite ) :: tvec1 REAL :: temp INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim ! Temporaries used for inlining fpvs function REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp REAL :: logtr @@ -344,14 +347,6 @@ CONTAINS cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv xlcal(x) = xlv0-xlv1*(x-t0c) !---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! -!---------------------------------------------------------------- ! diffus: diffusion coefficient of the water vapor ! viscos: kinematic viscosity(m2s-1) ! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y @@ -362,8 +357,9 @@ CONTAINS ! /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) ! conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) ! -! - pi = 4. * atan(1.) +!---------------------------------------------------------------- + idim = ite-its+1 + kdim = kte-kts+1 ! !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics @@ -388,6 +384,12 @@ CONTAINS xl(i,k) = xlcal(t(i,k)) enddo enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo ! !---------------------------------------------------------------- ! compute the minor time steps. @@ -432,7 +434,6 @@ CONTAINS dldti=cvap-cice xai=-dldti/rv xbi=xai+hsub/(rv*ttp) - ! this is for compilers where the conditional inhibits vectorization #ifdef WSM_NO_CONDITIONAL_IN_VECTOR do k = kts, kte @@ -456,8 +457,6 @@ CONTAINS qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) qs(i,k,2) = max(qs(i,k,2),qmin) rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo #else do k = kts, kte do i = its, ite @@ -478,6 +477,8 @@ CONTAINS enddo enddo #endif + enddo + enddo ! !---------------------------------------------------------------- ! initialize the variables for microphysical physics @@ -506,184 +507,127 @@ CONTAINS xni(i,k) = 1.e3 enddo enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif !------------------------------------------------------------- ! Ni: ice crystal number concentraiton [HDC 5c] !------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) + do k = kts, kte + do i = its, ite temp = (den(i,k)*max(qci(i,k,2),qmin)) temp = sqrt(sqrt(temp*temp*temp)) xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) enddo enddo ! - mstepmax = 1 - numdt = 1 +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!---------------------------------------------------------------- + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + enddo + enddo + call slope_wsm5(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! do k = kte, kts, -1 do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - numdt(i) = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + workr(i,k) = work1(i,k,1) + works(i,k) = work1(i,k,2) + denqrs1(i,k) = den(i,k)*qrs(i,k,1) + denqrs2(i,k) = den(i,k)*qrs(i,k,2) + if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0 + if(qrs(i,k,2).le.0.0) works(i,k) = 0.0 + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & + delqrs1,dtcld,1,1) + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,works,denqrs2, & + delqrs2,dtcld,2,1) + do k = kts, kte + do i = its, ite + qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.) + qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) + fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) + fall(i,k,2) = denqrs2(i,k)*works(i,k)/delz(i,k) enddo enddo do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - rmstep(i) = 1./mstep(i) + fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld + fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld enddo -! - do n = 1, mstepmax - k = kte + do k = kts, kte do i = its, ite - if(n.le.mstep(i)) then -! falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) -! falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)/mstep(i) - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) -! qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) -! qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - dtcldden = dtcld/den(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcldden,0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)*rmstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*work1(i,k,2)*rmstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - dtcldden = dtcld/den(i,k) - rdelz = 1./delz(i,k) - qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)*rdelz)*dtcldden,0.) - endif - enddo + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) enddo - do k = kte, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - if(t(i,k).gt.t0c.and.qrs(i,k,2).gt.0.) then + enddo + call slope_wsm5(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) + do k = kte, kts, -1 + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).gt.t0c.and.qrs(i,k,2).gt.0.) then !---------------------------------------------------------------- ! psmlt: melting of snow [HL A33] [RH83 A25] ! (T>T0: S->R) !---------------------------------------------------------------- - xlf = xlf0 -! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) - work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & - *exp(log(t(i,k))*(1.81))/p(i,k)))) & - *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & - *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & - *sqrt(sqrt(den0/(den(i,k))))) - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) -! psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & -! *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & -! *work2(i,k)*coeres) - psmlt(i,k) = (1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))) & - /((t(i,k))+120.)/(den(i,k)) )*(den(i,k))) & - /xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & - *work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif - endif - enddo + xlf = xlf0 +! work2(i,k)= venfac(p(i,k),t(i,k),den(i,k)) + work2(i,k)= (exp(log(((1.496e-6*((t(i,k))*sqrt(t(i,k))) & + /((t(i,k))+120.)/(den(i,k)))/(8.794e-5 & + *exp(log(t(i,k))*(1.81))/p(i,k)))) & + *((.3333333)))/sqrt((1.496e-6*((t(i,k)) & + *sqrt(t(i,k)))/((t(i,k))+120.)/(den(i,k)))) & + *sqrt(sqrt(den0/(den(i,k))))) + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psmlt(i,k) = (1.414e3*(1.496e-6*((t(i,k))*sqrt(t(i,k))) & + /((t(i,k))+120.)/(den(i,k)) )*(den(i,k))) & + /xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & + *work2(i,k)*coeres) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,2)/mstep(i)),0.) + qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif enddo enddo !--------------------------------------------------------------- ! Vice [ms-1] : fallout of ice crystal [HDC 5a] !--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 do k = kte, kts, -1 do i = its, ite if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. + work1c(i,k) = 0. else xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - work2c(i,k) = work1c(i,k)/delz(i,k) endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo ! - do n = 1, mstepmax - k = kte +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif + denqci(i,k) = den(i,k)*qci(i,k,2) enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) enddo enddo -! + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo ! !---------------------------------------------------------------- ! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf @@ -767,42 +711,21 @@ CONTAINS enddo ! !---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) +! update the slope parameters for microphysics computation ! do k = kts, kte do i = its, ite - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else -! rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslope(i,k,1) = 1./(sqrt(sqrt(pidn0r/((qrs(i,k,1))*(den(i,k)))))) - rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else -! rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2)) & - *(den(i,k)))))) - rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) enddo enddo + call slope_wsm5(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +!------------------------------------------------------------------ +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) ! do k = kts, kte do i = its, ite @@ -888,6 +811,7 @@ CONTAINS do k = kts, kte do i = its, ite supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) supsat = max(q(i,k),qmin)-qs(i,k,2) satdt = supsat/dtcld ifsat = 0 @@ -1236,7 +1160,6 @@ CONTAINS !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi ! pi = 4.*atan(1.) xlv1 = cl-cpv @@ -1286,4 +1209,402 @@ CONTAINS rslopes3max = rslopes2max * rslopesmax ! END SUBROUTINE wsm5init +!------------------------------------------------------------------------------ + subroutine slope_wsm5(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte,2) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + REAL, DIMENSION( its:ite , kts:kte) :: & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, lamdas, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = exp(log(rslope(i,k,1))*(bvtr)) + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = exp(log(rslope(i,k,2))*(bvts)) + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) + vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) + if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 + if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 + enddo + enddo + END subroutine slope_wsm5 +!----------------------------------------------------------------------------- + subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtr + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_rain +!------------------------------------------------------------------------------ + subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdas, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = rslope(i,k)**bvts + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_snow +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop 2: snow +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + if (id.eq.1) then + call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + else + call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + endif + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm END MODULE module_mp_wsm5 diff --git a/wrfv2_fire/phys/module_mp_wsm6.F b/wrfv2_fire/phys/module_mp_wsm6.F index 30470006..79ee1291 100644 --- a/wrfv2_fire/phys/module_mp_wsm6.F +++ b/wrfv2_fire/phys/module_mp_wsm6.F @@ -44,7 +44,7 @@ MODULE module_mp_wsm6 precr1,precr2,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc, & + pidn0s,xlv1,pacrc,pi, & bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & precg1,precg2,pidn0g, & @@ -72,31 +72,6 @@ CONTAINS !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- -! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the WRF -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte @@ -137,14 +112,12 @@ CONTAINS INTENT(INOUT) :: rain, & rainncv, & sr - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & + INTENT(INOUT) :: graupel, & + graupelncv ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte ) :: t REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci @@ -162,10 +135,8 @@ CONTAINS qrs(i,k,3) = qg(i,k,j) ENDDO ENDDO - ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. - CALL wsm62D(t, q(ims,kms,j), qci, qrs & ,den(ims,kms,j) & ,p(ims,kms,j), delz(ims,kms,j) & @@ -182,7 +153,6 @@ CONTAINS ,snow,snowncv & ,graupel,graupelncv & ) - DO K=kts,kte DO I=its,ite th(i,k,j)=t(i,k)/pii(i,k,j) @@ -197,7 +167,8 @@ CONTAINS END SUBROUTINE wsm6 !=================================================================== ! - SUBROUTINE wsm62D(t, q, qci, qrs, den, p, delz & + SUBROUTINE wsm62D(t, q & + ,qci, qrs, den, p, delz & ,delt,g, cpd, cpv, rd, rv, t0c & ,ep1, ep2, qmin & ,XLS, XLV0, XLF0, den0, denr & @@ -214,6 +185,35 @@ CONTAINS !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- +! +! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! All production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM6 cloud scheme +! +! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) +! Summer 2003 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2004 +! +! History : semi-lagrangian scheme sedimentation(JH), and clean up +! Hong, August 2009 +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan +! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. +! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. +! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. +! Juang and Hong (JH, 2010) Mon. Wea. Rev. +! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte, & @@ -260,7 +260,6 @@ CONTAINS REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & INTENT(INOUT) :: snow, & snowncv - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & INTENT(INOUT) :: graupel, & graupelncv @@ -272,17 +271,20 @@ CONTAINS rslope2, & rslope3, & rslopeb, & + qrs_tmp, & falk, & fall, & work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & fallc, & falkc, & work1c, & work2c, & + workr, & worka - + REAL, DIMENSION( its:ite , kts:kte ) :: & + den_tmp, & + delz_tmp REAL, DIMENSION( its:ite , kts:kte ) :: & pigen, & pidep, & @@ -311,7 +313,6 @@ CONTAINS pgmlt, & pseml, & pgeml - REAL, DIMENSION( its:ite , kts:kte ) :: & qsum, & xl, & @@ -319,12 +320,20 @@ CONTAINS work2, & denfac, & xni, & + denqrs1, & + denqrs2, & + denqrs3, & + denqci, & n0sfac + REAL, DIMENSION( its:ite ) :: delqrs1, & + delqrs2, & + delqrs3, & + delqi INTEGER, DIMENSION( its:ite ) :: mstep, & numdt LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: pi, & - cpmcal, xlcal, lamdar, lamdas, lamdag, diffus, & + REAL :: & + cpmcal, xlcal, diffus, & viscos, xka, venfac, conden, diffac, & x, y, z, a, b, c, d, e, & qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & @@ -337,7 +346,7 @@ CONTAINS REAL :: vt2ave REAL :: holdc, holdci INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim ! Temporaries used for inlining fpvs function REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp ! variables for optimization @@ -350,17 +359,9 @@ CONTAINS cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv xlcal(x) = xlv0-xlv1*(x-t0c) !---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. -! -! Optimizatin : A**B => exp(log(A)*(B)) - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! -!---------------------------------------------------------------- ! diffus: diffusion coefficient of the water vapor ! viscos: kinematic viscosity(m2s-1) +! Optimizatin : A**B => exp(log(A)*(B)) ! diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y @@ -370,8 +371,9 @@ CONTAINS /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) ! - pi = 4. * atan(1.) ! + idim = ite-its+1 + kdim = kte-kts+1 ! !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics @@ -397,6 +399,12 @@ CONTAINS xl(i,k) = xlcal(t(i,k)) enddo enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo ! !---------------------------------------------------------------- ! compute the minor time steps. @@ -504,206 +512,148 @@ CONTAINS xni(i,k) = 1.e3 enddo enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif !------------------------------------------------------------- ! Ni: ice crystal number concentraiton [HDC 5c] !------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) + do k = kts, kte + do i = its, ite temp = (den(i,k)*max(qci(i,k,2),qmin)) temp = sqrt(sqrt(temp*temp*temp)) xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) enddo enddo ! - mstepmax = 1 - numdt = 1 +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!---------------------------------------------------------------- + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + qrs_tmp(i,k,3) = qrs(i,k,3) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! do k = kte, kts, -1 do i = its, ite - work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k) - work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k) - work1(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)/delz(i,k) + workr(i,k) = work1(i,k,1) qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) IF ( qsum(i,k) .gt. 1.e-15 ) THEN - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) + worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & + /qsum(i,k) ELSE worka(i,k) = 0. ENDIF - numdt(i) = max(nint(max(work1(i,k,1),worka(i,k)) & - *dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) + denqrs1(i,k) = den(i,k)*qrs(i,k,1) + denqrs2(i,k) = den(i,k)*qrs(i,k,2) + denqrs3(i,k) = den(i,k)*qrs(i,k,3) + if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0 + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & + delqrs1,dtcld,1,1) + call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & + denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) + do k = kts, kte + do i = its, ite + qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.) + qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) + qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.) + fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) + fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) + fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) enddo enddo do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) + fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld + fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld + fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld enddo -! - do n = 1, mstepmax - k = kte + do k = kts, kte do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) - qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-falk(i,k,3)*dtcld/den(i,k),0.) - endif - enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falk(i,k,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i) - falk(i,k,2) = den(i,k)*qrs(i,k,2)*worka(i,k)/mstep(i) - falk(i,k,3) = den(i,k)*qrs(i,k,3)*worka(i,k)/mstep(i) - fall(i,k,1) = fall(i,k,1)+falk(i,k,1) - fall(i,k,2) = fall(i,k,2)+falk(i,k,2) - fall(i,k,3) = fall(i,k,3)+falk(i,k,3) - qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,2) = max(qrs(i,k,2)-(falk(i,k,2)-falk(i,k+1,2) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - qrs(i,k,3) = max(qrs(i,k,3)-(falk(i,k,3)-falk(i,k+1,3) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + qrs_tmp(i,k,3) = qrs(i,k,3) enddo - do k = kte, kts, -1 - do i = its, ite - if(n.le.mstep(i).and.t(i,k).gt.t0c) then + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).gt.t0c) then !--------------------------------------------------------------- ! psmlt: melting of snow [HL A33] [RH83 A25] ! (T>T0: S->R) !--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif + xlf = xlf0 + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + if(qrs(i,k,2).gt.0.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2) & + +precs2*work2(i,k)*coeres) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,2)/mstep(i)),0.) + qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif !--------------------------------------------------------------- ! pgmlt: melting of graupel [HL A23] [LFO 47] ! (T>T0: G->R) !--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif + if(qrs(i,k,3).gt.0.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & + *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & + +precg2*work2(i,k)*coeres) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & + -qrs(i,k,3)/mstep(i)),0.) + qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) + qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) endif - enddo + endif enddo enddo !--------------------------------------------------------------- ! Vice [ms-1] : fallout of ice crystal [HDC 5a] !--------------------------------------------------------------- - mstepmax = 1 - mstep = 1 - numdt = 1 do k = kte, kts, -1 do i = its, ite if(qci(i,k,2).le.0.) then - work2c(i,k) = 0. + work1c(i,k) = 0. else xmi = den(i,k)*qci(i,k,2)/xni(i,k) -! diameter = min(dicon * sqrt(xmi),dimax) diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*diameter**1.31 - work2c(i,k) = work1c(i,k)/delz(i,k) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) endif - numdt(i) = max(nint(work2c(i,k)*dtcld+.5),1) - if(numdt(i).ge.mstep(i)) mstep(i) = numdt(i) enddo enddo - do i = its, ite - if(mstepmax.le.mstep(i)) mstepmax = mstep(i) - enddo ! - do n = 1, mstepmax - k = kte +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-falkc(i,k)*dtcld/den(i,k),0.) - endif + denqci(i,k) = den(i,k)*qci(i,k,2) enddo - do k = kte-1, kts, -1 - do i = its, ite - if(n.le.mstep(i)) then - falkc(i,k) = den(i,k)*qci(i,k,2)*work2c(i,k)/mstep(i) - holdc = falkc(i,k) - fallc(i,k) = fallc(i,k)+falkc(i,k) - holdci = qci(i,k,2) - qci(i,k,2) = max(qci(i,k,2)-(falkc(i,k)-falkc(i,k+1) & - *delz(i,k+1)/delz(i,k))*dtcld/den(i,k),0.) - endif - enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) enddo enddo + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo ! !---------------------------------------------------------------- ! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf @@ -797,50 +747,22 @@ CONTAINS ! ! !---------------------------------------------------------------- -! rsloper: reverse of the slope parameter of the rain(m) -! xka: thermal conductivity of air(jm-1s-1k-1) -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) +! update the slope parameters for microphysics computation ! do k = kts, kte do i = its, ite - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif + qrs_tmp(i,k,1) = qrs(i,k,1) + qrs_tmp(i,k,2) = qrs(i,k,2) + qrs_tmp(i,k,3) = qrs(i,k,3) enddo enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +!------------------------------------------------------------------ +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) ! do k = kts, kte do i = its, ite @@ -912,6 +834,7 @@ CONTAINS do k = kts, kte do i = its, ite supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) supsat = max(q(i,k),qmin)-qs(i,k,2) satdt = supsat/dtcld ifsat = 0 @@ -1479,7 +1402,6 @@ CONTAINS !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv LOGICAL, INTENT(IN) :: allowed_to_read - REAL :: pi ! pi = 4.*atan(1.) xlv1 = cl-cpv @@ -1549,4 +1471,728 @@ CONTAINS rslopeg3max = rslopeg2max * rslopegmax ! END SUBROUTINE wsm6init +!------------------------------------------------------------------------------ + subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte,3) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt + REAL, DIMENSION( its:ite , kts:kte) :: & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, lamdas, lamdag, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + if(qrs(i,k,3).le.qcrmin)then + rslope(i,k,3) = rslopegmax + rslopeb(i,k,3) = rslopegbmax + rslope2(i,k,3) = rslopeg2max + rslope3(i,k,3) = rslopeg3max + else + rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) + rslopeb(i,k,3) = rslope(i,k,3)**bvtg + rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) + rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) + endif + vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) + vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) + vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) + if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 + if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 + if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 + enddo + enddo + END subroutine slope_wsm6 +!----------------------------------------------------------------------------- + subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdar, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtr + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_rain +!------------------------------------------------------------------------------ + subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdas, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = rslope(i,k)**bvts + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_snow +!---------------------------------------------------------------------------------- + subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & + vt,its,ite,kts,kte) + IMPLICIT NONE + INTEGER :: its,ite, jts,jte, kts,kte + REAL, DIMENSION( its:ite , kts:kte) :: & + qrs, & + rslope, & + rslopeb, & + rslope2, & + rslope3, & + vt, & + den, & + denfac, & + t + REAL, PARAMETER :: t0c = 273.15 + REAL, DIMENSION( its:ite , kts:kte ) :: & + n0sfac + REAL :: lamdag, x, y, z, supcol + integer :: i, j, k +!---------------------------------------------------------------- +! size distributions: (x=mixing ratio, y=air density): +! valid for mixing ratio > 1.e-9 kg/kg. + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 +! + do k = kts, kte + do i = its, ite +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopegmax + rslopeb(i,k) = rslopegbmax + rslope2(i,k) = rslopeg2max + rslope3(i,k) = rslopeg3max + else + rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtg + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + END subroutine slope_graup +!--------------------------------------------------------------------------------- +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),precip(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm +!------------------------------------------------------------------- + SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter) +!------------------------------------------------------------------- +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + implicit none + integer im,km,id + real dt + real dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im) + real denl(im,km),denfacl(im,km),tkl(im,km) +! + integer i,k,n,m,kk,kb,kt,iter,ist + real tl,tl2,qql,dql,qqd + real th,th2,qqh,dqh + real zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real allold, allnew, zz, dzamin, cflmax, decfl + real dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km) + real den(km), denfac(km), tk(km) + real wi(km+1), zi(km+1), za(km+1) + real qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) + real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) +! + precip(:) = 0.0 + precip1(:) = 0.0 + precip2(:) = 0.0 +! + i_loop : do i=1,im +! ----------------------------------- + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + qq2(:) = rql2(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qa2(k) = qq2(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + qr2(k) = qa2(k)/den(k) + enddo + qa(km+1) = 0.0 + qa2(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) + do k = 1, km + tmp(k) = max((qr(k)+qr2(k)), 1.E-15) + IF ( tmp(k) .gt. 1.e-15 ) THEN + wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) + ELSE + wa(k) = 0. + ENDIF + enddo + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & +! ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif + ist_loop : do ist = 1, 2 + if (ist.eq.2) then + qa(:) = qa2(:) + endif +! + precip(i) = 0. +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + if(ist.eq.1) then + rql(i,:) = qn(:) + precip1(i) = precip(i) + else + rql2(i,:) = qn(:) + precip2(i) = precip(i) + endif + enddo ist_loop +! +! ---------------------------------- + enddo i_loop +! + END SUBROUTINE nislfv_rain_plm6 END MODULE module_mp_wsm6 diff --git a/wrfv2_fire/phys/module_pbl_driver.F b/wrfv2_fire/phys/module_pbl_driver.F index 70555d5c..06aa7ad1 100644 --- a/wrfv2_fire/phys/module_pbl_driver.F +++ b/wrfv2_fire/phys/module_pbl_driver.F @@ -22,6 +22,9 @@ CONTAINS ,kpbl,mixht,ct,lh,snow,xice & ,znu, znw, mut, p_top & ,qke,tsq,qsq,cov,rmol,ch,qcg,grav_settling & +#if (NMM_CORE==1) + ,DISHEAT & +#endif ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,i_start,i_end, j_start,j_end, kts,kte, num_tiles & @@ -56,11 +59,12 @@ CONTAINS USE module_state_description, ONLY : & YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME,& QNSEPBLSCHEME,MYNNPBLSCHEME2,MYNNPBLSCHEME3,BOULACSCHEME,& - BEPSCHEME,MYJSFCSCHEME + BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, p_qi,param_first_scalar #else USE module_state_description, ONLY : & - YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME,QNSEPBLSCHEME,& - MYJSFCSCHEME + YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME & + , QNSEPBLSCHEME, p_qi,param_first_scalar & + , MYJSFCSCHEME #endif USE module_model_constants @@ -243,6 +247,9 @@ CONTAINS INTENT(IN ) :: LOWLYR ! LOGICAL, INTENT(IN ) :: warm_rain +#if (NMM_CORE==1) + LOGICAL, INTENT(IN ) :: DISHEAT ! (for HWRF) +#endif REAL, DIMENSION( kms:kme ), & OPTIONAL, INTENT(IN ) :: znu, & @@ -465,6 +472,8 @@ CONTAINS #if (NMM_CORE != 1) CASE (BEPSCHEME) flag_bep=.true. + CASE (BEP_BEMSCHEME) + flag_bep=.true. #endif CASE DEFAULT flag_bep=.false. @@ -708,21 +717,37 @@ CONTAINS ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & ,FLAG_QI=flag_qi & ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg & - ,DZ8W=dz8w,Z=z,XLV=XLV,RV=r_v,PSFC=PSFC & + ,DZ8W=dz8w,XLV=XLV,RV=r_v,PSFC=PSFC & ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top & - ,ZNT=znt,UST=ust,ZOL=zol,HOL=hol,HPBL=pblh & + ,ZNT=znt,UST=ust,HPBL=pblh & ,PSIM=psim,PSIH=psih,XLAND=xland & - ,HFX=hfx,QFX=qfx,TSK=tskold,GZ1OZ0=gz1oz0 & + ,HFX=hfx,QFX=qfx,GZ1OZ0=gz1oz0 & ,U10=u10,V10=v10 & - ,WSPD=wspd,BR=br,DT=dtbl,DTMIN=dtmin,KPBL2D=kpbl & - ,SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0 & - ,EP1=ep_1,EP2=ep_2,KARMAN=karman,EOMEG=eomeg & - ,STBOLT=stbolt,EXCH_H=exch_h,REGIME=regime & + ,WSPD=wspd,BR=br,DT=dtbl,KPBL2D=kpbl & + ,EP1=ep_1,EP2=ep_2,KARMAN=karman & + ,EXCH_H=exch_h,REGIME=regime & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & ) ELSE + WRITE ( message , FMT = '(A,7(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'qi_curr, '// & + 'rqvblten, '// & + 'rqcblten, '// & + 'rqiblten, '// & + 'hol = ' , & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( qi_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) , & + PRESENT( rqiblten ) , & + PRESENT( hol ) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call YSU pbl') ENDIF @@ -759,6 +784,19 @@ CONTAINS ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & ) ELSE + WRITE ( message , FMT = '(A,5(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'rqvblten, '// & + 'rqcblten, '// & + 'hol = ' , & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) , & + PRESENT( hol ) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call MRF pbl') ENDIF @@ -775,17 +813,32 @@ CONTAINS ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten & ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten & ,RQIBLTEN=rqiblten & - ,CP=cp,G=g,ROVCP=rcp,R=r_d,ROVG=rovg,FLAG_QI=flag_qi & + ,CP=cp,G=g,ROVCP=rcp,R=r_d,ROVG=rovg & ,DZ8W=dz8w,z=z,PSFC=psfc & ,UST=ust,PBL=pblh,PSIM=psim,PSIH=psih & ,HFX=hfx,QFX=qfx,TSK=tskold,GZ1OZ0=gz1oz0 & ,WSPD=wspd,BR=br & ,DT=dtbl,KPBL2D=kpbl,EP1=ep_1,KARMAN=karman & +#if (NMM_CORE==1) + ,DISHEAT=DISHEAT & +#endif + ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & ) ELSE + WRITE ( message , FMT = '(A,4(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'rqvblten, '// & + 'rqcblten = ', & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call GFS pbl') ENDIF @@ -850,6 +903,17 @@ CONTAINS ENDIF ELSE + WRITE ( message , FMT = '(A,4(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'rqvblten, '// & + 'rqcblten = ' , & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call MYJ pbl') ENDIF @@ -877,6 +941,17 @@ CONTAINS ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & ) ELSE + WRITE ( message , FMT = '(A,4(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'rqvblten, '// & + 'rqcblten = ' , & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call QNSE pbl') ENDIF @@ -903,6 +978,17 @@ CONTAINS ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & ) ELSE + WRITE ( message , FMT = '(A,4(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'rqvblten, '// & + 'rqcblten = ' , & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call ACM2 pbl') ENDIF @@ -914,7 +1000,7 @@ CONTAINS PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & & PRESENT(qke) .AND. PRESENT(tsq) .AND. & & PRESENT(qsq) .AND. PRESENT(cov) .AND. & - & PRESENT(rmol) .AND. PRESENT(rmol) .AND. & + & PRESENT(rmol) .AND. & & PRESENT(qcg) .AND. PRESENT(ch) .AND. & & PRESENT(grav_settling) ) THEN @@ -945,6 +1031,33 @@ CONTAINS ) ELSE + WRITE ( message , FMT = '(A,12(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'rqvblten, '// & + 'rqcblten, '// & + 'qke, '// & + 'tsq = '// & + 'qsq = '// & + 'cov = '// & + 'rmol = '// & + 'qcg = '// & + 'ch = '// & + 'grav_settling = ', & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) , & + PRESENT( qke ) , & + PRESENT( tsq ) , & + PRESENT( qsq ) , & + PRESENT( cov ) , & + PRESENT( rmol ) , & + PRESENT( qcg ) , & + PRESENT( ch ) , & + PRESENT( grav_settling) + CALL wrf_debug(0,message) CALL wrf_error_fatal('Lack arguments to call MYNN pbl') ENDIF diff --git a/wrfv2_fire/phys/module_physics_init.F b/wrfv2_fire/phys/module_physics_init.F index b4b32664..5153fbd6 100644 --- a/wrfv2_fire/phys/module_physics_init.F +++ b/wrfv2_fire/phys/module_physics_init.F @@ -12,7 +12,7 @@ MODULE module_physics_init USE module_state_description USE module_model_constants - USE module_configure + USE module_configure, ONLY : grid_config_rec_type CONTAINS @@ -42,6 +42,9 @@ CONTAINS #if (NMM_CORE != 1) TKE_PBL, & #endif +#if (NMM_CORE == 1) + RUCUTEN, RVCUTEN, & +#endif EXCH_H,THC,SNOWC,MAVAIL,HFX,QFX,RAINBL, & TSLB,ZS,DZS,num_soil_layers,warm_rain, & adv_moist_cond, & @@ -77,7 +80,13 @@ CONTAINS SH_URB2D, LH_URB2D, G_URB2D, RN_URB2D, & !Optional urban TS_URB2D, FRC_URB2D, UTYPE_URB2D, & !Optional urban TRB_URB4D,TW1_URB4D,TW2_URB4D, & !Optional multi-layer urban - TGB_URB4D,SFW1_URB3D,SFW2_URB3D, & !Optional multi-layer urban + TGB_URB4D,TLEV_URB3D,QLEV_URB3D, & !Optional multi-layer urban + TW1LEV_URB3D,TW2LEV_URB3D, & !Optional multi-layer urban + TGLEV_URB3D,TFLEV_URB3D, & !Optional multi-layer urban + SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D, & !Optional multi-layer urban + SFVENT_URB3D,LFVENT_URB3D, & !Optional multi-layer urban + SFWIN1_URB3D,SFWIN2_URB3D, & !Optional multi-layer urban + SFW1_URB3D,SFW2_URB3D, & !Optional multi-layer urban SFR_URB3D,SFG_URB3D, & !Optional multi-layer urban A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & !Optional multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & !Optional multi-layer urban @@ -147,7 +156,7 @@ CONTAINS SMSTAV, & SMSTOT, & SFCRUNOFF, & - UDRUNOFF, & + UDRUNOFF, & SFCEVP, & GRDFLX, & ACSNOW, & @@ -217,6 +226,10 @@ CONTAINS #if (NMM_CORE != 1) REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: TKE_PBL #endif +#if (NMM_CORE == 1) + REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(INOUT) :: & + RUCUTEN, RVCUTEN +#endif REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(OUT) :: & cugd_tten,cugd_ttens,cugd_qvten, & cugd_qvtens,cugd_qcten @@ -289,6 +302,19 @@ CONTAINS REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D ! multi-layer UCM REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D ! multi-layer UCM REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D ! multi-layer UCM REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFG_URB3D ! multi-layer UCM REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D ! multi-layer UCM REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D ! multi-layer UCM @@ -462,6 +488,7 @@ integer myproc TRIM ( mminlu_loc ) , & landuse_ISICE, landuse_LUCATS, & landuse_LUSEAS, landuse_ISN, & + config_flags%fractional_seaice, & lu_state, & allowed_to_read , usemonalb , & ids, ide, jds, jde, kds, kde, & @@ -486,19 +513,19 @@ integer myproc CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to ra_init' ) - CALL ra_init(id,STEPRA,RADT,DT,RTHRATEN,RTHRATENLW, & - RTHRATENSW,CLDFRA,EMISS,cen_lat,JULYR,JULDAY,GMT, & - levsiz,XLAT,n_ozmixm, & - cldfra_old, & ! Optional - ozmixm,pin, & ! Optional - m_ps_1,m_ps_2,m_hybi,aerosolc_1,aerosolc_2, & ! Optional - paerlev,n_aerosolc, & - sfull,shalf,pptop,swrad_scat, & - config_flags,restart, & - allowed_to_read, start_of_simulation, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + CALL ra_init(id=id,STEPRA=STEPRA,RADT=RADT,DT=DT,RTHRATEN=RTHRATEN,RTHRATENLW=RTHRATENLW, & + RTHRATENSW=RTHRATENSW,CLDFRA=CLDFRA,EMISS=EMISS,cen_lat=cen_lat,JULYR=JULYR,JULDAY=JULDAY,GMT=GMT, & + levsiz=levsiz,XLAT=XLAT,n_ozmixm=n_ozmixm, & + cldfra_old=cldfra_old, & ! Optional + ozmixm=ozmixm,pin=pin, & ! Optional + m_ps_1=m_ps_1,m_ps_2=m_ps_2,m_hybi=m_hybi,aerosolc_1=aerosolc_1,aerosolc_2=aerosolc_2, & ! Optional + paerlev=paerlev,n_aerosolc=n_aerosolc, & + sfull=sfull,shalf=shalf,pptop=pptop,swrad_scat=swrad_scat, & + config_flags=config_flags,restart=restart, & + allowed_to_read=allowed_to_read, start_of_simulation=start_of_simulation, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte ) CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to bl_init' ) CALL bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & @@ -531,7 +558,13 @@ integer myproc SF_URBAN_PHYSICS, & !Optional urban NUM_URBAN_LAYERS, & !Optional multi-layer urban TRB_URB4D,TW1_URB4D,TW2_URB4D, & !Optional multi-layer urban - TGB_URB4D,SFW1_URB3D,SFW2_URB3D, & !Optional multi-layer urban + TGB_URB4D,TLEV_URB3D,QLEV_URB3D, & !Optional multi-layer urban + TW1LEV_URB3D,TW2LEV_URB3D, & !Optional multi-layer urban + TGLEV_URB3D,TFLEV_URB3D, & !Optional multi-layer urban + SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D, & !Optional multi-layer urban + SFVENT_URB3D,LFVENT_URB3D, & !Optional multi-layer urban + SFWIN1_URB3D,SFWIN2_URB3D, & !Optional multi-layer urban + SFW1_URB3D,SFW2_URB3D, & !Optional multi-layer urban SFR_URB3D,SFG_URB3D, & !Optional multi-layer urban A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & !Optional multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & !Optional multi-layer urban @@ -548,6 +581,9 @@ integer myproc CALL cu_init(STEPCU,CUDT,DT,RTHCUTEN,RQVCUTEN,RQRCUTEN, & RQCCUTEN,RQSCUTEN,RQICUTEN,NCA,RAINC, & +#if (NMM_CORE == 1) + RUCUTEN, RVCUTEN, & +#endif RAINCV,W0AVG,config_flags,restart, & CLDEFI,LOWLYR,MASS_FLUX, & RTHFTEN, RQVFTEN, & @@ -601,10 +637,35 @@ integer myproc model_config_rec%obs_sfcfact, & model_config_rec%obs_sfcfacr, & model_config_rec%obs_dpsmx, & - model_config_rec%obs_lml_ht1, & - model_config_rec%obs_lml_ht2, & + model_config_rec%obs_nudgezfullr1_uv, & + model_config_rec%obs_nudgezrampr1_uv, & + model_config_rec%obs_nudgezfullr2_uv, & + model_config_rec%obs_nudgezrampr2_uv, & + model_config_rec%obs_nudgezfullr4_uv, & + model_config_rec%obs_nudgezrampr4_uv, & + model_config_rec%obs_nudgezfullr1_t, & + model_config_rec%obs_nudgezrampr1_t, & + model_config_rec%obs_nudgezfullr2_t, & + model_config_rec%obs_nudgezrampr2_t, & + model_config_rec%obs_nudgezfullr4_t, & + model_config_rec%obs_nudgezrampr4_t, & + model_config_rec%obs_nudgezfullr1_q, & + model_config_rec%obs_nudgezrampr1_q, & + model_config_rec%obs_nudgezfullr2_q, & + model_config_rec%obs_nudgezrampr2_q, & + model_config_rec%obs_nudgezfullr4_q, & + model_config_rec%obs_nudgezrampr4_q, & + model_config_rec%obs_nudgezfullmin, & + model_config_rec%obs_nudgezrampmin, & + model_config_rec%obs_nudgezmax, & xlat, & xlong, & + model_config_rec%start_year(id), & + model_config_rec%start_month(id), & + model_config_rec%start_day(id), & + model_config_rec%start_hour(id), & + model_config_rec%start_minute(id), & + model_config_rec%start_second(id), & p00, t00, tlp, & zhalf, p_top, & fdob, & @@ -621,6 +682,7 @@ integer myproc SUBROUTINE landuse_init(lu_index, snowc, albedo, albbck, snoalb, mavail, emiss, embck, & znt,Z0,thc,xland, xice, xicem, julday, cen_lat, iswater, mminlu, & ISICE, LUCATS, LUSEAS, ISN, & + fractional_seaice, & lu_state, & allowed_to_read , usemonalb , & ids, ide, jds, jde, kds, kde, & @@ -639,13 +701,14 @@ integer myproc REAL , INTENT(IN) :: cen_lat CHARACTER(LEN=*), INTENT(IN) :: mminlu LOGICAL, INTENT(IN) :: allowed_to_read , usemonalb - REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: lu_index, snowc, xice, snoalb + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: lu_index, snowc, xice, snoalb REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(OUT ) :: albedo, albbck, mavail, emiss, & embck, & znt, Z0, thc, xland, xicem - INTEGER , INTENT(INOUT) :: ISICE, LUCATS, LUSEAS, ISN + INTEGER , INTENT(INOUT) :: ISICE, LUCATS, LUSEAS, ISN, fractional_seaice REAL , INTENT(INOUT) , DIMENSION( : ) :: lu_state + REAL :: xice_threshold !--------------------------------------------------------------------- ! Local CHARACTER*256 LUTYPE @@ -670,6 +733,12 @@ integer myproc NSN=-1 ! set this to suppress uninitalized data messages from tools + if ( fractional_seaice == 0 ) then + xice_threshold = 0.5 + else if ( fractional_seaice == 1 ) then + xice_threshold = 0.02 + endif + ! recover LU variables from state IF ( 6*(max_cats*max_seas)+1*max_cats .GT. 7501 ) THEN WRITE(message,*)'landuse_init: lu_state overflow. Make Registry dimspec p > ',6*(max_cats*max_seas)+1*max_cats @@ -829,7 +898,7 @@ integer myproc ENDIF ! SET SEA-ICE POINTS TO LAND WITH ICE/SNOW SURFACE PROPERTIES XICEM(I,J)=XICE(I,J) - IF(XICE(I,J).GT.0.5)THEN + IF(XICE(I,J).GE.xice_threshold)THEN XLAND(I,J)=1.0 ALBBCK(I,J)=ALBD(ISICE,ISN)/100. ALBEDO(I,J)=ALBBCK(I,J) @@ -880,14 +949,17 @@ integer myproc ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) !--------------------------------------------------------------------- - USE module_ra_rrtm - USE module_ra_rrtmg_lw - USE module_ra_rrtmg_sw - USE module_ra_cam - USE module_ra_sw - USE module_ra_gsfcsw - USE module_ra_gfdleta - USE module_ra_hs + USE module_ra_rrtm , ONLY : rrtminit + USE module_ra_rrtmg_lw , ONLY : rrtmg_lwinit + USE module_ra_rrtmg_sw , ONLY : rrtmg_swinit + USE module_ra_cam , ONLY : camradinit + USE module_ra_sw , ONLY : swinit + USE module_ra_gsfcsw , ONLY : gsfc_swinit + USE module_ra_gfdleta , ONLY : gfdletainit +#if(NMM_CORE==1) + USE module_ra_hwrf , ONLY : hwrfrainit +#endif + USE module_ra_hs , ONLY : hsinit USE module_domain !--------------------------------------------------------------------- IMPLICIT NONE @@ -936,6 +1008,7 @@ integer myproc REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: EMISS LOGICAL :: etalw = .false. + LOGICAL :: hwrflw= .false. LOGICAL :: camlw = .false. LOGICAL :: etamp = .false. integer :: month,iday @@ -1037,6 +1110,28 @@ integer myproc ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) etalw = .true. +#if(NMM_CORE==1) + CASE (HWRFLWSCHEME) + CALL nl_get_start_month(id,month) + CALL nl_get_start_day(id,iday) +! test this with standard jul-day calls +! CALL nl_get_start_year(id,start_year) +! CALL nl_get_start_month(id,start_month) +! CALL nl_get_start_day(id,start_day) +! CALL nl_get_start_hour(id,start_hour) +! CALL nl_get_start_minute(id,start_minute) +! CALL nl_get_start_second(id,start_second) +! CALL jdn_sec(day_in_sec,start_year,start_month,start_day,0,0,0) +! CALL jdn_sec(day_in_sec_ref,start_year,1,1,0,0,0) +! julyr_start=start_year +! julday_start=(day_in_sec-day_in_sec_ref)/(3600.*24.)+1 +! gmt_start=start_hour+real(start_minute)/60.+real(start_second)/3600. + CALL hwrfrainit(sfull,shalf,pptop,JULYR,MONTH,IDAY,GMT,& +! CALL hwrfrainit(sfull,shalf,pptop,JULYR_start,MONTH,IDAY,GMT_start,& + allowed_to_read , & + kds, kde, kms, kme, kts, kte ) + hwrflw = .true. +#endif CASE (HELDSUAREZ) CALL hsinit(RTHRATEN,restart, & ids, ide, jds, jde, kds, kde, & @@ -1093,7 +1188,16 @@ integer myproc ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDIF - +#if(NMM_CORE==1) + CASE (HWRFSWSCHEME) + IF(.not.hwrflw)THEN + CALL nl_get_start_month(id,month) + CALL nl_get_start_day(id,iday) + CALL hwrfrainit(sfull,shalf,pptop,JULYR,MONTH,IDAY,GMT,& + allowed_to_read, & + kds, kde, kms, kme, kts, kte ) + ENDIF +#endif CASE DEFAULT END SELECT swrad_select @@ -1131,7 +1235,13 @@ integer myproc SF_URBAN_PHYSICS, & !Optional urban NUM_URBAN_LAYERS, & !Optional multi-layer urban TRB_URB4D,TW1_URB4D,TW2_URB4D, & !Optional multi-layer urban - TGB_URB4D,SFW1_URB3D,SFW2_URB3D, & !Optional multi-layer urban + TGB_URB4D,TLEV_URB3D,QLEV_URB3D, & !Optional multi-layer urban + TW1LEV_URB3D,TW2LEV_URB3D, & !Optional multi-layer urban + TGLEV_URB3D,TFLEV_URB3D, & !Optional multi-layer urban + SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D, & !Optional multi-layer urban + SFVENT_URB3D,LFVENT_URB3D, & !Optional multi-layer urban + SFWIN1_URB3D,SFWIN2_URB3D, & !Optional multi-layer urban + SFW1_URB3D,SFW2_URB3D, & !Optional multi-layer urban SFR_URB3D,SFG_URB3D, & !Optional multi-layer urban A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & !Optional multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & !Optional multi-layer urban @@ -1156,8 +1266,10 @@ integer myproc USE module_sf_noahdrv USE module_sf_urban USE module_sf_bep !BEP + USE module_sf_bep_bem USE module_sf_ruclsm USE module_sf_pxlsm + USE module_sf_oml USE module_bl_myjpbl USE module_bl_myjurb USE module_bl_boulac @@ -1282,6 +1394,19 @@ integer myproc REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1_URB4D !Optional UCM REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2_URB4D !Optional UCM REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGB_URB4D !Optional UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TLEV_URB3D !Optional UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: QLEV_URB3D !Optional UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D !multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D ! multi-layer UCM + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D ! multi-layer UCM REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFW1_URB3D !Optional UCM REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFW2_URB3D !Optional UCM REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFR_URB3D !Optional UCM @@ -1408,21 +1533,9 @@ integer myproc CASE (MYNNSFCSCHEME) - SELECT CASE(config_flags%bl_pbl_physics) - - CASE(MYNNPBLSCHEME2) - mynn_closure_level=2 - - CASE(MYNNPBLSCHEME3) - mynn_closure_level=3 - - CASE DEFAULT - - - END SELECT - - CALL mynn_sf_init_driver(allowed_to_read,mynn_closure_level) + CALL mynn_sf_init_driver(allowed_to_read) isfc=5 +! isfc=3 #endif @@ -1442,9 +1555,7 @@ integer myproc allowed_to_read ,start_of_simulation ,& ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte, & - oml_hml0, omlcall, & - tml, t0ml, hml, h0ml, huml, hvml ) + its, ite, jts, jte, kts, kte ) #if (NMM_CORE == 1) CASE (GFDLSLAB) @@ -1472,14 +1583,15 @@ integer myproc its,ite, jts,jte, kts,kte ) !URBAN - IF ((SF_URBAN_PHYSICS.eq.1).OR.(SF_URBAN_PHYSICS.EQ.2)) THEN + IF ((SF_URBAN_PHYSICS.eq.1).OR.(SF_URBAN_PHYSICS.EQ.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN IF ( PRESENT( FRC_URB2D ) .AND. PRESENT( UTYPE_URB2D )) THEN - + CALL urban_param_init(DZR,DZB,DZG,num_soil_layers & !urban ) ! num_roof_layers,num_wall_layers,road_soil_layers) !urban - + + CALL urban_var_init(ISURBAN,TSK,TSLB,TMN,IVGTYP, & !urban ims,ime,jms,jme,kms,kme,num_soil_layers, & !urban ! num_roof_layers,num_wall_layers,num_road_layers, & !urban @@ -1490,6 +1602,12 @@ integer myproc SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, TS_URB2D, & !urban num_urban_layers, & !urban TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D, & !urban + TLEV_URB3D,QLEV_URB3D, & !urban + TW1LEV_URB3D,TW2LEV_URB3D, & !urban + TGLEV_URB3D,TFLEV_URB3D, & !urban + SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D, & !urban + SFVENT_URB3D,LFVENT_URB3D, & !urban + SFWIN1_URB3D,SFWIN2_URB3D, & !urban SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D, & !urban A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & !multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & !multi-layer urban @@ -1504,8 +1622,9 @@ integer myproc CASE (RUCLSMSCHEME) ! if(isfc .ne. 2)CALL wrf_error_fatal & ! ( 'module_physics_init: use myjsfc and myjpbl scheme for this lsm option' ) - CALL lsmrucinit( SMFR3D,TSLB,SMOIS,ISLTYP,mavail, & - num_soil_layers, restart, & + CALL ruclsminit( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP,XICE, & + mavail,num_soil_layers, config_flags%iswater, & + config_flags%isice, restart, & allowed_to_read , & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1527,6 +1646,17 @@ integer myproc END SELECT sfc_select + IF(PRESENT(OMLCALL))THEN + IF (omlcall .EQ. 1) THEN + CALL omlinit(oml_hml0, tsk, & + tml,t0ml,hml,h0ml,huml,hvml, & + allowed_to_read, start_of_simulation, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ENDIF + ENDIF + !-- initialize pbl scheme pbl_select: SELECT CASE(config_flags%bl_pbl_physics) @@ -1578,7 +1708,7 @@ integer myproc CASE (MYJPBLSCHEME) if(isfc .ne. 2)CALL wrf_error_fatal & ( 'module_physics_init: use myjsfc scheme for this pbl option' ) - IF (SF_URBAN_PHYSICS.eq.2) THEN + IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN CALL myjurbinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & TKE_MYJ,EXCH_H,restart, & allowed_to_read , & @@ -1623,6 +1753,18 @@ integer myproc IF(isfc .NE. 5 .AND. isfc .NE. 1 .AND. isfc .NE. 2) CALL wrf_error_fatal & ( 'module_physics_init: use mynnsfc or sfclay or myjsfc scheme for this pbl option') + SELECT CASE(config_flags%bl_pbl_physics) + + CASE(MYNNPBLSCHEME2) + mynn_closure_level=2 + + CASE(MYNNPBLSCHEME3) + mynn_closure_level=3 + + CASE DEFAULT + + END SELECT + CALL mynn_bl_init_driver(& &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN& &,restart,allowed_to_read,mynn_closure_level & @@ -1642,6 +1784,9 @@ integer myproc !================================================================== SUBROUTINE cu_init(STEPCU,CUDT,DT,RTHCUTEN,RQVCUTEN,RQRCUTEN, & RQCCUTEN,RQSCUTEN,RQICUTEN,NCA,RAINC, & +#if (NMM_CORE == 1) + RUCUTEN, RVCUTEN, & +#endif RAINCV,W0AVG,config_flags,restart, & CLDEFI,LOWLYR,MASS_FLUX, & RTHFTEN, RQVFTEN, & @@ -1698,6 +1843,10 @@ integer myproc APR_CAPMA,APR_CAPME,APR_CAPMI INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: LOWLYR +#if (NMM_CORE == 1) + REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(INOUT) :: & + RUCUTEN, RVCUTEN +#endif ! LOCAL VAR @@ -1778,8 +1927,10 @@ integer myproc ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) #endif - CASE (SASSCHEME) CALL sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & +#if (NMM_CORE == 1) + RUCUTEN,RVCUTEN, & ! gopal's doing for SAS +#endif restart,P_QC,P_QI,PARAM_FIRST_SCALAR, & allowed_to_read , & ids, ide, jds, jde, kds, kde, & @@ -1807,9 +1958,14 @@ integer myproc USE module_mp_wsm5 USE module_mp_wsm6 USE module_mp_etanew +#if (NMM_CORE == 1) + USE module_mp_HWRF +#endif USE module_mp_thompson USE module_mp_thompson07 USE module_mp_morr_two_moment + USE module_mp_milbrandt2mom +! USE module_mp_milbrandt3mom USE module_mp_wdm5 USE module_mp_wdm6 !------------------------------------------------------------------ @@ -1868,6 +2024,15 @@ integer myproc ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) +#if(NMM_CORE==1) + CASE (etamp_HWRF) + CALL etanewinit_HWRF (MPDT,DT,DX,DY,LOWLYR,restart, & + F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +#endif CASE (THOMPSON) ! Cycling the WRF forecast with moving nests will cause this initialization to be ! called for each nest move. This is potentially very computationally expensive. @@ -1878,6 +2043,10 @@ integer myproc CASE (MORR_TWO_MOMENT) CALL morr_two_moment_init + CASE (MILBRANDT2MOM) + CALL milbrandt2mom_init +! CASE (MILBRANDT3MOM) +! CALL milbrandt3mom_init CASE (WDM5SCHEME) CALL wdm5init(rhoair0,rhowater,rhosnow,cliq,cpv,n_ccn0,allowed_to_read ) CASE (WDM6SCHEME) @@ -1952,7 +2121,7 @@ integer myproc config_flags%guv, & config_flags%gt, config_flags%gq, & config_flags%if_ramping, config_flags%dtramp_min, & - config_flags%gfdda_end_h, & + config_flags%auxinput10_end_h, & config_flags%grid_sfdda, & config_flags%guv_sfc, & config_flags%gt_sfc, & @@ -1980,7 +2149,7 @@ integer myproc config_flags%guv, & config_flags%gt, config_flags%gph, & config_flags%if_ramping, config_flags%dtramp_min, & - config_flags%gfdda_end_h, & + config_flags%auxinput9_end_h, & config_flags%xwavenum,config_flags%ywavenum, & restart, allowed_to_read, & ids, ide, jds, jde, kds, kde, & @@ -2001,8 +2170,19 @@ integer myproc no_pbl_nudge_t, & no_pbl_nudge_q, & sfcfact, sfcfacr, dpsmx, & - lml_ht1, lml_ht2, & + nudgezfullr1_uv, nudgezrampr1_uv, & + nudgezfullr2_uv, nudgezrampr2_uv, & + nudgezfullr4_uv, nudgezrampr4_uv, & + nudgezfullr1_t, nudgezrampr1_t, & + nudgezfullr2_t, nudgezrampr2_t, & + nudgezfullr4_t, nudgezrampr4_t, & + nudgezfullr1_q, nudgezrampr1_q, & + nudgezfullr2_q, nudgezrampr2_q, & + nudgezfullr4_q, nudgezrampr4_q, & + nudgezfullmin, nudgezrampmin, nudgezmax, & xlat, xlong, & + start_year, start_month, start_day, & + start_hour, start_minute, start_second, & p00, t00, tlp, & znu, p_top, & fdob, ipf_init, & @@ -2037,10 +2217,35 @@ integer myproc REAL , INTENT(IN) :: sfcfact ! scale factor applied to time window for surface obs REAL , INTENT(IN) :: sfcfacr ! scale fac applied to horiz rad of infl for sfc obs REAL , INTENT(IN) :: dpsmx ! max pressure change allowed within horiz. infl. range - REAL , INTENT(IN) :: lml_ht1 ! height 1 for spreading of lowest model level obs - REAL , INTENT(IN) :: lml_ht2 ! height 2 for spreading of lowest model level obs + REAL , INTENT(IN) :: nudgezfullr1_uv ! vert infl fcn, regime=1 full-wt hght, winds + REAL , INTENT(IN) :: nudgezrampr1_uv ! vert infl fcn, regime=1 ramp down hght, winds + REAL , INTENT(IN) :: nudgezfullr2_uv ! vert infl fcn, regime=2 full-wt hght, winds + REAL , INTENT(IN) :: nudgezrampr2_uv ! vert infl fcn, regime=2 ramp down hght, winds + REAL , INTENT(IN) :: nudgezfullr4_uv ! vert infl fcn, regime=4 full-wt hght, winds + REAL , INTENT(IN) :: nudgezrampr4_uv ! vert infl fcn, regime=4 ramp down hght, winds + REAL , INTENT(IN) :: nudgezfullr1_t ! vert infl fcn, regime=1 full-wt hght, temp + REAL , INTENT(IN) :: nudgezrampr1_t ! vert infl fcn, regime=1 ramp down hght, temp + REAL , INTENT(IN) :: nudgezfullr2_t ! vert infl fcn, regime=2 full-wt hght, temp + REAL , INTENT(IN) :: nudgezrampr2_t ! vert infl fcn, regime=2 ramp down hght, temp + REAL , INTENT(IN) :: nudgezfullr4_t ! vert infl fcn, regime=4 full-wt hght, temp + REAL , INTENT(IN) :: nudgezrampr4_t ! vert infl fcn, regime=4 ramp down hght, temp + REAL , INTENT(IN) :: nudgezfullr1_q ! vert infl fcn, regime=1 full-wt hght, mois + REAL , INTENT(IN) :: nudgezrampr1_q ! vert infl fcn, regime=1 ramp down hght, mois + REAL , INTENT(IN) :: nudgezfullr2_q ! vert infl fcn, regime=2 full-wt hght, mois + REAL , INTENT(IN) :: nudgezrampr2_q ! vert infl fcn, regime=2 ramp down hght, mois + REAL , INTENT(IN) :: nudgezfullr4_q ! vert infl fcn, regime=4 full-wt hght, mois + REAL , INTENT(IN) :: nudgezrampr4_q ! vert infl fcn, regime=4 ramp down hght, mois + REAL , INTENT(IN) :: nudgezfullmin ! min dpth thru which vert infl fcn remains 1.0 (m) + REAL , INTENT(IN) :: nudgezrampmin ! min dpth thru which vif decreases 1.0 to 0.0 (m) + REAL , INTENT(IN) :: nudgezmax ! max dpth in which vif is nonzero (m) REAL , INTENT(IN) :: xlat ( ims:ime, jms:jme ) ! latitudes on mass-point grid REAL , INTENT(IN) :: xlong( ims:ime, jms:jme ) ! longitudes on mass-point grid + INTEGER , INTENT(INOUT) :: start_year + INTEGER , INTENT(INOUT) :: start_month + INTEGER , INTENT(INOUT) :: start_day + INTEGER , INTENT(INOUT) :: start_hour + INTEGER , INTENT(INOUT) :: start_minute + INTEGER , INTENT(INOUT) :: start_second REAL , INTENT(IN) :: p00 ! base state pressure REAL , INTENT(IN) :: t00 ! base state temperature REAL , INTENT(IN) :: tlp ! base state lapse rate @@ -2064,8 +2269,19 @@ integer myproc no_pbl_nudge_t, & no_pbl_nudge_q, & sfcfact, sfcfacr, dpsmx, & - lml_ht1, lml_ht2, & + nudgezfullr1_uv, nudgezrampr1_uv, & + nudgezfullr2_uv, nudgezrampr2_uv, & + nudgezfullr4_uv, nudgezrampr4_uv, & + nudgezfullr1_t, nudgezrampr1_t, & + nudgezfullr2_t, nudgezrampr2_t, & + nudgezfullr4_t, nudgezrampr4_t, & + nudgezfullr1_q, nudgezrampr1_q, & + nudgezfullr2_q, nudgezrampr2_q, & + nudgezfullr4_q, nudgezrampr4_q, & + nudgezfullmin, nudgezrampmin, nudgezmax, & xlat, xlong, & + start_year, start_month, start_day, & + start_hour, start_minute, start_second, & p00, t00, tlp, & znu, p_top, & fdob, ipf_init, & diff --git a/wrfv2_fire/phys/module_ra_cam.F b/wrfv2_fire/phys/module_ra_cam.F index ad082ff9..c2bd81e1 100644 --- a/wrfv2_fire/phys/module_ra_cam.F +++ b/wrfv2_fire/phys/module_ra_cam.F @@ -345,9 +345,6 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) :: pint, lnpint - real(r8), DIMENSION( its:ite , kts:kte+1 ) :: phyd - real(r8), DIMENSION( its:ite , kts:kte ) :: phydmid - real(r8), DIMENSION( its:ite ) :: fp real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q ! real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm ! reference pressures at midpoints ! real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi ! reference pressures at interfaces @@ -551,35 +548,11 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4 enddo -! first guess - do k = kts,kte+1 - do i = its,ite - if(k.eq.kts)then - phyd(i,k)=p8w(i,kts,j) - else - phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j) - endif - enddo - enddo - -! correction factor FP to match p8w(I,kts,J)-p8w(I,kte+1,J) - do i = its,ite - fp(i)=(p8w(I,kts,J)-p8w(I,kte+1,J))/(PHYD(i,KTS)-PHYD(i,KTE+1)) - enddo - -! final pass - do k = kts+1,kte+1 - do i = its,ite - phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j)*fp(i) - phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k)) - enddo - enddo - do k = kts,kte+1 kk = kte - k + kts + 1 do i = its,ite ii = i - its + 1 - pint(ii,kk) = phyd(i,k) + pint(ii,kk) = p8w(i,k,j) if(k.eq.kts)ps(ii)=pint(ii,kk) lnpint(ii,kk) = log(pint(ii,kk)) enddo @@ -613,7 +586,7 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & kk = kte - k + kts do i = its,ite ii = i - its + 1 - pmid(ii,kk) = phydmid(i,k) + pmid(ii,kk) = p_phy(i,k,j) lnpmid(ii,kk) = log(pmid(ii,kk)) lnpint(ii,kk) = log(pint(ii,kk)) pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk) diff --git a/wrfv2_fire/phys/module_ra_gfdleta.F b/wrfv2_fire/phys/module_ra_gfdleta.F index ce416d50..d3112560 100755 --- a/wrfv2_fire/phys/module_ra_gfdleta.F +++ b/wrfv2_fire/phys/module_ra_gfdleta.F @@ -181,9 +181,6 @@ CONTAINS END SUBROUTINE GFDLETAINIT !----------------------------------------------------------------------- ! -!------------------------------------------------------------------ -! urban related variable are added to arguments of etara -!--------------------------------------------------------------------- ! !----------------------------------------------------------------------- SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D & @@ -196,7 +193,6 @@ CONTAINS !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] & ,NSTEPRA,NPHS,ITIMESTEP & & ,XTIME,JULIAN & - & ,COSZ_URB2D,OMG_URB2D & ! urban & ,JULYR,JULDAY,GFDL_LW,GFDL_SW & & ,CFRACL,CFRACM,CFRACH & & ,ACFRST,NCFRST,ACFRCV,NCFRCV & @@ -242,17 +238,12 @@ CONTAINS REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, & & QWFLIP,TFLIP - REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP,PHYD + REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT INTEGER :: IDAT(3),IHOUR,Jmonth,Jday INTEGER :: I,J,K,KFLIP,IHRST -!------------------------------------------------- -! urban related variables are added to declaration -!------------------------------------------------- - REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban - REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban ! begin debugging radiation integer :: imd,jmd real :: FSWrat @@ -269,26 +260,12 @@ CONTAINS ENDDO ENDDO ENDDO -! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) - DO J=JTS,JTE - DO I=ITS,ITE - PHYD(I,KTS,J)=P8W(I,KTS,J) - ENDDO - ENDDO -! - DO J=JTS,JTE - DO K=KTS,KTE - DO I=ITS,ITE - PHYD(I,K+1,J)=PHYD(I,K,J)-G*RHO_PHY(I,K,J)*DZ8W(I,K,J) - ENDDO - ENDDO - ENDDO ! DO K=KMS,KME KFLIP=KME+1-K DO J=JTS,JTE DO I=ITS,ITE - P8WFLIP(I,K,J)=PHYD(I,KFLIP,J) + P8WFLIP(I,K,J)=P8W(I,KFLIP,J) ENDDO ENDDO ENDDO @@ -306,11 +283,10 @@ CONTAINS ! Eta MP now outputs QS instead of QI (JD 2006-05-12) QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.) !Added QS IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J) !Added QI -! PFLIP (I,K,J)=P_PHY(I,KFLIP,J) + PFLIP (I,K,J)=P_PHY(I,KFLIP,J) ! !*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL ! - PFLIP(I,K,J)=0.5*(P8WFLIP(I,K,J)+P8WFLIP(I,K+1,J)) ENDDO ENDDO ENDDO @@ -343,8 +319,6 @@ CONTAINS & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, & & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, & & CFRACL,CFRACM,CFRACH, & -! & COSZ2D,OMG2D, & !urban - & COSZ_URB2D,OMG_URB2D, & !urban & IDS,IDE,JDS,JDE,KDS,KDE, & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE ) @@ -431,7 +405,6 @@ CONTAINS & NRADS,NRADL,NPHS,NTSD, & & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, & & CFRACL,CFRACM,CFRACH, & - & COSZ_URB2D,OMG_URB2D, & !urban & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) @@ -655,12 +628,6 @@ CONTAINS INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1 -!------------------------------------------------- -! urban related variables are added to declaration -!------------------------------------------------- - REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban - REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban - INTEGER :: INDEXS,IXSD DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/ DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./ @@ -729,8 +696,7 @@ CONTAINS & MYIS,MYIE,MYJS,MYJE, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte, & - & OMG_URB2d=OMG_URB2D ) !Optional urban + & its,ite, jts,jte, kts,kte ) !----------------------------------------------------------------------- ! write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS) ADDL=0. @@ -755,8 +721,7 @@ CONTAINS & MYIS,MYIE,MYJS,MYJE, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte, & - & OMG_URB2D) !Optional urban + & its,ite, jts,jte, kts,kte ) ! write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),& ! & II,NRADS,NPHS,NTSD,DT DO J=MYJS,MYJE @@ -775,14 +740,6 @@ CONTAINS ENDDO ENDIF -!-------------------------------------------- -! COSZ2D is calculated for urban -!-------------------------------------------- - DO J=MYJS,MYJE !urban - DO I=MYIS,MYIE !urban - if(present(COSZ_URB2D)) COSZ_URB2D(I,J)=CZEN(I,J) !urban - ENDDO !urban - ENDDO !urban ! ! !*** Do not modify pressure for ozone concentrations below the top layer @@ -1596,8 +1553,7 @@ CONTAINS MYIS,MYIE,MYJS,MYJE, & IDS,IDE, JDS,JDE, KDS,KDE, & IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE, & - OMG_URB2D) !Optional urban + ITS,ITE, JTS,JTE, KTS,KTE ) !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- @@ -1613,7 +1569,6 @@ CONTAINS INTEGER, INTENT(IN), DIMENSION(3) :: IDAT REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN - REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !Optional urban REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, & GSTC3=9.3104E-2,GSTC4=-6.2E-6, & @@ -1724,7 +1679,6 @@ CONTAINS COS(GLAT(I,J)) IF(SINALT.LT.0.)SINALT=0. CZEN(I,J)=SINALT - if(present(OMG_URB2D))OMG_URB2D(I,J)=HRLCL !urban 100 CONTINUE !*** !*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME, diff --git a/wrfv2_fire/phys/module_ra_gsfcsw.F b/wrfv2_fire/phys/module_ra_gsfcsw.F index a7faceff..aab73cbf 100644 --- a/wrfv2_fire/phys/module_ra_gsfcsw.F +++ b/wrfv2_fire/phys/module_ra_gsfcsw.F @@ -12,9 +12,6 @@ MODULE module_ra_gsfcsw CONTAINS -!------------------------------------------------------------------ -! urban related variable are added to arguments of gsfcswrad -!------------------------------------------------------------------ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & ,dz8w,rho_phy & ,alb,t3d,qv3d,qc3d,qr3d & @@ -29,8 +26,7 @@ CONTAINS ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop & ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,cosz_urb2d,omg_urb2d ) !Optional urban + ,its,ite, jts,jte, kts,kte ) !------------------------------------------------------------------ IMPLICIT NONE !------------------------------------------------------------------ @@ -142,8 +138,6 @@ CONTAINS P2D, & T2D, & fcld2D - real, DIMENSION( its:ite , kts:kte+1 ) :: phyd - real, DIMENSION( its:ite , kts:kte ) :: phydmid REAL, DIMENSION( np, 5 ) :: pres, & ozone @@ -171,10 +165,6 @@ CONTAINS REAL :: fac,latrmp REAL :: xt24,tloctm,hrang,xxlat -!URBAN - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: COSZ_URB2D !urban - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: OMG_URB2D !urban - real, dimension(11) :: midbands ! jcb data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/ ! jcb real :: ang,slope ! jcb @@ -468,31 +458,12 @@ CONTAINS p(k)=pres(k,iprof) ENDDO - do k = kts,kte+1 - do i = its,ite - if(k.eq.kts)then - phyd(i,k)=p8w3d(i,kts,j) - else - phyd(i,k)=phyd(i,k-1) - g*rho_phy(i,k-1,j)*dz8w(i,k-1,j) - phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k)) - endif - enddo - enddo -! normalize full pressure range - do k = kts+1,kte+1 - do i = its,ite - if(k.eq.kts+1)fp(i) = (p8w3d(i,kts,j)-p8w3d(i,kte+1,j))/(phyd(i,kts)-phyd(i,kte+1)) - phyd(i,k)=phyd(i,k-1) - g*rho_phy(i,k-1,j)*dz8w(i,k-1,j)*fp(i) - phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k)) - enddo - enddo - ! reverse vars ! DO K=kts,kte+1 DO I=its,ite NK=kme-K+kms - P8W2D(I,K)=phyd(I,NK)*0.01 ! P8w2D is in mb + P8W2D(I,K)=p8w3d(i,nk,j)*0.01 ! P8w2D is in mb ENDDO ENDDO @@ -512,7 +483,7 @@ CONTAINS cwc(I,K,2)=QC3D(I,NK,J) cwc(I,K,2)=max(0.,cwc(I,K,2)) - P2D(I,K)=phydmid(I,NK)*0.01 ! P2D is in mb + P2D(I,K)=p3d(i,nk,j)*0.01 ! P2D is in mb fcld2D(I,K)=CLDFRA3D(I,NK,J) ENDDO ENDDO @@ -753,9 +724,6 @@ CONTAINS xxlat = XLAT(i,j) * degrad cosz(i) = sin(xxlat) * sin(declin) + & cos(xxlat) * cos(declin) * cos(hrang) -!urban - if(present(COSZ_URB2D)) COSZ_URB2D(i,j)=cosz(i) !urban - if(present(OMG_URB2D)) OMG_URB2D(i,j)=hrang !urban rsuvbm(i) = ALB(i,j) rsuvdf(i) = ALB(i,j) rsirbm(i) = ALB(i,j) diff --git a/wrfv2_fire/phys/module_ra_rrtm.F b/wrfv2_fire/phys/module_ra_rrtm.F index 02c711e5..21d52856 100644 --- a/wrfv2_fire/phys/module_ra_rrtm.F +++ b/wrfv2_fire/phys/module_ra_rrtm.F @@ -1789,14 +1789,12 @@ CONTAINS ! LOCAL VARS REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & - Tw1D, & - PHYD + Tw1D REAL, DIMENSION( kts:kte ) :: TTEN1D, & CLDFRA1D, & DZ1D, & P1D, & - PHYDMID, & T1D, & QV1D, & QC1D, & @@ -1805,7 +1803,7 @@ CONTAINS QS1D, & QG1D ! - REAL :: TSFC,GLW0,OLR0,EMISS0,FP + REAL :: TSFC,GLW0,OLR0,EMISS0 ! INTEGER:: i,j,K,NK LOGICAL :: predicate @@ -1820,25 +1818,9 @@ CONTAINS ! reverse vars ! p1D pw1D are in mb -! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) -! PHYD REPLACES P8W, PHYDMID REPLACES P3D - PHYD(kts) = p8w(I,kts,J) -! first guess - DO K = KTS,KTE - PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J) - ENDDO -! correction factor FP to match p8w(I,kts,J)-p8w(I,kte,J) - FP = (p8w(I,kts,J)-p8w(I,kte,J))/(PHYD(KTS)-PHYD(KTE)) -! final pass - DO K = KTS,KTE - PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J)*FP - PHYDMID(K)= 0.5*(PHYD(K)+PHYD(K+1)) - ENDDO - do k=kts,kte+1 NK=kme-k+kms -! Pw1D(K) = p8w(I,NK,J)/100. - Pw1D(K) = PHYD(NK)/100. + Pw1D(K) = p8w(I,NK,J)/100. Tw1D(K) = t8w(I,NK,J) enddo @@ -1861,8 +1843,7 @@ CONTAINS NK=kme-1-K+kms TTEN1D(K)=0. T1D(K)=T3D(I,NK,J) -! P1D(K)=P3D(I,NK,J)/100. - P1D(K)=PHYDMID(NK)/100. + P1D(K)=P3D(I,NK,J)/100. DZ1D(K)=dz8w(I,NK,J) ENDDO @@ -6563,7 +6544,7 @@ CONTAINS ! ************************************************************************** USE module_wrf_error -USE module_dm +!USE module_dm, ONLY : wrf_dm_bcast_bytes IMPLICIT NONE ! RRTM Longwave Radiative Transfer Model diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lw.F b/wrfv2_fire/phys/module_ra_rrtmg_lw.F index e457bd0d..48d6474b 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_lw.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_lw.F @@ -11421,7 +11421,7 @@ MODULE module_ra_rrtmg_lw use module_model_constants, only : cp use module_wrf_error -use module_dm +!use module_dm use parrrtm, only : nbndlw, ngptlw use rrtmg_lw_init, only: rrtmg_lw_ini @@ -11547,14 +11547,12 @@ CONTAINS ! LOCAL VARS REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & - Tw1D, & - PHYD + Tw1D REAL, DIMENSION( kts:kte ) :: TTEN1D, & CLDFRA1D, & DZ1D, & P1D, & - PHYDMID, & T1D, & QV1D, & QC1D, & @@ -11688,7 +11686,6 @@ CONTAINS ! ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP - REAL :: FP real, dimension (1) :: landfrac, landm, snowh, icefrac @@ -11711,24 +11708,8 @@ CONTAINS ! longitude loop i_loop: do i = its,ite -! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) -! PHYD REPLACES P8W, PHYDMID REPLACES P3D - PHYD(kts) = p8w(I,kts,J) -! first guess - DO K = KTS,KTE - PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J) - ENDDO -! correction factor FP to match p8w(I,kts,J)-p8w(I,kte,J) - FP = (p8w(I,kts,J)-p8w(I,kte,J))/(PHYD(KTS)-PHYD(KTE)) -! final pass - DO K = KTS,KTE - PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J)*FP - PHYDMID(K)= 0.5*(PHYD(K)+PHYD(K+1)) - ENDDO - do k=kts,kte+1 -! Pw1D(K) = p8w(I,K,J)/100. - Pw1D(K) = PHYD(K)/100. + Pw1D(K) = p8w(I,K,J)/100. Tw1D(K) = t8w(I,K,J) enddo @@ -11749,8 +11730,7 @@ CONTAINS DO K=kts,kte TTEN1D(K)=0. T1D(K)=T3D(I,K,J) -! P1D(K)=P3D(I,K,J)/100. - P1D(K)=PHYDMID(K)/100. + P1D(K)=P3D(I,K,J)/100. DZ1D(K)=dz8w(I,K,J) ENDDO diff --git a/wrfv2_fire/phys/module_ra_rrtmg_sw.F b/wrfv2_fire/phys/module_ra_rrtmg_sw.F index d05b130a..283e097c 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_sw.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_sw.F @@ -9547,7 +9547,7 @@ MODULE module_ra_rrtmg_sw use module_model_constants, only : cp USE module_wrf_error -USE module_dm +!USE module_dm use parrrsw, only : nbndsw, ngptsw, naerec use rrtmg_sw_init, only: rrtmg_sw_ini @@ -9664,14 +9664,12 @@ CONTAINS ! LOCAL VARS REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & - Tw1D, & - PHYD + Tw1D REAL, DIMENSION( kts:kte ) :: TTEN1D, & CLDFRA1D, & DZ1D, & P1D, & - PHYDMID, & T1D, & QV1D, & QC1D, & @@ -9848,28 +9846,11 @@ CONTAINS ! Set flag to prevent shortwave calculation when sun below horizon if (coszrs.le.0.0) dorrsw = .false. - ! Perform shortwave calculation if sun above horizon if (dorrsw) then -! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) -! PHYD REPLACES P8W, PHYDMID REPLACES P3D - PHYD(kts) = p8w(I,kts,J) -! first guess - DO K = KTS,KTE - PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J) - ENDDO -! correction factor FP to match p8w(I,kts,J)-p8w(I,kte,J) - FP = (p8w(I,kts,J)-p8w(I,kte,J))/(PHYD(KTS)-PHYD(KTE)) -! final pass - DO K = KTS,KTE - PHYD(K+1) = PHYD(K) - G*RHO3D(I,K,J)*DZ8W(I,K,J)*FP - PHYDMID(K)= 0.5*(PHYD(K)+PHYD(K+1)) - ENDDO - do k=kts,kte+1 -! Pw1D(K) = p8w(I,K,J)/100. - Pw1D(K) = PHYD(K)/100. + Pw1D(K) = p8w(I,K,J)/100. Tw1D(K) = t8w(I,K,J) enddo @@ -9890,8 +9871,7 @@ CONTAINS DO K=kts,kte TTEN1D(K)=0. T1D(K)=t3d(I,K,J) -! P1D(K)=p3d(I,K,J)/100. - P1D(K)=PHYDMID(K)/100. + P1D(K)=p3d(I,K,J)/100. DZ1D(K)=dz8w(I,K,J) ENDDO diff --git a/wrfv2_fire/phys/module_ra_sw.F b/wrfv2_fire/phys/module_ra_sw.F index c0793648..48eded90 100644 --- a/wrfv2_fire/phys/module_ra_sw.F +++ b/wrfv2_fire/phys/module_ra_sw.F @@ -17,10 +17,7 @@ CONTAINS RADFRQ,ICLOUD,DEGRAD,warm_rain, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - slope_rad,topo_shading,ht, & ! Optional - dx,dy,sina,cosa,shadowmask, & ! Optional - cosz_urb2d,omg_urb2d & !Optional urban + its,ite, jts,jte, kts,kte & ) !------------------------------------------------------------------ IMPLICIT NONE @@ -67,10 +64,6 @@ CONTAINS ! ! Optional ! - REAL, OPTIONAL, INTENT(IN) :: dx,dy - - REAL, DIMENSION( ims:ime, jms:jme ), & - OPTIONAL, INTENT(IN) :: sina,cosa,ht REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & INTENT(IN ) :: & @@ -81,13 +74,8 @@ CONTAINS QS3D, & QG3D - INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading - - INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask - LOGICAL, OPTIONAL, INTENT(IN ) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D, OMG_URB2D !Optional urban ! LOCAL VARS REAL, DIMENSION( kts:kte ) :: & @@ -105,19 +93,13 @@ CONTAINS ! REAL:: XLAT0,XLONG0,ALB0,GSW0 - REAL :: COSZ, OMG !urban ! INTEGER :: i,j,K,NK LOGICAL :: predicate , do_topo_shading real :: aer_dry1(kts:kte),aer_water1(kts:kte) - real :: sinalpha,cosalpha,hx,hy,slope,slp_azi,pi - integer :: shadow - !------------------------------------------------------------------ -pi = 4.*atan(1.) - j_loop: DO J=jts,jte i_loop: DO I=its,ite @@ -233,81 +215,13 @@ pi = 4.*atan(1.) XLAT0=XLAT(I,J) XLONG0=XLONG(I,J) ALB0=ALBEDO(I,J) - - IF (PRESENT(topo_shading)) THEN - IF (topo_shading.eq.1) THEN - do_topo_shading = .TRUE. - ELSE - do_topo_shading = .FALSE. - END IF - ELSE - do_topo_shading = .FALSE. - END IF - - shadow = 0 - IF (do_topo_shading) THEN - IF(PRESENT(slope_rad) .AND. PRESENT(shadowmask))THEN -! Computations for slope-dependent radiation - - sinalpha = sina(i,j) - cosalpha = cosa(i,j) - -! Compute slope and slope azimuth of local grid point - - if ((i.ge.ids+1).and.(i.le.ide-2)) then - hx = (ht(i+1,j)-ht(i-1,j))/(2.*dx) - else if (i.eq.ids) then - hx = (ht(i+1,j)-ht(i,j))/dx - else if (i.eq.ide-1) then - hx = (ht(i,j)-ht(i-1,j))/dx - endif - if ((j.ge.jds+1).and.(j.le.jde-2)) then - hy = (ht(i,j+1)-ht(i,j-1))/(2.*dy) - else if (j.eq.jds) then - hy = (ht(i,j+1)-ht(i,j))/dy - else if (j.eq.jde-1) then - hy = (ht(i,j)-ht(i,j-1))/dy - endif - - slope = atan((hx**2+hy**2)**.5) - if (slope.lt.1.e-4) then - slope = 0. - slp_azi = 0. - else - slp_azi = atan2(hx,hy)+pi -! Rotate slope azimuth to lat-lon grid - if (cosalpha.ge.0) then - slp_azi = slp_azi - asin(sinalpha) - else - slp_azi = slp_azi - (pi - asin(sinalpha)) - endif - endif - - shadow = shadowmask(i,j) - ENDIF - +! slope code removed - factor now done in surface driver CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, & T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, & XTIME,GMT,RHO01D,DZ, & R,CP,G,DECLIN,SOLCON, & - COSZ, OMG, & !urban - RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & - kts,kte,slope_rad,shadow,slp_azi,slope ) - ELSE - CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0, & - T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D, & - XTIME,GMT,RHO01D,DZ, & - R,CP,G,DECLIN,SOLCON, & - COSZ, OMG, & !urban RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & kts,kte ) - ENDIF - - IF (PRESENT(COSZ_URB2D) .AND. PRESENT(OMG_URB2D)) THEN - COSZ_URB2D(I,J)=COSZ !urban - OMG_URB2D(I,J)=OMG !urban - ENDIF - GSW(I,J)=GSW0 DO K=kts,kte NK=kme-1-K+kms @@ -324,7 +238,6 @@ pi = 4.*atan(1.) T,QV,QC,QR,QI,QS,QG,P, & XTIME, GMT, RHO0, DZ, & R,CP,G,DECLIN,SOLCON, & - COSZ, OMG, & !urban RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, & kts,kte,slope_rad,shadow,slp_azi,slope ) !------------------------------------------------------------------ @@ -380,9 +293,6 @@ pi = 4.*atan(1.) REAL, DIMENSION( 4 ) :: XMUVAL - REAL, INTENT(OUT) :: COSZ !urban - REAL, INTENT(OUT) :: OMG !urban - REAL :: beta !------------------------------------------------------------------ @@ -423,9 +333,6 @@ pi = 4.*atan(1.) XXLAT=XLAT*DEGRAD CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG) - COSZ = CSZA !urban - OMG = HRANG !urban - ! RETURN IF NIGHT IF(CSZA.LE.1.E-9)GOTO 7 ! diff --git a/wrfv2_fire/phys/module_radiation_driver.F b/wrfv2_fire/phys/module_radiation_driver.F index 4f9285ba..20d67fa8 100644 --- a/wrfv2_fire/phys/module_radiation_driver.F +++ b/wrfv2_fire/phys/module_radiation_driver.F @@ -24,7 +24,7 @@ CONTAINS ,EMISS, rho, p8w, p , pi , dz8w ,t, t8w, GMT & ,XLAND, XICE, TSK, HTOP,HBOT,HTOPR,HBOTR, CUPPT, VEGFRA, SNOW & ,julyr, JULDAY, julian, YR, xtime, RADT, STEPRA, ICLOUD, warm_rain & - ,declin_urb,COSZ_URB2D, omg_urb2d & !Optional urban + ,declinx,solconx,COSZEN, HRANG & !Optional ,ra_call_offset,RSWTOA,RLWTOA, CZMEAN & ,CFRACL, CFRACM, CFRACH & ,ACFRST,NCFRST,ACFRCV,NCFRCV,SWDOWNC & @@ -51,29 +51,41 @@ CONTAINS ,waer300, waer400, waer600, waer999 & ! jcb ,qc_adjust ,qi_adjust & ! jm ,cu_rad_feedback, aer_ra_feedback & ! jm - ,ht,dx,dy,sina,cosa,shadowmask,slope_rad ,topo_shading ) ! slope-dependent radiation + ,ht,dx,dy,shadowmask,slope_rad ,topo_shading ) ! slope-dependent radiation !------------------------------------------------------------------------- ! !USES: +#ifdef HWRF + USE module_state_description, ONLY : RRTMSCHEME, GFDLLWSCHEME & + ,RRTMG_LWSCHEME, RRTMG_SWSCHEME & + ,SWRADSCHEME, GSFCSWSCHEME & + ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME & + ,HELDSUAREZ, HWRFSWSCHEME, HWRFLWSCHEME +#else USE module_state_description, ONLY : RRTMSCHEME, GFDLLWSCHEME & ,RRTMG_LWSCHEME, RRTMG_SWSCHEME & ,SWRADSCHEME, GSFCSWSCHEME & ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME & ,HELDSUAREZ +#endif USE module_model_constants USE module_wrf_error , ONLY : wrf_err_message ! *** add new modules of schemes here - USE module_ra_sw , ONLY : swrad - USE module_ra_gsfcsw , ONLY : gsfcswrad - USE module_ra_rrtm , ONLY : rrtmlwrad - USE module_ra_rrtmg_lw , ONLY : rrtmg_lwrad - USE module_ra_rrtmg_sw , ONLY : rrtmg_swrad - USE module_ra_cam , ONLY : camrad - USE module_ra_gfdleta , ONLY : etara - USE module_ra_hs , ONLY : hsrad + USE module_ra_sw , ONLY : swrad + USE module_ra_gsfcsw , ONLY : gsfcswrad + USE module_ra_rrtm , ONLY : rrtmlwrad + USE module_ra_rrtmg_lw , ONLY : rrtmg_lwrad + USE module_ra_rrtmg_sw , ONLY : rrtmg_swrad + USE module_ra_cam , ONLY : camrad + USE module_ra_gfdleta , ONLY : etara +#ifdef HWRF + USE module_ra_hwrf +#endif + USE module_ra_hs , ONLY : hsrad + ! This driver calls subroutines for the radiation parameterizations. ! @@ -429,7 +441,7 @@ CONTAINS REAL, OPTIONAL, INTENT(IN) :: dx,dy INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: sina,cosa,ht + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: ht INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask @@ -439,7 +451,7 @@ CONTAINS REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: CEMISS REAL, DIMENSION( ims:ime, jms:jme ) :: coszr - REAL :: DECLIN,SOLCON + REAL :: DECLIN,SOLCON,XXLAT,TLOCTM,XT24 INTEGER :: i,j,k,its,ite,jts,jte,ij INTEGER :: STEPABS LOGICAL :: gfdl_lw,gfdl_sw @@ -454,11 +466,11 @@ CONTAINS REAL :: next_rad_time LOGICAL :: run_param !------------------------------------------------------------------ -! urban related variables are added to declaration +! solar related variables are added to declaration !------------------------------------------------- - REAL, OPTIONAL, INTENT(OUT) :: DECLIN_URB !urban - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZ_URB2D !urban - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: omg_urb2d !urban + REAL, OPTIONAL, INTENT(OUT) :: DECLINX,SOLCONX + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZEN + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: HRANG !------------------------------------------------------------------ if (lw_physics .eq. 0 .and. sw_physics .eq. 0) return @@ -633,8 +645,24 @@ CONTAINS CALL radconst(XTIME,DECLIN,SOLCON,JULIAN, & DEGRAD,DPD ) + IF(PRESENT(declinx).AND.PRESENT(solconx))THEN +! saved to state arrays used in surface driver + declinx=declin + solconx=solcon + ENDIF - if(present(DECLIN_URB))DECLIN_URB=DECLIN ! urban + IF(PRESENT(coszen).AND.PRESENT(hrang))THEN +! state arrays of hrang and coszen used in surface driver + XT24=MOD(XTIME+RADT*0.5,1440.) + DO j=jts,jte + DO i=its,ite + TLOCTM=GMT+XT24/60.+XLONG(I,J)/15. + HRANG(I,J)=15.*(TLOCTM-12.)*DEGRAD + XXLAT=XLAT(I,J)*DEGRAD + COSZEN(I,J)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG(I,J)) + ENDDO + ENDDO + ENDIF lwrad_cldfra_select: SELECT CASE(lw_physics) @@ -730,7 +758,6 @@ CONTAINS ,VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt & ,NSTEPRA=stepra,NPHS=nphs,ITIMESTEP=itimestep & ,XTIME=xtime,JULIAN=julian & - ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & ,JULYR=julyr,JULDAY=julday & ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw & ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach & @@ -750,6 +777,31 @@ CONTAINS CALL wrf_error_fatal('Can not call ETARA (1b). Missing moisture fields.') ENDIF +#ifdef HWRF + CASE (HWRFLWSCHEME) + + CALL wrf_debug (100, 'CALL hwrflw') + + gfdl_lw = .true. + + CALL HWRFRA(DT=dt,thraten=RTHRATEN,thratenlw=RTHRATENLW,thratensw=RTHRATENSW,pi3d=pi, & + XLAND=xland,P8w=p8w,DZ8w=dz8w,RHO_PHY=rho,P_PHY=p,T=t, & + QV=qv,QW=qc_temp,QI=Qi, & + TSK2D=tsk,GLW=GLW,GSW=GSW, & + TOTSWDN=swdown,TOTLWDN=glw,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean, & !Added + GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot,htopr=htopr,hbotr=hbotr,ALBEDO=albedo,CUPPT=cuppt,& + VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt, & !Modified + NSTEPRA=stepra,NPHS=nphs,itimestep=itimestep, & !Modified + julyr=julyr,julday=julday,gfdl_lw=gfdl_lw,gfdl_sw=gfdl_sw, & + CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach, & !Added + ACFRST=acfrst,NCFRST=ncfrst,ACFRCV=acfrcv,NCFRCV=ncfrcv, & !Added + ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde, & + ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme, & + its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) + + +#endif + CASE (CAMLWSCHEME) CALL wrf_debug(100, 'CALL camrad lw') @@ -911,13 +963,11 @@ CONTAINS ,P3D=p,PI3D=pi,DZ8W=dz8w,GMT=gmt & ,R=r_d,CP=cp,G=g,JULDAY=julday & ,XTIME=xtime,DECLIN=declin,SOLCON=solcon & -! ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban ,RADFRQ=radt,ICLOUD=icloud,DEGRAD=degrad & ,warm_rain=warm_rain & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban ,QV3D=qv & ,QC3D=qc & ,QR3D=qr & @@ -925,10 +975,7 @@ CONTAINS ,QS3D=qs & ,QG3D=qg & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & - ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & - ,slope_rad=slope_rad,topo_shading=topo_shading & - ,shadowmask=shadowmask & - ,ht=ht,dx=dx,dy=dy,sina=sina,cosa=cosa ) + ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg ) CASE (GSFCSWSCHEME) CALL wrf_debug(100, 'CALL gsfcswrad') @@ -938,7 +985,6 @@ CONTAINS ,DZ8W=dz8w,RHO_PHY=rho & ,CLDFRA3D=cldfra,RSWTOA=rswtoa & ,GMT=gmt,CP=cp,G=g & -! ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban ,JULDAY=julday,XTIME=xtime & ,DECLIN=declin,SOLCON=solcon & ,RADFRQ=radt,DEGRAD=degrad & @@ -956,7 +1002,6 @@ CONTAINS ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & !urban ,QV3D=qv & ,QC3D=qc & ,QR3D=qr & @@ -1088,7 +1133,6 @@ CONTAINS ,VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt & ,NSTEPRA=stepra,NPHS=nphs,ITIMESTEP=itimestep & ,XTIME=xtime,JULIAN=julian & - ,COSZ_URB2D=COSZ_URB2D ,OMG_URB2D=omg_urb2d & ,JULYR=julyr,JULDAY=julday & ,GFDL_LW=gfdl_lw,GFDL_SW=gfdl_sw & ,CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach & @@ -1108,6 +1152,28 @@ CONTAINS CALL wrf_error_fatal('Can not call ETARA (2b). Missing moisture fields.') ENDIF +#ifdef HWRF + CASE (HWRFSWSCHEME) + + CALL wrf_debug (100, 'CALL hwrfsw') + + gfdl_sw = .true. + CALL HWRFRA(DT=dt,thraten=RTHRATEN,thratenlw=RTHRATENLW,thratensw=RTHRATENSW,pi3d=pi, & + XLAND=xland,P8w=p8w,DZ8w=dz8w,RHO_PHY=rho,P_PHY=p,T=t, & + QV=qv,QW=qc_temp,QI=Qi, & + TSK2D=tsk,GLW=GLW,GSW=GSW, & + TOTSWDN=swdown,TOTLWDN=glw,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean, & !Added + GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot,htopr=htopr,hbotr=hbotr,ALBEDO=albedo,CUPPT=cuppt, & + VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt, & !Modified + NSTEPRA=stepra,NPHS=nphs,itimestep=itimestep, & !Modified + julyr=julyr,julday=julday,gfdl_lw=gfdl_lw,gfdl_sw=gfdl_sw, & + CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach, & !Added + ACFRST=acfrst,NCFRST=ncfrst,ACFRCV=acfrcv,NCFRCV=ncfrcv, & !Added + ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde, & + ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme, & + its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) +#endif + CASE (0) ! Here in case we don't want to call a sw radiation scheme @@ -1250,8 +1316,13 @@ CONTAINS ,kts, kte & ,num_tiles ) - USE module_domain - USE module_dm + USE module_domain , ONLY : domain +#ifdef DM_PARALLEL + USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks,wrf_dm_minval_integer +# if (EM_CORE == 1) + USE module_comm_dm , ONLY : halo_toposhad_sub +# endif +#endif USE module_bc USE module_model_constants diff --git a/wrfv2_fire/phys/module_sf_bep.F b/wrfv2_fire/phys/module_sf_bep.F index 20d309e1..dc7e30bb 100644 --- a/wrfv2_fire/phys/module_sf_bep.F +++ b/wrfv2_fire/phys/module_sf_bep.F @@ -307,7 +307,7 @@ MODULE module_sf_bep ! Initialisation of the urban parameters and calculation of the view factors call icBEP(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & + fww,fwg,fgw,fsw,fws,fsg, & z0g_u,z0r_u, & nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & nz_u,z_u, & @@ -482,14 +482,14 @@ MODULE module_sf_bep ! ===6=8===============================================================72 - subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & + subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & zr,deltar,ah,rs,rld, & alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & + fww,fwg,fgw,fsw,fws,fsg, & z0g_u,z0r_u, & nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & + nz_u,z_u, & tw,tg,tr,sfw,sfg,sfr, & a_u,a_v,a_t,a_e, & b_u,b_v,b_t,b_e, & @@ -761,10 +761,10 @@ MODULE module_sf_bep rs,rld,rsw,rsg,rlw,rlg) ! calculation of the urban albedo and the upward long wave radiation - call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, & + call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, & tg,emg_u(iurb),albg_u(iurb),rlg,rsg,sfg, & tw,emw_u(iurb),albw_u(iurb),rlw,rsw,sfw, & - tr,emr_u(iurb),albr_u(iurb),rld,rs,sfr, & + tr,emr_u(iurb),albr_u(iurb),rld,rs,sfr, & rs_abs,rl_up,emiss,grdflx_urb) ! Compute the surface temperatures @@ -807,7 +807,7 @@ MODULE module_sf_bep ! calculation of the urban albedo and the upward long wave radiation -! call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, & +! call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, & ! tg,emg_u(iurb),albg_u(iurb),rlg,rsg, & ! tw,emw_u(iurb),albw_u(iurb),rlw,rsw, & ! tr,emr_u(iurb),albr_u(iurb),rld,rs, & @@ -839,7 +839,7 @@ MODULE module_sf_bep ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine param(iurb,nz,nd, & + subroutine param(iurb,nz,nd, & csg_u,csg,alag_u,alag,csr_u,csr, & alar_u,alar,csw_u,csw,alaw_u,alaw, & ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, & @@ -898,6 +898,22 @@ MODULE module_sf_bep ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- +! +!Initialize the variables +! + ss=0. + pb=0. + csg=0. + alag=0. + csr=0. + alar=0. + csw=0. + alaw=0. + z0=0. + ws=0. + bs=0. + strd=0. + drst=0. do iz=1,nz+1 ss(iz)=ss_u(iz,iurb) @@ -960,13 +976,14 @@ MODULE module_sf_bep real c(kms:kme) ! Parameter which has to be interpolated ! Data relative to the "urban grid" integer nz_u ! Number of levels - real z_u(nz_u+1) ! Altitude of the cell interface - +!! real z_u(nz_u+1) ! Altitude of the cell interface + real z_u(nz_um) ! Altitude of the cell interface ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- - real c_u(nz_u) ! Interpolated paramters in the "urban grid" - +!! real c_u(nz_u) ! Interpolated paramters in the "urban grid" + real c_u(nz_um) ! Interpolated paramters in the "urban grid" + ! LOCAL: ! ---------------------------------------------------------------------- integer iz_u,iz @@ -1050,7 +1067,7 @@ MODULE module_sf_bep ! Calculation of the shadow effects - call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,z, & + call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & rs,rsw,rsg) ! Calculation of the reflection effects @@ -1632,7 +1649,7 @@ MODULE module_sf_bep ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,z, & + subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & rs,rsw,rsg) ! ---------------------------------------------------------------------- @@ -1652,6 +1669,7 @@ MODULE module_sf_bep real drst(ndm) ! street directions for the current urban class real rs ! solar radiation real ss(nz_um) ! probability to have a building with height h + real pb(nz_um) ! Probability that a building has an height greater or equal to h real ws(ndm) ! Street width of the current urban class real z(nz_um) ! Height of the urban grid levels real zr ! zenith angle @@ -1710,21 +1728,23 @@ MODULE module_sf_bep do iz=1,nz_u rsw(2*id-1,iz)=0. rsw(2*id,iz)=0. - + if(pb(iz+1).gt.0.)then do jz=1,nz_u if(abs(sin(aae)).gt.1.e-10)then call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, & ws(id),rd) - rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1) + rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1) + endif if(abs(sin(aaw)).gt.1.e-10)then call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, & ws(id),rd) - rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1) + rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1) + endif enddo - + endif enddo if(abs(sin(aae)).gt.1.e-10)then wsd=abs(ws(id)/sin(aae)) @@ -1875,7 +1895,8 @@ MODULE module_sf_bep aaa(i,j)=-(1.-emw)*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1) enddo - aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)*pb(i+1) +!! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)*pb(i+1) + aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb) bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4 do j=1,nz_u @@ -1900,7 +1921,8 @@ MODULE module_sf_bep aaa(i,i)=1. - aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)*pb(i-nz_u+1) +!! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)*pb(i-nz_u+1) + aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb) bbb(i)=fsw(i-nz_u,id,iurb)*rl+ & emg*fgw(i-nz_u,id,iurb)*sigma*tg(id,ng_u)**4 @@ -2525,7 +2547,7 @@ MODULE module_sf_bep subroutine icBEP (alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & + fww,fwg,fgw,fsw,fws,fsg, & z0g_u,z0r_u, & nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & nz_u,z_u, & @@ -2605,8 +2627,20 @@ MODULE module_sf_bep ! ----------------------------------------------------------------------- ! This routine initialise the urban paramters for the BEP module !------------------------------------------------------------------------ - - +! +!Initialize variables +! + nz_u=0 + z_u=0. + ss_u=0. + pb_u=0. + fww=0. + fwg=0. + fgw=0. + fsw=0. + fws=0. + fsg=0. + ! Computation of the urban levels height z_u(1)=0. @@ -2944,6 +2978,13 @@ MODULE module_sf_bep integer i,iu integer nurb ! number of urban classes used +! +!Initialize some variables +! + + h_b=0. + d_b=0. + nurb=ICATE do iu=1,nurb nd_u(iu)=0 diff --git a/wrfv2_fire/phys/module_sf_myjsfc.F b/wrfv2_fire/phys/module_sf_myjsfc.F index 8b8d96d3..ff445589 100755 --- a/wrfv2_fire/phys/module_sf_myjsfc.F +++ b/wrfv2_fire/phys/module_sf_myjsfc.F @@ -30,8 +30,7 @@ REAL,PARAMETER :: EPSU2=1.E-6,EPSUST=1.e-9,EPSZT=1.E-28 REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC - REAL,PARAMETER :: BETA=1./273.,CZIL=0.1,EXCML=0.0001,EXCMS=0.0001 & -!old REAL,PARAMETER :: BETA=1./273.,CZIL=0.1,EXCML=0.001,EXCMS=0.001 & + REAL,PARAMETER :: BETA=1./273.,EXCML=0.0001,EXCMS=0.0001 & & ,GLKBR=10.,GLKBS=30.,PI=3.1415926 & & ,QVISC=2.1E-5,RIC=0.505,SMALL=0.35 & & ,SQPR=0.84,SQSC=0.84,SQVISC=258.2,TVISC=2.1E-5 & @@ -50,8 +49,7 @@ & ,PIHF=0.5*PI & & ,RQVISC=1./QVISC & & ,USTFC=0.018/G & - & ,WWST2=WWST*WWST & - & ,ZILFC=-CZIL*VKARMAN*SQVISC + & ,WWST2=WWST*WWST ! !---------------------------------------------------------------------- INTEGER, PARAMETER :: KZTM=10001,KZTM2=KZTM-2 @@ -68,7 +66,7 @@ CONTAINS SUBROUTINE MYJSFC(ITIMESTEP,HT,DZ & & ,PMID,PINT,TH,T,QV,QC,U,V,Q2 & & ,TSK,QSFC,THZ0,QZ0,UZ0,VZ0 & - & ,LOWLYR,XLAND & + & ,LOWLYR,XLAND,IVGTYP,ISURBAN,IZ0TLND & & ,USTAR,ZNT,Z0BASE,PBLH,MAVAIL,RMOL & & ,AKHS,AKMS & & ,RIB & @@ -100,6 +98,9 @@ CONTAINS & ,Q2,QC,QV & & ,T,TH & & ,U,V + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IVGTYP + INTEGER, INTENT(IN) :: ISURBAN + INTEGER, INTENT(IN) :: IZ0TLND ! REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: FLX_LH,HFX,PSHLTR & & ,QFX,Q10,QSHLTR & @@ -306,6 +307,7 @@ CONTAINS & ,UZ0(I,J),VZ0(I,J),TZ0,TSK(I,J),THZ0(I,J),QZ0(I,J) & & ,USTAR(I,J),ZNT(I,J),Z0BASE(I,J),CT(I,J),RMOL(I,J) & & ,AKMS(I,J),AKHS(I,J),RIB(I,J),PBLH(I,J),MAVAIL(I,J) & + & ,IVGTYP(I,J),ISURBAN,IZ0TLND & & ,CHS(I,J),CHS2(I,J),CQS2(I,J) & & ,HFX(I,J),QFX(I,J),FLX_LH(I,J) & & ,FLHC(I,J),FLQC(I,J),QGH(I,J),CPM(I,J) & @@ -357,6 +359,7 @@ CONTAINS SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & & ,UZ0,VZ0,TZ0,TSK,THZ0,QZ0 & & ,USTAR,Z0,Z0BASE,CT,RLMO,AKMS,AKHS,RIB,PBLH,WETM & + & ,VEGTYP,ISURBAN,IZ0TLND & & ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC,QGH,CPM & & ,ULOW,VLOW,TLOW,THLOW,THELOW,QLOW,CWMLOW & & ,ZSL,PLOW & @@ -383,6 +386,7 @@ CONTAINS REAL,INTENT(IN) :: CWMLOW,PBLH,PLOW,QLOW,PSFC,SEAMASK,ZSFC & & ,THELOW,THLOW,THS,TSK,TLOW,TZ0,ULOW,VLOW,WETM,ZSL & & ,Z0BASE + INTEGER, INTENT(IN) :: VEGTYP, ISURBAN, IZ0TLND ! REAL,INTENT(OUT) :: CHS,CHS2,CPM,CQS2,CT,FLHC,FLQC,FLX_LH,HFX & & ,PSHLTR,Q02,Q10,QFX,QGH,RIB,RLMO & @@ -410,6 +414,8 @@ CONTAINS & ,TERM1,RLOW,U10E,V10E,WSTAR,XLT02,XLT024,XLT10 & & ,XLT104,XLU10,XLU104,XU10,XU104,ZT02,ZT10,ZTAT02,ZTAT10 & & ,ZTAU,ZTAU10,ZU10,ZUUZ + REAL :: CZIL + REAL :: ZILFC !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- @@ -675,6 +681,17 @@ CONTAINS RLOGU=LOG(RZSU) ZSLT=ZSL+ZU ! u,v and t are at the same level + + IF ( (IZ0TLND==0) .or. (VEGTYP == ISURBAN) ) THEN + ! Just use the original CZIL value. + CZIL = 0.1 + ELSE + ! Modify CZIL according to Chen & Zhang, 2009 + ! CZIL = 10 ** -0.40 H, ( where H = 10*Zo ) + CZIL = 10.0 ** ( -0.40 * ( Z0 / 0.07 ) ) + ENDIF + ZILFC=-CZIL*VKARMAN*SQVISC + !---------------------------------------------------------------------- ! !mp Topo modification of ZILFC term diff --git a/wrfv2_fire/phys/module_sf_mynn.F b/wrfv2_fire/phys/module_sf_mynn.F index 49784a25..5aa827a2 100644 --- a/wrfv2_fire/phys/module_sf_mynn.F +++ b/wrfv2_fire/phys/module_sf_mynn.F @@ -20,21 +20,17 @@ MODULE module_sf_mynn REAL, DIMENSION(0:1000 ),SAVE :: PSIMTB,PSIHTB - INTEGER :: mynn_level CONTAINS - SUBROUTINE mynn_sf_init_driver(allowed_to_read,level) + SUBROUTINE mynn_sf_init_driver(allowed_to_read) LOGICAL, INTENT(in) :: allowed_to_read - INTEGER, INTENT(in) :: level !fill the table CALL sfclayinit(allowed_to_read) - mynn_level=level - END SUBROUTINE mynn_sf_init_driver @@ -221,9 +217,7 @@ CONTAINS REAL, DIMENSION(kts:kts+1) :: thl, qw, vt, vq REAL :: ql - INTEGER :: I,J,K, levflag - - levflag = mynn_level + INTEGER :: I,J,K DO J=jts,jte DO i=its,ite @@ -254,7 +248,6 @@ CONTAINS ! NOTE: The last grid number is kts+1 instead of kte. CALL mym_condensation (kts,kts+1, & - & levflag, & & dz8w(i,kts:kts+1,j), & & thl(kts:kts+1), qw(kts:kts+1), & & p3d(i,kts:kts+1,j),& diff --git a/wrfv2_fire/phys/module_sf_noahdrv.F b/wrfv2_fire/phys/module_sf_noahdrv.F index 5d72e5d7..6817db48 100644 --- a/wrfv2_fire/phys/module_sf_noahdrv.F +++ b/wrfv2_fire/phys/module_sf_noahdrv.F @@ -4,6 +4,7 @@ MODULE module_sf_noahdrv USE module_sf_noahlsm USE module_sf_urban USE module_sf_bep + USE module_sf_bep_bem #ifdef WRF_CHEM USE module_data_gocart_dust #endif @@ -39,6 +40,7 @@ CONTAINS ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & sf_urban_physics, & + CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & !Optional Urban TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban UC_URB2D, & !H urban @@ -54,7 +56,13 @@ CONTAINS num_road_layers, DZR, DZB, DZG, & !I urban FRC_URB2D,UTYPE_URB2D, & !O num_urban_layers, & !I multi-layer urban - trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban + trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban + tlev_urb3d,qlev_urb3d, & !H multi-layer urban + tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban + tglev_urb3d,tflev_urb3d, & !H multi-layer urban + sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d, & !H multi-layer urban + sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban + sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban th_phy,rho,p_phy,ust, & !I multi-layer urban gmt,julday,xlong,xlat, & !I multi-layer urban @@ -284,6 +292,10 @@ CONTAINS REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: QZ0 + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF ! Local variables (moved here from driver to make routine thread safe, 20031007 jm) REAL, DIMENSION(1:num_soil_layers) :: ET @@ -471,6 +483,19 @@ CONTAINS REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d @@ -497,6 +522,7 @@ CONTAINS ! REAL, DIMENSION( ims:ime, jms:jme ) :: GRDFLX_URB ! REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_URB,QSFC_URB,UMOM_URB,VMOM_URB REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_URB,UMOM_URB,VMOM_URB + REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_URB ! REAL, DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST REAL, DIMENSION(ims:ime,jms:jme) ::EMISS_URB REAL, DIMENSION(ims:ime,jms:jme) :: RL_UP_URB @@ -504,6 +530,7 @@ CONTAINS REAL, DIMENSION(ims:ime,jms:jme) ::GRDFLX_URB REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM REAL :: r1,r2,r3 + REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB ! ---------------------------------------------------------------------- ! DECLARATIONS END - urban ! ---------------------------------------------------------------------- @@ -733,7 +760,7 @@ CONTAINS !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as ! the "NATURAL" category in the VEGPARM.TBL - IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2 ) THEN + IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN VEGTYP = NATURAL @@ -744,7 +771,7 @@ CONTAINS IF ( FRC_URB2D(I,J) < 0.99 ) THEN if(sf_urban_physics.eq.1)then T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) - elseif(sf_urban_physics.eq.2)then + elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then r1= (tsk(i,j)**4.) r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.) r3= (1.-frc_urb2d(i,j)) @@ -969,6 +996,12 @@ CONTAINS ! CHS_URB = CHS(I,J) CHS2_URB = CHS2(I,J) + IF (PRESENT(CMR_SFCDIF)) THEN + CMR_URB = CMR_SFCDIF(I,J) + CHR_URB = CHR_SFCDIF(I,J) + CMC_URB = CMC_SFCDIF(I,J) + CHC_URB = CHC_SFCDIF(I,J) + ENDIF ! ! Call urban @@ -986,6 +1019,7 @@ CONTAINS TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O GZ1OZ0_URB, & !O + CMR_URB, CHR_URB, CMC_URB, CHC_URB, & U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O UST_URB) !O @@ -1081,7 +1115,12 @@ CONTAINS Q2_URB2D(I,J) = Q2_URB UST_URB2D(I,J) = UST_URB AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) - + IF (PRESENT(CMR_SFCDIF)) THEN + CMR_SFCDIF(I,J) = CMR_URB + CHR_SFCDIF(I,J) = CHR_URB + CMC_SFCDIF(I,J) = CMC_URB + CHC_SFCDIF(I,J) = CHC_URB + ENDIF END IF ENDIF ! end of UCM CALL if block @@ -1139,7 +1178,41 @@ CONTAINS ENDIF - if(sf_urban_physics.eq.2)then !Bep begin + + IF (SF_URBAN_PHYSICS == 3) THEN + + + do j=jts,jte + do i=its,ite + EMISS_URB(i,j)=0. + RL_UP_URB(i,j)=0. + RS_ABS_URB(i,j)=0. + GRDFLX_URB(i,j)=0. + end do + end do + + CALL BEP_BEM(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, & + th_phy,rho,p_phy,swdown,glw, & + gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, & + num_urban_layers, & + trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & + tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, & + tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & + cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, & + sfwin1_urb3d,sfwin2_urb3d, & + sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + a_u_bep,a_v_bep,a_t_bep, & + a_e_bep,b_u_bep,b_v_bep, & + b_t_bep,b_e_bep,b_q_bep,dlg_bep, & + dl_u_bep,sf_bep,vl_bep, & + rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb,qv3d, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + ENDIF + + if((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then !Bep begin ! fix the value of the Stefan-Boltzmann constant sigma_sb=5.67e-08 do j=jts,jte @@ -1147,6 +1220,7 @@ CONTAINS UMOM_URB(I,J)=0. VMOM_URB(I,J)=0. HFX_URB(I,J)=0. + QFX_URB(I,J)=0. do k=kts,kte a_u_bep(i,k,j)=a_u_bep(i,k,j)*frc_urb2d(i,j) a_v_bep(i,k,j)=a_v_bep(i,k,j)*frc_urb2d(i,j) @@ -1156,10 +1230,12 @@ CONTAINS b_u_bep(i,k,j)=b_u_bep(i,k,j)*frc_urb2d(i,j) b_v_bep(i,k,j)=b_v_bep(i,k,j)*frc_urb2d(i,j) b_t_bep(i,k,j)=b_t_bep(i,k,j)*frc_urb2d(i,j) - b_q_bep(i,k,j)=0. + b_q_bep(i,k,j)=b_q_bep(i,k,j)*frc_urb2d(i,j) b_e_bep(i,k,j)=b_e_bep(i,k,j)*frc_urb2d(i,j) HFX_URB(I,J)=HFX_URB(I,J)+B_T_BEP(I,K,J)*RHO(I,K,J)*CP* & DZ8W(I,K,J)*VL_BEP(I,K,J) + QFX_URB(I,J)=QFX_URB(I,J)+B_Q_BEP(I,K,J)* & + DZ8W(I,K,J)*VL_BEP(I,K,J) UMOM_URB(I,J)=UMOM_URB(I,J)+ (A_U_BEP(I,K,J)*U_PHY(I,K,J)+ & B_U_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J) VMOM_URB(I,J)=VMOM_URB(I,J)+ (A_V_BEP(I,K,J)*V_PHY(I,K,J)+ & @@ -1173,7 +1249,7 @@ CONTAINS ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_v_bep(i,1,j) b_t_bep(i,1,j)=(1.-frc_urb2d(i,j))*hfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP+ & b_t_bep(i,1,j) - b_q_bep(i,1,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j) + b_q_bep(i,1,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)+b_q_bep(i,1,j) umom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*u_phy(i,1,j)/ & ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+umom_urb(i,j) vmom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*v_phy(i,1,j)/ & @@ -1199,11 +1275,12 @@ CONTAINS endif ! rename *_urb to sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d grdflx(i,j)= (1.-frc_urb2d(i,j))*grdflx_rural(i,j)+frc_urb2d(i,j)*grdflx_urb(i,j) - qfx(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j) - lh(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)*xlv + qfx(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)+qfx_urb(i,j) +! lh(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)*xlv + lh(i,j)=qfx(i,j)*xlv HFX(I,J) = HFX_URB(I,J)+(1-FRC_URB2D(I,J))*HFX_RURAL(I,J) ![W/m/m] SH_URB2D(I,J) = HFX_URB(I,J)/FRC_URB2D(I,J) - LH_URB2D(I,J) = 0. + LH_URB2D(I,J) = qfx_urb(i,j)*xlv G_URB2D(I,J) = grdflx_urb(i,j) RN_URB2D(I,J) = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j) ust(i,j)=(umom**2.+vmom**2.)**.25 @@ -1694,6 +1771,8 @@ CONTAINS READ (19,*)SMLOW_DATA READ (19,*) READ (19,*)SMHIGH_DATA + READ (19,*) + READ (19,*)LVCOEF_DATA CLOSE (19) ENDIF @@ -1711,6 +1790,7 @@ CONTAINS CALL wrf_dm_bcast_real ( CZIL_DATA , 1 ) CALL wrf_dm_bcast_real ( SMLOW_DATA , 1 ) CALL wrf_dm_bcast_real ( SMHIGH_DATA , 1 ) + CALL wrf_dm_bcast_real ( LVCOEF_DATA , 1 ) !----------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_noahlsm.F b/wrfv2_fire/phys/module_sf_noahlsm.F index 5d4cc647..45b98e42 100644 --- a/wrfv2_fire/phys/module_sf_noahlsm.F +++ b/wrfv2_fire/phys/module_sf_noahlsm.F @@ -1,5 +1,4 @@ MODULE module_sf_noahlsm - USE module_model_constants ! REAL, PARAMETER :: CP = 1004.5 @@ -36,6 +35,7 @@ MODULE module_sf_noahlsm REAL :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, & CZIL_DATA + REAL :: LVCOEF_DATA CHARACTER*256 :: err_message @@ -312,6 +312,7 @@ CONTAINS RSNOW,SNDENS,SNCOND,SBETA,SN_NEW,SLOPE,SNUP,SALP,SOILWM, & SOILWW,T1V,T24,T2V,TH2V,TOPT,TFREEZ,TSNOW,ZBOT,Z0,PRCPF, & ETNS,PTU,LSUBS + REAL :: LVCOEF REAL :: INTERP_FRACTION REAL :: LAIMIN, LAIMAX REAL :: ALBEDOMIN, ALBEDOMAX @@ -369,7 +370,7 @@ CONTAINS RTDIS,SLDPTH,ZSOIL,NROOT,NSOIL,CZIL, & LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, & ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, & - LSOIL,LOCAL) + LSOIL,LOCAL,LVCOEF) !urban IF(VEGTYP==ISURBAN)THEN @@ -557,7 +558,7 @@ CONTAINS SNCOVR = MIN(SNCOVR,0.98) endif CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1,ALBEDO,EMISSI, & - DT,SNOWNG,SNOTIME1) + DT,SNOWNG,SNOTIME1,LVCOEF) END IF ! ---------------------------------------------------------------------- ! SNOW COVER, ALBEDO OVER SEA-ICE, GLACIAL ICE @@ -676,7 +677,7 @@ CONTAINS ! THE PREVIOUS TIMESTEP. ! ---------------------------------------------------------------------- IF (SNCOVR > 0. ) THEN - CALL SNOWZ0 (SNCOVR,Z0,Z0BRD) + CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH) ELSE Z0=Z0BRD END IF @@ -884,7 +885,7 @@ CONTAINS ! ---------------------------------------------------------------------- SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO,EMISSI, & - DT,SNOWNG,SNOTIME1) + DT,SNOWNG,SNOTIME1,LVCOEF) ! ---------------------------------------------------------------------- ! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) @@ -911,7 +912,8 @@ CONTAINS REAL, INTENT(OUT) :: ALBEDO, EMISSI REAL :: SNOALB2 REAL :: TM,SNOALB1 - REAL, PARAMETER :: COEF=0.5, SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46 + REAL, INTENT(IN) :: LVCOEF + REAL, PARAMETER :: SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46 ! turn of vegetation effect ! ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB) ! ALBEDO = (1.0-SNCOVR)*ALB + SNCOVR*SNOALB !this is equivalent to below @@ -970,7 +972,7 @@ CONTAINS ! IS INDEED ACCUMULATION SEASON. I.E. THAT SNOW SURFACE TEMP IS BELOW ! ZERO AND THE DATE FALLS BETWEEN OCTOBER AND FEBRUARY ! ---------------------------------------------------------------------- - SNOALB1 = SNOALB+COEF*(0.85-SNOALB) + SNOALB1 = SNOALB+LVCOEF*(0.85-SNOALB) SNOALB2=SNOALB1 ! ---------------- Initial LSTSNW -------------------------------------- IF (SNOWNG) THEN @@ -2215,7 +2217,7 @@ CONTAINS RTDIS,SLDPTH,ZSOIL, NROOT,NSOIL,CZIL, & LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, & ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, & - LSOIL, LOCAL) + LSOIL, LOCAL,LVCOEF) IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -2316,6 +2318,7 @@ CONTAINS REAL, INTENT(OUT) :: SLOPE,CZIL,SBETA,FXEXP, & CSOIL,SALP,FRZX,KDT,CFACTR, & ZBOT,REFKDT,PTU + REAL, INTENT(OUT) :: LVCOEF REAL,DIMENSION(1:NSOIL),INTENT(IN) :: SLDPTH,ZSOIL REAL,DIMENSION(1:NSOIL),INTENT(OUT):: RTDIS REAL :: FRZFACT,FRZK,REFDK @@ -2362,6 +2365,7 @@ CONTAINS KDT = REFKDT * DKSAT / REFDK CZIL = CZIL_DATA SLOPE = SLOPE_DATA (SLOPETYP) + LVCOEF = LVCOEF_DATA ! ---------------------------------------------------------------------- ! TO ADJUST FRZK PARAMETER TO ACTUAL SOIL TYPE: FRZK * FRZFACT @@ -3339,7 +3343,7 @@ CONTAINS END SUBROUTINE SNOWPACK ! ---------------------------------------------------------------------- - SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD) + SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH) ! ---------------------------------------------------------------------- ! SUBROUTINE SNOWZ0 @@ -3353,9 +3357,19 @@ CONTAINS REAL, INTENT(IN) :: SNCOVR, Z0BRD REAL, INTENT(OUT) :: Z0 REAL, PARAMETER :: Z0S=0.001 + REAL, INTENT(IN) :: SNOWH + REAL BURIAL, Z0EFF !m Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S - Z0 = Z0BRD + BURIAL = 7.0*Z0BRD - SNOWH + IF(BURIAL.LE.0.0007) THEN + Z0EFF = Z0S + ELSE + Z0EFF = BURIAL/7.0 + ENDIF + + Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF + ! ---------------------------------------------------------------------- END SUBROUTINE SNOWZ0 ! ---------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_pxlsm.F b/wrfv2_fire/phys/module_sf_pxlsm.F index 3a18991f..4649f72d 100755 --- a/wrfv2_fire/phys/module_sf_pxlsm.F +++ b/wrfv2_fire/phys/module_sf_pxlsm.F @@ -25,12 +25,12 @@ CONTAINS SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & PSFC, GSW, GLW, RAINBL, EMISS, & ITIMESTEP, NSOIL, DT, ANAL_INTERVAL, & - XLAND, ALBBCK, ALBEDO, SNOALB, & + XLAND, XICE, ALBBCK, ALBEDO, SNOALB, & SMOIS, TSLB, MAVAIL, TA2, QA2, & ZS,DZS, PSIH, & LANDUSEF,SOILCTOP,SOILCBOT,VEGFRA,VEGF_PX, & ISLTYP,RA,RS,LAI,NLCAT,NSCAT, & - HFX,QFX,LH,TSK,ZNT,CANWAT, & + HFX,QFX,LH,TSK,SST,ZNT,CANWAT, & GRDFLX,SHDMIN,SHDMAX, & SNOWC,PBLH,RMOL,UST,CAPG,DTBL, & T2_NDG_OLD, T2_NDG_NEW, & @@ -97,6 +97,7 @@ CONTAINS !-- ANAL_INTERVAL Interval of analyses used for soil moisture and temperature nudging !-- XLAND land mask (1 for land, 2 for water) +!-- XICE Sea ice !-- ALBBCK Background Albedo !-- ALBEDO surface albedo with snow cover effects !-- SNOALB Albedo of snow @@ -133,6 +134,7 @@ CONTAINS !-- QFX net upward moisture flux at the surface (kg/m^2/s) !-- LH net upward latent heat flux at surface (W/m^2) !-- TSK surface skin temperature (K) +!-- SST sea surface temperature !-- ZNT rougness length !-- CANWAT Canopy water (mm) @@ -217,7 +219,7 @@ CONTAINS EMISS, SNOALB, & ALBBCK, SHDMIN, SHDMAX, & PBLH, RMOL, SNOWNCV, & - UST, MAVAIL + UST, MAVAIL, SST REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN) :: T2_NDG_OLD, T2_NDG_NEW, & Q2_NDG_OLD, Q2_NDG_NEW, & @@ -228,22 +230,26 @@ CONTAINS REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: CAPG,CANWAT, QFX, HFX, LH, & PSIH,VEGFRA, VEGF_PX, SNOW, & - SNOWH, SNOWC, ALBEDO, XLAND + SNOWH, SNOWC, ALBEDO, XLAND, XICE LOGICAL :: radiation -! <<<< Local Variables >>>> - REAL:: G1000, ALN10 - INTEGER:: J, I, NS, NUDGE, ISTI, WEIGHT -!... Parameters - INTEGER, PARAMETER :: NSTPS = 11 ! max. soil types +!------------------------------------------------------------------------- +! ---------- Local Variables -------------------------------- -!... Integer - INTEGER, DIMENSION( 1: NSTPS ) :: JP -!... Real + !---- PARAMETERS + INTEGER, PARAMETER :: NSTPS = 11 ! max. soil types + REAL, PARAMETER :: DTPBLX = 40.0 ! Max PX timestep = 40 sec + + + !---- INTEGERS + INTEGER, DIMENSION( 1: NSTPS ) :: JP + INTEGER:: J, I, NS, NUDGE, ISTI, WEIGHT + INTEGER:: NTSPS, IT + !---- REALS REAL, DIMENSION( ims:ime, jms:jme ) :: XLAI, XLAIMN, RSTMIN, & XVEG, XVEGMN, XSNUP, & XALB @@ -256,25 +262,23 @@ CONTAINS RAIR,CPAIR,IFLAND,ISNOW, & ES,QSS,BETAP, & RH2_OLD, RH2_NEW, T2_OLD, T2_NEW, & - CORE, CORB, TIME_BETWEEN_ANALYSIS - REAL:: FWSAT,FWFC,FWWLT,FB,FCGSAT,FJP,FAS,FC2R,FC1SAT - REAL:: RH2OBS, HU, SNOBS - REAL:: FSEAS, T2I, HC_SNOW, SNOW_FRA, SNOWALB - REAL:: QST12,ZFUNC,ZF1,ZA2,QV2, DT_FDDA, CURTIME - - REAL, PARAMETER :: DTPBLX = 40.0 ! Max PX timestep = 40 sec - REAL:: DTPBL - INTEGER:: NTSPS, IT + CORE, CORB, TIME_BETWEEN_ANALYSIS, & + G1000, ALN10,RH2OBS, HU, SNOBS, & + FWSAT,FWFC,FWWLT,FB,FCGSAT,FJP,FAS, & + FSEAS, T2I, HC_SNOW, SNOW_FRA,SNOWALB, & + QST12,ZFUNC,ZF1,ZA2,QV2, DT_FDDA,CURTIME, & + FC2R,FC1SAT, DTPBL -! +!------------------------------------------------------------------------- !-------------------------------Executable starts here-------------------- ! ALN10 = ALOG(10.0) G1000 = g*1.0E-3 ! G/1000 WEIGHT = 0 DT_FDDA = ANAL_INTERVAL * 1.0 ! Convert DT of Analysis to real - !IF (ITIMESTEP .EQ. 1) THEN - ! Calculate several soil and vegetation parameters, e.g., LAI, + + ! Compute vegetation and land-use characteristics by land-use fraction weighting + ! These parameters include LAI, VEGF, ZNT, ALBEDO, RS, etc. CALL VEGELAND(LANDUSEF, VEGFRA, SHDMIN, SHDMAX, & SOILCTOP, SOILCBOT, NLCAT, NSCAT, & ZNT,XLAI,XLAIMN,RSTMIN,XVEG,XVEGMN,XSNUP, & @@ -282,7 +286,6 @@ CONTAINS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) - !ENDIF !----------------------------------------------------------------------------------- !--- Compute time relatve to old and new analysis time for timestep interpolation CURTIME = (ITIMESTEP-1) * DT @@ -296,10 +299,10 @@ CONTAINS ENDIF !----------------------------------------------------------------------------------- - - DO J = jts,jte !-- MAIN J LOOP - - DO I = its,ite !-- MAIN I LOOP + !----------------------------------------------------------------------------------- + ! Main loop over individual grid cells + DO J = jts,jte !-- J LOOP + DO I = its,ite !-- I LOOP IFLAND = XLAND(I,J) @@ -328,8 +331,10 @@ CONTAINS PRECIP = MAX ( 1.0E-3*RAINBL(i,j)/DTBL,0.0) ! accumulated precip. rate during DT (=dtpbl) ! convert RAINBL from mm to m for PXLSM WR = 1.0E-3*CANWAT(I,J) ! convert CANWAT from mm to m for PXLSM - THETA1 = TH3D(i,1,j) ! potential temp at first layer - SNOBS = SNOW(I,J) + THETA1 = TH3D(i,1,j) ! potential temp at first layer + SNOBS = SNOW(I,J) ! Set snow cover to existing model value + ! this is overwritten below if snow analysis is availiable + ! otherwise snow cover remains constant through simulation IF(PXLSM_SOIL_NUDGE .EQ. 1) THEN !-- 2 m Temp and RH for Nudging @@ -346,13 +351,40 @@ CONTAINS Q2OBS(I,J) = CORB * Q2_NDG_OLD(I,J) + CORE * Q2_NDG_NEW(I,J) SNOBS = CORB * SN_NDG_OLD(I,J) + CORE * SN_NDG_NEW(I,J) ENDIF + + USTAR = MAX(UST(I,J),0.005) IF (IFLAND .GT. 1.5) THEN ! if over water ZNT(I,J) = CZO * UST(I,J) * UST(I,J) / G + OZO ENDIF - USTAR = MAX(UST(I,J),0.01) Z0 = ZNT(I,J) CPAIR = CPD * (1.0 + 0.84 * QV1) ! J/(K KG) + ! Compute fractional snow area and snow albedo + CALL PXSNOW (ITIMESTEP, SNOBS, SNOWNCV(I,J), SNOW(I,J), & + SNOWH(I,J), XSNUP(I,J), XALB(i,j), & + SNOALB(I,J),VEGF_PX(I,J), SHDMIN(I,J), & + HC_SNOW, SNOW_FRA, SNOWC(I,J), ALBEDO(I,J) ) + + !------------------------------------------------------------- + ! Sea Ice from analysis and water cells that are very cold, but more than 50% water + ! are converted to ice/snow for more reasonable treatment. + IF( (XICE(I,J).GE.0.5) .OR. & + (SST(I,J).LE.270.0.AND.XLAND(I,J).GT.1.50) ) THEN + XLAND(I,J) = 1.0 + IFLAND = 1.0 + ZNT(I,J) = 0.001 ! Ice + SMOIS(I,1,J) = 1.0 ! FWSAT + SMOIS(I,2,J) = 1.0 ! FWSAT + XICE(I,J) = 1.0 + ALBEDO(I,J) = 0.7 + SNOWC(I,J) = 1.0 + SNOW_FRA = 1.0 + VEGF_PX(I,J) = 0.0 + LAI(I,J) = 0.0 + ENDIF + !------------------------------------------------------------- + + !------------------------------------------------------------- !-- Note that when IFGROW = 0 is selected in Vegeland then max and min !-- LAI and Veg are the same T2I = TSLB(I,2,J) @@ -361,25 +393,22 @@ CONTAINS IF (T2I .GE. 290.0) FSEAS = 1.0 LAI(I,J) = XLAIMN(I,J) + FSEAS*(XLAI(I,J) - XLAIMN(I,J)) - VEGF_PX(I,J) = XVEGMN(I,J) + FSEAS*(XVEG(I,J) - XVEGMN(I,J)) + VEGF_PX(I,J) = XVEGMN(I,J) + FSEAS*(XVEG(I,J) - XVEGMN(I,J)) - !!--- Set LAI and VEGFRC according to deep soil temp - - IF (IFLAND .GT. 1.5) THEN ! if over water - VEGF_PX(I,J) = 0. !MAKE Sure veg algorithms not used for water + ! Ensure veg algorithms not used for water + IF (IFLAND .GT. 1.5) THEN + VEGF_PX(I,J) = 0.0 ENDIF - - ! Compute fractional snow area and snow albedo - CALL PXSNOW (ITIMESTEP, SNOBS, SNOWNCV(I,J), SNOW(I,J), & - SNOWH(I,J), XSNUP(I,J), XALB(i,j), & - SNOALB(I,J),VEGF_PX(I,J), SHDMIN(I,J), & - HC_SNOW, SNOW_FRA, SNOWC(I,J), ALBEDO(I,J) ) + !------------------------------------------------------------- + SOLDN = GSW(I,J) / (1.0 - ALBEDO(I,J)) ! downward shortwave radiaton ISNOW = SNOWC(I,J) + NUDGE=PXLSM_SOIL_NUDGE - IF ( J .LE. 2 .OR. J .GE. (jme-1) ) NUDGE=0 + IF ( J .LE. 2 .OR. J .GE. (jde-1) ) NUDGE=0 + IF ( I .LE. 2 .OR. I .GE. (ide-1) ) NUDGE=0 IF ( RMOL(I,J) .GT. 0.0 ) THEN MOLX = AMIN1(1/RMOL(I,J),1000.0) @@ -398,8 +427,9 @@ CONTAINS DTPBL = DT / NTSPS DO IT=1,NTSPS - !... SATURATION VAPOR PRESSURE (MB) OVER WATER OR LAND - IF ( TSLB(I,1,J) .LE. SVPT0 ) THEN ! with snow + + !... SATURATION VAPOR PRESSURE (MB) + IF ( TSLB(I,1,J) .LE. SVPT0 ) THEN ! For ground that is below freezing ES = SVP1 * EXP(22.514 - 6.15E3 / TSLB(I,1,J)) ! cb ELSE ES = SVP1 * EXP(SVP2 * (TSLB(I,1,J) - SVPT0) / (TSLB(I,1,J) - SVP3)) @@ -412,8 +442,7 @@ CONTAINS BETAP = 0.25 * (1.0 - COS(SMOIS(I,1,J) / FWFC * PI)) ** 2 ENDIF - - CALL SURFPX (DTPBL, IFLAND, SNOWC(I,J), NUDGE, & !in + CALL SURFPX (DTPBL, IFLAND, SNOWC(I,J), NUDGE, XICE(I,J), & !in SOLDN, GSW(I,J), LWDN, EMISSI, ZLVL, & !in MOLX, Z0, USTAR, & !in SFCPRS, DENS1, QV1, QSS, TA1, & !in @@ -432,13 +461,12 @@ CONTAINS END DO ! Time internal PX time loop - TSK(I,J)= TSLB(I,1,J) ! Skin temp set to 1 cm soil temperature in PX for now CANWAT(I,J) = WR * 1000. ! convert WR back to mm for CANWAT - + ENDDO ! END MIAN I LOOP ENDDO ! END MAIN J LOOP - + !------------------------------------------------------ END SUBROUTINE pxlsm !------------------------------------------------------ @@ -523,7 +551,7 @@ CONTAINS ! 21 WdTun 200. 10. 30. 10. 1.0 0.5 Shrub and Brush Tundra ! 22 MxTun 150. 5. 20. 05. 1.0 0.5 Mixed Tundra ! 23 BGTun 100. 5. 5. 02. 0.1 0.1 Bare Ground Tundra -! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 Perennial Snowfields or Glaciers +! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 Perennial Snowfields or Glaciers !----------------------------------------------------------------------------- REAL, DIMENSION(24) :: RSMIN, Z00, VEG0, VEGMN0, & @@ -548,8 +576,8 @@ CONTAINS 1.0, 1.0, 1.0, 1.0, 4.0, 3.0, 2.0, 0.0, & 1.0, 3.0, 0.20, 0.50, 0.50, 0.50, 0.10, 0.10/ DATA SNUP0/ 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.03, & - 0.035, 0.04, 0.08, 0.08, 0.08, 0.08, 0.08, 0.01, & - 0.01, 0.01, 0.02, 0.02, 0.025, 0.025, 0.025, 0.02/ + 0.035, 0.04, 0.08, 0.08, 0.08, 0.08, 0.08, 0.01, & + 0.01, 0.01, 0.02, 0.02, 0.025, 0.025, 0.025, 0.02/ DATA ALBF/ 15.0, 17.0, 18.0, 18.0, 18.0, 16.0, 19.0, 22.0, & 20.0, 20.0, 16.0, 14.0, 12.0, 12.0, 13.0, 8.0, & 14.0, 14.0, 25.0, 15.0, 15.0, 15.0, 25.0, 55.0/ @@ -560,16 +588,6 @@ CONTAINS DATA KWAT / 16/ !-------------------------------------------------------------------- - !-- Initialize 2 and 3-D veg parameters to be cacluated - DO K=1,NLCAT - LAIMX(K) = LAI0(K) - LAIMN(K) = LAIMN0(K) - Z0(K) = Z00(K) - VEG(K) = VEG0(K) - VEGMN(K) = VEGMN0(K) - SNUP(K) = SNUP0(K) - ENDDO - DO J = jts,jte DO I = its,ite XLAI(I,J) = 0.0 @@ -586,6 +604,16 @@ CONTAINS DO J = jts,jte DO I = its,ite + !-- Initialize 2 and 3-D veg parameters to be cacluated + DO K=1,NLCAT + LAIMX(K) = LAI0(K) + LAIMN(K) = LAIMN0(K) + Z0(K) = Z00(K) + VEG(K) = VEG0(K) + VEGMN(K) = VEGMN0(K) + SNUP(K) = SNUP0(K) + ENDDO + !-- INITIALIZE SUMS SUMLAI = 0.0 SUMLMN = 0.0 @@ -598,30 +626,18 @@ CONTAINS SUMALB = 0.0 !-- ESTIMATE CROP EMERGANCE DATE FROM VEGFRAC - VFMX = SHDMAX(I,J) + 0.001 + VFMX = SHDMAX(I,J) VFMN = SHDMIN(I,J) VEGF = VEGFRA(I,J) - - !-- Consistency check for unknown - IF(VFMX*VFMN .LE. 0.001 .AND. VEGF .GT. 0.0) THEN - VFMX = VEGF - VFMN = VEGF - ENDIF - + !-- Computations for VEGETATION CELLS ONLY IF(VFMX.GT.0.0.AND.LANDUSEF(I,KWAT,J).LT.1.00) THEN - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - IF(VEGF.LE.VFMN) THEN - VSEAS = 0.0 - ELSE - VSEAS = ((VEGF-VFMN)/(VFMX-VFMN)) - ENDIF - ! print *,I,J,VSEAS,VEGF,VFMX-VFMN + VSEAS = VEGF/VFMX IF(VSEAS.GT.1.0.OR.VSEAS.LT.0.0) THEN - print *,' VSEAS NOT BETWEEN 0 AND 1, STOP', & - ' VSEAS=',VSEAS,VEGF,VFMX,VFMN - STOP + VSEAS = MIN(VSEAS,1.0) + VSEAS = MAX(VSEAS,0.0) ENDIF + ZNOTC = ZNOTCMN * (1-VSEAS) + ZNOTCMX * VSEAS ! Zo FOR CROPS DO K = 1, NLCAT !-- USE THE VEGFRAC DATA ONLY FOR CROPS @@ -632,7 +648,7 @@ CONTAINS VEGMN(K) = VEG(K) !-- SEASONALLY VARY Zo FOR DryCrop (k=2) OR Irigated Crop (k=3) OR Mix Crop (k=4) IF (K .GE. 2 .AND. K .LE. 4) THEN - Z0(K) = ZNOTC + Z0(K) = ZNOTC !-- CrGrM (k=5) or CrWdM (k=6) USE AVG WITH GRASS AND FOREST ELSE IF (K .GE.5 .AND. K .LE. 6) THEN Z0(K) = 0.5 * (ZNOTC + Z00(K)) @@ -693,7 +709,7 @@ CONTAINS XVEGMN(I,J) = XVEGMN(I,J) * 0.01 XLAND(I,J) = 1.0 + FWAT XALB(I,J) = XALB(I,J) * 0.01 - + ENDDO ! END LOOP THROUGH GRID CELLS ENDDO ! END LOOP THROUGH GRID CELLS !-------------------------------------------------------------------- @@ -702,7 +718,7 @@ CONTAINS END SUBROUTINE vegeland !------------------------------------------------------------------------------ !********************************************************************** - SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, & !in + SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in SOLDN, GSW, LWDN, EMISSI, Z1, & !in MOL, ZNT, UST, & !in PSURF, DENS1, QV1, QSS, TA1, & !in @@ -795,7 +811,7 @@ CONTAINS !... Real REAL , INTENT(IN) :: DTPBL, DS1, DS2 - REAL , INTENT(IN) :: IFLAND, ISNOW + REAL , INTENT(IN) :: IFLAND, ISNOW, XICE1 REAL , INTENT(IN) :: SOLDN, GSW, LWDN, EMISSI, Z1 REAL , INTENT(IN) :: ZNT REAL , INTENT(IN) :: PSURF, DENS1, QV1, QSS, TA1, THETA1, PRECIP @@ -842,7 +858,6 @@ CONTAINS PARAMETER (CT_SNOW = 2.0E-5) ALN10 = ALOG(10.0) RADNET = SOLDN - (EMISSI *(STBOLT *TG **4 - LWDN)) ! NET RADIATION - !-------------------------------------------------------------------- CPOT= (100.0 / PSURF) ** ROVCP ! rcp is global constant(module_model_constants) THETAG = TG * CPOT @@ -937,11 +952,10 @@ CONTAINS ENDIF !----------------------------------------------------------------------------------------- - !-------------------------------------------------------------------- !-- ASSIMILATION --- COMPUTE SOIL MOISTURE NUDGING FROM TA2 and RH2 !-------COMPUTE ASSIMILATION COEFFICIENTS FOR ALL I - IF (IFLAND .LT. 1.5 ) THEN + IF (IFLAND .LT. 1.5) THEN IF (NUDGEX .EQ. 0) THEN !-- NO NUDGING CASE WGNUDG = 0.0 W2NUDG = 0.0 @@ -964,7 +978,8 @@ CONTAINS !----------------------------------------------------------------------------------------- !-- Compute new values for TS,T2,WG,W2 and WR. No change over ice or water (XLAND > 1) - IF (IFLAND .LT. 1.5 ) THEN + IF (IFLAND .LT. 1.5) THEN + !-- SOLVE BY CRANK-NIC -- TENDTS=CT*(RADNET-HFX-QFX)-SOILFLX !-- Calculate the coefficients for implicit calculation of TG CQ1 = (1.0 - 0.622 * LV * CRANKP / (r_d * TG)) * QSS @@ -973,53 +988,57 @@ CONTAINS COEFFNP1 = 1.0 + DTPBL * CRANKP * (4.0 * EMISSI * STBOLT * TG ** 3 & * CT + DENS1 * CPAIR / RAH * CPOT * CT + 2.0 * PI & * TAUINV ) + DTPBL * (CT * LV * CQ2 * (CQ3 + CQ4)) - COEFFN = CT * (GSW + EMISSI * (STBOLT * (4.0 * CRANKP - 1.0) & - * TG ** 4 + LWDN) & !NET RAD + COEFFN = CT * (GSW + EMISSI * (STBOLT * (4.0 * CRANKP - 1.0) & + * TG*TG*TG*TG + LWDN) & !NET RAD + DENS1 * CPAIR / RAH * (THETA1 - (1.0 - CRANKP) * THETAG) & - - LV * (CQ3 * (CQ1 - QV1) + CQ4 * (CQ1 - QV1))) & !SFC HEAT FLUX + - LV * (CQ3 * (CQ1 - QV1) + CQ4 * (CQ1 - QV1))) & !SFC HEAT FLUX - 2.0 * PI * TAUINV * ((1.0 - CRANKP) * TG - T2) !SOIL FLUX TSNEW = (TG + DTPBL * COEFFN) / COEFFNP1 !-- FOR SNOW COVERED SURFACE TEMPERATURE IS NOT MORE THAN ZERO ! IF (ISNOW .GT. 0.5) TSNEW = AMIN1(TSNEW,273.15) TSHLF = 0.5 * ( TSNEW + TG) - T2NEW = (T2 + DTPBL * TAUINV * T2TFAC * (TSHLF - (1 - CRANKP) * T2) & + T2NEW = (T2 + DTPBL * TAUINV * T2TFAC * (TSHLF - (1 - CRANKP) * T2) & + DTPBL*T2NUD) & ! Added deep temperature nudging / (1.0 + DTPBL * TAUINV * T2TFAC * CRANKP) !-- REPLACE OLD with NEW Value TG = TSNEW T2 = T2NEW + ENDIF !----------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------- ! Compute new subsurface soil and canopy moisture values DENS1. No change required over ocean. - IF (IFLAND .LT. 1.5) THEN + IF (IFLAND .LT. 1.5.AND. XICE1.LT.0.5) THEN !-- Compute WR ROFF = 0.0 WRMAX = 0.2E-3 * VEGFRC * LAI ! max. WRMAX IN m - !-- PC is precip. intercepted by veg.(M/S) - PC = VEGFRC * SIGF * PRECIP - DWR = (WRMAX - WR) / DTPBL !the tendency to reach max. - PNET = PC - ER/ DENW ! residual of precip. and evap. - IF (PNET .GT. DWR) THEN - ROFF = PNET - DWR - PC = PC - ROFF - ENDIF - IF (QSS .LT. QV1) THEN - TENDWR = PC - ER / DENW - WRNEW = WR + DTPBL * TENDWR + + IF(WRMAX.GT.0.0) THEN + !-- PC is precip. intercepted by veg.(M/S) + PC = VEGFRC * SIGF * PRECIP + DWR = (WRMAX - WR) / DTPBL !the tendency to reach max. + PNET = PC - ER/ DENW ! residual of precip. and evap. + IF (PNET .GT. DWR) THEN + ROFF = PNET - DWR + PC = PC - ROFF + ENDIF + IF (QSS .LT. QV1) THEN + TENDWR = PC - ER / DENW + WRNEW = WR + DTPBL * TENDWR + ELSE + COF1 = DENS1 / DENW * VEGFRC * (QSS - QV1) / RAW + !-- using delta=wr/wrmax + CFNP1WR = 1.0 + DTPBL * COF1 * CRANKP / WRMAX + CFNWR = PC - COF1 * (1.0 - CRANKP) * WR / WRMAX + WRNEW = (WR + DTPBL * CFNWR) / CFNP1WR + ENDIF ELSE - COF1 = DENS1 / DENW * VEGFRC * (QSS - QV1) / RAW - !-- using delta=wr/wrmax - CFNP1WR = 1.0 + DTPBL * COF1 * CRANKP / WRMAX - CFNWR = PC - COF1 * (1.0 - CRANKP) * WR / WRMAX - WRNEW = (WR + DTPBL * CFNWR) / CFNP1WR + WRNEW=0.0 ENDIF + !--------------------------------------------- !-- Compute W2 - !.......... PG = DENW * (PRECIP - PC) ! PG is precip. reaching soil (PC already including ROFF) - IF(ER.GT.0.5E-3)PRINT *,' PRECIP,PC,DTPBL,PNET=' & - ,PRECIP,PC,DTPBL,PNET TENDW2 = 1.0 / (DENW * DS2) * (PG - EG - ETR) & + (W2NUDG + WGNUDG) / DS2 ! NUDGING W2NEW = W2 + DTPBL * TENDW2 @@ -1029,13 +1048,12 @@ CONTAINS !.. new values W2 = W2NEW WR = AMIN1(WRMAX,WRNEW) - if (WR .lt. 1.0E-8) WR = 0.0 ENDIF !----------------------------------------------------------------------------------------- !----------------------------------------------------------------------------------------- ! Compute new surface soil moisture values (WR). - IF (IFLAND .LT. 1.5) THEN ! over ocean no change to wg w2,wr + IF (IFLAND .LT. 1.5.AND. XICE1.LT.0.5) THEN ! over ocean no change to wg w2,wr !-- FOR SNOW COVERED SURFACE, ASSUME SURFACE IS SATURATED AND ! WG AND W2 ARE NOT CHANGED IF (ISNOW .GT.0.5) THEN @@ -1155,13 +1173,15 @@ CONTAINS !... for water surface, no canopy evaporation and transpiration ER = 0.0 ETR = 0.0 - + CQ4 = 0.0 + !... GROUND EVAPORATION (DEPOSITION) IF (QSS .LT. QV1) BETAP = 1.0 EG = DENS1 * (1.0 - VEGFRC) * BETAP * (QSS - QV1) / RAW + !!--------------------------------------------------------------------- !... CANOPY - IF (IFLAND .LT. 1.5 .AND. ISTI .GT. 0) THEN + IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0) THEN WRMAX = 0.2E-3 * VEGFRC * LAI ! in unit m IF (WR .LE. 0.0) THEN DELTA = 0.0 @@ -1179,60 +1199,68 @@ CONTAINS ! IF(ER.GT.0.5E-3)PRINT *,' WR,SIGG,DENS1,VEGFRC,QSS,QV1,RAW=', & ! WR,SIGG,DENS1,VEGFRC,QSS,QV1,RAW,' ER=',ER ENDIF + !!--------------------------------------------------------------------- -!-- TRANSPIRATION - - IF (IFLAND .LT. 1.5 .AND. ISTI .GT. 0) THEN -! -!-RADIATION + !-- TRANSPIRATION + !!--------------------------------------------------------------------- + IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0) THEN + + !!!-RADIATION IF (RSTMIN .GT. 130.0) THEN RADL = 30.0 ! W/M2 ELSE RADL = 100.0 ! W/M2 ENDIF - RADF = 1.1 * RG / (RADL * LAI) ! NP89 - EQN34 + RADF = 1.1 * RG / (RADL * LAI) ! NP89 - EQN34 F1 = (RSTMIN / RSMAX + RADF) / (1.0 + RADF) -!-SOIL MOISTURE + !!!-SOIL MOISTURE W2AVAIL = W2 - WWLT W2MXAV = WFC - WWLT F2 = 1.0 / (1.0 + EXP(-5.0 * ( W2AVAIL / W2MXAV - & (W2MXAV / 3.0 + WWLT)))) ! according JP, 9/94 -!-AIR TEMP -!... according to Avissar (1985) and AX 7/95 + !-AIR TEMP + !... according to Avissar (1985) and AX 7/95 IF (TA1 .LE. 302.15) THEN F4 = 1.0 / (1.0 + EXP(-0.41 * (TA1 - 282.05))) ELSE F4 = 1.0 / (1.0 + EXP(0.5 * (TA1 - 314.0))) ENDIF -!... + FTOT = LAI * F1 * F2 * F4 - FTOT = AMAX1(FTOT,FTMIN) ENDIF - IF (IFLAND .LT. 1.5 .AND. ISTI .GT. 0) THEN + !!--------------------------------------------------------------------- + IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0) THEN FSHELT = 1.0 ! go back to NP89 GS = FTOT / (RSTMIN * FSHELT) GA = 1.0 / RAW -!-- Compute humidity effect according to RH at leaf surf + !-- Compute humidity effect according to RH at leaf surf F3 = 0.5 * (GS - GA + SQRT(GA * GA + GA * GS * & (4.0 * QV1 / QSS - 2.0) + GS * GS)) / GS F3 = AMIN1(AMAX1(F3,F3MIN),1.0) - RS = 1.0 / (GS * F3) -!--- Compute Assimilation factor for soil moisture nudging - jp 12/94 -!-- Note that the 30 coef is to result in order 1 factor for max + RS = 1.0 / (GS * F3) + + !IF(RS .GT. 999999.0) THEN + ! print *,'RS,LAI,VEGFRC,ISTI-->',RS,LAI,VEGFRC,ISTI,ISNOW + !ENDIF + + !--- Compute Assimilation factor for soil moisture nudging - jp 12/94 + !-- Note that the 30 coef is to result in order 1 factor for max IF (RG .LT. 0.00001) THEN ! do not nudge during night FX = 0.0 ELSE FX = 30.0 * F1 * F4 * LAI / (RSTMIN * FSHELT) ENDIF + FASS = FX ETR = DENS1 * VEGFRC * (1.0 - SIGG) * (QSS - QV1) / (RAW + RS) -!..... CQ4 is used for the implicit calculation of TG in SURFACE + !..... CQ4 is used for the implicit calculation of TG in SURFACE CQ4 = DENS1 * VEGFRC * ((1.0 - SIGG) / (RAW + RS) + SIGG / RAW) - ENDIF ! endif for if IFLAND + ENDIF + !!--------------------------------------------------------------------- END SUBROUTINE qflux !------------------------------------------------------------------------------------------ @@ -1601,15 +1629,8 @@ CONTAINS END IF SNOWC = SNOW_FRA - - ! ---------------------------------------------------------------------- - ! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, - ! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM - ! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA - ! (1985, JCAM, VOL 24, 402-411) - ! ---------------------------------------------------------------------- - SNOWALB = AMIN1(1.0,ALB + AMAX1(0.0,(1.0- SHDFAC - & - (SHDMIN/100)) * SNOW_FRA * (SNOALB - ALB))) + + SNOWALB = ALB + SNOWC*(SNOALB-ALB) END SUBROUTINE pxsnow diff --git a/wrfv2_fire/phys/module_sf_qnsesfc.F b/wrfv2_fire/phys/module_sf_qnsesfc.F index 2b1113e1..fde4ffb2 100755 --- a/wrfv2_fire/phys/module_sf_qnsesfc.F +++ b/wrfv2_fire/phys/module_sf_qnsesfc.F @@ -47,6 +47,7 @@ & ,FZT2=CZIV*GRRS*TVISC*SQPR & & ,FZU1=CZIV*VISC & & ,PIHF=0.5*PI & + & ,PRT0=0.72 & & ,RQVISC=1./QVISC & & ,USTFC=0.018/G & & ,WWST2=WWST*WWST & @@ -559,14 +560,8 @@ CONTAINS K=MAX(K,0) PSHZL=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) ! - SIMH=(PSHZL-PSHZ+RLOGT/1.4)*FH01 -! -! IF(RLMO.LE.0.)THEN -! SIMH=(PSHZL-PSHZ+RLOGT)*FH01 -! ELSE -! Pr=0.7 used in stable case -! SIMH=(PSHZL-PSHZ+RLOGT/1.4)*FH01 -! ENDIF + SIMH=(PSHZL-PSHZ+RLOGT)*PRT0 +! SIMH=(PSHZL-PSHZ+RLOGT)*FH01 !---------------------------------------------------------------------- USTARK=USTAR*VKARMAN AKMS=MAX(USTARK/SIMM,CXCHS) @@ -714,14 +709,8 @@ CONTAINS K=MAX(K,0) PSHZL=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) ! - SIMH=(PSHZL-PSHZ+RLOGT/1.4)*FH02 -! -! IF(RLMO.LE.0.)THEN -! SIMH=(PSHZL-PSHZ+RLOGT)*FH02 -! ELSE -! Pr=0.7 used in stable case -! SIMH=(PSHZL-PSHZ+RLOGT/1.4)*FH02 -! ENDIF + SIMH=(PSHZL-PSHZ+RLOGT)*PRT0 +! SIMH=(PSHZL-PSHZ+RLOGT)*FH02 !---------------------------------------------------------------------- USTARK=USTAR*VKARMAN AKMS=MAX(USTARK/SIMM,CXCHL) @@ -830,7 +819,8 @@ CONTAINS K=MAX(K,0) PSH02=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) ! - SIMH02=(PSH02-PSHZ+RLNT02)*FH01 + SIMH02=(PSH02-PSHZ+RLNT02)*PRT0 +! SIMH02=(PSH02-PSHZ+RLNT02)*FH01 ! RZ=(ZTAT10-ZTMIN1)/DZETA1 K=INT(RZ) @@ -839,7 +829,8 @@ CONTAINS K=MAX(K,0) PSH10=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) ! - SIMH10=(PSH10-PSHZ+RLNT10)*FH01 + SIMH10=(PSH10-PSHZ+RLNT10)*PRT0 +! SIMH10=(PSH10-PSHZ+RLNT10)*FH01 ! AKMS10=MAX(USTARK/SIMM10,CXCHS) AKHS02=MAX(USTARK/SIMH02,CXCHS) @@ -872,7 +863,8 @@ CONTAINS K=MAX(K,0) PSH02=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) ! - SIMH02=(PSH02-PSHZ+RLNT02)*FH02 + SIMH02=(PSH02-PSHZ+RLNT02)*PRT0 +! SIMH02=(PSH02-PSHZ+RLNT02)*FH02 ! RZ=(ZTAT10-ZTMIN2)/DZETA2 K=INT(RZ) @@ -881,7 +873,8 @@ CONTAINS K=MAX(K,0) PSH10=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) ! - SIMH10=(PSH10-PSHZ+RLNT10)*FH02 + SIMH10=(PSH10-PSHZ+RLNT10)*PRT0 +! SIMH10=(PSH10-PSHZ+RLNT10)*FH02 ! AKMS10=MAX(USTARK/SIMM10,CXCHL) AKHS02=MAX(USTARK/SIMH02,CXCHL) @@ -1141,7 +1134,8 @@ CONTAINS !---------------------------------------------------------------------- ! PSIMQ=2.25*ZETA1+ZETA1**2+45.9*ZETA1**3 - PSIHQ=1.45*ZETA1+7.42*ZETA1**2+93.5*ZETA1**3 + PSIHQ=2.0*ZETA1+10.3*ZETA1**2+130*ZETA1**3 +! PSIHQ=1.45*ZETA1+7.42*ZETA1**2+93.5*ZETA1**3 ! /PRT0 PSIM1(K)=MAX(PSIMQ,PSIM1(K)) PSIH1(K)=MAX(PSIHQ,PSIH1(K)) ! @@ -1169,7 +1163,8 @@ CONTAINS !---------------------------------------------------------------------- ! PSIM1(K)=2.25*ZETA1-0.2*ZETA1*ZETA1 - PSIH1(K)=1.42*ZETA1+0.1*((ZETA1-0.5)**5+0.03125) + PSIH1(K)=2.0*ZETA1+0.14*((ZETA1-0.5)**5+0.03125) +! PSIH1(K)=1.42*ZETA1+0.1*((ZETA1-0.5)**5+0.03125) !/PRT0 !---------------------------------------------------------------------- ! ENDIF @@ -1194,7 +1189,8 @@ CONTAINS !---------------------------------------------------------------------- ! PSIMQ=2.25*ZETA2+ZETA2**2+45.9*ZETA2**3 - PSIHQ=1.45*ZETA2+7.42*ZETA2**2+93.5*ZETA2**3 + PSIHQ=2.0*ZETA2+10.3*ZETA2**2+130*ZETA2**3 +! PSIHQ=1.45*ZETA2+7.42*ZETA2**2+93.5*ZETA2**3 ! /PRT0 PSIM2(K)=MAX(PSIMQ,PSIM2(K)) PSIH2(K)=MAX(PSIHQ,PSIH2(K)) ! @@ -1223,7 +1219,8 @@ CONTAINS !---------------------------------------------------------------------- ! PSIM2(K)=2.25*ZETA2-0.2*ZETA2*ZETA2 - PSIH2(K)=1.42*ZETA2+0.1*((ZETA2-0.5)**5+0.03125) + PSIH2(K)=2.0*ZETA2+0.14*((ZETA2-0.5)**5+0.03125) +! PSIH2(K)=1.42*ZETA2+0.1*((ZETA2-0.5)**5+0.03125) !/PRT0 !---------------------------------------------------------------------- ! ENDIF diff --git a/wrfv2_fire/phys/module_sf_ruclsm.F b/wrfv2_fire/phys/module_sf_ruclsm.F index 9644f34d..84e445c4 100644 --- a/wrfv2_fire/phys/module_sf_ruclsm.F +++ b/wrfv2_fire/phys/module_sf_ruclsm.F @@ -42,10 +42,11 @@ CONTAINS Z3D,P8W,T3D,QV3D,QC3D,RHO3D, & !p8W in [PA] GLW,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & - SNOALB,ALBBCK, & !new - QSFC,QSG,QVG,QCG,SOILT1,TSNAV, & - TBOT,IVGTYP,ISLTYP,XLAND,XICE, & - CP,G0,LV,STBOLT, & + Z0,SNOALB,ALBBCK, & !new + QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, & + TBOT,IVGTYP,ISLTYP,XLAND, & + ISICE,XICE,XICE_THRESHOLD, & + CP,ROVCP,G0,LV,STBOLT, & SOILMOIS,SH2O,SMAVAIL,SMMAX, & TSO,SOILT,HFX,QFX,LH, & SFCRUNOFF,UDRUNOFF,SFCEXC, & @@ -117,6 +118,11 @@ CONTAINS ! ACSNOW - accumulation of snow water [m] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). !-- used only in MYJPBL. +!-- tice - sea ice temperture (C) +!-- rhosice - sea ice density (kg m^-3) +!-- capice - sea ice volumetric heat capacity (J/m^3/K) +!-- thdifice - sea ice thermal diffusivity (m^2/s) +!-- !-- ims start index for i in memory !-- ime end index for i in memory !-- jms start index for j in memory @@ -131,7 +137,7 @@ CONTAINS REAL, INTENT(IN ) :: DT LOGICAL, INTENT(IN ) :: myj,frpcpn - INTEGER, INTENT(IN ) :: ktau, nsl, & + INTEGER, INTENT(IN ) :: ktau, nsl, isice, & ims,ime, jms,jme, kms,kme, & ids,ide, jds,jde, kds,kde, & its,ite, jts,jte, kts,kte @@ -148,14 +154,13 @@ CONTAINS INTENT(IN ) :: RAINBL, & GLW, & GSW, & - SNOALB, & - ALBBCK, & FLHC, & FLQC, & CHS , & EMISS, & XICE, & XLAND, & + ALBBCK, & VEGFRA, & TBOT @@ -167,9 +172,11 @@ CONTAINS SNOWH, & SNOWC, & CANWAT, & ! new + SNOALB, & ALB, & MAVAIL, & SFCEXC, & + Z0 , & ZNT REAL, DIMENSION( ims:ime , jms:jme ), & @@ -180,7 +187,7 @@ CONTAINS INTENT(IN ) :: IVGTYP, & ISLTYP - REAL, INTENT(IN ) :: CP,G0,LV,STBOLT + REAL, INTENT(IN ) :: CP,ROVCP,G0,LV,STBOLT,XICE_threshold REAL, DIMENSION( ims:ime , 1:nsl, jms:jme ) , & INTENT(INOUT) :: SOILMOIS,SH2O,TSO @@ -198,6 +205,7 @@ CONTAINS SNOM, & QVG, & QCG, & + DEW, & QSFC, & QSG, & CHKLOWQ, & @@ -208,7 +216,7 @@ CONTAINS INTENT(INOUT) :: SMAVAIL, & SMMAX - REAL, DIMENSION( its:ite, jts:jte ) :: DEW, & + REAL, DIMENSION( its:ite, jts:jte ) :: & PC, & RUNOFF1, & RUNOFF2, & @@ -225,7 +233,7 @@ CONTAINS sflx, & EVAPL, & PRCPL, & - XICED, & + SEAICE, & INFILTR !--- soil/snow properties @@ -236,6 +244,7 @@ CONTAINS REAL & :: RHOCS, & RHOSN, & + RHONEWSN, & BCLH, & DQM, & KSAT, & @@ -283,11 +292,11 @@ CONTAINS REAL :: PRCPMS, & NEWSNMS, & PATM, & + PATMB, & TABS, & QVATM, & QCATM, & Q2SAT, & - SATFLG, & CONFLX, & RHO, & QKMS, & @@ -295,14 +304,15 @@ CONTAINS INFILTRP REAL :: cq,r61,r273,arp,brp,x,evs,eis + REAL :: meltfactor INTEGER :: NROOT INTEGER :: ILAND,ISOIL - INTEGER, DIMENSION ( 1:nvegclas ) :: IFOREST + INTEGER, DIMENSION( 1:(nvegclas) ) :: IFOREST INTEGER :: I,J,K,NZS,NZS1,NDDZS INTEGER :: k1,l,k2,kp,km - + CHARACTER (LEN=132) :: message !----------------------------------------------------------------- @@ -342,20 +352,32 @@ CONTAINS DO i=its,ite do k=1,nsl ! smfr3d (i,k,j)=soilmois(i,k,j)/900.*1.e3 +! sh2o (i,k,j)=soilmois(i,k,j)-smfr3d(i,k,j)/1.e3*900. keepfr3dflag(i,k,j)=0. - sh2o (i,k,j)=0. enddo !--- initializing to zero snow fraction - snowc(i,j) = min(1.,snowh(i,j)/0.1) -!--- initializing of snow temp - soilt1(i,j)=soilt(i,j) + snowc(i,j) = min(1.,snowh(i,j)/0.05) +!--- initializing inside snow temp if it is not defined + IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN + IF(snowc(i,j).gt.0.1) THEN + soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j)) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + WRITE ( message , FMT='(A,F8.3,2I6)' ) & + 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j + CALL wrf_debug ( 0 , message ) + ENDIF + ELSE + soilt1(i,j) = soilt(i,j) + ENDIF + ENDIF tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273. qcg (i,j) =0. - patm=P8w(i,kms,j)*1.e-2 - QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATM + patmb=P8w(i,kms,j)*1.e-2 + QSG (i,j) = QSN(SOILT(i,j),TBQ)/PATMB qvg (i,j) = QSG(i,j)*mavail(i,j) -! qvg (i,j) =qv3d(i,kms,j) - qsfc(i,j) = qsg(i,j)/(1.+qsg(i,j)) +! qvg (i,j) =qv3d(i,1,j) +! qsfc(i,j) = qsg(i,j)/(1.+qsg(i,j)) + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) SMELT(i,j) = 0. SNOM (i,j) = 0. SNFLX(i,j) = 0. @@ -364,6 +386,8 @@ CONTAINS zntl (i,j) = 0. RUNOFF1(i,j) = 0. RUNOFF2(i,j) = 0. + SFCRUNOFF(i,j) = 0. + UDRUNOFF(i,j) = 0. emissl (i,j) = 0. ! Temporarily!!! canwat(i,j)=0. @@ -393,7 +417,6 @@ CONTAINS !----------------------------------------------------------------- PRCPMS = 0. -! NROOT = 4 DO J=jts,jte @@ -425,11 +448,10 @@ CONTAINS QVATM = QV3D(i,kms,j) QCATM = QC3D(i,kms,j) PATM = P8w(i,kms,j)*1.e-5 -!---- what height is the first level?---- check!!!!! -!-- need to de-stagger from w levels to P levels - CONFLX = Z3D(i,kms,j) -! CONFLX = 0.5*Z3D(i,kms,j) -! CONFLX = 5. +!-- Z3D(1) is thickness between first full sigma level and the surface, +!-- but first mass level is at the half of the first sigma level +!-- (u and v are also at the half of first sigma level) + CONFLX = Z3D(i,kms,j)*0.5 RHO = RHO3D(I,kms,J) !--- 1*e-3 is to convert from mm/s to m/s IF(FRPCPN) THEN @@ -444,17 +466,14 @@ CONTAINS NEWSNMS = 0. endif ENDIF -!--- rooting depth is 5 levels for forests -! if(iforest(ivgtyp(i,j)).eq.1) nroot=5 -!--- convert exchange coeff to [m/s] -! QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) - if (myj) then +! if (myj) then QKMS=CHS(i,j) TKMS=CHS(i,j) - else - QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) - TKMS=FLHC(I,J)/RHO/CP - endif +! else +!--- convert exchange coeff QKMS to [m/s] +! QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) +! TKMS=FLHC(I,J)/RHO/CP +! endif !--- convert incoming snow and canwat from mm to m SNWE=SNOW(I,J)*1.E-3 SNHEI=SNOWH(I,J) @@ -471,7 +490,7 @@ CONTAINS !------------------------------------------------------------ -!----- DDZS and DSDZ1 are for implicit soilution of soil eqns. +!----- DDZS and DSDZ1 are for implicit solution of soil eqns. !------------------------------------------------------------- NZS1=NZS-1 !----- @@ -514,6 +533,7 @@ CONTAINS NROOT= 4 ! ! rooting depth + RHONEWSN = 200. if(SNOWH(i,j).gt.0.) then RHOSN = SNOW(i,j)/SNOWH(i,j) else @@ -529,15 +549,23 @@ CONTAINS !-- definition of number of soil levels in the rooting zone IF(iforest(ivgtyp(i,j)).ne.1) THEN !---- all vegetation types except evergreen and mixed forests +!18apr08 - define meltfactor for Egglston melting limit: +! for open areas factor is 2, and for forests - factor is 1.5 +! This will make limit on snow melting smaller and let snow stay +! longer in the forests. + meltfactor = 2.0 + do k=2,nzs if(zsmain(k).ge.0.4) then NROOT=K goto 111 endif enddo - ELSE !---- evergreen and mixed forests +!18apr08 - define meltfactor + meltfactor = 1.5 + do k=2,nzs if(zsmain(k).ge.1.1) then NROOT=K @@ -555,25 +583,25 @@ CONTAINS !*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS - - IF((XLAND(I,J)-1.5).GE.0. .or. XICE(I,J).gt.0.5)THEN -!-- Water or ice point + IF((XLAND(I,J)-1.5).GE.0.)THEN +!-- Water SMAVAIL(I,J)=1.0 SMMAX(I,J)=1.0 -! SNOW(I,J)=0.0 + SNOW(I,J)=0.0 LMAVAIL(I,J)=1.0 ILAND=16 ISOIL=14 - patm=P8w(i,kms,j)*1.e-2 - qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATM + patmb=P8w(i,1,j)*1.e-2 + qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) CHKLOWQ(I,J)=1. - Q2SAT=QSN(TABS,TBQ)/PATM + Q2SAT=QSN(TABS,TBQ)/PATMB DO K=1,NZS SOILMOIS(I,K,J)=1.0 + SH2O (I,K,J)=1.0 TSO(I,K,J)= SOILT(I,J) ENDDO @@ -581,18 +609,18 @@ CONTAINS PRINT*,' water point, I=',I, & 'J=',J, 'SOILT=', SOILT(i,j) ENDIF -!--- decide if this water point is ice: -! if(tabs.le.271.) then - if(xice(i,j).gt.0.5) then -! if(soilt(i,j).le.271.or.xice(i,j).eq.1.) then -! if(tabs.le.271.or.xice(i,j).eq.1.) then - XICED(i,j)=1. + + ELSE + +! LAND POINT OR SEA ICE + if(xice(i,j).ge.xice_threshold) then +! if(IVGTYP(i,j).eq.isice) then + SEAICE(i,j)=1. else - XICED(i,j)=0. + SEAICE(i,j)=0. endif - IF(XICED(I,J).NE.1.) SNOW(I,J)=0. - IF(XICED(I,J).GT.0.5)THEN + IF(SEAICE(I,J).GT.0.5)THEN !-- Sea-ice case IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN PRINT*,' sea-ice at water point, I=',I, & @@ -600,55 +628,30 @@ CONTAINS ENDIF ILAND = 24 ISOIL = 16 - - SMAVAIL(I,J)=1.0 - SMMAX(I,J)=1.0 - LMAVAIL(I,J)=1.0 -! RUC model approach is to keep sea-ice skin temperature equal to temperature -! at first atmospheric level - SOILT(I,J)=MIN(271.,TABS) - ZNT(I,J)=0.011 - + ZNT(I,J) = 0.011 + snoalb(i,j) = 0.75 + dqm = 1. + ref = 1. + qmin = 0. + wilt = 0. + emissl(i,j) = 1.0 DO K=1,NZS - SOILMOIS(I,K,J)=1.0 - TSO(I,K,J)= MIN(273.15,SOILT(I,J)) + soilmois(i,k,j) = 1. + smfr3d(i,k,j) = 1. + sh2o(i,k,j) = 0. + keepfr3dflag(i,k,j) = 0. ENDDO ENDIF -! for MYJ surface and PBL scheme - if (myj) then - IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN -! IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qsg(I,J))THEN - SATFLG=0. - ELSE - SATFLG=1.0 - ENDIF - else - SATFLG=1.0 - endif - QFX(I,J)=QFX(I,J)*SATFLG - - - ELSE - -!-- Land point ! Attention!!!! RUC LSM uses soil moisture content minus residual (minimum -! soil moisture content for a given soil type) as a state variable. -! If the WRF model is initialized from the RUC background model, then the -! soil moisture variable is consistent with the RUC LSM. -! If the WRF model is initialized from another background model (ETA, GFS...) -! then the residual value should be subtracted when the 1-d array of soil -! moisture is initialized before the call to SFCTMP, and after SFCTMP qmin -! should be added back in. -! -! soilm1d (k) = min(max(0.,soilmois(i,k,j)-qmin(i,j)),dqm(i,j)) - +! or dry soil moisture content for a given soil type) as a state variable. DO k=1,nzs ! soilm1d - soil moisture content minus residual [m**3/m**3] soilm1d (k) = min(max(0.,soilmois(i,k,j)),dqm) tso1d (k) = tso(i,k,j) + soiliqw (k) = sh2o(i,k,j) ENDDO do k=1,nzs @@ -659,6 +662,9 @@ CONTAINS ! LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/(REF-QMIN))) LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/dqm)) +! extract dew from the cloud water at the surface + QCG(I,J)=QCG(I,J)-DEW(I,J) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', & i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO @@ -669,22 +675,22 @@ CONTAINS !----------------------------------------------------------------- CALL SFCTMP (dt,ktau,conflx,i,j, & !--- input variables - nzs,nddzs,nroot, & - iland,isoil,xland(i,j),ivgtyp(i,j), & - PRCPMS,NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN, & + nzs,nddzs,nroot,meltfactor, & !added meltfactor + iland,isoil,xland(i,j),ivgtyp(i,j),PRCPMS, & + NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN,RHONEWSN, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSW(I,J),EMISSL(I,J), & QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & canwatr,vegfra(I,J),alb(I,J),znt(I,J), & snoalb(i,j),albbck(i,j), & !new - myj, & + myj,seaice(i,j), & !--- soil fixed fields QWRTZ, & rhocs,dqm,qmin,ref, & wilt,psis,bclh,ksat, & sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - cp,g0,lv,stbolt,cw,c1sn,c2sn, & + cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & KQWRTZ,KICE,KWT, & !--- output variables snweprint,snheiprint,rsm, & @@ -701,6 +707,7 @@ CONTAINS !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil !--- domain + smavail(i,j) = 0. smmax (i,j) = 0. @@ -721,23 +728,38 @@ CONTAINS UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*1000.0 SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. SMMAX (I,J) = SMMAX(I,J) * 1000. + + do k=1,nzs + + soilmois(i,k,j) = soilm1d(k) + sh2o (i,k,j) = soiliqw(k) + tso(i,k,j) = tso1d(k) + enddo + + do k=1,nzs + smfr3d(i,k,j) = smfrkeep(k) + keepfr3dflag(i,k,j) = keepfr (k) + enddo + +!tgs add together dew and cloud at the ground surface + qcg(i,j)=qcg(i,j)+dew(i,j) + + Z0 (I,J) = ZNT (I,J) SFCEXC (I,J) = TKMS -! SFCLAY expects QSFC as saturation mixing ration at surface -! QSFC(I,J) = QSG(I,J) -! MYJSFC expects QSFC as actual specific humidity at the surface + patmb=P8w(i,1,j)*1.e-2 + Q2SAT=QSN(TABS,TBQ)/PATMB QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J)) - patm=P8w(i,kms,j)*1.e-2 - Q2SAT=QSN(TABS,TBQ)/PATM ! for MYJ surface and PBL scheme - if (myj) then +! if (myj) then +! MYJSFC expects QSFC as actual specific humidity at the surface IF((QVATM.GE.Q2SAT*0.95).AND.QVATM.LT.qvg(I,J))THEN CHKLOWQ(I,J)=0. ELSE CHKLOWQ(I,J)=1. ENDIF - else - CHKLOWQ(I,J)=1. - endif +! else +! CHKLOWQ(I,J)=1. +! endif IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN if(CHKLOWQ(I,J).eq.0.) then @@ -746,12 +768,13 @@ CONTAINS endif ENDIF - MAVAIL (i,j) = LMAVAIL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m SNOW (i,j) = SNWE*1000. SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. + INFILTR(I,J) = INFILTRP + MAVAIL (i,j) = LMAVAIL(I,J) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) ENDIF @@ -765,13 +788,6 @@ CONTAINS !--- SNOWC snow cover flag SNOWC(I,J)=SNOWFRAC -! IF(SNOWH(I,J).GT.0.02)THEN -! SNOWC(I,J)=1.0 -! ELSE -! SNOWC(I,J)=0.0 -! ENDIF - - INFILTR(I,J) = INFILTRP !--- get 3d soil fields IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN @@ -779,18 +795,7 @@ CONTAINS i,j,tso1d,soilm1d ENDIF - do k=1,nzs - - soilmois(i,k,j) = soilm1d(k) - sh2o (i,k,j) = soiliqw(k) - tso(i,k,j) = tso1d(k) - enddo - - do k=1,nzs - smfr3d(i,k,j) = smfrkeep(k) - keepfr3dflag(i,k,j) = keepfr (k) - enddo - +!--- end of a land or sea ice point ENDIF ENDDO @@ -805,19 +810,19 @@ CONTAINS SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !--- input variables - nzs,nddzs,nroot, & - ILAND,ISOIL,XLAND,IVGTYP, & - PRCPMS,NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN, & + nzs,nddzs,nroot,meltfactor, & + ILAND,ISOIL,XLAND,IVGTYP,PRCPMS, & + NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN,RHONEWSN, & PATM,TABS,QVATM,QCATM,rho, & GLW,GSW,EMISS,QKMS,TKMS,PC, & MAVAIL,CST,VEGFRA,ALB,ZNT, & ALB_SNOW,ALB_SNOW_FREE, & - MYJ, & + MYJ,SEAICE, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - cp,g0,lv,stbolt,cw,c1sn,c2sn, & + cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & KQWRTZ,KICE,KWT, & !--- output variables snweprint,snheiprint,rsm, & @@ -833,10 +838,10 @@ CONTAINS !--- input variables - INTEGER, INTENT(IN ) :: i,j,nroot,ktau,nzs , & + INTEGER, INTENT(IN ) :: i,j,nroot,ktau,nzs , & nddzs !nddzs=2*(nzs-2) - REAL, INTENT(IN ) :: DELT,CONFLX + REAL, INTENT(IN ) :: DELT,CONFLX,meltfactor REAL, INTENT(IN ) :: C1SN,C2SN LOGICAL, INTENT(IN ) :: myj !--- 3-D Atmospheric variables @@ -849,9 +854,9 @@ CONTAINS INTENT(IN ) :: GLW, & GSW, & PC, & - ALB_SNOW, & - ALB_SNOW_FREE, & VEGFRA, & + ALB_SNOW_FREE, & + SEAICE, & XLAND, & RHO, & QKMS, & @@ -863,6 +868,7 @@ CONTAINS INTENT(INOUT) :: EMISS, & MAVAIL, & SNOWFRAC, & + ALB_SNOW, & ALB, & CST @@ -882,6 +888,7 @@ CONTAINS REAL, INTENT(IN ) :: CN, & CW, & CP, & + ROVCP, & G0, & LV, & STBOLT, & @@ -893,6 +900,7 @@ CONTAINS ZSHALF, & DTDZS2 + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ @@ -920,6 +928,7 @@ CONTAINS EVAPL, & INFILTR, & RHOSN, & + RHONEWSN, & SUBLIM, & PRCPL, & QVG, & @@ -942,9 +951,16 @@ CONTAINS TSNAV, & ZNT + REAL, DIMENSION(1:NZS) :: & + tice, & + rhosice, & + capice, & + thdifice !-------- 1-d variables REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & SOILIQW + + REAL, INTENT(OUT) :: RSM, & SNWEPRINT, & @@ -953,13 +969,14 @@ CONTAINS INTEGER :: K,ILNB - REAL :: BSN, XSN, RHONEWSN , & + REAL :: BSN, XSN , & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET REAL :: snhei_crit, keep_snow_albedo - REAL :: RNET,GSWNEW,EMISSN,ALBSN,ZNTSN + REAL :: RNET,GSWNEW,EMISSN,ZNTSN REAL :: VEGFRAC + real :: cice, albice, albsn !----------------------------------------------------------------- integer, parameter :: ilsnow=99 @@ -968,42 +985,62 @@ CONTAINS print *,' in SFCTMP',i,j,nzs,nddzs,nroot, & SNWE,RHOSN,SNOM,SMELT,TS1D ENDIF -! print *,' in SFCTMP',i,j,nzs,nddzs,nroot, & -! IVGTYP,ISOIL,ILAND, & -! PRCPMS,SNWE,RHOSN, & -! PATM,TABS,QVATM,QCATM,rho -! GLW,GSW,EMISS,QKMS,TKMS,PC, & -! cst,vegfrac,alb,znt, & -!--- soil fixed fields -! QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & -! sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & -!--- constants -! cp,g0,lv,stbolt,cw,c1sn,c2sn, & -! KQWRTZ,KICE,KWT NEWSN=0. RAINF = 0. RSM=0. INFILTR=0. VEGFRAC=0.01*VEGFRA + if(VEGFRAC.le.0.01) VEGFRAC=0. +!---initialize local arrays for sea ice + do k=1,nzs + tice(k) = 0. + rhosice(k) = 0. + cice = 0. + capice(k) = 0. + thdifice(k) = 0. + enddo + + GSWnew=GSW + ALBice=ALB_SNOW_FREE +!--- sea ice properties +!--- N.N Zubov "Arctic Ice" +!--- no salinity dependence because we consider the ice pack +!--- to be old and to have low salinity (0.0002) + if(SEAICE.ge.0.5) then + do k=1,nzs + tice(k) = ts1d(k) - 273.15 + rhosice(k) = 917.6/(1-0.000165*tice(k)) + cice = 2115.85 +7.7948*tice(k) + capice(k) = cice*rhosice(k) + thdifice(k) = 2.260872/capice(k) + enddo +!-- SEA ICE ALB dependence on ice temperature. When ice temperature is +!-- below critical value of -10C - no change to albedo. +!-- If temperature is higher that -10C then albedo is decreasing. +!-- The minimum albedo at t=0C for ice is 0.1 less. + GSWNEW=GSW/(1.-ALB) + ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.1, & + ALB_SNOW_FREE - 0.1*(tice(1)+10.)/10. )) + GSWNEW=GSW*(1.-ALBice) + endif IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms - print *,'GSW, GLW, SOILT, STBOLT, EMISS', & - GSW, GLW, SOILT, STBOLT, EMISS + print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',& + GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE ENDIF - SNHEI = SNWE * 1000. / RHOSN !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT XINET = EMISS*(GLW-UPFLUX) - RNET = GSW + XINET + RNET = GSWnew + XINET !Calculate the amount (m) of fresh snow - if(snhei.gt.0.0081*1.e3/rhosn) then + if(snhei.gt.0.0081*1.e3/rhosn) then !*** Correct snow density for current temperature (Koren et al. 1999) BSN=delt/3600.*c1sn*exp(0.08*tsnav-c2sn*rhosn*1.e-3) if(bsn*snwe*100..lt.1.e-4) goto 777 @@ -1014,14 +1051,10 @@ CONTAINS else rhosn =200. - rhonewsn =100. + rhonewsn =200. endif -! IF(TABS.LE.273.15)THEN - newsn=newsnms*delt -!--- consider for now that all PRCPMS went into snow -! prcpms = 0. !---- ACSNOW - accumulation of snow water [m] acsnow=acsnow+newsn @@ -1059,14 +1092,6 @@ CONTAINS NEWSN=NEWSN*1.E3/rhosn endif -! ELSE -!--- TABS is above freezing. Needed precip rates from microphysics -!--- to do a better job with mixed phase precip. - -! NEWSN = 0. -! -! ENDIF - IF(PRCPMS.NE.0.) THEN ! PRCPMS is liquid precipitation rate @@ -1078,26 +1103,16 @@ CONTAINS RAINF=1. ENDIF -! IF((XLAND-1.5).GE.0.)THEN -! IF(ILAND.EQ.16) THEN -! SNHEI=0. -! SNWE=0. -! ELSE - IF(SNHEI.GT.0.0) THEN !--- Set of surface parameters should be changed to snow values for grid !--- points where the snow cover exceeds snow threshold of 2 cm - EMISS = 0.91 - -! GSWNEW = GSW -! The following lines compute albedo depending on snow -! depth. For now commented out. -! alb_snow_free=0.2 -! alb_snow=0.70 -! SNHEI_CRIT=0.05 SNHEI_CRIT=0.01601*1.e3/rhosn SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) +!tgs NEW - low limit on snow fraction + if(SNOWFRAC.lt.0.01) snowfrac=0. +!--- EMISS = 0.91 for snow + EMISS = EMISS*(1.-snowfrac)+0.91*snowfrac KEEP_SNOW_ALBEDO = 0. IF (NEWSN.GT.0.) KEEP_SNOW_ALBEDO = 1. @@ -1105,10 +1120,44 @@ CONTAINS !--- GSW in-coming solar GSWNEW=GSW/(1.-ALB) - ALB = MAX(keep_snow_albedo*alb_snow, & + IF(SEAICE .LT. 0.5) THEN +!----- SNOW on soil +!-- ALB dependence on snow depth + ALBsn = MAX(keep_snow_albedo*alb_snow, & MIN((alb_snow_free + & (alb_snow - alb_snow_free) * & (snhei/(2.*SNHEI_CRIT))), alb_snow)) + +!-- ALB dependence on snow temperature. When snow temperature is +!-- below critical value of -10C - no change to albedo. +!-- If temperature is higher that -10C then albedo is decreasing. +!-- The minimum albedo at t=0C for snow on land is 15% less than +!-- albedo of temperatures below -10C. + if(albsn.lt.alb_snow)then + ALB=ALBsn + else + ALB = MIN(ALBSN,MAX(ALBSN - 0.15*(soilt - 263.15)/ & + (273.15-263.15), ALBSN - 0.15)) + endif + ELSE +!----- SNOW on ice + ALBsn = MAX(keep_snow_albedo*alb_snow, & + MIN((albice + (alb_snow - albice) * & + (snhei/(2.*SNHEI_CRIT))), alb_snow)) + +!-- ALB dependence on snow temperature. When snow temperature is +!-- below critical value of -10C - no change to albedo. +!-- If temperature is higher that -10C then albedo is decreasing. +!-- The minimum albedo at t=0C for snow on ice is 0.15 less. + if(albsn.lt.alb_snow)then + ALB=ALBsn + else + ALB = MIN(ALBSN,MAX(ALBSN - 0.15*(soilt - 263.15)/ & + (273.15-263.15), ALBSN - 0.15)) + endif + + ENDIF + !--- recompute absorbed solar radiation and net radiation !--- for new value of albedo gswnew=gswnew*(1.-alb) @@ -1116,8 +1165,17 @@ CONTAINS XINET = EMISS*(GLW-UPFLUX) RNET = GSWnew + XINET + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'I,J,GSW,GSWnew,GLW,UPFLUX,ALB',& + i,j,GSW,GSWnew,GLW,UPFLUX,ALB + ENDIF + + + if (SEAICE .LT. 0.5) then +! LAND CALL SNOWSOIL ( & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + meltfactor,rhonewsn, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & RHOSN,PATM,QVATM,QCATM, & GLW,GSWnew,EMISS,RNET,IVGTYP, & @@ -1128,7 +1186,7 @@ CONTAINS QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - lv,CP,G0,cw,stbolt,tabs, & + lv,CP,rovcp,G0,cw,stbolt,tabs, & KQWRTZ,KICE,KWT, & !--- output variables ilnb,snweprint,snheiprint,rsm, & @@ -1137,33 +1195,67 @@ CONTAINS SMELT,SNOH,SNFLX,SNOM,edir1,ec1,ett1,eeta, & qfx,hfx,s,sublim,prcpl,runoff1,runoff2, & mavail,soilice,soiliqw,infiltr ) + else +! SEA ICE + CALL SNOWSEAICE ( & + i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + meltfactor,rhonewsn, & ! new + ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & + RHOSN,PATM,QVATM,QCATM, & + GLW,GSWnew,EMISS,RNET, & + QKMS,TKMS,RHO, & +!--- sea ice parameters + ALB,ZNT, & + tice,rhosice,capice,thdifice, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + lv,CP,rovcp,cw,stbolt,tabs, & +!--- output variables + ilnb,snweprint,snheiprint,rsm,ts1d, & + dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & + SMELT,SNOH,SNFLX,SNOM,eeta, & + qfx,hfx,s,sublim,prcpl & + ) + edir1 = eeta + ec1 = 0. + ett1 = 0. + runoff1 = smelt + runoff2 = 0. + mavail = 1. + infiltr=0. + cst=0. + do k=1,nzs + soilm1d(k)=1. + soiliqw(k)=0. + soilice(k)=1. + smfrkeep(k)=1. + keepfr(k)=0. + enddo + endif if(snhei.eq.0.) then - -! if(snhei.le.2.e-2) then !--- all snow is melted -! gswnew=gswnew/(1.-alb) alb=alb_snow_free -! gswnew=gswnew*(1.-alb) endif ELSE - - alb=alb_snow_free +!--- no snow snheiprint=0. snweprint=0. + if(SEAICE .LT. 0.5) then +! LAND CALL SOIL( & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & + PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & EMISS,RNET,QKMS,TKMS,PC,cst,rho,vegfrac, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt, & psis,bclh,ksat,sat,cn, & zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - lv,CP,G0,cw,stbolt,tabs, & + lv,CP,rovcp,G0,cw,stbolt,tabs, & KQWRTZ,KICE,KWT, & !--- output variables soilm1d,ts1d,smfrkeep,keepfr, & @@ -1171,6 +1263,38 @@ CONTAINS ett1,eeta,qfx,hfx,s,evapl,prcpl,runoff1, & runoff2,mavail,soilice,soiliqw, & infiltr) + else +! SEA ICE + CALL SICE( & +!--- input variables + i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & + EMISS,RNET,QKMS,TKMS,rho, & +!--- sea ice parameters + tice,rhosice,capice,thdifice, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + lv,CP,rovcp,cw,stbolt,tabs, & +!--- output variables + ts1d,dew,soilt,qvg,qsg,qcg, & + eeta,qfx,hfx,s,evapl,prcpl & + ) + edir1 = eeta + ec1 = 0. + ett1 = 0. + runoff1 = prcpms + runoff2 = 0. + mavail = 1. + infiltr=0. + cst=0. + do k=1,nzs + soilm1d(k)=1. + soiliqw(k)=0. + soilice(k)=1. + smfrkeep(k)=1. + keepfr(k)=0. + enddo + endif ENDIF ! ENDIF @@ -1221,7 +1345,7 @@ CONTAINS QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - xlv,CP,G0_P,cw,stbolt,TABS, & + xlv,CP,rovcp,G0_P,cw,stbolt,TABS, & KQWRTZ,KICE,KWT, & !--- output variables soilmois,tso,smfrkeep,keepfr, & @@ -1232,7 +1356,7 @@ CONTAINS !************************************************************* ! Energy and moisture budget for vegetated surfaces -! without snow, heat diffusion amf Richards eqns. in +! without snow, heat diffusion and Richards eqns. in ! soil ! ! DELT - time step (s) @@ -1384,7 +1508,7 @@ CONTAINS REAL :: INFILTRP, transum , & RAINF, PRCPMS , & TABS, T3, UPFLUX, XINET - REAL :: CP,G0,LV,STBOLT,xlmelt,dzstop , & + REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & can,epot,fac,fltot,ft,fq,hft , & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & @@ -1405,7 +1529,7 @@ CONTAINS ! STBOLT=5.670151E-8 RHOICE=900. CI=RHOICE*2100. - XLMELT=3.335E+5 + XLMELT=3.35E+5 cvw=cw SAT=0.0004 @@ -1564,8 +1688,6 @@ CONTAINS WETCAN=(CST/SAT)**CN DRYCAN=1.-WETCAN -! print *,'CST,DRIP',cst,drip - !************************************************************** ! TRANSF computes transpiration function !************************************************************** @@ -1651,26 +1773,21 @@ CONTAINS endif ENDDO - INFMAX=999. -!--- The threshold when the infiltration stops is: -!--- volumetric content of unfrozen pores < 0.12 - if((dqm+qmin-riw*soilicem(1)).lt.0.12) & - INFMAX=0. - !************************************************************************* ! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28) ! and Richards eqn. !************************************************************************* CALL SOILMOIST ( & !-- input - delt,nzs,nddzs,DTDZS,DTDZS2, & + delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & +! QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output - SOILMOIS,MAVAIL,RUNOFF1, & + SOILMOIS,SOILIQW,MAVAIL,RUNOFF1, & RUNOFF2,INFILTRP) !--- KEEPFR is 1 when the temperature and moisture in soil @@ -1697,29 +1814,35 @@ CONTAINS UPFLUX = T3 *SOILT XINET = EMISS*(GLW-UPFLUX) RNET = GSW + XINET - HFT=-TKMS*CP*RHO*(TABS-SOILT) + HFT=-TKMS*CP*RHO*(TABS-SOILT) & + *(P1000mb*0.00001/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) - EDIR1 =-(1.-vegfrac)*QKMS*RAS* & - (QVATM-QVG) IF (Q1.LE.0.) THEN ! --- condensation EC1=0. EDIR1=0. ETT1=0. -! EETA=0. - QFX=- XLV*RHO*DEW - EETA= QFX/XLV +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + QFX= XLV*EETA +!-- actual moisture flux from RUC LSM + EETA= RHO*DEW ELSE ! --- evaporation + EDIR1 =-(1.-vegfrac)*QKMS*RAS* & + (QVATM-QVG) EC1 = Q1 * WETCAN CMC2MS=CST/DELT if(EC1.gt.CMC2MS) cst=0. EC1=MIN(CMC2MS,EC1)*vegfrac - EETA = (EDIR1 + EC1 + ETT1)*1.E3 +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLV * EETA +!-- actual moisture flux from RUC LSM + EETA = (EDIR1 + EC1 + ETT1)*1.E3 ENDIF - EVAPL=QFX/XLV + EVAPL=EETA S=THDIF(1)*CAP(1)*DZSTOP*(TSO(1)-TSO(2)) HFX=HFT FLTOT=RNET-HFT-QFX-S @@ -1738,148 +1861,60 @@ CONTAINS END SUBROUTINE SOIL !------------------------------------------------------------------- - - SUBROUTINE SNOWSOIL ( & + SUBROUTINE SICE ( & !--- input variables - i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & - RHOSN, & - PATM,QVATM,QCATM, & - GLW,GSW,EMISS,RNET,IVGTYP, & - QKMS,TKMS,PC,cst,rho,vegfrac,alb,znt, & - MYJ, & -!--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & - sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & + i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, & + EMISS,RNET,QKMS,TKMS,rho, & +!--- sea ice parameters + tice,rhosice,capice,thdifice, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & !--- constants - xlv,CP,G0_P,cw,stbolt,TABS, & - KQWRTZ,KICE,KWT, & + xlv,CP,rovcp,cw,stbolt,tabs, & !--- output variables - ilnb,snweprint,snheiprint,rsm, & - soilmois,tso,smfrkeep,keepfr, & - dew,soilt,soilt1,tsnav, & - qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & - edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & - prcpl,runoff1,runoff2,mavail,soilice, & - soiliqw,infiltrp ) + tso,dew,soilt,qvg,qsg,qcg, & + eeta,qfx,hfx,s,evapl,prcpl & + ) -!*************************************************************** -! Energy and moisture budget for snow, heat diffusion eqns. -! in snow and soil, Richards eqn. for soil covered with snow -! -! DELT - time step (s) -! ktau - numver of time step -! CONFLX - depth of constant flux layer (m) -! J,I - the location of grid point -! IME, JME, NZS - dimensions of the domain -! NROOT - number of levels within the root zone -! PRCPMS - precipitation rate in m/s -! NEWSNOW - pcpn in soilid form (m) -! SNHEI, SNWE - snow height and snow water equivalent (m) -! RHOSN - snow density (kg/m-3) -! PATM - pressure (bar) -! QVATM,QCATM - cloud and water vapor mixing ratio -! at the first atm. level (kg/kg) -! GLW, GSW - incoming longwave and absorbed shortwave -! radiation at the surface (W/m^2) -! EMISS,RNET - emissivity (0-1) of the ground surface and net -! radiation at the surface (W/m^2) -! QKMS - exchange coefficient for water vapor in the -! surface layer (m/s) -! TKMS - exchange coefficient for heat in the surface -! layer (m/s) -! PC - plant coefficient (resistance) (0-1) -! RHO - density of atmosphere near surface (kg/m^3) -! VEGFRAC - greeness fraction (0-1) -! RHOCS - volumetric heat capacity of dry soil (J/m^3/K) -! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3) -! REF, WILT - field capacity soil moisture and the -! wilting point (m^3/m^3) -! PSIS - matrix potential at saturation (m) -! BCLH - exponent for Clapp-Hornberger parameterization -! KSAT - saturated hydraulic conductivity (m/s) -! SAT - maximum value of water intercepted by canopy (m) -! CN - exponent for calculation of canopy water -! ZSMAIN - main levels in soil (m) -! ZSHALF - middle of the soil layers (m) -! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil -! TBQ - table to define saturated mixing ration -! of water vapor for given temperature and pressure -! ilnb - number of layers in snow -! rsm - liquid water inside snow pack (m) -! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K) -! DEW - dew in (kg/m^2 s) -! SOILT - skin temperature (K) -! SOILT1 - snow temperature at 7.5 cm depth (K) -! TSNAV - average temperature of snow pack (C) -! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of -! water vapor and cloud at the ground -! surface, respectively (kg/kg) -! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of -! canopy water, transpiration (kg m-2 s-1) and total -! evaporation in (m s-1). -! QFX, HFX - latent and sensible heat fluxes (W/m^2) -! S - soil heat flux in the top layer (W/m^2) -! SUBLIM - snow sublimation (kg/m^2/s) -! RUNOFF1 - surface runoff (m/s) -! RUNOFF2 - underground runoff (m) -! MAVAIL - moisture availability in the top soil layer (0-1) -! SOILICE - content of soil ice in soil layers (m^3/m^3) -! SOILIQW - lliquid water in soil layers (m^3/m^3) -! INFILTRP - infiltration flux from the top of soil domain (m/s) -! XINET - net long-wave radiation (W/m^2) -! -!******************************************************************* +!***************************************************************** +! Energy budget and heat diffusion eqns. for +! sea ice +!************************************************************* IMPLICIT NONE -!------------------------------------------------------------------- +!----------------------------------------------------------------- + !--- input variables INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & - nddzs !nddzs=2*(nzs-2) - INTEGER, INTENT(IN ) :: i,j,isoil - - REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & - RAINF,NEWSNOW - - LOGICAL, INTENT(IN ) :: myj - + nddzs !nddzs=2*(nzs-2) + INTEGER, INTENT(IN ) :: i,j,iland,isoil + REAL, INTENT(IN ) :: DELT,CONFLX !--- 3-D Atmospheric variables REAL, & INTENT(IN ) :: PATM, & QVATM, & QCATM !--- 2-D variables - REAL , & + REAL, & INTENT(IN ) :: GLW, & GSW, & + EMISS, & RHO, & - PC, & - VEGFRAC, & QKMS, & TKMS +!--- sea ice properties + REAL, DIMENSION(1:NZS) , & + INTENT(IN ) :: & + tice, & + rhosice, & + capice, & + thdifice - INTEGER, INTENT(IN ) :: IVGTYP -!--- soil properties - REAL , & - INTENT(IN ) :: RHOCS, & - BCLH, & - DQM, & - KSAT, & - PSIS, & - QMIN, & - QWRTZ, & - REF, & - SAT, & - WILT - REAL, INTENT(IN ) :: CN, & + REAL, INTENT(IN ) :: & CW, & - XLV, & - G0_P, & - KQWRTZ, & - KICE, & - KWT + XLV REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & @@ -1892,209 +1927,532 @@ CONTAINS !--- input/output variables -!-------- 3-d soil moisture and temperature - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: TSO, & - SOILMOIS, & - SMFRKEEP - - REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: KEEPFR - - - INTEGER, INTENT(INOUT) :: ILAND - - +!----soil temperature + REAL, DIMENSION( 1:nzs ), INTENT(INOUT) :: TSO !-------- 2-d variables - REAL , & + REAL, & INTENT(INOUT) :: DEW, & - CST, & - EDIR1, & - EC1, & - ETT1, & EETA, & - RHOSN, & - SUBLIM, & + EVAPL, & PRCPL, & - ALB, & - EMISS, & - ZNT, & - MAVAIL, & QVG, & QSG, & QCG, & + RNET, & QFX, & HFX, & S, & - RUNOFF1, & - RUNOFF2, & - SNWE, & - SNHEI, & - SMELT, & - SNOM, & - SNOH, & - SNFLX, & - SOILT, & - SOILT1, & - SNOWFRAC, & - TSNAV - - INTEGER, INTENT(INOUT) :: ILNB - -!-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + SOILT - REAL, INTENT(OUT) :: RSM, & - SNWEPRINT, & - SNHEIPRINT !--- Local variables + REAL :: x,x1,x2,x4,tn,denom + REAL :: RAINF, PRCPMS , & + TABS, T3, UPFLUX, XINET + REAL :: CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop , & + epot,fltot,ft,fq,hft,ras,cvw - INTEGER :: nzs1,nzs2,k + REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & + PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & + TDENOM - REAL :: INFILTRP, RHONEWSN,TRANSUM , & - SNTH, NEWSN , & - TABS, T3, UPFLUX, XINET , & - BETA, SNWEPR,EPDT,PP - REAL :: CP,G0,LV,xlvm,STBOLT,xlmelt,dzstop , & - can,epot,fac,fltot,ft,fq,hft , & - q1,ras,rhoice,sph , & - trans,zn,ci,cvw,tln,tavln,pi , & - DD1,CMC2MS,DRYCAN,WETCAN , & - INFMAX,RIW,DELTSN,H,UMVEG + REAL :: AA1,RHCS - REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & - thdif,tranf,tav,soilmoism , & - soilicem,soiliqwm,detal , & - fwsat,lwsat,told,smold - REAL :: drip - REAL :: RNET + REAL, DIMENSION(1:NZS) :: cotso,rhtso + + INTEGER :: nzs1,nzs2,k,k1,kn,kk !----------------------------------------------------------------- - cvw=cw - XLMELT=3.335E+5 -!-- the next line calculates heat of sublimation of water vapor - XLVm=XLV+XLMELT +!-- define constants ! STBOLT=5.670151E-8 + XLMELT=3.35E+5 + cvw=cw -!--- SNOW flag -- 99 - ILAND=99 - -!--- DELTSN - is the threshold for splitting the snow layer into 2 layers. -!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, -!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is -!--- computed using SNWE=0.03 m and current snow density. -!--- SNTH - the threshold below which the snow layer is combined with -!--- the top soil layer. SNTH is computed using snwe=0.016 m, and -!--- equals 4 cm for snow density 400 kg/m^3. - - DELTSN=0.0301*1.e3/rhosn - snth=0.01601*1.e3/rhosn - - RHOICE=900. - CI=RHOICE*2100. - RAS=RHO*1.E-3 - RIW=rhoice*1.e-3 - MAVAIL=1. - RSM=0. - - DO K=1,NZS - TRANSP (K)=0. - soilmoism (k)=0. - soiliqwm (k)=0. - soilice (k)=0. - soilicem (k)=0. - lwsat (k)=0. - fwsat (k)=0. - tav (k)=0. - cap (k)=0. - diffu (k)=0. - hydro (k)=0. - thdif (k)=0. - tranf (k)=0. - detal (k)=0. - told (k)=0. - smold (k)=0. - ENDDO - - snweprint=0. - snheiprint=0. prcpl=prcpms -!*** DELTSN is the depth of the top layer of snow where -!*** there is a temperature gradient, the rest of the snow layer -!*** is considered to have constant temperature - - NZS1=NZS-1 NZS2=NZS-2 - DZSTOP=1./(zsmain(2)-zsmain(1)) - -!----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND --- -!----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) --- -!tgs - the following loop is added to define the amount of frozen -!tgs - water in soil if there is any - DO K=1,NZS - - tln=log(tso(k)/273.15) - if(tln.lt.0.) then - soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) - soiliqw(k)=min(soiliqw(k),soilmois(k)) - soilice(k)=(soilmois(k)-soiliqw(k))/riw + dzstop=1./(zsmain(2)-zsmain(1)) + RAS=RHO*1.E-3 -!---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then - soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*rhoice*1.e-3) - endif + do k=1,nzs + cotso(k)=0. + rhtso(k)=0. + enddo - else - soilice(k)=0. - soiliqw(k)=soilmois(k) - endif + cotso(1)=0. + rhtso(1)=TSO(NZS) - ENDDO + DO 33 K=1,NZS2 + KN=NZS-K + K1=2*KN-3 + X1=DTDZS(K1)*THDIFICE(KN-1) + X2=DTDZS(K1+1)*THDIFICE(KN) + FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & + -X2*(TSO(KN)-TSO(KN+1)) + DENOM=1.+X1+X2-X2*cotso(K) + cotso(K+1)=X1/DENOM + rhtso(K+1)=(FT+X2*rhtso(K))/DENOM + 33 CONTINUE - DO K=1,NZS1 +!************************************************************************ +!--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26) + RHCS=CAPICE(1) + H=1. + FKT=TKMS + D1=cotso(NZS1) + D2=rhtso(NZS1) + TN=SOILT + D9=THDIFICE(1)*RHCS*dzstop + D10=TKMS*CP*RHO + R211=.5*CONFLX/DELT + R21=R211*CP*RHO + R22=.5/(THDIFICE(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5*TN**4 + R7=R6/TN + D11=RNET+R6 + TDENOM=D9*(1.-D1+R22)+D10+R21+R7 & + +RAINF*CVW*PRCPMS + FKQ=QKMS*RHO + R210=R211*RHO + AA=XLS*(FKQ+R210)/TDENOM + BB=(D10*TABS+R21*TN+XLS*(QVATM*FKQ & + +R210*QVG)+D11+D9*(D2+R22*TN) & + +RAINF*CVW*PRCPMS*max(273.15,TABS) & + )/TDENOM + AA1=AA + PP=PATM*1.E3 + AA1=AA1/PP + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + PRINT *,' VILKA-SEAICE1' + print *,'D10,TABS,R21,TN,QVATM,FKQ', & + D10,TABS,R21,TN,QVATM,FKQ + print *,'RNET, EMISS, STBOLT, SOILT',RNET, EMISS, STBOLT, SOILT + print *,'R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM', & + R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM + print *,'tn,aa1,bb,pp,fkq,r210', & + tn,aa1,bb,pp,fkq,r210 + ENDIF + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) +!--- it is saturation over sea ice + QVG=QS1 + QSG=QS1 + TSO(1)=min(271.4,TS1) + QCG=0. +!--- sea ice melting is not included in this simple approach +!--- SOILT - skin temperature + SOILT=TSO(1) +!---- Final solution for soil temperature - TSO + DO K=2,NZS + KK=NZS-K+1 + TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) + END DO +!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW + DEW=0. - tav(k)=0.5*(tso(k)+tso(k+1)) - soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) - tavln=log(tav(k)/273.15) +!--- THE DIAGNOSTICS OF SURFACE FLUXES + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + HFT=-TKMS*CP*RHO*(TABS-SOILT) & + *(P1000mb*0.00001/Patm)**ROVCP + Q1=-QKMS*RAS*(QVATM - QSG) + IF (Q1.LE.0.) THEN +! --- condensation +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + QFX= XLS*EETA +!-- actual moisture flux from RUC LSM + DEW=QKMS*(QVATM-QSG) + EETA= RHO*DEW + ELSE +! --- evaporation +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 +! EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ + QFX= XLS * EETA +!-- actual moisture flux from RUC LSM + EETA = Q1*1.E3 + ENDIF + EVAPL=EETA + S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2)) + HFX=HFT + FLTOT=RNET-HFT-QFX-S - if(tavln.lt.0.) then - soiliqwm(k)=(dqm+qmin)*(XLMELT* & - (tav(k)-273.15)/tav(k)/9.81/psis) & - **(-1./bclh)-qmin - fwsat(k)=dqm-soiliqwm(k) - lwsat(k)=soiliqwm(k)+qmin - soiliqwm(k)=max(0.,soiliqwm(k)) - soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) - soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw -!---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then - soilicem(k)=min(soilicem(k), & - 0.5*(smfrkeep(k)+smfrkeep(k+1))) - soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) - fwsat(k)=dqm-soiliqwm(k) - lwsat(k)=soiliqwm(k)+qmin - endif +!------------------------------------------------------------------- + END SUBROUTINE SICE +!------------------------------------------------------------------- - else - soilicem(k)=0. - soiliqwm(k)=soilmoism(k) - lwsat(k)=dqm+qmin - fwsat(k)=0. - endif - ENDDO - do k=1,nzs + SUBROUTINE SNOWSOIL ( & +!--- input variables + i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + meltfactor,rhonewsn, & ! new + ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & + RHOSN, & + PATM,QVATM,QCATM, & + GLW,GSW,EMISS,RNET,IVGTYP, & + QKMS,TKMS,PC,cst,rho,vegfrac,alb,znt, & + MYJ, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & + sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + xlv,CP,rovcp,G0_P,cw,stbolt,TABS, & + KQWRTZ,KICE,KWT, & +!--- output variables + ilnb,snweprint,snheiprint,rsm, & + soilmois,tso,smfrkeep,keepfr, & + dew,soilt,soilt1,tsnav, & + qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & + edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & + prcpl,runoff1,runoff2,mavail,soilice, & + soiliqw,infiltrp ) + +!*************************************************************** +! Energy and moisture budget for snow, heat diffusion eqns. +! in snow and soil, Richards eqn. for soil covered with snow +! +! DELT - time step (s) +! ktau - numver of time step +! CONFLX - depth of constant flux layer (m) +! J,I - the location of grid point +! IME, JME, NZS - dimensions of the domain +! NROOT - number of levels within the root zone +! PRCPMS - precipitation rate in m/s +! NEWSNOW - pcpn in soilid form (m) +! SNHEI, SNWE - snow height and snow water equivalent (m) +! RHOSN - snow density (kg/m-3) +! PATM - pressure (bar) +! QVATM,QCATM - cloud and water vapor mixing ratio +! at the first atm. level (kg/kg) +! GLW, GSW - incoming longwave and absorbed shortwave +! radiation at the surface (W/m^2) +! EMISS,RNET - emissivity (0-1) of the ground surface and net +! radiation at the surface (W/m^2) +! QKMS - exchange coefficient for water vapor in the +! surface layer (m/s) +! TKMS - exchange coefficient for heat in the surface +! layer (m/s) +! PC - plant coefficient (resistance) (0-1) +! RHO - density of atmosphere near surface (kg/m^3) +! VEGFRAC - greeness fraction (0-1) +! RHOCS - volumetric heat capacity of dry soil (J/m^3/K) +! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3) +! REF, WILT - field capacity soil moisture and the +! wilting point (m^3/m^3) +! PSIS - matrix potential at saturation (m) +! BCLH - exponent for Clapp-Hornberger parameterization +! KSAT - saturated hydraulic conductivity (m/s) +! SAT - maximum value of water intercepted by canopy (m) +! CN - exponent for calculation of canopy water +! ZSMAIN - main levels in soil (m) +! ZSHALF - middle of the soil layers (m) +! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil +! TBQ - table to define saturated mixing ration +! of water vapor for given temperature and pressure +! ilnb - number of layers in snow +! rsm - liquid water inside snow pack (m) +! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K) +! DEW - dew in (kg/m^2 s) +! SOILT - skin temperature (K) +! SOILT1 - snow temperature at 7.5 cm depth (K) +! TSNAV - average temperature of snow pack (C) +! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of +! water vapor and cloud at the ground +! surface, respectively (kg/kg) +! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of +! canopy water, transpiration (kg m-2 s-1) and total +! evaporation in (m s-1). +! QFX, HFX - latent and sensible heat fluxes (W/m^2) +! S - soil heat flux in the top layer (W/m^2) +! SUBLIM - snow sublimation (kg/m^2/s) +! RUNOFF1 - surface runoff (m/s) +! RUNOFF2 - underground runoff (m) +! MAVAIL - moisture availability in the top soil layer (0-1) +! SOILICE - content of soil ice in soil layers (m^3/m^3) +! SOILIQW - lliquid water in soil layers (m^3/m^3) +! INFILTRP - infiltration flux from the top of soil domain (m/s) +! XINET - net long-wave radiation (W/m^2) +! +!******************************************************************* + + IMPLICIT NONE +!------------------------------------------------------------------- +!--- input variables + + INTEGER, INTENT(IN ) :: nroot,ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + INTEGER, INTENT(IN ) :: i,j,isoil + + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + RAINF,NEWSNOW,RHONEWSN,meltfactor + + LOGICAL, INTENT(IN ) :: myj + +!--- 3-D Atmospheric variables + REAL, & + INTENT(IN ) :: PATM, & + QVATM, & + QCATM +!--- 2-D variables + REAL , & + INTENT(IN ) :: GLW, & + GSW, & + RHO, & + PC, & + VEGFRAC, & + QKMS, & + TKMS + + INTEGER, INTENT(IN ) :: IVGTYP +!--- soil properties + REAL , & + INTENT(IN ) :: RHOCS, & + BCLH, & + DQM, & + KSAT, & + PSIS, & + QMIN, & + QWRTZ, & + REF, & + SAT, & + WILT + + REAL, INTENT(IN ) :: CN, & + CW, & + XLV, & + G0_P, & + KQWRTZ, & + KICE, & + KWT + + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TSO, & + SOILMOIS, & + SMFRKEEP + + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: KEEPFR + + + INTEGER, INTENT(INOUT) :: ILAND + + +!-------- 2-d variables + REAL , & + INTENT(INOUT) :: DEW, & + CST, & + EDIR1, & + EC1, & + ETT1, & + EETA, & + RHOSN, & + SUBLIM, & + PRCPL, & + ALB, & + EMISS, & + ZNT, & + MAVAIL, & + QVG, & + QSG, & + QCG, & + QFX, & + HFX, & + S, & + RUNOFF1, & + RUNOFF2, & + SNWE, & + SNHEI, & + SMELT, & + SNOM, & + SNOH, & + SNFLX, & + SOILT, & + SOILT1, & + SNOWFRAC, & + TSNAV + + INTEGER, INTENT(INOUT) :: ILNB + +!-------- 1-d variables + REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & + SOILIQW + + REAL, INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT +!--- Local variables + + + INTEGER :: nzs1,nzs2,k + + REAL :: INFILTRP, TRANSUM , & + SNTH, NEWSN , & + TABS, T3, UPFLUX, XINET , & + BETA, SNWEPR,EPDT,PP + REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt,dzstop , & + can,epot,fac,fltot,ft,fq,hft , & + q1,ras,rhoice,sph , & + trans,zn,ci,cvw,tln,tavln,pi , & + DD1,CMC2MS,DRYCAN,WETCAN , & + INFMAX,RIW,DELTSN,H,UMVEG + + REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & + thdif,tranf,tav,soilmoism , & + soilicem,soiliqwm,detal , & + fwsat,lwsat,told,smold + REAL :: drip + + REAL :: RNET + +!----------------------------------------------------------------- + + cvw=cw + XLMELT=3.35E+5 +!-- the next line calculates heat of sublimation of water vapor + XLVm=XLV+XLMELT +! STBOLT=5.670151E-8 + +!--- SNOW flag -- 99 + ILAND=99 + +!--- DELTSN - is the threshold for splitting the snow layer into 2 layers. +!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, +!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is +!--- computed using SNWE=0.03 m and current snow density. +!--- SNTH - the threshold below which the snow layer is combined with +!--- the top soil layer. SNTH is computed using snwe=0.016 m, and +!--- equals 4 cm for snow density 400 kg/m^3. + + DELTSN=0.0301*1.e3/rhosn + snth=0.01601*1.e3/rhosn + +!tgs when the snow depth is marginlly higher than DELTSN, +! reset DELTSN to half of snow depth. + IF(SNHEI.GT.DELTSN+SNTH) THEN +! 2-layer model + if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + ENDIF + + RHOICE=900. + CI=RHOICE*2100. + RAS=RHO*1.E-3 + RIW=rhoice*1.e-3 + MAVAIL=1. + RSM=0. + + DO K=1,NZS + TRANSP (K)=0. + soilmoism (k)=0. + soiliqwm (k)=0. + soilice (k)=0. + soilicem (k)=0. + lwsat (k)=0. + fwsat (k)=0. + tav (k)=0. + cap (k)=0. + diffu (k)=0. + hydro (k)=0. + thdif (k)=0. + tranf (k)=0. + detal (k)=0. + told (k)=0. + smold (k)=0. + ENDDO + + snweprint=0. + snheiprint=0. + prcpl=prcpms + +!*** DELTSN is the depth of the top layer of snow where +!*** there is a temperature gradient, the rest of the snow layer +!*** is considered to have constant temperature + + + NZS1=NZS-1 + NZS2=NZS-2 + DZSTOP=1./(zsmain(2)-zsmain(1)) + +!----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND --- +!----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) --- +!tgs - the following loop is added to define the amount of frozen +!tgs - water in soil if there is any + DO K=1,NZS + + tln=log(tso(k)/273.15) + if(tln.lt.0.) then + soiliqw(k)=(dqm+qmin)*(XLMELT* & + (tso(k)-273.15)/tso(k)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(k)=max(0.,soiliqw(k)) + soiliqw(k)=min(soiliqw(k),soilmois(k)) + soilice(k)=(soilmois(k)-soiliqw(k))/riw + +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilice(k)=min(soilice(k),smfrkeep(k)) + soiliqw(k)=max(0.,soilmois(k)-soilice(k)*rhoice*1.e-3) + endif + + else + soilice(k)=0. + soiliqw(k)=soilmois(k) + endif + + ENDDO + + DO K=1,NZS1 + + tav(k)=0.5*(tso(k)+tso(k+1)) + soilmoism(k)=0.5*(soilmois(k)+soilmois(k+1)) + tavln=log(tav(k)/273.15) + + if(tavln.lt.0.) then + soiliqwm(k)=(dqm+qmin)*(XLMELT* & + (tav(k)-273.15)/tav(k)/9.81/psis) & + **(-1./bclh)-qmin + fwsat(k)=dqm-soiliqwm(k) + lwsat(k)=soiliqwm(k)+qmin + soiliqwm(k)=max(0.,soiliqwm(k)) + soiliqwm(k)=min(soiliqwm(k), soilmoism(k)) + soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilicem(k)=min(soilicem(k), & + 0.5*(smfrkeep(k)+smfrkeep(k+1))) + soiliqwm(k)=max(0.,soilmoism(k)-soilicem(k)*riw) + fwsat(k)=dqm-soiliqwm(k) + lwsat(k)=soiliqwm(k)+qmin + endif + + else + soilicem(k)=0. + soiliqwm(k)=soilmoism(k) + lwsat(k)=dqm+qmin + fwsat(k)=0. + + endif + ENDDO + + do k=1,nzs if(soilice(k).gt.0.) then smfrkeep(k)=soilice(k) else @@ -2102,315 +2460,946 @@ CONTAINS endif enddo +!****************************************************************** +! SOILPROP computes thermal diffusivity, and diffusional and +! hydraulic condeuctivities +!****************************************************************** + CALL SOILPROP( & +!--- input variables + nzs,fwsat,lwsat,tav,keepfr, & + soilmois,soiliqw,soilice, & + soilmoism,soiliqwm,soilicem, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & +!--- constants + riw,xlmelt,CP,G0_P,cvw,ci, & + kqwrtz,kice,kwt, & +!--- output variables + thdif,diffu,hydro,cap) + +!******************************************************************** +!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW + + DRIP=0. + SMELT=0. + DD1=0. + H=1. + + FQ=QKMS + + +!--- If vegfrac.ne.0. then part of falling snow can be +!--- intercepted by the canopy. + + DEW=0. + UMVEG=1.-vegfrac + EPOT = -FQ*(QVATM-QSG) + + IF(vegfrac.EQ.0.) then + cst=0. + drip=0. + ELSE + IF(EPOT.GE.0.) THEN +! Evaporation +! DD1=CST+(NEWSNOW*RHOSN*1.E-3 & + DD1=CST+(NEWSNOW*RHOnewSN*1.E-3 & +!-- this change will not let liquid waer be intercepted by the canopy.... + -DELT*(RAS*EPOT & +! -DELT*(-PRCPMS+RAS*EPOT & + *(CST/SAT)**CN)) *vegfrac + ELSE +! Sublimation + DEW = - EPOT +! DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*( & + DD1=CST+(NEWSNOW*RHOnewSN*1.E-3+delt*( & +! DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*(PRCPMS & + +DEW*RAS)) *vegfrac + ENDIF + + IF(DD1.LT.0.) DD1=0. + IF (vegfrac.GT.0.) THEN + CST=DD1 + IF(CST.GT.SAT*vegfrac) THEN + CST=SAT*vegfrac + DRIP=DD1-SAT*vegfrac + ENDIF + ENDIF + + +!--- In SFCTMP NEWSNOW is added to SNHEI as if there is no vegetation +!--- With vegetation part of NEWSNOW can be intercepted by canopy until +!--- the saturation is reached. After the canopy saturation is reached +!--- DRIP in the solid form will be added to SNOW cover. + + SNWE=(SNHEI-vegfrac*NEWSNOW)*RHOSN*1.E-3 & + + DRIP + + ENDIF + + DRIP=0. + SNHEI=SNWE*1.e3/RHOSN + SNWEPR=SNWE + +! check if all snow can evaporate during DT + BETA=1. + EPDT = EPOT * RAS *DELT*UMVEG + IF(SNWEPR.LE.EPDT) THEN + BETA=SNWEPR/max(1.e-8,EPDT) + SNWE=0. + SNHEI=0. + ENDIF + + WETCAN=(CST/SAT)**CN + DRYCAN=1.-WETCAN + +!************************************************************** +! TRANSF computes transpiration function +!************************************************************** + CALL TRANSF( & +!--- input variables + nzs,nroot,soiliqw,tabs, & +!--- soil fixed fields + dqm,qmin,ref,wilt,zshalf, & +!--- output variables + tranf,transum) + +!--- Save soil temp and moisture from the beginning of time step + do k=1,nzs + told(k)=tso(k) + smold(k)=soilmois(k) + enddo + +!************************************************************** +! SNOWTEMP solves heat budget and diffusion eqn. in soil +!************************************************************** + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print *, 'TSO before calling SNOWTEMP: ', tso + ENDIF + CALL SNOWTEMP( & +!--- input variables + i,j,iland,isoil, & + delt,ktau,conflx,nzs,nddzs,nroot, & + snwe,snwepr,snhei,newsnow,snowfrac, & + beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor + PRCPMS,RAINF, & + PATM,TABS,QVATM,QCATM, & + GLW,GSW,EMISS,RNET, & + QKMS,TKMS,PC,rho,vegfrac, & + thdif,cap,drycan,wetcan,cst, & + tranf,transum,dew,mavail, & +!--- soil fixed fields + dqm,qmin,psis,bclh, & + zsmain,zshalf,DTDZS,tbq, & +!--- constants + xlvm,CP,rovcp,G0_P,cvw,stbolt, & +!--- output variables + snweprint,snheiprint,rsm, & + tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & + smelt,snoh,snflx,ilnb) + +!************************************************************************ +!--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW + DEW=0. + ETT1=0. + PP=PATM*1.E3 + QSG= QSN(SOILT,TBQ)/PP + EPOT = -FQ*(QVATM-QSG) + IF(EPOT.GE.0.) THEN +! Evaporation + DO K=1,NROOT + TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & + *PC*tranf(K)*DRYCAN/zshalf(NROOT+1) + IF(TRANSP(K).GT.0.) TRANSP(K)=0. + ETT1=ETT1-TRANSP(K) + ENDDO + DO k=nroot+1,nzs + transp(k)=0. + enddo + + ELSE +! Sublimation + DEW=-EPOT + DO K=1,NZS + TRANSP(K)=0. + ENDDO + ETT1=0. + ENDIF + +!-- recalculating of frozen water in soil + DO K=1,NZS + tln=log(tso(k)/273.15) + if(tln.lt.0.) then + soiliqw(k)=(dqm+qmin)*(XLMELT* & + (tso(k)-273.15)/tso(k)/9.81/psis) & + **(-1./bclh)-qmin + soiliqw(k)=max(0.,soiliqw(k)) + soiliqw(k)=min(soiliqw(k),soilmois(k)) + soilice(k)=(soilmois(k)-soiliqw(k))/riw +!---- melting and freezing is balanced, soil ice cannot increase + if(keepfr(k).eq.1.) then + soilice(k)=min(soilice(k),smfrkeep(k)) + soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) + endif + + else + soilice(k)=0. + soiliqw(k)=soilmois(k) + endif + ENDDO + +!************************************************************************* +!--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) +! AND TSO,ETA PROFILES +!************************************************************************* + CALL SOILMOIST ( & +!-- input + delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & + zsmain,zshalf,diffu,hydro, & + QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & + 0.,TRANSP,0., & + 0.,SMELT,soilice,vegfrac, & +!-- soil properties + DQM,QMIN,REF,KSAT,RAS,INFMAX, & +!-- output + SOILMOIS,SOILIQW,MAVAIL,RUNOFF1, & + RUNOFF2,infiltrp) + +! 4 Nov 07 - update CST for snow melt + if(snwe.ne.0.) then + CST=(1.-min(1.,smelt/snwe))*CST + else + CST=0. + endif + +!-- Restore land-use parameters if snow is less than threshold + IF(SNHEI.EQ.0.) then + tsnav=soilt-273.15 + CALL SNOWFREE(ivgtyp,myj,emiss, & + znt,iland) + smelt=smelt+snwe/delt + rsm=0. +! snwe=0. + ENDIF + +! 21apr2009 +! SNOM goes into the passed-in ACSNOM variable in the grid derived type + SNOM=SNOM+SMELT*DELT*1.e3 + +!--- KEEPFR is 1 when the temperature and moisture in soil +!--- are both increasing. In this case soil ice should not +!--- be increasing according to the freezing curve. +!--- Some part of ice is melted, but additional water is +!--- getting frozen. Thus, only structure of frozen soil is +!--- changed, and phase changes are not affecting the heat +!--- transfer. This situation may happen when it rains on the +!--- frozen soil. + + do k=1,nzs + if (soilice(k).gt.0.) then + if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then + keepfr(k)=1. + else + keepfr(k)=0. + endif + endif + enddo +!--- THE DIAGNOSTICS OF SURFACE FLUXES + + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + HFT=-TKMS*CP*RHO*(TABS-SOILT) & + *(P1000mb*0.00001/Patm)**ROVCP + Q1 = - FQ*RAS* (QVATM - QSG) + + IF (Q1.LT.0.) THEN +! --- condensation + EDIR1=0. + EC1=0. + ETT1=0. +! --- condensation +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + QFX= XLVm*EETA +!-- actual moisture flux from RUC LSM + DEW=QKMS*(QVATM-QSG) + EETA= RHO*DEW + ELSE +! --- evaporation + EDIR1 = Q1*UMVEG *BETA + EC1 = Q1 * WETCAN + CMC2MS=CST/DELT + if(EC1.gt.CMC2MS) cst=0. + EC1=MIN(CMC2MS,EC1)*vegfrac +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 +! EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ + QFX= XLVm * EETA +!-- actual moisture flux from RUC LSM + EETA = (EDIR1 + EC1 + ETT1)*1.E3 + ENDIF + s=THDIF(1)*CAP(1)*dzstop*(tso(1)-tso(2)) + HFX=HFT + FLTOT=RNET-HFT-QFX-S + + 222 CONTINUE + + 1123 FORMAT(I5,8F12.3) + 1133 FORMAT(I7,8E12.4) + 123 format(i6,f6.2,7f8.1) + 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) + + +! RETURN +! END +!------------------------------------------------------------------- + END SUBROUTINE SNOWSOIL +!------------------------------------------------------------------- + + SUBROUTINE SNOWSEAICE( & + i,j,isoil,delt,ktau,conflx,nzs,nddzs, & + meltfactor,rhonewsn, & ! new + ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & + RHOSN,PATM,QVATM,QCATM, & + GLW,GSW,EMISS,RNET, & + QKMS,TKMS,RHO, & +!--- sea ice parameters + ALB,ZNT, & + tice,rhosice,capice,thdifice, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + xlv,CP,rovcp,cw,stbolt,tabs, & +!--- output variables + ilnb,snweprint,snheiprint,rsm,tso, & + dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & + SMELT,SNOH,SNFLX,SNOM,eeta, & + qfx,hfx,s,sublim,prcpl & + ) +!*************************************************************** +! Solving energy budget for snow on sea ice and heat diffusion +! eqns. in snow and sea ice +!*************************************************************** + + + IMPLICIT NONE +!------------------------------------------------------------------- +!--- input variables + + INTEGER, INTENT(IN ) :: ktau,nzs , & + nddzs !nddzs=2*(nzs-2) + INTEGER, INTENT(IN ) :: i,j,isoil + + REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & + RAINF,NEWSNOW,RHONEWSN,meltfactor + real :: rhonewcsn + +!--- 3-D Atmospheric variables + REAL, & + INTENT(IN ) :: PATM, & + QVATM, & + QCATM +!--- 2-D variables + REAL , & + INTENT(IN ) :: GLW, & + GSW, & + RHO, & + QKMS, & + TKMS + +!--- sea ice properties + REAL, DIMENSION(1:NZS) , & + INTENT(IN ) :: & + tice, & + rhosice, & + capice, & + thdifice + + REAL, INTENT(IN ) :: & + CW, & + XLV + + REAL, DIMENSION(1:NZS), INTENT(IN) :: ZSMAIN, & + ZSHALF, & + DTDZS2 + + REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS + + REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + +!--- input/output variables +!-------- 3-d soil moisture and temperature + REAL, DIMENSION( 1:nzs ) , & + INTENT(INOUT) :: TSO + + INTEGER, INTENT(INOUT) :: ILAND + + +!-------- 2-d variables + REAL , & + INTENT(INOUT) :: DEW, & + EETA, & + RHOSN, & + SUBLIM, & + PRCPL, & + ALB, & + EMISS, & + ZNT, & + QVG, & + QSG, & + QCG, & + QFX, & + HFX, & + S, & + SNWE, & + SNHEI, & + SMELT, & + SNOM, & + SNOH, & + SNFLX, & + SOILT, & + SOILT1, & + SNOWFRAC, & + TSNAV + + INTEGER, INTENT(INOUT) :: ILNB + + REAL, INTENT(OUT) :: RSM, & + SNWEPRINT, & + SNHEIPRINT +!--- Local variables + + + INTEGER :: nzs1,nzs2,k,k1,kn,kk + REAL :: x,x1,x2,dzstop,ft,tn,denom + + REAL :: SNTH, NEWSN , & + TABS, T3, UPFLUX, XINET , & + BETA, SNWEPR,EPDT,PP + REAL :: CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt , & + epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw , & + RIW,DELTSN,H + + REAL :: rhocsn,thdifsn, & + xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn + + REAL :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn + REAL :: fso,fsn, & + FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11, & + FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2, & + TDENOM,AA1,RHCS,H1,TSOB, SNPRIM, & + SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW + REAL, DIMENSION(1:NZS) :: cotso,rhtso + + REAL :: RNET,rsmfrac,soiltfrac,hsn + integer :: nmelt + + +!----------------------------------------------------------------- + XLMELT=3.35E+5 +!-- the next line calculates heat of sublimation of water vapor + XLVm=XLV+XLMELT +! STBOLT=5.670151E-8 + +!--- SNOW flag -- 99 + ILAND=99 + +!--- DELTSN - is the threshold for splitting the snow layer into 2 layers. +!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, +!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is +!--- computed using SNWE=0.03 m and current snow density. +!--- SNTH - the threshold below which the snow layer is combined with +!--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and +!--- equals 4 cm for snow density 400 kg/m^3. + + DELTSN=0.0301*1.e3/rhosn + snth=0.01601*1.e3/rhosn + +!tgs when the snow depth is marginlly higher than DELTSN, +! reset DELTSN to half of snow depth. + IF(SNHEI.GT.DELTSN+SNTH) THEN +! 2-layer model + if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + ENDIF + + + RHOICE=900. + CI=RHOICE*2100. + RAS=RHO*1.E-3 + RIW=rhoice*1.e-3 + RSM=0. + + XLMELT=3.35E+5 + RHOCSN=2090.* RHOSN +!18apr08 - add rhonewcsn + RHOnewCSN=2090.* RHOnewSN + THDIFSN = 0.265/RHOCSN + RAS=RHO*1.E-3 + + SOILTFRAC=SOILT + + SMELT=0. + SOH=0. + SNODIF=0. + SNOH=0. + SNOHGNEW=0. + RSM = 0. + RSMFRAC = 0. + fsn=1. + fso=0. + hsn=snhei + + NZS1=NZS-1 + NZS2=NZS-2 + + QGOLD=QVG + TNOLD=SOILT + DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) + + snweprint=0. + snheiprint=0. + prcpl=prcpms + +!*** DELTSN is the depth of the top layer of snow where +!*** there is a temperature gradient, the rest of the snow layer +!*** is considered to have constant temperature + + + H=1. + SMELT=0. + + FQ=QKMS + SNHEI=SNWE*1.e3/RHOSN + SNWEPR=SNWE + +! check if all snow can evaporate during DT + BETA=1. + EPDT = EPOT * RAS *DELT + IF(SNWEPR.LE.EPDT) THEN + BETA=SNWEPR/max(1.e-8,EPDT) + SNWE=0. + SNHEI=0. + ENDIF + +!****************************************************************************** +! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO +!****************************************************************************** + + cotso(1)=0. + rhtso(1)=TSO(NZS) + DO 33 K=1,NZS2 + KN=NZS-K + K1=2*KN-3 + X1=DTDZS(K1)*THDIFICE(KN-1) + X2=DTDZS(K1+1)*THDIFICE(KN) + FT=TSO(KN)+X1*(TSO(KN-1)-TSO(KN)) & + -X2*(TSO(KN)-TSO(KN+1)) + DENOM=1.+X1+X2-X2*cotso(K) + cotso(K+1)=X1/DENOM + rhtso(K+1)=(FT+X2*rhtso(K))/DENOM + 33 CONTINUE +!--- THE NZS element in COTSO and RHTSO will be for snow +!--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH + IF(SNHEI.GT.SNTH) then + if(snhei.le.DELTSN+SNTH) then +!-- 1-layer snow model + ilnb=1 + snprim=snhei + soilt1=tso(1) + tsob=tso(1) + XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) + DDZSN = XSN / SNPRIM + X1SN = DDZSN * thdifsn + X2 = DTDZS(1)*THDIFICE(1) + FT = TSO(1)+X1SN*(SOILT-TSO(1)) & + -X2*(TSO(1)-TSO(2)) + DENOM = 1. + X1SN + X2 -X2*cotso(NZS1) + cotso(NZS)=X1SN/DENOM + rhtso(NZS)=(FT+X2*rhtso(NZS1))/DENOM + cotsn=cotso(NZS) + rhtsn=rhtso(NZS) +!*** Average temperature of snow pack (C) + tsnav=0.5*(soilt+tso(1)) & + -273.15 + + else +!-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth + ilnb=2 + snprim=deltsn + tsob=soilt1 + XSN = DELT/2./(0.5*SNHEI) + XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) + DDZSN = XSN / DELTSN + DDZSN1 = XSN1 / (SNHEI-DELTSN) + X1SN = DDZSN * thdifsn + X1SN1 = DDZSN1 * thdifsn + X2 = DTDZS(1)*THDIFICE(1) + FT = TSO(1)+X1SN1*(SOILT1-TSO(1)) & + -X2*(TSO(1)-TSO(2)) + DENOM = 1. + X1SN1 + X2 - X2*cotso(NZS1) + cotso(nzs)=x1sn1/denom + rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom + ftsnow = soilt1+x1sn*(soilt-soilt1) & + -x1sn1*(soilt1-tso(1)) + denomsn = 1. + X1SN + X1SN1 - X1SN1*cotso(NZS) + cotsn=x1sn/denomsn + rhtsn=(ftsnow+X1SN1*rhtso(NZS))/denomsn +!*** Average temperature of snow pack (C) + tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15 + endif + ENDIF + + IF(SNHEI.LE.SNTH.AND.SNHEI.GT.0.) then +!--- snow is too thin to be treated separately, therefore it +!--- is combined with the first sea ice layer. + fsn=SNHEI/(SNHEI+zsmain(2)) + fso=1.-fsn + soilt1=tso(1) + tsob=tso(2) + snprim=SNHEI+zsmain(2) + XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + DDZSN = XSN /snprim + X1SN = DDZSN * (fsn*thdifsn+fso*thdifice(1)) + X2=DTDZS(2)*THDIFICE(2) + FT=TSO(2)+X1SN*(SOILT-TSO(2))- & + X2*(TSO(2)-TSO(3)) + denom = 1. + x1sn + x2 - x2*cotso(nzs-2) + cotso(nzs1) = x1sn/denom + rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom + tsnav=0.5*(soilt+tso(1)) & + -273.15 + ENDIF + +!************************************************************************ +!--- THE HEAT BALANCE EQUATION +!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes + nmelt=0 + SNOH=0. -! print *,'etaf,etal,etamf,etaml,lwsat,fwsat', -! 1 soilice,soiliqw,soilicem,soiliqwm,lwsat,fwsat + EPOT=-QKMS*(QVATM-QSG) + RHCS=CAPICE(1) + H=1. + FKT=TKMS + D1=cotso(NZS1) + D2=rhtso(NZS1) + TN=SOILT + D9=THDIFICE(1)*RHCS*dzstop + D10=TKMS*CP*RHO + R211=.5*CONFLX/DELT + R21=R211*CP*RHO + R22=.5/(THDIFICE(1)*DELT*dzstop**2) + R6=EMISS *STBOLT*.5*TN**4 + R7=R6/TN + D11=RNET+R6 -!****************************************************************** -! SOILPROP computes thermal diffusivity, and diffusional and -! hydraulic condeuctivities -!****************************************************************** - CALL SOILPROP( & -!--- input variables - nzs,fwsat,lwsat,tav,keepfr, & - soilmois,soiliqw,soilice, & - soilmoism,soiliqwm,soilicem, & -!--- soil fixed fields - QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & -!--- constants - riw,xlmelt,CP,G0_P,cvw,ci, & - kqwrtz,kice,kwt, & -!--- output variables - thdif,diffu,hydro,cap) + IF(SNHEI.GT.SNTH) THEN + D1SN = cotsn + D2SN = rhtsn + D9SN= THDIFSN*RHOCSN / SNPRIM + R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + ENDIF -!******************************************************************** -!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - - DRIP=0. - SMELT=0. - DD1=0. - H=1. + IF(SNHEI.LE.SNTH.AND.SNHEI.GT.0.) then +!--- thin snow is combined with sea ice + D1SN = D1 + D2SN = D2 + D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIFICE(1)*RHCS)/ & + snprim + R22SN = snprim*snprim*0.5 & + /((fsn*THDIFSN+fso*THDIFICE(1))*delt) + ENDIF - FQ=QKMS + IF(SNHEI.eq.0.)then +!--- all snow is sublimated + D9SN = D9 + R22SN = R22 + D1SN = D1 + D2SN = D2 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' SNHEI = 0, D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN + ENDIF + ENDIF +!---- TDENOM for snow +!18apr08 - the iteration start point + 212 continue + TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & + +RAINF*CVW*PRCPMS & + +RHOnewCSN*NEWSNOW/DELT -!--- If vegfrac.ne.0. then part of falling snow can be -!--- intercepted by the canopy. + FKQ=QKMS*RHO + R210=R211*RHO + AA=XLVM*(BETA*FKQ+R210)/TDENOM + BB=(D10*TABS+R21*TN+XLVM*(QVATM* & + (BETA*FKQ) & + +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & + +RAINF*CVW*PRCPMS*max(273.15,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & +!18apr08 - add heat of snow phase change + -SNOH & + )/TDENOM + AA1=AA + PP=PATM*1.E3 + AA1=AA1/PP + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'VILKA-SNOW on SEAICE' + print *,'tn,aa1,bb,pp,fkq,r210', & + tn,aa1,bb,pp,fkq,r210 + ENDIF - DEW=0. - UMVEG=1.-vegfrac - EPOT = -FQ*(QVATM-QSG) + CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) +!--- it is saturation over snow + QVG=QS1 + QSG=QS1 + QCG=0. - IF(vegfrac.EQ.0.) then - cst=0. - drip=0. - ELSE - IF(EPOT.GE.0.) THEN -! Evaporation - DD1=CST+(NEWSNOW*RHOSN*1.E-3 & -!-- need to think more if we want this change.... - -DELT*(RAS*EPOT & -! -DELT*(-PRCPMS+RAS*EPOT & - *(CST/SAT)**CN)) *vegfrac - ELSE -! Sublimation - DEW = - EPOT - DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*( & -! DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*(PRCPMS & - +DEW*RAS)) *vegfrac +!--- SOILT - skin temperature + SOILT=TS1 + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' AFTER VILKA-SNOW on SEAICE' + print *,' TS1,QS1: ', ts1,qs1 + ENDIF +! Solution for temperature at 7.5 cm depth and snow-seaice interface + IF(SNHEI.GT.SNTH) THEN + if(snhei.gt.DELTSN+SNTH) then +!-- 2-layer snow model + SOILT1=rhtsn+cotsn*SOILT + TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) + tsob=soilt1 + else +!-- 1 layer in snow + TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT)) + SOILT1=TSO(1) + tsob=tso(1) + endif + ELSE + tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) + SOILT1=TSO(1) + tsob=tso(2) + ENDIF + IF(SNHEI.EQ.0.) THEN +!-- all snow is evaporated + SOILT=min(271.4,SOILT) + TSO(1)=SOILT + SOILT1=SOILT + tsob=SOILT ENDIF +!---- Final solution for TSO in sea ice + DO K=2,NZS + KK=NZS-K+1 + TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) + END DO +!--- For thin snow layer combined with the top sea ice layer +!--- TSO is computed by linear inmterpolation between SOILT +!--- and TSO(2) - IF(DD1.LT.0.) DD1=0. - IF (vegfrac.GT.0.) THEN - CST=DD1 - IF(CST.GT.SAT*vegfrac) THEN - CST=SAT*vegfrac - DRIP=DD1-SAT*vegfrac - ENDIF - ENDIF + if(nmelt.eq.1) go to 220 +!--- IF SOILT > 273.15 F then melting of snow can happen + IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN + nmelt = 1 + soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT + QSG= QSN(soiltfrac,TBQ)/PP + QVG=QSG + T3 = STBOLT*SOILTfrac*SOILTfrac*SOILTfrac + UPFLUX = T3 * SOILTfrac + XINET = EMISS*(GLW-UPFLUX) + RNET = GSW + XINET + EPOT = -QKMS*(QVATM-QSG) + Q1=EPOT*RAS -!--- In SFCTMP NEWSNOW is added to SNHEI as if there is no vegetation -!--- With vegetation part of NEWSNOW can be intercepted by canopy until -!--- the saturation is reached. After the canopy saturation is reached -!--- DRIP in the solid form will be added to SNOW cover. + IF (Q1.LE.0.) THEN +! --- condensation + DEW=-EPOT -!!! 4 Nov 07 SNWE=(SNHEI-vegfrac*NEWSNOW)*RHOSN*1.E-3 & -!!! 4 Nov 07 + DRIP & -! - 10% of liquid precip could be added to snow water -! - this is based on SnowMIP2. -! - something more intelligent should be done to liquid water - SNWE = SNWE & - +0.10*prcpms*delt + QFX= XLVM*RHO*DEW + EETA=QFX/XLVM + ELSE +! --- evaporation + EETA = Q1 * BETA *1.E3 +! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ + QFX= - XLVM * EETA + ENDIF + HFX=D10*(TABS-soiltfrac) + IF(SNHEI.GT.SNTH)then + SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM + SNFLX=SOH + ELSE + SOH=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* & + (soiltfrac-TSOB)/snprim + SNFLX=SOH ENDIF - - DRIP=0. - SNHEI=SNWE*1.e3/RHOSN - SNWEPR=SNWE + X= (R21+D9SN*R22SN)*(soiltfrac-TNOLD) + & + XLVM*R210*(QSG-QGOLD) +!-- SNOH is energy flux of snow phase change + SNOH=RNET+QFX +HFX & + +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-TN) & + -SOH-X+RAINF*CVW*PRCPMS* & + (max(273.15,TABS)-TN) + SNOH=AMAX1(0.,SNOH) +!-- SMELT is speed of melting in M/S + SMELT= SNOH /XLMELT*1.E-3 + SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) +!18apr08 - Egglston limit +! SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) +!-- pre 17 nov09 SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) + SMELT= amin1 (smelt, 9.6E-8*meltfactor*max(1.,(soilt-273.15))) +!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack +!!! rsm=0.13*smelt*delt + if(snwepr.gt.0.) then + rsmfrac=min(0.18,(max(0.08,0.10/snwe*0.13))) +! else +! rsmfrac=0.13 + endif -! check if all snow can evaporate during DT - BETA=1. - EPDT = EPOT * RAS *DELT*UMVEG - IF(SNWEPR.LE.EPDT) THEN - BETA=SNWEPR/max(1.e-8,EPDT) - SNWE=0. - SNHEI=0. - ENDIF + rsm=rsmfrac*smelt*delt - WETCAN=(CST/SAT)**CN - DRYCAN=1.-WETCAN + SNOHGNEW=SMELT*XLMELT*1.E3 + SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) -!************************************************************** -! TRANSF computes transpiration function -!************************************************************** - CALL TRANSF( & -!--- input variables - nzs,nroot,soiliqw,tabs, & -!--- soil fixed fields - dqm,qmin,ref,wilt,zshalf, & -!--- output variables - tranf,transum) + SNOH=SNOHGNEW -!--- Save soil temp and moisture from the beginning of time step - do k=1,nzs - told(k)=tso(k) - smold(k)=soilmois(k) - enddo +!18apr08 rsm is part of melted water that stays in snow as liquid + SMELT=AMAX1(0.,SMELT-rsm/delt) + +!18apr08 - if snow melt occurred then go into iteration for energy budget +! solution +!-- correction of liquid equivalent of snow depth +!-- due to evaporation and snow melt + SNWE = AMAX1(0.,(SNWEPR- & + (SMELT+BETA*EPOT*RAS)*DELT & + ) ) + +!--- If all snow melts, then 13% of snow melt we kept in the +!--- snow pack should be added back to snow melt and infiltrate +!--- into soil. + if(snwe.le.rsm) then + smelt=smelt+rsm/delt + snwe=0. + rsm=0. + else +!*** Correct snow density on effect of snow melt, melted +!*** from the top of the snow. 13% of melted water +!*** remains in the pack and changes its density. +!*** Eq. 9 (with my correction) in Koren et al. (1999) + + if(snwe.gt.0.) then + xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & + snwe + rhosn=MIN(XSN,400.) + + RHOCSN=2090.* RHOSN + thdifsn = 0.265/RHOCSN + endif + + endif + +!--- If there is no snow melting then just evaporation +!--- or condensation cxhanges SNWE + ELSE + EPOT=-QKMS*(QVATM-QSG) + SNWE = AMAX1(0.,(SNWEPR- & + BETA*EPOT*RAS*DELT)) + + ENDIF +!*** Correct snow density on effect of snow melt, melted +!*** from the top of the snow. 13% of melted water +!*** remains in the pack and changes its density. +!*** Eq. 9 (with my correction) in Koren et al. (1999) + + SNHEI=SNWE *1.E3 / RHOSN + + snweprint=snwe +! & +!--- if VEGFRAC.ne.0. then some snow stays on the canopy +!--- and should be added to SNWE for water conservation +! 4 Nov 07 +VEGFRAC*cst + snheiprint=snweprint*1.E3 / RHOSN -!************************************************************** -! SOILTEMP soilves heat budget and diffusion eqn. in soil -!************************************************************** + if(nmelt.eq.1) goto 212 + 220 continue IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -print *, 'TSO before calling SNOWTEMP: ', tso +print *, 'snweprint : ',snweprint +print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ENDIF - CALL SNOWTEMP( & -!--- input variables - i,j,iland,isoil, & - delt,ktau,conflx,nzs,nddzs,nroot, & - snwe,snwepr,snhei,newsnow,snowfrac, & - beta,deltsn,snth,rhosn, & - PRCPMS,RAINF, & - PATM,TABS,QVATM,QCATM, & - GLW,GSW,EMISS,RNET, & - QKMS,TKMS,PC,rho,vegfrac, & - thdif,cap,drycan,wetcan,cst, & - tranf,transum,dew,mavail, & -!--- soil fixed fields - dqm,qmin,psis,bclh, & - zsmain,zshalf,DTDZS,tbq, & -!--- constants - xlvm,CP,G0_P,cvw,stbolt, & -!--- output variables - snweprint,snheiprint,rsm, & - tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & - smelt,snoh,snflx,ilnb) - -!************************************************************************ -!--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW +!--- Compute flux in the top snow layer + SNFLX=D9SN*(SOILT-TSOB) + IF(SNHEI.GT.0.) THEN + if(ilnb.gt.1) then + tsnav=0.5/snhei*((soilt+soilt1)*deltsn & + +(soilt1+tso(1))*(SNHEI-DELTSN)) & + -273.15 + else + tsnav=0.5*(soilt+tso(1)) - 273.15 + endif + ENDIF +!--- RECALCULATION OF DEW USING NEW VALUE OF QSG DEW=0. - ETT1=0. PP=PATM*1.E3 QSG= QSN(SOILT,TBQ)/PP EPOT = -FQ*(QVATM-QSG) - IF(EPOT.GE.0.) THEN -! Evaporation - DO K=1,NROOT - TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & - *PC*tranf(K)*DRYCAN/zshalf(NROOT+1) - IF(TRANSP(K).GT.0.) TRANSP(K)=0. - ETT1=ETT1-TRANSP(K) - ENDDO - DO k=nroot+1,nzs - transp(k)=0. - enddo - - ELSE + IF(EPOT.LT.0.) THEN ! Sublimation DEW=-EPOT - DO K=1,NZS - TRANSP(K)=0. - ENDDO - ETT1=0. ENDIF - -!-- recalculating of frozen water in soil - DO K=1,NZS - tln=log(tso(k)/273.15) - if(tln.lt.0.) then - soiliqw(k)=(dqm+qmin)*(XLMELT* & - (tso(k)-273.15)/tso(k)/9.81/psis) & - **(-1./bclh)-qmin - soiliqw(k)=max(0.,soiliqw(k)) - soiliqw(k)=min(soiliqw(k),soilmois(k)) - soilice(k)=(soilmois(k)-soiliqw(k))/riw -!---- melting and freezing is balanced, soil ice cannot increase - if(keepfr(k).eq.1.) then - soilice(k)=min(soilice(k),smfrkeep(k)) - soiliqw(k)=max(0.,soilmois(k)-soilice(k)*riw) - endif - - else - soilice(k)=0. - soiliqw(k)=soilmois(k) - endif - ENDDO - - INFMAX=999. -!--- The threshold when the infiltration stops is: -!--- volumetric content of unfrozen pores < 0.12 - soilicem(1)=0.5*(soilice(1)+soilice(2)) - if((dqm+qmin-riw*soilicem(1)).lt.0.12) & - INFMAX=0. - -!************************************************************************* -!--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28) -! AND TSO,ETA PROFILES -!************************************************************************* - CALL SOILMOIST ( & -!-- input - delt,nzs,nddzs,DTDZS,DTDZS2, & - zsmain,zshalf,diffu,hydro, & -! 4 Nov 07 QSG,QVG,QCG,QCATM,QVATM,-0.9*PRCPMS/(1.-vegfrac), & - QSG,QVG,QCG,QCATM,QVATM,-0.9*PRCPMS, & -! QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & - 0.,TRANSP,0., & - 0.,SMELT,soilice,vegfrac, & -!-- soil properties - DQM,QMIN,REF,KSAT,RAS,INFMAX, & -!-- output - soilmois,MAVAIL,RUNOFF1, & - RUNOFF2,infiltrp) - -! 4 Nov 07 - update CST for snow melt - if(snwe.ne.0.) then - CST=(1.-min(1.,smelt/snwe))*CST - else - CST=0. - endif - -!-- Restore land-use parameters if snow is less than threshold +!-- Restore sea-ice parameters if snow is less than threshold IF(SNHEI.EQ.0.) then tsnav=soilt-273.15 - CALL SNOWFREE(ivgtyp,myj,emiss, & - znt,iland) smelt=smelt+snwe/delt rsm=0. -! snwe=0. + emiss=1. + znt=0.011 + alb=0.55 ENDIF -! 21apr2009 -! SNOM goes into the passed-in ACSNOM variable in the grid derived type - SNOM=SNOM+SMELT*DELT - -!--- KEEPFR is 1 when the temperature and moisture in soil -!--- are both increasing. In this case soil ice should not -!--- be increasing according to the freezing curve. -!--- Some part of ice is melted, but additional water is -!--- getting frozen. Thus, only structure of frozen soil is -!--- changed, and phase changes are not affecting the heat -!--- transfer. This situation may happen when it rains on the -!--- frozen soil. + SNOM=SNOM+SMELT*DELT*1.e3 - do k=1,nzs - if (soilice(k).gt.0.) then - if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then - keepfr(k)=1. - else - keepfr(k)=0. - endif - endif - enddo !--- THE DIAGNOSTICS OF SURFACE FLUXES T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT - XINET = EMISS*(GLW-UPFLUX) + XINET = EMISS*(GLW-UPFLUX) RNET = GSW + XINET - HFT=- TKMS*CP*RHO*(TABS-SOILT) + HFT=-TKMS*CP*RHO*(TABS-SOILT) & + *(P1000mb*0.00001/Patm)**ROVCP Q1 = - FQ*RAS* (QVATM - QSG) - EDIR1 = Q1*UMVEG *BETA - - IF (Q1.LT.0.) THEN + IF (Q1.LE.0.) THEN ! --- condensation - EC1=0. - EDIR1=0. - ETT1=0. -! EETA=0. - DEW=FQ*(QVATM-QSG) - QFX= -XLVm*RHO*DEW - sublim=QFX/XLVm - eeta=QFX/XLVm - ELSE +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + QFX= XLVm*EETA +!-- actual moisture flux from RUC LSM + DEW=QKMS*(QVATM-QSG) + EETA= RHO*DEW + sublim = EETA + ELSE ! --- evaporation - EC1 = Q1 * WETCAN - CMC2MS=CST/DELT - if(EC1.gt.CMC2MS) cst=0. - EC1=MIN(CMC2MS,EC1)*vegfrac - EETA = (EDIR1 + EC1 + ETT1)*1.E3 +!-- moisture flux for coupling with PBL + EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 +! EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ - QFX= XLVm * EETA - sublim=(EDIR1 + EC1)*1.E3 - ENDIF - s=THDIF(1)*CAP(1)*dzstop*(tso(1)-tso(2)) + QFX= XLVm * EETA +!-- actual moisture flux from RUC LSM + EETA = Q1*1.E3 + sublim = EETA + ENDIF + + s=THDIFICE(1)*CAPICE(1)*dzstop*(tso(1)-tso(2)) +! s=D9SN*(SOILT-TSOB) HFX=HFT FLTOT=RNET-HFT-QFX-S - - 222 CONTINUE - - 1123 FORMAT(I5,8F12.3) - 1133 FORMAT(I7,8E12.4) - 123 format(i6,f6.2,7f8.1) - 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) - - -! RETURN -! END -!------------------------------------------------------------------- - END SUBROUTINE SNOWSOIL -!------------------------------------------------------------------- +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ + END SUBROUTINE SNOWSEAICE +!------------------------------------------------------------------------ SUBROUTINE SOILTEMP( & @@ -2643,7 +3632,7 @@ print *, 'TSO before calling SNOWTEMP: ', tso tn,aa1,bb,pp,umveg,fkq,r210,vegfrac ENDIF CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) - TQ2=QVATM+QCATM + TQ2=QVATM TX2=TQ2*(1.-H) Q1=TX2+H*QS1 IF(Q1.LT.QS1) GOTO 100 @@ -2652,7 +3641,7 @@ print *, 'TSO before calling SNOWTEMP: ', tso 90 QVG=QS1 QSG=QS1 TSO(1)=TS1 - QCG=Q1-QS1 + QCG=max(0.,Q1-QS1) GOTO 200 100 BB=BB-AA*TX2 AA=(AA*H+CC)/PP @@ -2685,8 +3674,6 @@ print *, 'TSO before calling SNOWTEMP: ', tso TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) END DO -! return -! end !-------------------------------------------------------------------- END SUBROUTINE SOILTEMP !-------------------------------------------------------------------- @@ -2697,7 +3684,7 @@ print *, 'TSO before calling SNOWTEMP: ', tso i,j,iland,isoil, & delt,ktau,conflx,nzs,nddzs,nroot, & snwe,snwepr,snhei,newsnow,snowfrac, & - beta,deltsn,snth,rhosn, & + beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor PRCPMS,RAINF, & PATM,TABS,QVATM,QCATM, & GLW,GSW,EMISS,RNET, & @@ -2708,7 +3695,7 @@ print *, 'TSO before calling SNOWTEMP: ', tso DQM,QMIN,PSIS,BCLH, & ZSMAIN,ZSHALF,DTDZS,TBQ, & !--- constants - XLVM,CP,G0_P,CVW,STBOLT, & + XLVM,CP,rovcp,G0_P,CVW,STBOLT, & !--- output variables SNWEPRINT,SNHEIPRINT,RSM, & TSO,SOILT,SOILT1,TSNAV,QVG,QSG,QCG, & @@ -2772,7 +3759,9 @@ print *, 'TSO before calling SNOWTEMP: ', tso INTEGER, INTENT(IN ) :: i,j,iland,isoil REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & RAINF,NEWSNOW,DELTSN,SNTH , & - TABS,TRANSUM,SNWEPR + TABS,TRANSUM,SNWEPR , & + rhonewsn,meltfactor + real :: rhonewcsn !--- 3-D Atmospheric variables REAL, & @@ -2798,6 +3787,7 @@ print *, 'TSO before calling SNOWTEMP: ', tso QMIN REAL, INTENT(IN ) :: CP, & + ROVCP, & CVW, & STBOLT, & XLVM, & @@ -2879,6 +3869,7 @@ print *, 'TSO before calling SNOWTEMP: ', tso hfx REAL :: RNET,rsmfrac,soiltfrac,hsn + integer :: nmelt !----------------------------------------------------------------- @@ -2891,8 +3882,10 @@ print *, 'TSO before calling SNOWTEMP: ', tso IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF - XLMELT=3.335E+5 + XLMELT=3.35E+5 RHOCSN=2090.* RHOSN +!18apr08 - add rhonewcsn + RHOnewCSN=2090.* RHOnewSN THDIFSN = 0.265/RHOCSN RAS=RHO*1.E-3 @@ -2940,13 +3933,11 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt 33 CONTINUE !--- THE NZS element in COTSO and RHTSO will be for snow !--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH - IF(SNHEI.GE.SNTH) then -! if(snhei.le.DELTSN+DELTSN) then + IF(SNHEI.GT.SNTH) then if(snhei.le.DELTSN+SNTH) then !-- 1-layer snow model ilnb=1 snprim=snhei - soilt1=tso(1) tsob=tso(1) XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) DDZSN = XSN / SNPRIM @@ -2968,7 +3959,7 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*SNHEI) + XSN = DELT/2./(0.5*SNPRIM) XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) @@ -2992,12 +3983,11 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LE.SNTH.AND.SNHEI.GT.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. fsn=SNHEI/(SNHEI+zsmain(2)) fso=1.-fsn - soilt1=tso(1) tsob=tso(2) snprim=SNHEI+zsmain(2) XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) @@ -3015,6 +4005,10 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt !************************************************************************ !--- THE HEAT BALANCE EQUATION (Smirnova et al. 1996, EQ. 21,26) +!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes + nmelt=0 + SNOH=0. + ETT1=0. EPOT=-QKMS*(QVATM-QSG) @@ -3040,22 +4034,14 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt R7=R6/TN D11=RNET+R6 - IF(SNHEI.GE.SNTH) THEN -! if(snhei.le.DELTSN+DELTSN) then - if(snhei.le.DELTSN+SNTH) then -!--- 1-layer snow - D1SN = cotso(NZS) - D2SN = rhtso(NZS) - else -!--- 2-layer snow + IF(SNHEI.GT.SNTH) THEN D1SN = cotsn D2SN = rhtsn - endif D9SN= THDIFSN*RHOCSN / SNPRIM R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LE.SNTH.AND.SNHEI.GT.0.) then !--- thin snow is combined with soil D1SN = D1 D2SN = D2 @@ -3077,10 +4063,11 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF !---- TDENOM for snow - +!18apr08 - the iteration start point + 212 continue TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & - +RHOCSN*NEWSNOW/DELT + +RHOnewCSN*NEWSNOW/DELT FKQ=QKMS*RHO R210=R211*RHO @@ -3091,7 +4078,9 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt (BETA*FKQ*UMVEG+C) & +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & +RAINF*CVW*PRCPMS*max(273.15,TABS) & - + RHOCSN*NEWSNOW/DELT*min(273.15,TABS) & + + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & +!18apr08 - added heat of snow phase change computed in the first iteration + -SNOH & )/TDENOM AA1=AA+CC PP=PATM*1.E3 @@ -3103,14 +4092,10 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) - TQ2=QVATM+QCATM - TX2=TQ2*(1.-H) - Q1=TX2+H*QS1 !--- it is saturation over snow - 90 QVG=QS1 + QVG=QS1 QSG=QS1 - QCG=Q1-QS1 - + QCG=0. !--- SOILT - skin temperature SOILT=TS1 @@ -3120,8 +4105,7 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface - IF(SNHEI.GE.SNTH) THEN -! if(snhei.gt.DELTSN+DELTSN) then + IF(SNHEI.GT.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model SOILT1=rhtsn+cotsn*SOILT @@ -3134,6 +4118,12 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt tsob=tso(1) endif ELSE + tso(1)=tso(2)+(soilt-tso(2))*fso + SOILT1=TSO(1) + tsob=tso(2) + ENDIF + + IF(snhei.eq.0.) THEN !-- all snow is evaporated TSO(1)=SOILT SOILT1=SOILT @@ -3148,24 +4138,16 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt !--- For thin snow layer combined with the top soil layer !--- TSO is computed by linear inmterpolation between SOILT !--- and TSO(2) - - if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then - tso(1)=tso(2)+(soilt-tso(2))*fso - SOILT1=TSO(1) - tsob=tso(2) -!!! tsob=tso(1) - endif + if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen - IF(SOILT.GE.273.15.AND.SNHEI.GT.0.) THEN -!!! SOILT=273.15 + IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN + nmelt = 1 soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT - soilt=soiltfrac - QSG= QSN(soilt,TBQ)/PP -!!! QSG= QSN(273.15,TBQ)/PP + QSG= QSN(soiltfrac,TBQ)/PP QVG=QSG - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 * SOILT + T3 = STBOLT*SOILTfrac*SOILTfrac*SOILTfrac + UPFLUX = T3 * SOILTfrac XINET = EMISS*(GLW-UPFLUX) RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) @@ -3201,50 +4183,51 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt QFX= - XLVM * EETA ENDIF - HFX=D10*(TABS-soilt) -!!! HFX=D10*(TABS-273.15) + HFX=D10*(TABS-soiltfrac) - IF(SNHEI.GE.SNTH)then - SOH=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM -! SOH=thdifsn*RHOCSN*(273.15-TSOB)/SNPRIM + IF(SNHEI.GT.SNTH)then + SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM SNFLX=SOH ELSE - SOH=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & - (soilt-TSOB)/snprim -!!! (273.15-TSOB)/snprim + SOH=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & + (soiltfrac-TSOB)/snprim SNFLX=SOH ENDIF - X= (R21+D9SN*R22SN)*(soilt-TNOLD) + & -!!! X= (R21+D9SN*R22SN)*(273.15-TNOLD) + & + X= (R21+D9SN*R22SN)*(soiltfrac-TNOLD) + & XLVM*R210*(QSG-QGOLD) !-- SNOH is energy flux of snow phase change - SNOH=RNET+QFX +HFX & - +RHOCSN*NEWSNOW/DELT*(min(273.15,TABS)-TN) & - -SOH-X+RAINF*CVW*PRCPMS* & + SNOH=RNET+QFX +HFX & + +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-TN) & + -SOH-X+RAINF*CVW*PRCPMS* & (max(273.15,TABS)-TN) SNOH=AMAX1(0.,SNOH) !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 - SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) ! SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS*UMVEG) - - SNOHGNEW=SMELT*XLMELT*1.E3 - SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) - - SNOH=SNOHGNEW -! SNOHSMELT*XLMELT*1.E3 + SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) + SMELT=AMAX1(0.,SMELT) !*** From Koren et al. (1999) 13% of snow melt stays in the snow pack !!! rsm=0.13*smelt*delt - if(snwe.gt.0.) then - rsmfrac=min(0.18,(max(0.08,0.10/snwe*0.13))) - else - rsmfrac=0.13 + if(snwepr.gt.0.) then + rsmfrac=min(0.18,(max(0.08,0.10/snwepr*0.13))) +! else +! rsmfrac=0.13 endif rsm=rsmfrac*smelt*delt - SMELT=SMELT-rsm/delt +!18apr08 - Egglston limit + SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) +! SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) + + SNOHGNEW=SMELT*XLMELT*1.E3 + SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) + + SNOH=SNOHGNEW + +!18apr08 rsm is part of melted water that stays in snow as liquid + SMELT=AMAX1(0.,SMELT-rsm/delt) !-- correction of liquid equivalent of snow depth !-- due to evaporation and snow melt @@ -3260,16 +4243,12 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt smelt=smelt+rsm/delt snwe=0. rsm=0. - SOILT=SNODIF*DELT/RHCS*ZSHALF(2) & - +soiltfrac -!!! +273.15 else !*** Correct snow density on effect of snow melt, melted !*** from the top of the snow. 13% of melted water !*** remains in the pack and changes its density. !*** Eq. 9 (with my correction) in Koren et al. (1999) - - if(snwe.gt.snth*rhosn*1.e-3) then + if(snwe.gt.0.) then xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/ & snwe rhosn=MIN(XSN,400.) @@ -3278,8 +4257,6 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt thdifsn = 0.265/RHOCSN endif - SOILT=SOILTFRAC - endif !--- If there is no snow melting then just evaporation @@ -3298,37 +4275,44 @@ print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',SNHEI,SNTH,SOILT1,soilt SNHEI=SNWE *1.E3 / RHOSN +!18apr08 - if snow melt occurred then go into iteration for energy budget +! solution + if(nmelt.eq.1) goto 212 + 220 continue !-- Snow melt from the top is done. But if ground surface temperature !-- is above freezing snow can melt from the bottom. The following !-- piece of code will check if bottom melting is possible. - IF(TSO(1).GE.273.15.AND.SNHEI.GT.0.) THEN + IF(TSO(1).GT.273.15.AND.SNHEI.GT.0.) THEN + if (snhei.GE.deltsn+snth) then + hsn = snhei - deltsn + else + hsn = snhei + endif + soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) SNOHG=(TSO(1)-soiltfrac)*(RHCS*zshalf(2)+ & - RHOCSN*0.5*SNHEI) / DELT + RHOCSN*0.5*hsn) / DELT SNOHG=AMAX1(0.,SNOHG) SNODIF=0. -! TSO(1)=273.15 SMELTG=SNOHG/XLMELT*1.E-3 -! SMELTG=AMIN1(SMELTG,SNWE/DELT) +! Egglston - empirical limit on snow melt from the bottom of snow pack + SMELTG=AMIN1(SMELTG, 5.8e-9) + if(SNWE-SMELTG*DELT.ge.rsm) then -! SNWE = SNWE-SMELTG*DELT SNWE = AMAX1(0.,SNWE-SMELTG*DELT) else smeltg=snwe/delt snwe=0. rsm=0. + hsn=0. endif SNOHGNEW=SMELTG*XLMELT*1.e3 SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) - TSO(1)=soiltfrac - if(snwe.eq.0.)then - TSO(1)=SNODIF*DELT/RHCS*zshalf(2) + soiltfrac -!!! TSO(1)=SNODIF*DELT/RHCS*zshalf(2) + 273.15 - endif - + TSO(1)=soiltfrac & + + SNODIF/(RHCS*zshalf(2)+ RHOCSN*0.5*hsn)* DELT SMELT=SMELT+SMELTG SNOH=SNOH+SNOHGNEW @@ -3368,7 +4352,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB SUBROUTINE SOILMOIST ( & !--input parameters - DELT,NZS,NDDZS,DTDZS,DTDZS2, & + DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & ZSMAIN,ZSHALF,DIFFU,HYDRO, & QSG,QVG,QCG,QCATM,QVATM,PRCP, & QKMS,TRANSP,DRIP, & @@ -3376,7 +4360,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !--soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !--output - SOILMOIS,MAVAIL,RUNOFF,RUNOFF2,INFILTRP) + SOILMOIS,SOILIQW,MAVAIL,RUNOFF,RUNOFF2,INFILTRP) !************************************************************************* ! moisture balance equation and Richards eqn. ! are solved here @@ -3402,6 +4386,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ! DEW - dew in kg/m^2s ! SMELT - melting rate in m/s ! SOILICE - volumetric content of ice in soil (m^3/m^3) +! SOILIQW - volumetric content of liquid water in soil (m^3/m^3) ! VEGFRAC - greeness fraction (0-1) ! RAS - ration of air density to soil density ! INFMAX - maximum infiltration rate (kg/m^2/s) @@ -3438,13 +4423,13 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB REAL, INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM , & QKMS,VEGFRAC,DRIP,PRCP , & DEW,SMELT , & - DQM,QMIN,REF,KSAT,RAS + DQM,QMIN,REF,KSAT,RAS,RIW ! output REAL, DIMENSION( 1:nzs ) , & - INTENT(INOUT) :: SOILMOIS + INTENT(INOUT) :: SOILMOIS,SOILIQW REAL, INTENT(INOUT) :: MAVAIL,RUNOFF,RUNOFF2,INFILTRP, & INFMAX @@ -3455,7 +4440,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB REAL :: DZS,R1,R2,R3,R4,R5,R6,R7,R8,R9,R10 REAL :: REFKDT,REFDK,DELT1,F1MAX,F2MAX - REAL :: F1,F2,FD,KDT,VAL,DDT,PX + REAL :: F1,F2,FD,KDT,VAL,DDT,PX,FK,FKMAX REAL :: QQ,UMVEG,INFMAX1,TRANS REAL :: TOTLIQ,FLX,FLXSAT,QTOT REAL :: DID,X1,X2,X4,DENOM,Q2,Q4 @@ -3476,8 +4461,10 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB rhsmc(k)=0. enddo - DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2. + DID=(ZSMAIN(NZS)-ZSHALF(NZS)) X1=ZSMAIN(NZS)-ZSMAIN(NZS1) + +!7may09 DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2. ! DENOM=DID/DELT+DIFFU(NZS1)/X1 ! COSMC(1)=DIFFU(NZS1)/X1/DENOM ! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT @@ -3486,9 +4473,9 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ! 1 /X1) /DENOM DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/(2.*DID)*DELT) - COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +HYDRO(NZS1)/2./DID)/DENOM - RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & + RHSMC(1)=(SOILIQW(NZS)+TRANSP(NZS)*DELT/ & DID)/DENOM DO 330 K=1,NZS2 @@ -3500,7 +4487,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB Q2=X2-HYDRO(KN+1)*DTDZS2(KN-1) DENOM=1.+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM - 330 RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & + 330 RHSMC(K+1)=(SOILIQW(KN)+Q2*RHSMC(K) & +TRANSP(KN) & /(ZSHALF(KN+1)-ZSHALF(KN)) & *DELT)/DENOM @@ -3524,14 +4511,6 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !-- water dripping from the canopy and dew !-- With snow - only one source of water - snow melt -! print *,'PRCP,DRIP,DEW,umveg,ras,smelt', -! 1 PRCP,DRIP,DEW,umveg,ras,smelt -! if (drip.ne.0.) then -! print *,'DRIP non-zero' -! write(6,191) drip -! write (6,191)soilmois(1) -! write (6,191)soilmois(2) -! endif 191 format (f23.19) TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT @@ -3558,30 +4537,27 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB F1MAX=DQM*ZSHALF(2) F2MAX=DQM*(ZSHALF(3)-ZSHALF(2)) F1=F1MAX*(1.-SOILMOIS(1)/DQM) - F2=F2MAX*(1.-SOILMOIS(2)/DQM) - FD=F1+F2 + DICE=SOILICE(1)*ZSHALF(2) + FD=F1 + do k=2,nzs1 + DICE=DICE+(ZSHALF(k+1)-ZSHALF(k))*SOILICE(K) + FKMAX=DQM*(ZSHALF(k+1)-ZSHALF(k)) + FK=FKMAX*(1.-SOILMOIS(k)/DQM) + FD=FD+FK + enddo KDT=REFKDT*KSAT/REFDK VAL=(1.-EXP(-KDT*DELT1)) DDT = FD*VAL PX= - TOTLIQ * DELT IF(PX.LT.0.0) PX = 0.0 - if(ddt.eq.0.) then - infmax1=ksat - else INFMAX1 = (PX*(DDT/(PX+DDT)))/DELT - INFMAX1 = MIN(INFMAX1, KSAT) - endif ! print *,'INFMAX1=,ksat',infmax1,ksat,f1,f2,kdt,val,ddt,px ! ----------- FROZEN GROUND VERSION -------------------------- ! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS ! ! ------------------------------------------------------------------ - DICE = soilice(1)*zshalf(2) - DO K=2,NZS1 - DICE = DICE + ( ZSHALF(K+1) - ZSHALF(K) ) * soilice(k) - ENDDO - FRZX= 0.28*((dqm+qmin)/ref) * (0.400 / 0.482) + FRZX= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468) FCR = 1. IF ( DICE .GT. 1.E-2) THEN ACRT = CVFRZ * FRZX / DICE @@ -3598,22 +4574,22 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB END IF ! print *,'FCR--------',fcr INFMAX1 = INFMAX1* FCR - INFMAX1 = MIN(INFMAX1, KSAT) ! ------------------------------------------------------------------- - INFMAX = MIN(INFMAX,INFMAX1) + INFMAX = MAX(INFMAX1,HYDRO(1)*SOILIQW(1)) + INFMAX = MIN(INFMAX, -TOTLIQ) + !---- - IF (-TOTLIQ.GE.INFMAX)THEN + IF (-TOTLIQ.GT.INFMAX)THEN RUNOFF=-TOTLIQ-INFMAX FLX=-INFMAX ENDIF ! INFILTRP is total infiltration flux in M/S INFILTRP=FLX -! print *,'PRCIP',infiltrp,flx,infmax ! Solution of moisture budget R7=.5*DZS/DELT R4=R4+R7 - FLX=FLX-SOILMOIS(1)*R7 + FLX=FLX-SOILIQW(1)*R7 R8=UMVEG*R6 QTOT=QVATM+QCATM R9=TRANS @@ -3630,39 +4606,43 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB END IF IF(QQ.LT.0.) THEN - SOILMOIS(1)=0. + SOILIQW (1)=1.e-8 + SOILMOIS(1)=1.e-8+soilice(1)*riw ELSE IF(QQ.GT.DQM) THEN !-- saturation + SOILIQW (1)=DQM SOILMOIS(1)=DQM - RUNOFF2=runoff2+(FLXSAT-FLX)*DELT + RUNOFF2=(FLXSAT-FLX)*DELT RUNOFF=RUNOFF+(FLXSAT-FLX) ELSE - SOILMOIS(1)=max(1.e-8,QQ) + SOILIQW (1)=min(dqm,max(1.e-8,QQ)) + SOILMOIS(1)=max(1.e-8,QQ)+soilice(1)*riw END IF !--- FINAL SOLUTION FOR SOILMOIS -! DO K=2,NZS - DO K=2,NZS-1 + DO K=2,NZS KK=NZS-K+1 - QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) + QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK) IF (QQ.LT.0.) THEN - SOILMOIS(K)=0. + SOILIQW(K) =1.e-8 + SOILMOIS(K)=1.e-8 + soilice(k)*riw ELSE IF(QQ.GT.DQM) THEN !-- saturation + SOILIQW (K)=DQM SOILMOIS(K)=DQM IF(K.EQ.NZS)THEN RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)) ELSE - RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K+1)-ZSHALF(K)) + RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)) ENDIF ELSE - SOILMOIS(K)=max(1.e-8,QQ) + SOILIQW (K)=min(dqm,max(1.e-8,QQ)) + SOILMOIS(K)=max(1.e-8,QQ)+soilice(k)*riw END IF END DO - ! MAVAIL=min(1.,SOILMOIS(1)/(REF-QMIN)) MAVAIL=min(1.,SOILMOIS(1)/DQM) if (MAVAIL.EQ.0.) MAVAIL=.00001 @@ -4080,7 +5060,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB IMPLICIT NONE !--------------------------------------------------------------------------- integer, parameter :: nsoilclas=19 - integer, parameter :: nvegclas=24 + integer, parameter :: nvegclas=24+3 integer, parameter :: iwater=16 integer, parameter :: ilsnow=99 @@ -4233,25 +5213,28 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !-- USGS model ! DATA LALB/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, & - .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55/ + .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55, & + .30,.16,.60 / DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, & - .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95/ + .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, & + .85,.85,.90 / !-- Roughness length is changed for forests and some others ! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & ! 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ - DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & - .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ + DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & + .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, & + .01,.15,.01 / DATA LMOI/.1,.3,.5,.25,.25,.35,.15,.1,.15,.15,.3,.3, & - .5,.3,.3,1.,.6,.35,.02,.5,.5,.5,.02,.95/ + .5,.3,.3,1.,.6,.35,.02,.5,.5,.5,.02,.95,.40,.50,.40/ ! !---- still needs to be corrected ! ! DATA LPC/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/ DATA LPC /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55, & - 0.3,0.3,0.4,0.4,0.3,0./ + 0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./ -! DATA LPC /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & +! used in RUC DATA LPC /0.6,6*0.8,0.7,0.75,6*0.8,0.,0.8,0.8, & ! 0.5,0.7,0.6,0.7,0.5,0./ @@ -4282,12 +5265,12 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB REF, & WILT - INTEGER, DIMENSION( 1:(nvegclas+3) ) , & + INTEGER, DIMENSION( 1:(nvegclas) ) , & INTENT ( OUT) :: iforest - INTEGER, DIMENSION( 1:(nvegclas+3) ) :: if1 + INTEGER, DIMENSION( 1:(nvegclas) ) :: if1 INTEGER :: kstart, kfin, lstart, lfin INTEGER :: i,j,k @@ -4296,7 +5279,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ! DATA ZS2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil DATA IF1/12*0,1,1,1,12*0/ - do k=1,nvegclas+3 + do k=1,nvegclas iforest(k)=if1(k) enddo @@ -4319,7 +5302,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ! RHOCS = LRHC(ISLTYP)*1.E6 RHOCS = HC(ISLTYP)*1.E6 -!tgs - parameters from SOILPARM.TBL +! parameters from SOILPARM.TBL BCLH = BB(ISLTYP) DQM = MAXSMC(ISLTYP)- & DRYSMC(ISLTYP) @@ -4330,6 +5313,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB WILT = WLTSMC(ISLTYP) QWRTZ = QTZ(ISLTYP) +! parameters from the look-up tables ! BCLH = LBCL(ISLTYP) ! DQM = LQMA(ISLTYP)- & ! LQMI(ISLTYP) @@ -4355,7 +5339,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !*************************************************************************** IMPLICIT NONE !--------------------------------------------------------------------------- - integer, parameter :: nvegclas=24 + integer, parameter :: nvegclas=24+3 INTEGER :: IVGTYP @@ -4377,20 +5361,24 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !-- USGS model ! DATA LALB/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, & - .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55/ + .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55, & + .30,.16,.60/ DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, & - .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95/ + .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, & + .85,.85,.90 / !-- Roughness length is changed for forests and some others ! next 2 lines - table from RUC ! DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.8,.85, & ! 2.0,1.0,.563,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ - DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & - .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05/ + DATA LROU/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, & + .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, & + .01,.15,.01 / ! With MYJSFC better use the table from MYJSFCINIT - DATA LROU_MYJ/1.0,.07,.07,.07,.07,.15,.08,.03,.05,.86,.8,.85, & - 2.65,1.09,.8,.001,.04,.05,.01,.04,.06,.05,.03,.001/ + DATA LROU_MYJ/1.0,.07,.07,.07,.07,.15,.08,.03,.05,.86,.8,.85, & + 2.65,1.09,.8,.001,.04,.05,.01,.04,.06,.05,.03,.001, & + .01,.15,.01 / @@ -4412,8 +5400,8 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !-------------------------------------------------------------------------- END SUBROUTINE SNOWFREE - SUBROUTINE LSMRUCINIT( SMFR3D,TSLB,SMOIS,ISLTYP,mavail, & - nzs, restart, & + SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP, & + XICE,mavail,nzs, iswater, isice, restart, & allowed_to_read , & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -4427,20 +5415,21 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - nzs + nzs, iswater, isice REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & INTENT(IN) :: TSLB, & SMOIS INTEGER, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ISLTYP + INTENT(INOUT) :: ISLTYP,IVGTYP REAL, DIMENSION( ims:ime, 1:nzs, jms:jme ) , & - INTENT(INOUT) :: SMFR3D + INTENT(INOUT) :: SMFR3D, & + SH2O REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: MAVAIL + INTENT(INOUT) :: XICE,MAVAIL REAL, DIMENSION ( 1:nzs ) :: SOILIQW @@ -4457,7 +5446,7 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB RIW=900.*1.e-3 - XLMELT=3.335E+5 + XLMELT=3.35E+5 ! initialize three LSM related tables IF ( allowed_to_read ) THEN @@ -4465,6 +5454,15 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB CALL RUCLSM_PARM_INIT ENDIF +#ifdef WRF_CHEM +! +! need this parameter for dust parameterization in wrf/chem +! + do I=1,NSLTYPE + porosity(i)=maxsmc(i) + enddo +#endif + IF(.not.restart)THEN itf=min0(ite,ide-1) @@ -4485,14 +5483,6 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB "of ISLTYP. Is this field in the input?" ) ENDIF -#ifdef WRF_CHEM -! -! need this parameter for dust parameterization in wrf/chem -! - do I=1,NSLTYPE - porosity(i)=maxsmc(i) - enddo -#endif DO J=jts,jtf DO I=its,itf @@ -4511,42 +5501,53 @@ print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB !!! IF (.not.restart) THEN - if(isltyp(i,j).ne.14) then + IF(xice(i,j).gt.0.) THEN +!-- for ice + DO L=1,NZS + smfr3d(i,l,j)=1. + sh2o(i,l,j)=0. + mavail(i,j) = 1. + ENDDO + ELSE + if(isltyp(i,j).ne.14 ) then +!-- land mavail(i,j) = max(0.00001,min(1.,smois(i,1,j)/dqm)) ! mavail(i,j) = max(0.00001,min(1.,smois(i,1,j)/(ref-qmin))) - else - mavail(i,j) = 1. - endif DO L=1,NZS - if(isltyp(i,j).ne.14) then !-- for land points initialize soil ice tln=log(TSLB(i,l,j)/273.15) - - if(tln.lt.0.) then + + if(tln.lt.0.) then soiliqw(l)=(dqm+qmin)*(XLMELT* & (tslb(i,l,j)-273.15)/tslb(i,l,j)/9.81/psis) & **(-1./bclh)-qmin soiliqw(l)=max(0.,soiliqw(l)) soiliqw(l)=min(soiliqw(l),smois(i,l,j)) + sh2o(i,l,j)=soiliqw(l) smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW - - else + + else smfr3d(i,l,j)=0. - endif - else -!-- for water points - smfr3d(i,l,j)=0. - endif - - ENDDO -! ENDIF + sh2o(i,l,j)=smois(i,l,j) + endif + ENDDO + + else +!-- for water ISLTYP=14 + DO L=1,NZS + smfr3d(i,l,j)=0. + sh2o(i,l,j)=1. + mavail(i,j) = 1. + ENDDO + endif + ENDIF ENDDO ENDDO ENDIF - END SUBROUTINE lsmrucinit + END SUBROUTINE ruclsminit ! !----------------------------------------------------------------- SUBROUTINE RUCLSM_PARM_INIT diff --git a/wrfv2_fire/phys/module_sf_sfclay.F b/wrfv2_fire/phys/module_sf_sfclay.F index 275a1609..1b243215 100644 --- a/wrfv2_fire/phys/module_sf_sfclay.F +++ b/wrfv2_fire/phys/module_sf_sfclay.F @@ -23,7 +23,7 @@ CONTAINS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - ustm,ck,cka,cd,cda,isftcflx ) + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd ) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -85,6 +85,7 @@ CONTAINS !-- cka enthalpy exchange coeff at the lowest model level !-- cda momentum exchange coeff at the lowest model level !-- isftcflx =0, (Charnock and Carlson-Boland); =1, AHW Ck, Cd +!-- iz0tlnd =0 Carlson-Boland, =1 Czil_new, =2 Garratt !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -177,7 +178,7 @@ CONTAINS REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda,ustm - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX + INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND ! LOCAL VARS @@ -223,7 +224,7 @@ CONTAINS ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & #if ( EM_CORE == 1 ) - ,isftcflx, & + ,isftcflx,iz0tlnd, & USTM(ims,j),CK(ims,j),CKA(ims,j), & CD(ims,j),CDA(ims,j) & #endif @@ -247,7 +248,7 @@ CONTAINS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - isftcflx, & + isftcflx, iz0tlnd, & ustm,ck,cka,cd,cda ) !------------------------------------------------------------------- IMPLICIT NONE @@ -321,7 +322,7 @@ CONTAINS REAL, OPTIONAL, DIMENSION( ims:ime ) , & INTENT(OUT) :: ck,cka,cd,cda,ustm - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX + INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND ! LOCAL VARS @@ -334,6 +335,8 @@ CONTAINS PSIH10, & PSIM10, & DENOMQ, & + DENOMQ2, & + DENOMT2, & WSPDI, & GZ2OZ0, & GZ10OZ0 @@ -352,7 +355,7 @@ CONTAINS REAL :: PL,THCON,TVCON,E1 REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 REAL :: DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10 - REAL :: FLUXC,VSGD,Z0Q + REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2 !------------------------------------------------------------------- KL=kte @@ -686,6 +689,20 @@ CONTAINS PSIQ10=ALOG(10./Z0Q)-PSIH10(I) PSIT2=PSIQ2 ENDIF + IF ( ISFTCFLX.EQ.2 .AND. (XLAND(I)-1.5).GE.0. ) THEN +! AHW: Garratt formula: Calculate roughness Reynolds number +! Kinematic viscosity of air (linear approc to +! temp dependence at sea levle) + VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 +!! VISC=1.5E-5 + RESTAR=UST(I)*ZNT(I)/VISC + RESTAR2=2.48*SQRT(SQRT(RESTAR))-2. + PSIT=GZ1OZ0(I)-PSIH(I)+RESTAR2 + PSIQ=GZ1OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2. + PSIT2=GZ2OZ0(I)-PSIH2(I)+RESTAR2 + PSIQ2=GZ2OZ0(I)-PSIH2(I)+2.28*SQRT(SQRT(RESTAR))-2. + PSIQ2=PSIT2 + ENDIF ENDIF IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN Ck(I)=(karman/psix10)*(karman/psiq10) @@ -693,6 +710,23 @@ CONTAINS Cka(I)=(karman/psix)*(karman/psiq) Cda(I)=(karman/psix)*(karman/psix) ENDIF + IF ( PRESENT(IZ0TLND) ) THEN + IF ( IZ0TLND.EQ.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN + ZL=ZNT(I) +! CZIL RELATED CHANGES FOR LAND + VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 + RESTAR=UST(I)*ZL/VISC +! Modify CZIL according to Chen & Zhang, 2009 + + CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) + + PSIT=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) + PSIQ=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) + PSIT2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR) + PSIQ2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR) + + ENDIF + ENDIF ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX ! TKE coupling: compute ust without vconv for use in tke scheme @@ -717,6 +751,8 @@ CONTAINS ENDIF MOL(I)=KARMAN*DTG/PSIT/PRT DENOMQ(I)=PSIQ + DENOMQ2(I)=PSIQ2 + DENOMT2(I)=PSIT2 330 CONTINUE ! 335 CONTINUE @@ -790,15 +826,13 @@ CONTAINS ELSE ZL=0.01 ENDIF - CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & - /XKA+ZA(I)/ZL)-PSIH(I)) + CHS(I)=UST(I)*KARMAN/DENOMQ(I) ! GZ2OZ0(I)=ALOG(2./ZNT(I)) ! PSIM2(I)=-10.*GZ2OZ0(I) ! PSIM2(I)=AMAX1(PSIM2(I),-10.) ! PSIH2(I)=PSIM2(I) - CQS2(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*2.0 & - /XKA+2.0/ZL)-PSIH2(I)) - CHS2(I)=UST(I)*KARMAN/(GZ2OZ0(I)-PSIH2(I)) + CQS2(I)=UST(I)*KARMAN/DENOMQ2(I) + CHS2(I)=UST(I)*KARMAN/DENOMT2(I) ENDDO 410 CONTINUE diff --git a/wrfv2_fire/phys/module_sf_slab.F b/wrfv2_fire/phys/module_sf_slab.F index dc9e5b0c..56f8ff15 100644 --- a/wrfv2_fire/phys/module_sf_slab.F +++ b/wrfv2_fire/phys/module_sf_slab.F @@ -24,9 +24,7 @@ CONTAINS P1000mb, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & - f,g,omlcall,oml_gamma ) + its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------- @@ -81,14 +79,6 @@ CONTAINS !-- TSLB soil temperature in 5-layer model !-- ZS depths of centers of soil layers !-- DZS thicknesses of soil layers -!-- TML ocean mixed layer temperature (K) -!-- T0ML ocean mixed layer temperature (K) at initial time -!-- HML ocean mixed layer depth (m) -!-- H0ML ocean mixed layer depth (m) at initial time -!-- HUML ocean mixed layer u component of wind -!-- HVML ocean mixed layer v component of wind -!-- OML_GAMMA deep water lapse rate (K m-1) -!-- OMLCALL whether to call oml model !-- num_soil_layers the number of soil layers !-- ids start index for i in domain !-- ide end index for i in domain @@ -163,17 +153,6 @@ CONTAINS FLHC, & FLQC -! Ocean Mixed Layer Vars - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) :: & - TML,T0ML,HML,H0ML,HUML,HVML - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, INTENT(IN ) :: & - U_PHY,V_PHY - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN ) :: & - UST, F - REAL, OPTIONAL, INTENT(IN ) :: G - REAL, OPTIONAL, INTENT(IN ) :: OML_GAMMA - INTEGER, OPTIONAL, INTENT(IN ) :: OMLCALL - ! LOCAL VARS REAL, DIMENSION( its:ite ) :: QV1D, & @@ -207,27 +186,6 @@ CONTAINS ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - IF (OMLCALL .EQ. 1) THEN -! CALL wrf_debug( 1, 'Call OCEANML' ) - IF (PRESENT(tml) .AND. PRESENT(t0ml) & - .AND. .TRUE. ) THEN - DO i=its,ite - IF(XLAND(I,J).GT.1.5)THEN - CALL OCEANML(I,J,TML(i,j),T0ML(i,j),HML(i,j),H0ML(i,j),& - HUML(i,j),HVML(i,j),TSK(i,j),HFX(i,j), & - LH(i,j),GSW(i,j),GLW(i,j), & - U_PHY(i,kts,j),V_PHY(i,kts,j),UST(i,j),F(i,j), & - EMISS(i,j),STBOLT,G,DELTSM,OML_GAMMA, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - ENDIF - ENDDO - ELSE - CALL wrf_error_fatal('Lacking arguments for OCEANML in slab') - ENDIF - ENDIF - ENDDO END SUBROUTINE SLAB @@ -557,9 +515,7 @@ CONTAINS allowed_to_read, start_of_simulation, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - oml_hml0, omlcall, & - tml,t0ml,hml,h0ml,huml,hvml ) + its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------- @@ -578,10 +534,6 @@ CONTAINS REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(IN) :: TSK, & TMN - REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL , & - INTENT(INOUT) :: TML, T0ML, HML, H0ML, HUML, HVML - REAL , OPTIONAL, INTENT(IN ) :: oml_hml0 - INTEGER, OPTIONAL, INTENT(IN ) :: omlcall ! LOCAR VAR @@ -593,137 +545,7 @@ CONTAINS itf=min0(ite,ide-1) jtf=min0(jte,jde-1) - IF ( PRESENT(omlcall) .AND. omlcall .EQ. 1) THEN - WRITE(message,*)'Initializing OML with HML0 = ', oml_hml0 - CALL wrf_debug (1, TRIM(message)) - - IF(start_of_simulation .AND. & - PRESENT(tml) .AND. PRESENT(t0ml) ) THEN - DO J=jts,jtf - DO I=its,itf - TML(I,J)=TSK(I,J) - T0ML(I,J)=TSK(I,J) -! MAY HAVE INPUT OF HML BUT FOR NOW SET HERE - HML(I,J)=oml_hml0 - H0ML(I,J)=HML(I,J) - HUML(I,J)=0. - HVML(I,J)=0. - ENDDO - ENDDO - ENDIF - ENDIF - END SUBROUTINE slabinit - -!------------------------------------------------------------------- - - SUBROUTINE OCEANML(I,J,TML,T0ML,H,H0,HUML, & - HVML,TSK,HFX, & - LH,GSW,GLW, & - UAIR,VAIR,UST,F,EMISS,STBOLT,G,DT,OML_GAMMA, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- - INTEGER, INTENT(IN ) :: I, J - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - - REAL, INTENT(INOUT) :: TML, H, H0, HUML, HVML, TSK - - REAL, INTENT(IN ) :: T0ML, HFX, LH, GSW, GLW, & - UAIR, VAIR, UST, F, EMISS - - REAL, INTENT(IN) :: STBOLT, G, DT, OML_GAMMA - -! Local - REAL :: rhoair, rhowater, Gam, alp, BV2, A1, A2, B2, u, v, wspd, & - hu1, hv1, hu2, hv2, taux, tauy, tauxair, tauyair, q, hold, & - hsqrd, thp, cwater - CHARACTER(LEN=120) :: time_series - - hu1=huml - hv1=hvml - rhoair=1. - rhowater=1000. - cwater=4200. -! Deep ocean lapse rate (K/m) - from Rich - Gam=oml_gamma -! if(i.eq.1 .and. j.eq.1 .or. i.eq.105.and.j.eq.105) print *, 'gamma = ', gam -! Gam=0.14 -! Gam=5.6/40. -! if(i.eq.1 .and. j.eq.1 ) print *, 'gamma = ', gam -! Gam=5./100. -! Thermal expansion coeff (/K) -! alp=.0002 -! temp dependence (/K) - alp=max((tml-273.15)*1.e-5, 1.e-6) - BV2=alp*g*Gam - thp=t0ml-Gam*(h-h0) - A1=(tml-thp)*h - 0.5*Gam*h*h - if(h.ne.0.)then - u=hu1/h - v=hv1/h - else - u=0. - v=0. - endif - -! time step - -! q=(-hfx-lh+gsw+glw-stbolt*emiss*tml*tml*tml*tml)/(rhowater*cwater) -! wspd=max(sqrt(uair*uair+vair*vair),0.1) - wspd=sqrt(uair*uair+vair*vair) - if (wspd .lt. 1.e-10 ) then -! print *, 'i,j,wspd are ', i,j,wspd - wspd = 1.e-10 - endif - tauxair=ust*ust*uair/wspd - taux=rhoair/rhowater*tauxair - tauyair=ust*ust*vair/wspd - tauy=rhoair/rhowater*tauyair -! note: forward-backward coriolis force for effective time-centering - hu2=hu1+dt*( f*hv1 + taux) - hv2=hv1+dt*(-f*hu2 + tauy) -! A2=A1+q*dt - A2=A1 - - huml=hu2 - hvml=hv2 - - hold=h - B2=hu2*hu2+hv2*hv2 - hsqrd=-A2/Gam + sqrt(A2*A2/(Gam*Gam) + 2.*B2/BV2) - h=sqrt(max(hsqrd,0.0)) -! limit to positive h change - if(h.lt.hold)h=hold - - if(h.ne.0.)then - tml=max(t0ml - Gam*(h-h0) + 0.5*Gam*h + A2/h, 273.15) - u=hu2/h - v=hv2/h - else - tml=t0ml - u=0. - v=0. - endif - tsk=tml -! if(h.gt.100.)print *,i,j,h,tml,' h,tml' - -! ww: output point data -! if( (i.eq.190 .and. j.eq.115) .or. (i.eq.170 .and. j.eq.125) ) then -! write(jtime,fmt='("TS ",f10.0)') float(itimestep) -! CALL wrf_message ( TRIM(jtime) ) -! write(time_series,fmt='("OML",2I4,2F9.5,2F8.2,2E15.5,F8.3)') & -! i,j,u,v,tml,h,taux,tauy,a2 -! CALL wrf_message ( TRIM(time_series) ) -! end if - - END SUBROUTINE OCEANML !------------------------------------------------------------------- END MODULE module_sf_slab diff --git a/wrfv2_fire/phys/module_sf_urban.F b/wrfv2_fire/phys/module_sf_urban.F index 70cea601..44edc6a6 100644 --- a/wrfv2_fire/phys/module_sf_urban.F +++ b/wrfv2_fire/phys/module_sf_urban.F @@ -24,13 +24,28 @@ MODULE module_sf_urban REAL, ALLOCATABLE, DIMENSION(:) :: BETG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: FRC_URB_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: COP_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: PWIN_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: BETA_TBL + INTEGER, ALLOCATABLE, DIMENSION(:) :: SW_COND_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: TIME_ON_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: TIME_OFF_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: TARGTEMP_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: GAPTEMP_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: TARGHUM_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: GAPHUM_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: PERFLO_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: HSESF_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: CAPR_TBL, CAPB_TBL, CAPG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: AKSR_TBL, AKSB_TBL, AKSG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: ALBR_TBL, ALBB_TBL, ALBG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: EPSR_TBL, EPSB_TBL, EPSG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: Z0R_TBL, Z0B_TBL, Z0G_TBL - REAL, ALLOCATABLE, DIMENSION(:) :: Z0HR_TBL, Z0HB_TBL, Z0HG_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA_ZED_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: Z0HB_TBL, Z0HG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: TRLEND_TBL, TBLEND_TBL, TGLEND_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: AKANDA_URBAN_TBL !for BEP ! MAXDIRS :: The maximum number of street directions we're allowed to define @@ -50,6 +65,7 @@ MODULE module_sf_urban INTEGER :: CH_SCHEME_DATA, TS_SCHEME_DATA INTEGER :: ahoption ! Miao, 2007/01/17, cal. ah REAL, DIMENSION(1:24) :: ahdiuprf ! ah diurnal profile, tloc: 1-24 + REAL, DIMENSION(1:24) :: hsequip_tbl INTEGER :: allocate_status @@ -153,6 +169,7 @@ MODULE module_sf_urban ! These parameters assigned in the URBPARM.TBL ! ! ZR [m] : roof level (building height) +! SIGMA_ZED [m] : Standard Deviation of roof height ! ROOF_WIDTH [m] : roof (i.e., building) width ! ROAD_WIDTH [m] : road width ! @@ -182,10 +199,8 @@ MODULE module_sf_urban ! EPSR [-] : surface emissivity of roof ! EPSB [-] : surface emissivity of building wall ! EPSG [-] : surface emissivity of road -! Z0R [m] : roughness length for momentum of roof ! Z0B [m] : roughness length for momentum of building wall (only for CH_SCHEME = 1) ! Z0G [m] : roughness length for momentum of road (only for CH_SCHEME = 1) -! Z0HR [m] : roughness length for heat of roof ! Z0HB [m] : roughness length for heat of building wall (only for CH_SCHEME = 1) ! Z0HG [m] : roughness length for heat of road ! num_roof_layers : number of layers within roof @@ -220,7 +235,7 @@ MODULE module_sf_urban ! BETR [-] : minimum moisture availability of roof ! BETB [-] : minimum moisture availability of building wall ! BETG [-] : minimum moisture availability of road -! Z0HR [m] : roughness length for heat of roof +! Z0R [m] : roughness length for momentum of roof ! Z0HB [m] : roughness length for heat of building wall (only for CH_SCHEME = 1) ! Z0HG [m] : roughness length for heat of road ! num_roof_layers : number of layers within roof @@ -258,6 +273,7 @@ MODULE module_sf_urban TS,QS,SH,LH,LH_KINEMATIC, & ! O SW,ALB,LW,G,RN,PSIM,PSIH, & ! O GZ1OZ0, & ! O + CMR_URB,CHR_URB,CMC_URB,CHC_URB, & ! I/O U10,V10,TH2,Q2,UST & ! O ) @@ -324,6 +340,10 @@ MODULE module_sf_urban REAL, INTENT(INOUT) :: SSGD ! downward direct short wave radiation [W/m/m] REAL, INTENT(INOUT) :: SSGQ ! downward diffuse short wave radiation [W/m/m] + REAL, INTENT(INOUT) :: CMR_URB + REAL, INTENT(INOUT) :: CHR_URB + REAL, INTENT(INOUT) :: CMC_URB + REAL, INTENT(INOUT) :: CHC_URB !------------------------------------------------------------------------------- ! O: output variables from Urban to LSM @@ -380,9 +400,13 @@ MODULE module_sf_urban !------------------------------------------------------------------------------- REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, AH + REAL :: SIGMA_ZED REAL :: CAPR, CAPB, CAPG, AKSR, AKSB, AKSG, ALBR, ALBB, ALBG - REAL :: EPSR, EPSB, EPSG, Z0R, Z0B, Z0G, Z0HR, Z0HB, Z0HG + REAL :: EPSR, EPSB, EPSG, Z0R, Z0B, Z0G, Z0HB, Z0HG REAL :: TRLEND,TBLEND,TGLEND + REAL :: T1VR, T1VC,TH2V + REAL :: RLMO_URB + REAL :: AKANDA_URBAN REAL :: TH2X !m @@ -407,7 +431,7 @@ MODULE module_sf_urban REAL :: BETR, BETB, BETG REAL :: SX, SD, SQ, RX REAL :: UR, ZC, XLB, BB - REAL :: Z, RIBR, RIBB, RIBG, RIBC, BHR, BHB, BHG, BHC + REAL :: Z, RIBB, RIBG, RIBC, BHR, BHB, BHG, BHC REAL :: TSC, LNET, SNET, FLXUV, THG, FLXTH, FLXHUM, FLXG REAL :: W, VFGS, VFGW, VFWG, VFWS, VFWW REAL :: HOUI1, HOUI2, HOUI3, HOUI4, HOUI5, HOUI6, HOUI7, HOUI8 @@ -463,24 +487,24 @@ MODULE module_sf_urban if(tloc==0) tloc=24 endif - CALL read_param(UTYPE,ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & - CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & - EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HR,Z0HB,Z0HG, & + CALL read_param(UTYPE,ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT, & + AH,CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB, & + ALBG,EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, & BETR,BETB,BETG,TRLEND,TBLEND,TGLEND, & !for BEP NUMDIR, STREET_DIRECTION, STREET_WIDTH, & BUILDING_WIDTH, NUMHGT, HEIGHT_BIN, & HPERCENT_BIN, & !end BEP - BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME) + BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & + AKANDA_URBAN) ! Miao, 2007/01/17, cal. ah if(ahoption==1) AH=AH*ahdiuprf(tloc) IF( ZDC+Z0C+2. >= ZA) THEN - PRINT *, 'ZDC + Z0C + 2m is larger than the 1st WRF level' - PRINT *, 'Stop in the subroutine urban - change ZDC and Z0C' - STOP + CALL wrf_error_fatal ("ZDC + Z0C + 2m is larger than the 1st WRF level "// & + "Stop in subroutine urban - change ZDC and Z0C" ) END IF IF(.NOT.LSOLAR) THEN @@ -529,7 +553,7 @@ MODULE module_sf_urban BB = 0.4 * ZR / ( XLB * alog( ( ZR - ZDC ) / Z0C ) ) UC=UR*EXP(-BB*(1.-ZC/ZR)) ELSE - PRINT *, 'Warning ZR + 2m is larger than the 1st WRF level' + ! PRINT *, 'Warning ZR + 2m is larger than the 1st WRF level' ZC=ZA/2. UC=UA/2. END IF @@ -621,12 +645,20 @@ MODULE module_sf_urban ! CHR, CDR, BETR !------------------------------------------------------------------------------- - Z=ZA-ZDC - BHR=LOG(Z0R/Z0HR)/0.4 - RIBR=(9.8*2./(TA+TRP))*(TA-TRP)*(Z+Z0R)/(UA*UA) - - CALL mos(XXXR,ALPHAR,CDR,BHR,RIBR,Z,Z0R,UA,TA,TRP,RHO) - + ! Z=ZA-ZDC + ! BHR=LOG(Z0R/Z0HR)/0.4 + ! RIBR=(9.8*2./(TA+TRP))*(TA-TRP)*(Z+Z0R)/(UA*UA) + ! CALL mos(XXXR,ALPHAR,CDR,BHR,RIBR,Z,Z0R,UA,TA,TRP,RHO) + + ! Alternative option for MOST using SFCDIF routine from Noah + ! Virtual temperatures needed by SFCDIF + T1VR = TRP* (1.0+ 0.61 * QA) + TH2V = (TA + ( 0.0098 * ZA)) * (1.0+ 0.61 * QA) + + ! note that CHR_URB contains UA (=CHR_MOS*UA) + RLMO_URB=0.0 + CALL SFCDIF_URB (ZA,Z0R,T1VR,TH2V,UA,AKANDA_URBAN,CMR_URB,CHR_URB,RLMO_URB,CDR) + ALPHAR = RHO*CP*CHR_URB CHR=ALPHAR/RHO/CP/UA IF(RAIN > 1.) BETR=0.7 @@ -710,11 +742,17 @@ MODULE module_sf_urban ! CHC, CHB, CDB, BETB, CHG, CDG, BETG !------------------------------------------------------------------------------- - Z=ZA-ZDC - BHC=LOG(Z0C/Z0HC)/0.4 - RIBC=(9.8*2./(TA+TCP))*(TA-TCP)*(Z+Z0C)/(UA*UA) + ! Z=ZA-ZDC + ! BHC=LOG(Z0C/Z0HC)/0.4 + ! RIBC=(9.8*2./(TA+TCP))*(TA-TCP)*(Z+Z0C)/(UA*UA) + ! + ! CALL mos(XXXC,ALPHAC,CDC,BHC,RIBC,Z,Z0C,UA,TA,TCP,RHO) + ! Virtual temperatures needed by SFCDIF routine from Noah - CALL mos(XXXC,ALPHAC,CDC,BHC,RIBC,Z,Z0C,UA,TA,TCP,RHO) + T1VC = TCP* (1.0+ 0.61 * QA) + RLMO_URB=0.0 + CALL SFCDIF_URB(ZA,Z0C,T1VC,TH2V,UA,AKANDA_URBAN,CMC_URB,CHC_URB,RLMO_URB,CDC) + ALPHAC = RHO*CP*CHC_URB IF (CH_SCHEME == 1) THEN @@ -1310,23 +1348,26 @@ MODULE module_sf_urban ! !=============================================================================== SUBROUTINE read_param(UTYPE, & ! in - ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & ! out + ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & ! out CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & ! out - EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HR,Z0HB,Z0HG, & ! out + EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, & ! out BETR,BETB,BETG,TRLEND,TBLEND,TGLEND, & ! out !for BEP NUMDIR, STREET_DIRECTION, STREET_WIDTH, & ! out BUILDING_WIDTH, NUMHGT, HEIGHT_BIN, & ! out HPERCENT_BIN, & ! out !end BEP - BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME) ! out + BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & ! out + AKANDA_URBAN) ! out INTEGER, INTENT(IN) :: UTYPE REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & - EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HR,Z0HB,Z0HG, & + SIGMA_ZED, & + EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, & BETR,BETB,BETG,TRLEND,TBLEND,TGLEND + REAL, INTENT(OUT) :: AKANDA_URBAN !for BEP INTEGER, INTENT(OUT) :: NUMDIR REAL, DIMENSION(MAXDIRS), INTENT(OUT) :: STREET_DIRECTION @@ -1335,11 +1376,13 @@ MODULE module_sf_urban INTEGER, INTENT(OUT) :: NUMHGT REAL, DIMENSION(MAXHGTS), INTENT(OUT) :: HEIGHT_BIN REAL, DIMENSION(MAXHGTS), INTENT(OUT) :: HPERCENT_BIN + !end BEP INTEGER, INTENT(OUT) :: BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME ZR = ZR_TBL(UTYPE) + SIGMA_ZED = SIGMA_ZED_TBL(UTYPE) Z0C= Z0C_TBL(UTYPE) Z0HC= Z0HC_TBL(UTYPE) ZDC= ZDC_TBL(UTYPE) @@ -1369,7 +1412,6 @@ MODULE module_sf_urban Z0R= Z0R_TBL(UTYPE) Z0B= Z0B_TBL(UTYPE) Z0G= Z0G_TBL(UTYPE) - Z0HR= Z0HR_TBL(UTYPE) Z0HB= Z0HB_TBL(UTYPE) Z0HG= Z0HG_TBL(UTYPE) TRLEND= TRLEND_TBL(UTYPE) @@ -1380,6 +1422,7 @@ MODULE module_sf_urban BOUNDG= BOUNDG_DATA CH_SCHEME = CH_SCHEME_DATA TS_SCHEME = TS_SCHEME_DATA + AKANDA_URBAN = AKANDA_URBAN_TBL(UTYPE) !for BEP @@ -1440,6 +1483,7 @@ MODULE module_sf_urban real :: Cd real :: alpha_macd real :: beta_macd + real :: lambda_fr !for BEP @@ -1462,7 +1506,9 @@ MODULE module_sf_urban POSITION='REWIND', & IOSTAT=IOSTATUS) - IF (IOSTATUS > 0) STOP 'ERROR OPEN URBPARM.TBL' + IF (IOSTATUS > 0) THEN + CALL wrf_error_fatal('ERROR OPEN URBPARM.TBL') + ENDIF READLOOP : do read(11,'(A512)', iostat=iostatus) string @@ -1478,92 +1524,118 @@ MODULE module_sf_urban read(string(indx+1:),*) icate IF (.not. ALLOCATED(ZR_TBL)) then ALLOCATE( ZR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ZR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZR_TBL in urban_param_init') + ALLOCATE( SIGMA_ZED_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0)CALL wrf_error_fatal('Error allocating SIGMA_ZED_TBL in urban_param_init') ALLOCATE( Z0C_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0C_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0C_TBL in urban_param_init') ALLOCATE( Z0HC_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0HC_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HC_TBL in urban_param_init') ALLOCATE( ZDC_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ZDC_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZDC_TBL in urban_param_init') ALLOCATE( SVF_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating SVF_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SVF_TBL in urban_param_init') ALLOCATE( R_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating R_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating R_TBL in urban_param_init') ALLOCATE( RW_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating RW_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating RW_TBL in urban_param_init') ALLOCATE( HGT_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating HGT_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HGT_TBL in urban_param_init') ALLOCATE( AH_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating AH_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AH_TBL in urban_param_init') ALLOCATE( BETR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating BETR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETR_TBL in urban_param_init') ALLOCATE( BETB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating BETB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETB_TBL in urban_param_init') ALLOCATE( BETG_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating BETG_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETG_TBL in urban_param_init') ALLOCATE( CAPR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating CAPR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPR_TBL in urban_param_init') ALLOCATE( CAPB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating CAPB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPB_TBL in urban_param_init') ALLOCATE( CAPG_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating CAPG_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPG_TBL in urban_param_init') ALLOCATE( AKSR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating AKSR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSR_TBL in urban_param_init') ALLOCATE( AKSB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating AKSB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSB_TBL in urban_param_init') ALLOCATE( AKSG_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating AKSG_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSG_TBL in urban_param_init') ALLOCATE( ALBR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ALBR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBR_TBL in urban_param_init') ALLOCATE( ALBB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ALBB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBB_TBL in urban_param_init') ALLOCATE( ALBG_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ALBG_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBG_TBL in urban_param_init') ALLOCATE( EPSR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating EPSR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSR_TBL in urban_param_init') ALLOCATE( EPSB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating EPSB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSB_TBL in urban_param_init') ALLOCATE( EPSG_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating EPSG_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSG_TBL in urban_param_init') ALLOCATE( Z0R_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0R_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0R_TBL in urban_param_init') ALLOCATE( Z0B_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0B_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0B_TBL in urban_param_init') ALLOCATE( Z0G_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0G_TBL in urban_param_init' - ALLOCATE( Z0HR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0HR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0G_TBL in urban_param_init') + ALLOCATE( AKANDA_URBAN_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKANDA_URBAN_TBL in urban_param_init') ALLOCATE( Z0HB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0HB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HB_TBL in urban_param_init') ALLOCATE( Z0HG_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating Z0HG_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HG_TBL in urban_param_init') ALLOCATE( TRLEND_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating TRLEND_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TRLEND_TBL in urban_param_init') ALLOCATE( TBLEND_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating TBLEND_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TBLEND_TBL in urban_param_init') ALLOCATE( TGLEND_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating TGLEND_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TGLEND_TBL in urban_param_init') ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating FRC_URB_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating FRC_URB_TBL in urban_param_init') ! ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) - ! if(allocate_status /= 0) stop 'Error allocating ROOF_WIDTH in urban_param_init' + ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init') ! ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) - ! if(allocate_status /= 0) stop 'Error allocating ROAD_WIDTH in urban_param_init' + ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init') !for BEP ALLOCATE( NUMDIR_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating NUMDIR_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMDIR_TBL in urban_param_init') ALLOCATE( STREET_DIRECTION_TBL(MAXDIRS , ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating STREET_DIRECTION_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_DIRECTION_TBL in urban_param_init') ALLOCATE( STREET_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating STREET_WIDTH_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_WIDTH_TBL in urban_param_init') ALLOCATE( BUILDING_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating BUILDING_WIDTH_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BUILDING_WIDTH_TBL in urban_param_init') ALLOCATE( NUMHGT_TBL(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating NUMHGT_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMHGT_TBL in urban_param_init') ALLOCATE( HEIGHT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating HEIGHT_BIN_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HEIGHT_BIN_TBL in urban_param_init') ALLOCATE( HPERCENT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating HPERCENT_BIN_TBL in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HPERCENT_BIN_TBL in urban_param_init') + ALLOCATE( COP_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating COP_TBL in urban_param_init') + ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PWIN_TBL in urban_param_init') + ALLOCATE( BETA_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETA_TBL in urban_param_init') + ALLOCATE( SW_COND_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SW_COND_TBL in urban_param_init') + ALLOCATE( TIME_ON_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_ON_TBL in urban_param_init') + ALLOCATE( TIME_OFF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_OFF_TBL in urban_param_init') + ALLOCATE( TARGTEMP_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGTEMP_TBL in urban_param_init') + ALLOCATE( GAPTEMP_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPTEMP_TBL in urban_param_init') + ALLOCATE( TARGHUM_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGHUM_TBL in urban_param_init') + ALLOCATE( GAPHUM_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPHUM_TBL in urban_param_init') + ALLOCATE( PERFLO_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PERFLO_TBL in urban_param_init') + ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HSESF_TBL in urban_param_init') endif numdir_tbl = 0 street_direction_tbl = -1.E36 @@ -1576,15 +1648,16 @@ MODULE module_sf_urban else if (name == "ZR") then read(string(indx+1:),*) zr_tbl(1:icate) -! print*, 'zr_tbl = ', zr_tbl(1:icate) + else if (name == "SIGMA_ZED") then + read(string(indx+1:),*) sigma_zed_tbl(1:icate) else if (name == "ROOF_WIDTH") then ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ROOF_WIDTH in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init') read(string(indx+1:),*) roof_width(1:icate) else if (name == "ROAD_WIDTH") then ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) - if(allocate_status /= 0) stop 'Error allocating ROAD_WIDTH in urban_param_init' + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init') read(string(indx+1:),*) road_width(1:icate) else if (name == "AH") then read(string(indx+1:),*) ah_tbl(1:icate) @@ -1626,8 +1699,8 @@ MODULE module_sf_urban read(string(indx+1:),*) epsb_tbl(1:icate) else if (name == "EPSG") then read(string(indx+1:),*) epsg_tbl(1:icate) - else if (name == "Z0R") then - read(string(indx+1:),*) z0r_tbl(1:icate) + else if (name == "AKANDA_URBAN") then + read(string(indx+1:),*) akanda_urban_tbl(1:icate) else if (name == "Z0B") then read(string(indx+1:),*) z0b_tbl(1:icate) else if (name == "Z0G") then @@ -1697,12 +1770,37 @@ MODULE module_sf_urban if ( pctsum /= 100.) then write (*,'(//,"Building height percentages for category ", I2, " must sum to 100.0")') k write (*,'("Currently, they sum to ", F6.2,/)') pctsum - stop + CALL wrf_error_fatal('pctsum is not equal to 100.') endif + else if ( name == "COP") then + read(string(indx+1:),*) cop_tbl(1:icate) + else if ( name == "PWIN") then + read(string(indx+1:),*) pwin_tbl(1:icate) + else if ( name == "BETA") then + read(string(indx+1:),*) beta_tbl(1:icate) + else if ( name == "SW_COND") then + read(string(indx+1:),*) sw_cond_tbl(1:icate) + else if ( name == "TIME_ON") then + read(string(indx+1:),*) time_on_tbl(1:icate) + else if ( name == "TIME_OFF") then + read(string(indx+1:),*) time_off_tbl(1:icate) + else if ( name == "TARGTEMP") then + read(string(indx+1:),*) targtemp_tbl(1:icate) + else if ( name == "GAPTEMP") then + read(string(indx+1:),*) gaptemp_tbl(1:icate) + else if ( name == "TARGHUM") then + read(string(indx+1:),*) targhum_tbl(1:icate) + else if ( name == "GAPHUM") then + read(string(indx+1:),*) gaphum_tbl(1:icate) + else if ( name == "PERFLO") then + read(string(indx+1:),*) perflo_tbl(1:icate) + else if (name == "HSEQUIP") then + read(string(indx+1:),*) hsequip_tbl(1:24) + else if (name == "HSEQUIP_SCALE_FACTOR") then + read(string(indx+1:),*) hsesf_tbl(1:icate) !end BEP else - print*, 'name = "'//trim(name)//'"' - stop + CALL wrf_error_fatal('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') endif enddo READLOOP @@ -1710,7 +1808,6 @@ MODULE module_sf_urban ! Assign a few table values that do not need to come from URBPARM.TBL - Z0HR_TBL = 0.1 * Z0R_TBL Z0HB_TBL = 0.1 * Z0B_TBL Z0HG_TBL = 0.1 * Z0G_TBL @@ -1747,6 +1844,13 @@ MODULE module_sf_urban Z0C_TBL(LC) = ZR_TBL(LC) * ( 1.0 - ZDC_TBL(LC)/ZR_TBL(LC) ) * & exp (-(0.5 * beta_macd * Cd / (VonK**2) * ( 1.0-ZDC_TBL(LC)/ZR_TBL(LC) ) * Lambda_F )**(-0.5)) + ! Include roof height variability in Macdonald + ! to parameterize Z0R as a function of ZR_SD (Standard Deviation) + Lambda_FR = SIGMA_ZED_TBL(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) ) + Z0R_TBL(LC) = ZR_TBL(LC) * ( 1.0 - ZDC_TBL(LC)/ZR_TBL(LC) ) & + * exp ( -(0.5 * beta_macd * Cd / (VonK**2) & + * ( 1.0-ZDC_TBL(LC)/ZR_TBL(LC) ) * Lambda_FR )**(-0.5)) + ! ! Z0HC still one-tenth of Z0C, as before ? ! @@ -1792,6 +1896,12 @@ MODULE module_sf_urban TS_URB2D, & ! inout num_urban_layers, & ! in TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D, & ! inout + TLEV_URB3D,QLEV_URB3D, & ! inout + TW1LEV_URB3D,TW2LEV_URB3D, & ! inout + TGLEV_URB3D,TFLEV_URB3D, & ! inout + SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D, & ! inout + SFVENT_URB3D,LFVENT_URB3D, & ! inout + SFWIN1_URB3D,SFWIN2_URB3D, & ! inout SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D, & ! inout A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & ! inout multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & ! inout multi-layer urban @@ -1839,6 +1949,19 @@ MODULE module_sf_urban REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D + REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D + REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D + REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D + REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D + REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D + REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D + REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D + REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW2_URB3D REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D @@ -1953,22 +2076,52 @@ MODULE module_sf_urban END DO ! multi-layer urban -! write(*,*)i,j,TSURFACE0_URB(i,j),TLAYER0_URB(i,1,j),TLAYER0_URB(i,4,j) - IF( sf_urban_physics .EQ. 2)THEN +! IF( sf_urban_physics .EQ. 2)THEN + IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN DO k=1,num_urban_layers ! TRB_URB4D(I,k,J)=TSURFACE0_URB(I,J) ! TW1_URB4D(I,k,J)=TSURFACE0_URB(I,J) ! TW2_URB4D(I,k,J)=TSURFACE0_URB(I,J) ! TGB_URB4D(I,k,J)=TSURFACE0_URB(I,J) - TRB_URB4D(I,k,J)=tlayer0_urb(I,1,J) - TW1_URB4D(I,k,J)=tlayer0_urb(I,1,J) - TW2_URB4D(I,k,J)=tlayer0_urb(I,1,J) - TGB_URB4D(I,k,J)=tlayer0_urb(I,1,J) - SFW1_URB3D(I,k,J)=0. - SFW2_URB3D(I,k,J)=0. - SFR_URB3D(I,k,J)=0. - SFG_URB3D(I,k,J)=0. + TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J) + TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J) + TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J) + TGB_URB4D(I,K,J)=tlayer0_urb(I,1,J) + SFW1_URB3D(I,K,J)=0. + SFW2_URB3D(I,K,J)=0. + SFR_URB3D(I,K,J)=0. + SFG_URB3D(I,K,J)=0. ENDDO + + ENDIF + + if (SF_URBAN_PHYSICS.EQ.3) then + LF_AC_URB3D(I,J)=0. + SF_AC_URB3D(I,J)=0. + CM_AC_URB3D(I,J)=0. + SFVENT_URB3D(I,J)=0. + LFVENT_URB3D(I,J)=0. + + DO K=1,num_urban_layers + TLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) + TW1LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) + TW2LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) + TGLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) + TFLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) + QLEV_URB3D(I,K,J)=0.01 + SFWIN1_URB3D(I,K,J)=0. + SFWIN2_URB3D(I,K,J)=0. +!rm LF_AC_URB3D(I,J)=0. +!rm SF_AC_URB3D(I,J)=0. +!rm CM_AC_URB3D(I,J)=0. +!rm SFVENT_URB3D(I,J)=0. +!rm LFVENT_URB3D(I,J)=0. + ENDDO + + endif + +! IF( sf_urban_physics .EQ. 2 )THEN + IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN DO K= KMS,KME SF_BEP(I,K,J)=1. VL_BEP(I,K,J)=1. @@ -1976,10 +2129,12 @@ MODULE module_sf_urban A_V_BEP(I,K,J)=0. A_T_BEP(I,K,J)=0. A_E_BEP(I,K,J)=0. + A_Q_BEP(I,K,J)=0. B_U_BEP(I,K,J)=0. B_V_BEP(I,K,J)=0. B_T_BEP(I,K,J)=0. B_E_BEP(I,K,J)=0. + B_Q_BEP(I,K,J)=0. DLG_BEP(I,K,J)=0. DL_U_BEP(I,K,J)=0. END DO @@ -2051,4 +2206,202 @@ MODULE module_sf_urban RETURN END SUBROUTINE bisection !=========================================================================== + +SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) + +! ---------------------------------------------------------------------- +! SUBROUTINE SFCDIF_URB (Urban version of SFCDIF_off) +! ---------------------------------------------------------------------- +! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. +! SEE CHEN ET AL (1997, BLM) +! ---------------------------------------------------------------------- + + IMPLICIT NONE + REAL WWST, WWST2, G, VKRM, EXCM, BETA, BTG, ELFC, WOLD, WNEW + REAL PIHF, EPSU2, EPSUST, EPSIT, EPSA, ZTMIN, ZTMAX, HPBL, & + & SQVISC + REAL RIC, RRIC, FHNEU, RFC,RLMO_THR, RFAC, ZZ, PSLMU, PSLMS, PSLHU, & + & PSLHS + REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM + REAL SFCSPD, AKANDA, AKMS, AKHS, ZU, ZT, RDZ, CXCH + REAL DTHV, DU2, BTGH, WSTAR2, USTAR, ZSLU, ZSLT, RLOGU, RLOGT + REAL RLMO, ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 +!CC ......REAL ZTFC + + REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & + & RLMA + + INTEGER ITRMX, ILECH, ITR + REAL, INTENT(OUT) :: CD + PARAMETER & + & (WWST = 1.2,WWST2 = WWST * WWST,G = 9.8,VKRM = 0.40, & + & EXCM = 0.001 & + & ,BETA = 1./270.,BTG = BETA * G,ELFC = VKRM * BTG & + & ,WOLD =.15,WNEW = 1. - WOLD,ITRMX = 05, & + & PIHF = 3.14159265/2.) + PARAMETER & + & (EPSU2 = 1.E-4,EPSUST = 0.07,EPSIT = 1.E-4,EPSA = 1.E-8 & + & ,ZTMIN = -5.,ZTMAX = 1.,HPBL = 1000.0 & + & ,SQVISC = 258.2) + PARAMETER & + & (RIC = 0.183,RRIC = 1.0/ RIC,FHNEU = 0.8,RFC = 0.191 & + & ,RLMO_THR = 0.001,RFAC = RIC / (FHNEU * RFC * RFC)) + +! ---------------------------------------------------------------------- +! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS +! ---------------------------------------------------------------------- +! LECH'S SURFACE FUNCTIONS +! ---------------------------------------------------------------------- + PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.)) + PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ) + +! ---------------------------------------------------------------------- +! PAULSON'S SURFACE FUNCTIONS +! ---------------------------------------------------------------------- + PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.)) + PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) & + & +2.* ATAN (XX) & + &- PIHF + PSPMS (YY)= 5.* YY + PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5) + +! ---------------------------------------------------------------------- +! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND +! OVER SOLID SURFACE (LAND, SEA-ICE). +! ---------------------------------------------------------------------- + PSPHS (YY)= 5.* YY + +! ---------------------------------------------------------------------- +! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 +! C......ZTFC=0.1 +! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT +! ---------------------------------------------------------------------- + ILECH = 0 + +! ---------------------------------------------------------------------- +! ZILFC = - CZIL * VKRM * SQVISC +! C.......ZT=Z0*ZTFC + ZU = Z0 + RDZ = 1./ ZLM + CXCH = EXCM * RDZ + DTHV = THLM - THZ0 + +! ---------------------------------------------------------------------- +! BELJARS CORRECTION OF USTAR +! ---------------------------------------------------------------------- + DU2 = MAX (SFCSPD * SFCSPD,EPSU2) +!cc If statements to avoid TANGENT LINEAR problems near zero + BTGH = BTG * HPBL + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF + +! ---------------------------------------------------------------------- +! ZILITINKEVITCH APPROACH FOR ZT +! ---------------------------------------------------------------------- + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + +! ---------------------------------------------------------------------- +! KCL/TL Try Kanda approach instead (Kanda et al. 2007, JAMC) +! ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0 + + ZSLU = ZLM + ZU + + ZSLT = ZLM + ZT + RLOGU = log (ZSLU / ZU) + + RLOGT = log (ZSLT / ZT) + + RLMO = ELFC * AKHS * DTHV / USTAR **3 +! ---------------------------------------------------------------------- +! 1./MONIN-OBUKKHOV LENGTH-SCALE +! ---------------------------------------------------------------------- + DO ITR = 1,ITRMX + ZETALT = MAX (ZSLT * RLMO,ZTMIN) + RLMO = ZETALT / ZSLT + ZETALU = ZSLU * RLMO + ZETAU = ZU * RLMO + + ZETAT = ZT * RLMO + IF (ILECH .eq. 0) THEN + IF (RLMO .lt. 0.0)THEN + XLU4 = 1. -16.* ZETALU + XLT4 = 1. -16.* ZETALT + XU4 = 1. -16.* ZETAU + + XT4 = 1. -16.* ZETAT + XLU = SQRT (SQRT (XLU4)) + XLT = SQRT (SQRT (XLT4)) + XU = SQRT (SQRT (XU4)) + + XT = SQRT (SQRT (XT4)) + + PSMZ = PSPMU (XU) + SIMM = PSPMU (XLU) - PSMZ + RLOGU + PSHZ = PSPHU (XT) + SIMH = PSPHU (XLT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) + PSMZ = PSPMS (ZETAU) + SIMM = PSPMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS (ZETAT) + SIMH = PSPHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! LECH'S FUNCTIONS +! ---------------------------------------------------------------------- + ELSE + IF (RLMO .lt. 0.)THEN + PSMZ = PSLMU (ZETAU) + SIMM = PSLMU (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU (ZETAT) + SIMH = PSLHU (ZETALT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) + PSMZ = PSLMS (ZETAU) + SIMM = PSLMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS (ZETAT) + SIMH = PSLHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! BELJAARS CORRECTION FOR USTAR +! ---------------------------------------------------------------------- + END IF + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + !KCL/TL + !ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0 + ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0 + ZSLT = ZLM + ZT + RLOGT = log (ZSLT / ZT) + USTARK = USTAR * VKRM + AKMS = MAX (USTARK / SIMM,CXCH) + AKHS = MAX (USTARK / SIMH,CXCH) +! + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF +!----------------------------------------------------------------------- + RLMN = ELFC * AKHS * DTHV / USTAR **3 +!----------------------------------------------------------------------- +! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 +!----------------------------------------------------------------------- + RLMA = RLMO * WOLD+ RLMN * WNEW +!----------------------------------------------------------------------- + RLMO = RLMA + + END DO + + CD = USTAR*USTAR/SFCSPD**2 +! ---------------------------------------------------------------------- + END SUBROUTINE SFCDIF_URB +! ---------------------------------------------------------------------- +!=========================================================================== END MODULE module_sf_urban diff --git a/wrfv2_fire/phys/module_surface_driver.F b/wrfv2_fire/phys/module_surface_driver.F index e0e33078..3c748266 100644 --- a/wrfv2_fire/phys/module_surface_driver.F +++ b/wrfv2_fire/phys/module_surface_driver.F @@ -37,7 +37,9 @@ CONTAINS & ,ch,tsq,qsq,cov & ! MYNN #endif ! Optional urban - & ,declin_urb,cosz_urb2d,omg_urb2d,xlat_urb2d & !I urban + & ,slope_rad,topo_shading,shadowmask & !I solar + & ,swnorm,slope,slp_azi & !I solar + & ,declin,solcon,coszen,hrang,xlat_urb2d & !I solar/urban & ,num_roof_layers, num_wall_layers & !I urban & ,num_road_layers, dzr, dzb, dzg & !I urban & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d & !H urban @@ -46,6 +48,7 @@ CONTAINS & ,trl_urb3d,tbl_urb3d,tgl_urb3d & !H urban & ,sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d,ts_urb2d & !H urban & ,frc_urb2d, utype_urb2d & !H urban + & ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif & & , ids,ide,jds,jde,kds,kde & & , ims,ime,jms,jme,kms,kme & & , i_start,i_end,j_start,j_end,kts,kte,num_tiles & @@ -59,7 +62,7 @@ CONTAINS & ,capg,hol,mol & & ,rainncv,rainbl,regime,thc & & ,qsg,qvg,qcg,soilt1,tsnav & - & ,smfr3d,keepfr3dflag & + & ,smfr3d,keepfr3dflag,dew & ! Other optionals (more or less nmm specific) & ,potevp,snopcx,soiltb,sr & ! Optional observation PX LSM surface nudging @@ -71,7 +74,7 @@ CONTAINS ! Optional simple oml model & ,omlcall,oml_hml0,oml_gamma & & ,tml,t0ml,hml,h0ml,huml,hvml,f & - & ,ustm,ck,cka,cd,cda,isftcflx & + & ,ustm,ck,cka,cd,cda,isftcflx,iz0tlnd & & ,isurban, mminlu & & ,snotime & & ,rdlai2d & @@ -82,7 +85,13 @@ CONTAINS ! Optional urban with BEP & ,sf_urban_physics,gmt,xlat,xlong,julday & & ,num_urban_layers & !multi-layer urban - & ,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d & !multi-layer urban + & ,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d & !multi-layer urban + & ,tlev_urb3d,qlev_urb3d & !multi-layer urban + & ,tw1lev_urb3d,tw2lev_urb3d & !multi-layer urban + & ,tglev_urb3d,tflev_urb3d & !multi-layer urban + & ,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d & !multi-layer urban + & ,sfvent_urb3d,lfvent_urb3d & !multi-layer urban + & ,sfwin1_urb3d,sfwin2_urb3d & !multi-layer urban & ,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d & !multi-layer urban & ,a_u_bep,a_v_bep,a_t_bep,a_q_bep & & ,b_u_bep,b_v_bep,b_t_bep,b_q_bep & @@ -131,6 +140,7 @@ CONTAINS USE module_sf_pxlsm #if ( EM_CORE==1) USE module_sf_mynn + USE module_sf_oml #endif #if ( NMM_CORE == 1 ) @@ -140,24 +150,27 @@ CONTAINS USE module_sf_slab ! USE module_sf_sfcdiags + USE module_sf_sfcdiags_ruclsm USE module_sf_sstskin USE module_sf_tmnupdate ! - - ! This driver calls subroutines for the surface parameterizations. - ! - ! surface layer: (between surface and pbl) - ! 1. sfclay - ! 2. myjsfc - ! 7. Pleim surface layer - ! 5. MYNN surface layer - ! surface: ground temp/lsm scheme: - ! 1. slab - ! 2. Noah LSM - ! 7. Pleim-Xiu LSM - - ! surface: ground temp/lsm scheme for urban: - ! 2. BEP +! This driver calls subroutines for the surface parameterizations. +! +! surface layer: (between surface and pbl) +! 1. sfclay +! 2. myjsfc +! 7. Pleim surface layer +! 5. MYNN surface layer +! surface: ground temp/lsm scheme: +! 1. slab +! 2. Noah LSM +! 7. Pleim-Xiu LSM +! +! surface: ground temp/lsm scheme for urban: +! 2. BEP +! +! ocean mixed layer model +! omlcall = 1 !------------------------------------------------------------------ IMPLICIT NONE !====================================================================== @@ -351,7 +364,7 @@ CONTAINS REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: SMOIS REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: TSLB REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: GLW - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: GSW,SWDOWN + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: GSW,SWDOWN REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: HT REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: RAINCV REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: SST @@ -363,7 +376,7 @@ CONTAINS REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL :: TDLY REAL, DIMENSION( ims:ime , 1:lagday , jms:jme ), INTENT(INOUT ),OPTIONAL :: TLAG REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: VEGFRA - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: XICE + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ):: XICE REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: XLAND REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: XICEM REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: MAVAIL @@ -463,6 +476,19 @@ CONTAINS REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d @@ -498,7 +524,12 @@ CONTAINS #endif - INTEGER, OPTIONAL, INTENT(IN ):: ISFTCFLX + INTEGER, OPTIONAL, INTENT(IN ):: slope_rad, topo_shading + INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: shadowmask + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: swnorm + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: slope,slp_azi + + INTEGER, OPTIONAL, INTENT(IN ):: ISFTCFLX,IZ0TLND INTEGER, OPTIONAL, INTENT(IN ):: OMLCALL REAL , OPTIONAL, INTENT(IN ):: OML_HML0 REAL , OPTIONAL, INTENT(IN ):: OML_GAMMA @@ -563,6 +594,7 @@ CONTAINS REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: qsg REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: qvg REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: qcg + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: dew REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: soilt1 REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: tsnav REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: potevp ! NMM LSM @@ -598,12 +630,18 @@ CONTAINS REAL :: julian REAL :: total_depth,mid_point_depth REAL :: tconst,tprior,tnew,yrday,deltat + REAL :: SWSAVE + REAL, DIMENSION( ims:ime, jms:jme ) :: GSWSAVE !------------------------------------------------- ! urban related variables are added to declaration !------------------------------------------------- - REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB !urban - REAL, OPTIONAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D !urban - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF + REAL, OPTIONAL, INTENT(IN) :: DECLIN, SOLCON + REAL, OPTIONAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZEN + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: HRANG REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D !urban INTEGER, INTENT(IN) :: num_roof_layers !urban INTEGER, INTENT(IN) :: num_wall_layers !urban @@ -764,6 +802,9 @@ CONTAINS IVGTYP(I,J) = ISWATER ISLTYP(I,J) = 14 VEGFRA(I,J) = 0. + SNOW(I,J) = 0. + SNOWC(I,J) = 0. + SNOWH(I,J) = 0. TMN(I,J) = SST(I,J) DO nk = 1, num_soil_layers TSLB(I,NK,J) = SST(I,J) @@ -773,27 +814,35 @@ CONTAINS ENDIF ENDDO ENDDO - IF(PRESENT(SST_SKIN))THEN + ENDDO + !$OMP END PARALLEL DO + ENDIF + + IF(PRESENT(SST_SKIN))THEN IF (sst_skin .EQ. 1) THEN - ! Calculate skin sst based on Zeng and Beljaars (2005) - CALL wrf_debug( 100, 'in SST_UPDATE' ) +! Calculate skin sst based on Zeng and Beljaars (2005) + CALL wrf_debug( 100, 'in SST_SKIN_UPDATE' ) CALL sst_skin_update(xland,glw,gsw,hfx,qfx,tsk,ust, & emiss,dtw,sstsk,dt,stbolt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles DO j=j_start(ij),j_end(ij) DO i=i_start(ij),i_end(ij) IF(XLAND(i,j) .GT. 1.5)TSK(i,j)=SSTSK(i,j) ENDDO ENDDO - ENDIF - ENDIF ENDDO !$OMP END PARALLEL DO + ENDIF ENDIF + IF(PRESENT(TMN_UPDATE))THEN IF (tmn_update .EQ. 1) THEN + CALL wrf_debug( 100, 'in TMN_UPDATE' ) CALL tmnupdate(tsk,tmn,tlag,tyr,tyra,tdly,nday,nyear,lagday, & julian_in, dt, yr, & ids, ide, jds, jde, kds, kde, & @@ -802,8 +851,6 @@ CONTAINS ENDIF ENDIF - - ! ! Modified for adaptive time step ! @@ -841,6 +888,25 @@ CONTAINS IF (ra_lw_physics .gt. 0) radiation = .true. + IF( PRESENT(slope_rad).AND. radiation )THEN +! topographic slope effects modify SWDOWN and GSW here + IF (slope_rad .EQ. 1) THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + CALL TOPO_RAD_ADJ_DRVR (XLAT,XLONG,COSZEN, & + shadowmask, & + declin, & + SWDOWN,GSW,SWNORM,GSWSAVE,solcon,hrang, & + slope,slp_azi, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + ENDDO + !$OMP END PARALLEL DO + + ENDIF + ENDIF !---- ! CALCULATE CONSTANT @@ -927,7 +993,7 @@ CONTAINS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & - ustm,ck,cka,cd,cda,isftcflx ) + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd ) ELSE CALL SFCLAY(u_phytmp,v_phytmp,t_phy,qv_curr,& p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, & @@ -940,7 +1006,7 @@ CONTAINS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & - ustm,ck,cka,cd,cda,isftcflx ) + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd ) #if ( EM_CORE==1) DO j = j_start(ij),j_end(ij) DO i = i_start(ij),i_end(ij) @@ -1006,7 +1072,7 @@ CONTAINS u_phy,v_phy,tke_myj, & tsk,qsfc,thz0,qz0,uz0,vz0, & lowlyr, & - xland, & + xland,ivgtyp,isurban,iz0tlnd, & XICE_THRESHOLD, & ! Extra for wrapper. XICE, SST, & ! Extra for wrapper. CHS_SEA, CHS2_SEA, CQS2_SEA, CPM_SEA, & @@ -1029,7 +1095,7 @@ CONTAINS u_phy,v_phy,tke_myj, & tsk,qsfc,thz0,qz0,uz0,vz0, & lowlyr, & - xland, & + xland,ivgtyp,isurban,iz0tlnd, & ust,znt,z0,pblh,mavail,rmol, & akhs,akms, & br, & @@ -1232,9 +1298,7 @@ CONTAINS p1000mb, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte,& - tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy,f,g, & - omlcall,oml_gamma ) + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte) DO j=j_start(ij),j_end(ij) DO i=i_start(ij),i_end(ij) @@ -1257,8 +1321,8 @@ CONTAINS IF (PRESENT(qv_curr) .AND. PRESENT(rainbl) .AND. & ! PRESENT(emiss) .AND. PRESENT(t2) .AND. & -! PRESENT(declin_urb) .AND. PRESENT(cosz_urb2d) .AND. & -! PRESENT(omg_urb2d) .AND. PRESENT( xlat_urb2d) .AND. & +! PRESENT(declin) .AND. PRESENT(coszen) .AND. & +! PRESENT(hrang) .AND. PRESENT( xlat_urb2d) .AND. & ! PRESENT(dzr) .AND. & ! PRESENT( dzb) .AND. PRESENT(dzg) .AND. & ! PRESENT(tr_urb2d) .AND. PRESENT(tb_urb2d) .AND. & @@ -1335,6 +1399,7 @@ CONTAINS i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & sf_urban_physics & !Optional urban + ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban uc_urb2d, & !H urban xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban @@ -1343,13 +1408,19 @@ CONTAINS psim_urb2d,psih_urb2d,u10_urb2d,v10_urb2d, & !O urban GZ1OZ0_urb2d, AKMS_URB2D, & !O urban th2_urb2d,q2_urb2d,ust_urb2d, & !O urban - declin_urb,cosz_urb2d,omg_urb2d, & !I urban + declin,coszen,hrang, & !I solar xlat_urb2d, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban FRC_URB2D, UTYPE_URB2D, & !I urban num_urban_layers, & !I multi-layer urban trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban + tlev_urb3d,qlev_urb3d, & !H multi-layer urban + tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban + tglev_urb3d,tflev_urb3d, & !H multi-layer urban + sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d, & !H multi-layer urban + sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban + sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban th_phy,rho,p_phy,ust, & !I multi-layer urban gmt,julday,xlong,xlat, & !I multi-layer urban @@ -1358,6 +1429,7 @@ CONTAINS b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban dl_u_bep,sf_bep,vl_bep & !O multi-layer urban ) + IF ( FRACTIONAL_SEAICE == 1 ) THEN IF ( isisfc ) THEN DO j=j_start(ij),j_end(ij) @@ -1433,7 +1505,7 @@ CONTAINS ENDDO !urban ENDIF ! urban BEP - IF(SF_URBAN_PHYSICS.eq.2) THEN + IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN DO j=j_start(ij),j_end(ij) !urban DO i=i_start(ij),i_end(ij) !urban IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & !urban @@ -1461,6 +1533,7 @@ CONTAINS PRESENT(qcg) .AND. PRESENT(soilt1) .AND. & PRESENT(tsnav) .AND. PRESENT(smfr3d) .AND. & PRESENT(keepfr3dflag) .AND. PRESENT(rainbl) .AND. & + PRESENT(dew) .AND. & .TRUE. ) THEN IF( PRESENT(sr) ) THEN @@ -1507,10 +1580,11 @@ CONTAINS dz8w,p8w,t_phy,qv_curr,qc_curr,rho, & !p8w in [pa] glw,gsw,emiss,chklowq, & chs,flqc,flhc,mavail,canwat,vegfra,albedo,znt, & - snoalb, albbck, & !new - qsfc,qsg,qvg,qcg,soilt1,tsnav, & - tmn,ivgtyp,isltyp,xland,xice, & - cp,g,xlv,stbolt, & + z0,snoalb, albbck, & !new + qsfc,qsg,qvg,qcg,dew,soilt1,tsnav, & + tmn,ivgtyp,isltyp,xland, & + isice,xice,xice_threshold, & + cp,rovcp,g,xlv,stbolt, & smois,sh2o,smstav,smstot,tslb,tsk,hfx,qfx,lh, & sfcrunoff,udrunoff,sfcexc, & sfcevp,grdflx,acsnow,acsnom, & @@ -1556,14 +1630,13 @@ CONTAINS ENDDO endif ENDIF -!tgs IF(.not. MYJ) then - - CALL SFCDIAGS(HFX,QFX,TSK,QVG,CHS2,CQS2,T2,TH2,Q2, & - PSFC,CP,R_d,RCP, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) -!tgs ENDIF + + CALL SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, & + T_PHY,QV_CURR,RHO,P8W, & + PSFC,CP,R_d,RCP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) ELSE @@ -1573,10 +1646,7 @@ CONTAINS CASE (PXLSMSCHEME) IF (PRESENT(qv_curr) .AND. PRESENT(qc_curr) .AND. & PRESENT(emiss) .AND. PRESENT(t2) .AND. & - PRESENT(qsg) .AND. PRESENT(qvg) .AND. & - PRESENT(qcg) .AND. PRESENT(soilt1) .AND. & - PRESENT(tsnav) .AND. PRESENT(smfr3d) .AND. & - PRESENT(keepfr3dflag) .AND. PRESENT(rainbl) .AND. & + PRESENT(rainbl) .AND. & .TRUE. ) THEN IF ( FRACTIONAL_SEAICE == 1 ) THEN @@ -1617,12 +1687,12 @@ CONTAINS CALL PXLSM(u_phy, v_phy, dz8w, qv_curr, t_phy, th_phy, rho,& psfc, gsw, glw, rainbl, emiss, & ITIMESTEP, num_soil_layers, DT, anal_interval, & - xland, albbck, albedo, snoalb, smois, tslb, & + xland, xice, albbck, albedo, snoalb, smois, tslb, & mavail,T2, Q2, & zs, dzs, psih, & landusef,soilctop,soilcbot,vegfra, vegf_px, & isltyp,ra,rs,lai,nlcat,nscat, & - hfx,qfx,lh,tsk,znt,canwat, & + hfx,qfx,lh,tsk,sst,znt,canwat, & grdflx,shdmin,shdmax, & snowc,pblh,rmol,ust,capg,dtbl, & t2_ndg_old,t2_ndg_new,q2_ndg_old,q2_ndg_new, & @@ -1698,6 +1768,25 @@ CONTAINS 430 CONTINUE +#if ( EM_CORE==1) + IF (omlcall .EQ. 1) THEN +! simple ocean mixed layer model based Pollard, Rhines and Thompson (1973) + CALL wrf_debug( 100, 'Call OCEANML' ) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + CALL oceanml(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & + f,g,oml_gamma, & + xland,hfx,lh,tsk,gsw,glw,emiss, & + dtbl,STBOLT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte) + ENDDO + !$OMP END PARALLEL DO + ENDIF +#endif + ! Reset RAINBL in mm (Accumulation between PBL calls) IF ( PRESENT( rainbl ) ) THEN @@ -1713,6 +1802,31 @@ CONTAINS !$OMP END PARALLEL DO ENDIF + IF( PRESENT(slope_rad).AND. radiation )THEN +! topographic slope effects removed from SWDOWN and GSW here for output + IF (slope_rad .EQ. 1) THEN + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + IF(SWNORM(I,J) .GT. 1.E-3)THEN ! daytime + SWSAVE = SWDOWN(i,j) +! SWDOWN contains unaffected SWDOWN in output + SWDOWN(i,j) = SWNORM(i,j) +! SWNORM contains slope-affected SWDOWN in output + SWNORM(i,j) = SWSAVE + GSW(i,j) = GSWSAVE(i,j) + ENDIF + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + ENDIF + ENDIF END SUBROUTINE surface_driver @@ -1723,7 +1837,7 @@ CONTAINS subroutine myjsfc_seaice_wrapper(ITIMESTEP,HT,DZ, & & PMID,PINT,TH,T,QV,QC,U,V,Q2, & & TSK,QSFC,THZ0,QZ0,UZ0,VZ0, & - & LOWLYR,XLAND, & + & LOWLYR,XLAND,IVGTYP,ISURBAN,IZ0TLND, & & XICE_THRESHOLD, & ! Extra for wrapper & XICE,SST, & ! Extra for wrapper & CHS_SEA, CHS2_SEA, CQS2_SEA, CPM_SEA, & ! Extra for wrapper @@ -1768,6 +1882,9 @@ CONTAINS REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: VZ0 INTEGER,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: LOWLYR REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: XLAND + INTEGER,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: IVGTYP + INTEGER :: ISURBAN + INTEGER :: IZ0TLND REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: XICE ! Extra for wrapper ! REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: SST ! Extra for wrapper REAL,DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: SST ! Extra for wrapper @@ -1992,7 +2109,7 @@ CONTAINS CALL MYJSFC ( ITIMESTEP, HT, DZ, & ! I,I,I, & PMID, PINT, TH, T, QV, QC, U, V, Q2, & ! I,I,I,I,I,I,I,I,I, & TSK, QSFC, THZ0, QZ0, UZ0, VZ0, & ! I,IO,IO,IO,IO,IO, - & LOWLYR, XLAND, & ! I,I, + & LOWLYR, XLAND, IVGTYP, ISURBAN, IZ0TLND, & ! I,I,I,I,I & USTAR, ZNT, Z0BASE, PBLH, MAVAIL, RMOL, & ! IO,IO,I,IO,I,IO, & AKHS, AKMS, & ! IO,IO, & BR, & ! O @@ -2047,7 +2164,7 @@ CONTAINS CALL MYJSFC ( ITIMESTEP, HT, DZ, & ! I,I,I, & PMID, PINT, TH, T, QV, QC, U, V, Q2, & ! I,I,I,I,I,I,I,I,I, & TSK_SEA, QSFC_SEA, THZ0_SEA, QZ0_SEA, UZ0_SEA, VZ0_SEA, & ! I,IO,IO,IO,IO,IO, - & LOWLYR, XLAND_SEA, & ! I,I, + & LOWLYR, XLAND_SEA, IVGTYP, ISURBAN, IZ0TLND, & ! I,I,I,I,I, & USTAR_SEA, ZNT_SEA, Z0BASE_SEA, PBLH_SEA, MAVAIL_SEA, RMOL_SEA, & ! IO,IO,I,IO,I,IO, & AKHS_SEA, AKMS_SEA, & ! IO,IO, & BR_SEA, & ! dummy space holder @@ -2426,7 +2543,7 @@ ITIMESTEP,XICE_THRESHOLD, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - ustm,ck,cka,cd,cda,isftcflx ) + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd ) USE module_sf_sfclay implicit none @@ -2498,7 +2615,7 @@ ITIMESTEP,XICE_THRESHOLD, & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda,ustm - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX + INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX,IZ0TLND !-------------------------------------------------------------------- ! New for wrapper @@ -2579,7 +2696,7 @@ ITIMESTEP,XICE_THRESHOLD, & ! SVP1,SVP2,SVP3,SVPT0 ! EP1,EP2,KARMAN,EOMEG,STBOLT ! CP,G,ROVCP,R,XLV,DX - ! ISFTCFLX + ! ISFTCFLX,IZ0TLND ! P1000 ! dz8w ! QV3D @@ -2681,7 +2798,7 @@ ITIMESTEP,XICE_THRESHOLD, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - ustm,ck,cka,cd,cda,isftcflx ) + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd ) ! Set up for open-water call DO j = JTS , JTE @@ -2746,7 +2863,7 @@ ITIMESTEP,XICE_THRESHOLD, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ! 0 - ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx ) + ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd ) DO j = JTS , JTE DO i = ITS, ITE @@ -3121,6 +3238,138 @@ HFX_SEA, LH_SEA, QFX_SEA, QGH_SEA, QSFC_SEA, TSK_SEA, & END SUBROUTINE pxsfclay_seaice_wrapper !------------------------------------------------------------------------- + + SUBROUTINE TOPO_RAD_ADJ_DRVR (XLAT,XLONG,COSZEN, & + shadowmask, & + declin, & + SWDOWN,GSW,SWNORM,GSWSAVE,solcon,hrang2d, & + slope_in,slp_azi_in, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + INTEGER, INTENT(IN) :: its,ite,jts,jte,kts,kte, & + ims,ime,jms,jme,kms,kme, & + ids,ide,jds,jde,kds,kde + INTEGER, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN) :: shadowmask + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: XLAT,XLONG + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: SWDOWN,GSW,SWNORM,GSWSAVE + real,intent(in) :: solcon + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: hrang2d,coszen + + + REAL, INTENT(IN ) :: declin + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: slope_in,slp_azi_in + + +! LOCAL VARS + integer :: i,j + real :: pi,degrad + integer :: shadow + real :: swdown_teradj,swdown_in,xlat1,xlong1 + +!------------------------------------------------------------------ + + pi = 4.*atan(1.) + degrad=pi/180. + + DO J=jts,jte + DO I=its,ite + SWNORM(i,j) = SWDOWN(i,j) ! save + IF(SWDOWN(I,J) .GT. 1.E-3)THEN ! daytime + shadow = shadowmask(i,j) + + SWDOWN_IN = SWDOWN(i,j) + XLAT1 = XLAT(i,j) + XLONG1 = XLONG(i,j) + CALL TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN(i,j), & + DECLIN,DEGRAD, & + SWDOWN_IN,solcon,hrang2d(i,j),SWDOWN_teradj, & + kts,kte, & + slope_in(i,j),slp_azi_in(i,j), & + shadow , i,j & + ) + + GSWSAVE(I,J) = GSW(I,J) ! save + GSW(I,J) = GSW(I,J)*SWDOWN_teradj/SWDOWN(i,j) + SWDOWN(i,j) = SWDOWN_teradj + + ENDIF ! daytime + ENDDO ! i_loop + ENDDO ! j_loop + + + END SUBROUTINE TOPO_RAD_ADJ_DRVR +!------------------------------------------------------------------ +!------------------------------------------------------------------ + SUBROUTINE TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN, & + DECLIN,DEGRAD, & + SWDOWN_IN,solcon,hrang,SWDOWN_teradj, & + kts,kte, & + slope,slp_azi, & + shadow & + ,i,j) + +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + INTEGER, INTENT(IN) :: kts,kte + REAL, INTENT(IN) :: COSZEN,DECLIN, & + XLAT1,XLONG1,DEGRAD + REAL, INTENT(IN) :: SWDOWN_IN,solcon,hrang + INTEGER, INTENT(IN) :: shadow + REAL, INTENT(IN) :: slp_azi,slope + + REAL, INTENT(OUT) :: SWDOWN_teradj + +! LOCAL VARS + REAL :: XT24,TLOCTM,CSZA,XXLAT + REAL :: diffuse_frac,corr_fac,csza_slp + integer :: i,j + + +!------------------------------------------------------------------ + + SWDOWN_teradj=SWDOWN_IN + + CSZA=COSZEN + XXLAT=XLAT1*DEGRAD + +! RETURN IF NIGHT + IF(CSZA.LE.1.E-9) return + +! Parameterize diffuse fraction of global solar radiation as a function of the ratio between TOA radiation and surface global radiation + diffuse_frac = min(1.,1./(max(0.1,2.1-2.8*log(log(csza*solcon/max(SWDOWN_IN,1.e-3)))))) + if ((slope.eq.0).or.(diffuse_frac.eq.1).or.(csza.lt.1.e-2)) then ! no topographic effects when all radiation diffuse or sun too close to horizon + corr_fac = 1 + goto 140 + endif + +! cosine of zenith angle over sloping topography + csza_slp = ((SIN(XXLAT)*COS(HRANG))* & + (-cos(slp_azi)*sin(slope))-SIN(HRANG)*(sin(slp_azi)*sin(slope))+ & + (COS(XXLAT)*COS(HRANG))*cos(slope))* & + COS(DECLIN)+(COS(XXLAT)*(cos(slp_azi)*sin(slope))+ & + SIN(XXLAT)*cos(slope))*SIN(DECLIN) + IF(csza_slp.LE.1.E-4) csza_slp = 0 + +! Topographic shading + if (shadow.eq.1) csza_slp = 0 + +! Correction factor for sloping topography; the diffuse fraction of solar radiation is assumed to be unaffected by the slope + corr_fac = diffuse_frac + (1-diffuse_frac)*csza_slp/csza + + 140 continue + + SWDOWN_teradj=(1.)*SWDOWN_IN*corr_fac + + END SUBROUTINE TOPO_RAD_ADJ + !------------------------------------------------------------------------- END MODULE module_surface_driver diff --git a/wrfv2_fire/run/GENPARM.TBL b/wrfv2_fire/run/GENPARM.TBL index 037f15e9..026f5e26 100644 --- a/wrfv2_fire/run/GENPARM.TBL +++ b/wrfv2_fire/run/GENPARM.TBL @@ -32,3 +32,5 @@ SMLOW_DATA 0.5 SMHIGH_DATA 3.0 +LVCOEF_DATA +1.0 diff --git a/wrfv2_fire/run/README.namelist b/wrfv2_fire/run/README.namelist index 57995919..fe5ba576 100644 --- a/wrfv2_fire/run/README.namelist +++ b/wrfv2_fire/run/README.namelist @@ -115,6 +115,7 @@ Additional settings when running WRFVAR: Example, if you want to use 60.3 sec as your time step, set time_step = 60, time_step_fract_num = 3, and time_step_fract_den = 10 + time_step_dfi = 60, ; time step for DFI, may be different from regular time_step max_dom = 1, ; number of domains - set it to > 1 if it is a nested run s_we (max_dom) = 1, ; start index in x (west-east) direction (leave as is) e_we (max_dom) = 91, ; end index in x (west-east) direction (staggered dimension) @@ -295,6 +296,7 @@ Namelist variables for controlling the adaptive time step option: dfi_fwdstop_hour = 12 ; two-digit month of stop time for forward DFI integration dfi_fwdstop_minute = 00 ; two-digit month of stop time for forward DFI integration dfi_fwdstop_second = 00 ; two-digit month of stop time for forward DFI integration + dfi_radar = 0 ; DFI radar da switch &physics @@ -527,6 +529,8 @@ Namelist variables for controlling the adaptive time step option: oml_gamma = 0.14 ; oml deep water lapse rate (K m-1) isftcflx = 0 ; alternative Ck, Cd formulation for tropical storm application (0=default, 1=new) fractional_seaice = 0 ; treat sea-ice as fractional field (1) or ice/no-ice flag (0) + iz0tlnd = 0 ; thermal roughness length for sfclay and myjsfc (0 - old, 1 - veg dependent Czil) + mp_tend_lim = 10., ; limit on temp tendency from mp latent heating from radar data assimilation &fdda grid_fdda (max_dom) = 1 ; grid-nudging fdda on (=0 off) for each domain @@ -701,6 +705,12 @@ The following are for observation nudging: (if using a time_step much larger than 6*dx (in km), proportionally increase number of sound steps - also best to use even numbers) + do_avgflx_em (max_dom) = 0, ; whether to output time-averaged mass-coupled advective velocities + 0 = no (default) + 1 = yes + do_avgflx_cugd (max_dom) = 0, ; whether to output time-averaged convective mass-fluxes from Grell-Devenyi ensemble scheme + 0 = no (default) + 1 = yes (only takes effect if do_avgflx_em=1 and cu_physics= 3 do_coriolis (max_dom) = .true., ; whether to do Coriolis calculations (idealized) (inactive) do_curvature (max_dom) = .true., ; whether to do curvature calculations (idealized) (inactive) do_gradp (max_dom) = .true., ; whether to do horizontal pressure gradient calculations (idealized) (inactive) @@ -709,6 +719,11 @@ The following are for observation nudging: gwd_opt = 0 ; for running without gravity wave drag = 1 ; for running the WRF-ARW with its gravity wave drag = 2 ; for running the WRF-NMM with its gravity wave drag + sfs_opt (max_dom) = 0 ; nonlinear backscatter and anisotropy (NBA) off + = 1 ; NBA1 using diagnostic stress terms (km_opt=2,3 for scalars) + = 2 ; NBA2 using tke-based stress terms (km_opt=2 needed)) + m_opt (max_dom) = 0 ; no added output + = 1 ; adds output of Mij stress terms when NBA is not used &bdy_control spec_bdy_width = 5, ; total number of rows for specified boundary value nudging @@ -732,6 +747,9 @@ The following are for observation nudging: nested (max_dom) = .false., ; nested boundary conditions (must be used for nests) polar = .false., ; polar boundary condition (v=0 at polarward-most v-point) + euler_adv = .false., ; conservative Eulerian passive advection (NMM only) + idtadt = 1, ; fundamental timesteps between calls to Euler advection, dynamics (NMM only) + idtadc = 1 ; fundamental timesteps between calls to Euler advection, chemistry (NMM only) diff --git a/wrfv2_fire/run/URBPARM.TBL b/wrfv2_fire/run/URBPARM.TBL index 893de80f..f5d21eff 100644 --- a/wrfv2_fire/run/URBPARM.TBL +++ b/wrfv2_fire/run/URBPARM.TBL @@ -12,26 +12,32 @@ Number of urban categories: 3 # Type: Commercial, Hi-dens Res, Low-dens Res # +AKANDA_URBAN: 1.29 1.29 1.29 + # # ZR: Roof level (building height) [ m ] # -ZR: 10.0, 7.5, 5.0 +ZR: 8.9, 5.1, 5.4 + +# +# SIGMA_ZED: Standard Deviation of roof height [ m ] +# + +SIGMA_ZED: 4.0, 3.0, 1.0 # # ROOF_WIDTH: Roof (i.e., building) width [ m ] -# (KWM Just made up some numbers for the time being) # -ROOF_WIDTH: 10.0, 9.4, 8.3 +ROOF_WIDTH: 31.7, 25.7, 17.6 # # ROAD_WIDTH: road width [ m ] -# (KWM Just made up some numbers for the time being) # -ROAD_WIDTH: 10.0, 9.4, 8.3 +ROAD_WIDTH: 98.9, 39.2, 108.0 # # AH: Anthropogenic heat [ W m{-2} ] @@ -44,19 +50,19 @@ AH: 90.0, 50.0, 20.0 # vegetation. [ Fraction ] # -FRC_URB: 0.95, 0.9, 0.5 +FRC_URB: 0.865, 0.429, 0.429 # # CAPR: Heat capacity of roof [ J m{-3} K{-1} ] # -CAPR: 1.0E6, 1.0E6, 1.0E6, +CAPR: 1.32E6, 1.32E6, 1.32E6, # # CAPB: Heat capacity of building wall [ J m{-3} K{-1} ] # -CAPB: 1.0E6, 1.0E6, 1.0E6, +CAPB: 1.32E6, 1.32E6, 1.32E6, # # CAPG: Heat capacity of ground (road) [ J m{-3} K{-1} ] @@ -68,13 +74,13 @@ CAPG: 1.4E6, 1.4E6, 1.4E6, # AKSR: Thermal conductivity of roof [ J m{-1} s{-1} K{-1} ] # -AKSR: 0.67, 0.67, 0.67, +AKSR: 0.695, 0.695, 0.695, # # AKSB: Thermal conductivity of building wall [ J m{-1} s{-1} K{-1} ] # -AKSB: 0.67, 0.67, 0.67, +AKSB: 0.695, 0.695, 0.695, # # AKSG: Thermal conductivity of ground (road) [ J m{-1} s{-1} K{-1} ] @@ -98,7 +104,7 @@ ALBB: 0.20, 0.20, 0.20 # ALBG: Surface albedo of ground (road) [ fraction ] # -ALBG: 0.20, 0.20, 0.20 +ALBG: 0.15, 0.15, 0.15 # # EPSR: Surface emissivity of roof [ - ] @@ -119,12 +125,6 @@ EPSB: 0.90, 0.90, 0.90 EPSG: 0.95, 0.95, 0.95 # -# Z0R: Roughness length for momentum, over roof [ m ] -# - -Z0R: 0.01, 0.01, 0.01 - -# # Z0B: Roughness length for momentum, over building wall [ m ] # Only active for CH_SCHEME == 1 # @@ -138,6 +138,84 @@ Z0B: 0.0001, 0.0001, 0.0001 Z0G: 0.01, 0.01, 0.01 +# +# COP: Coefficient of performance of the A/C systems [ - ] +# + +COP: 3.5, 3.5, 3.5 + +# +# PWIN: Coverage area fraction of windows in the walls of the building [ - ] +# + +PWIN: 0.2, 0.2, 0.2 + +# +# BETA: Thermal efficiency of heat exchanger +# + +BETA: 0.75, 0.75, 0.75 + +# +# SW_COND: Air conditioning switch, 1=ON +# + +SW_COND: 1, 1, 1 + +# +# TIME_ON: Initial local time of A/C systems, [ h ] +# + +TIME_ON: 0., 0., 0. + +# +# TIME_OFF: End local time of A/C systems, [ h ] +# + +TIME_OFF: 24., 24., 24. + +# +# TARGTEMP: Target Temperature of the A/C systems, [ K ] +# + +TARGTEMP: 297., 298., 298. + +# +# GAPTEMP: Comfort Range of the indoor Temperature, [ K ] +# + +GAPTEMP: 0.5, 0.5, 0.5 + +# +# TARGHUM: Target humidity of the A/C systems, [ Kg/Kg ] +# + +TARGHUM: 0.005, 0.005, 0.005 + +# +# GAPHUM: Comfort Range of the specific humidity, [ Kg/Kg ] +# + +GAPHUM: 0.005, 0.005, 0.005 + +# +# PERFLO: Peak number of occupants per unit floor area, [ person/m^2 ] +# + +PERFLO: 0.02, 0.01, 0.01 + +# +# HSEQUIP: Diurnal heating profile of heat generated by equipments +# + +HSEQUIP: 0.25 0.25 0.25 0.25 0.25 0.25 0.25 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 0.5 0.25 0.25 0.25 0.25 0.25 + +# +# HSEQUIP_SCALE_FACTOR: Peak heat generated by equipments, [ W/m^2 ] +# + +HSEQUIP_SCALE_FACTOR: 36.00, 20.00, 16.00 + #ifdef _FOR_ALBERTO_ STREET PARAMETERS: @@ -145,12 +223,12 @@ STREET PARAMETERS: # category direction width width # [index] [deg from N] [m] [m] - 1 0.0 15.0 15.0 - 1 90.0 15.0 15.0 - 2 0.0 15.0 15.0 - 2 90.0 15.0 15.0 - 3 0.0 15.0 15.0 - 3 90.0 15.0 15.0 + 1 0.0 98.9 31.7 + 1 90.0 98.9 31.7 + 2 0.0 39.2 25.7 + 2 90.0 39.2 25.7 + 3 0.0 108.0 17.6 + 3 90.0 108.0 17.6 END STREET PARAMETERS @@ -158,35 +236,28 @@ BUILDING HEIGHTS: 1 # height Percentage # [m] [%] - - 5.0 30.0 - 10.0 40.0 - 15.0 30.0 + 5.0 37.0 + 10.0 34.0 + 15.0 9.0 + 20.0 20.0 END BUILDING HEIGHTS BUILDING HEIGHTS: 2 # height Percentage # [m] [%] - - 10.0 3.0 - 15.0 7.0 - 20.0 12.0 - 25.0 18.0 - 30.0 20.0 - 35.0 18.0 - 40.0 12.0 - 45.0 7.0 - 50.0 3.0 + 5.0 59.0 + 10.0 34.0 + 15.0 7.0 END BUILDING HEIGHTS BUILDING HEIGHTS: 3 # height Percentage # [m] [%] - - 5.0 50.0 - 10.0 50.0 + 5.0 55.0 + 10.0 30.0 + 15.0 15.0 END BUILDING HEIGHTS #endif # diff --git a/wrfv2_fire/run/gribmap.txt b/wrfv2_fire/run/gribmap.txt index 94e1b03b..a822e9fa 100644 --- a/wrfv2_fire/run/gribmap.txt +++ b/wrfv2_fire/run/gribmap.txt @@ -153,22 +153,22 @@ 151:PTOP:Pressure at model top [Pa]:P_TOP:3 152:TIMESTEP:Timestep number:ITIMESTEP:3 153:CLWMR:Cloud water [kg/kg]:QCLOUD,QCG:8 -154:var154:undefined:: +154:MUU:Total dry air mass in column on u-grid[Pa]:MUU:2 155:GFLUX:Ground heat flux [W/m^2]:HFX:4 156:RAINBL:Acc. precip. over Boundary Layer time step [kg/m^2]:RAINBL:2 -157:var157:undefined:: +157:MUV:Total dry air mass in column on v-grid[Pa]:MUV:2 158:TKE:Turbulent kinetic energy [J/kg]:TKE:3 159:TKE_MYJ:MYJ Turbulent kinetic energy [J/kg]:TKE_MYJ:3 160:SOILL:Liquid volumetric soil moisture (non-frozen) [fraction]:SH2O:6 -161:var157:undefined:: -162:var157:undefined:: -163:var157:undefined:: -164:var157:undefined:: -165:var157:undefined:: -166:var157:undefined:: -167:var157:undefined:: -168:var157:undefined:: -169:var157:undefined:: +161:MU_U:mu-coupled u [Pa m s-1]:MU_U:2 +162:RU_M:avg mu-coupled u [Pa m s-1]:RU_M:2 +163:MU_V:mu-coupled v [Pa m s-1]:MU_V:2 +164:RV_M:avg mu-coupled v [Pa m s-1]:RV_M:2 +165:RW:mu-coupled w [Pa m s-1]:RW:2 +166:WWM:avg mu-coupled eta-dot [Pa s-1]:WW_M:5 +167:UST:U* IN SIMILARITY THEORY [m/s]:UST:4 +168:MASSFLX:DOWNDRAFT MASS FLUX GRELL [mb/hour]:MASS_FLUX: +169:MUT:Total dry air mass in column on mass grid[Pa]:MUT:2 170:RWMR:Rain water mixing ratio [kg/kg]:QRAIN:5 171:SNMR:Snow mixing ratio [kg/kg]:QSNOW:5 172:RESM:Time weight constant for small steps:RESM:3 @@ -186,7 +186,7 @@ 184:COSALPHA:Local cosine of map rotation:COSALPHA:4 185:TURB:Turbulence SIGMET/AIRMET [non-dim]:: 186:EPSTS:EPSTS in WRF [?]:EPSTS:3 -187:var187:undefined:: +187:CFU1:AVERAGE updraft mass flux from GD-scheme [kg m-2 s-1]:CFU1:8 188:AKMS:Surface Exchange for Momentum [m/s]:AKMS:3 189:MAPFAC_M:Map Scale Factor [dimensionless]:MAPFAC_M:7 190:MAPFAC_U:Map Scale Factor [dimensionless]:MAPFAC_U:7 @@ -200,7 +200,7 @@ 198:MAPFAC_UX:Map Scale Factor [dimensionless]:MAPFAC_UX:7 199:MAPFAC_VX:Map Scale Factor [dimensionless]:MAPFAC_VX:7 200:MF_VX_INV:Inverse Map Scale Factor:MF_VX_INV:8 -201:var201:undefined:: +201:EFD1:AVERAGE entrainment into downdraft from GD-scheme [kg m-2 s-1]:EFD1:8 202:SNOWCU:Cumulative Snow [cm]:SNOWCU,ACSNOW:2 203:ACSNOM:Accumulated Melted Snow [cm]:ACSNOM:2 204:DSWRF:Downward short wave flux [W/m^2]:SWDOWN:3 @@ -218,10 +218,10 @@ 216:LANDUSEF:Land use categorical fraction on mass grid:LANDUSEF:3 217:SOILCTOP:Top layer soil type as a categorical fraction:SOILCTOP:3 218:SOILCBOT:Top layer soil type as a categorical fraction:SOILCBOT:3 -219:var219:undefined:: -220:var220:undefined:: +219:AVGFLX_RUM:hist-time-averaged mu-coupled u [Pa m s-1]:AVGFLX_RUM: +220:AVGFLX_RVM:hist-time-averaged mu-coupled v [Pa m s-1]:AVGFLX_RVM: 221:HPBL:Planetary boundary layer height [m]:PBLH:2 -222:var222:undefined:: +222:AVGFLX_WWM:hist-time-averaged mu-coupled eta-dot [Pa s-1]:AVGFLX_WWM:5 223:CNWAT:Plant canopy surface water [kg/m^2]:CANWAT:8 224:SOTYP:Soil type (Zobler) [0..9]:ISLTYP:0 225:VGTYP:Vegetation type (as in SiB) [0..13]:IVGTYP:1 @@ -231,16 +231,16 @@ 229:CF1:Second-order extrapolation constant 1:CF1:5 230:CF2:Second-order extrapolation constant 2:CF2:5 231:CF3:Second-order extrapolation constant 3:CF3:5 -232:var232:undefined:: -233:var233:undefined:: +232:CFD1:AVERAGE downdraft mass flux from GD-scheme [kg m-2 s-1]:CFD1:8 +233:DFU1:AVERAGE detrainment from updraft from GD-scheme [kg m-2 s-1]:DFU1:8 234:BGRUN:Baseflow-groundwater runoff [kg/m^2]:UDROFF:4 235:SSRUN:Storm surface runoff [kg/m^2]:SFROFF:4 236:SNOW:Snow Water Equivalent [kg/m^2]:SNOW:2 -237:var237:undefined:: +237:EFU1:AVERAGE entrainment into updraft from GD-scheme [kg m-2 s-1]:EFU1:8 238:SNOWC:Snow cover [%]:SNOWC:1 -239:var239:undefined:: +239:DFD1:AVERAGE detrainment from downdraft from GD-scheme [kg m-2 s-1]:DFD1:8 240:QFX:Upward moisture flux [kg/(m^s)]:QFX:8 -241:var241:undefined:: +241:ALT:inverse dry density [m3 kg-1]:ALT:8 242:var242:undefined:: 243:var243:undefined:: 244:var244:undefined:: diff --git a/wrfv2_fire/share/Makefile b/wrfv2_fire/share/Makefile index 377fde53..d124e60d 100644 --- a/wrfv2_fire/share/Makefile +++ b/wrfv2_fire/share/Makefile @@ -36,59 +36,9 @@ OBJS = \ wrf_timeseries.o \ wrf_ext_write_field.o \ wrf_ext_read_field.o \ - wrf_inputout.o \ - wrf_auxinput1out.o \ - wrf_auxinput2out.o \ - wrf_auxinput3out.o \ - wrf_auxinput4out.o \ - wrf_auxinput5out.o \ - wrf_auxinput6out.o \ - wrf_auxinput7out.o \ - wrf_auxinput8out.o \ - wrf_auxinput9out.o \ - wrf_auxinput10out.o \ - wrf_auxinput11out.o \ - wrf_histout.o \ - wrf_auxhist1out.o \ - wrf_auxhist2out.o \ - wrf_auxhist3out.o \ - wrf_auxhist4out.o \ - wrf_auxhist5out.o \ - wrf_auxhist6out.o \ - wrf_auxhist7out.o \ - wrf_auxhist8out.o \ - wrf_auxhist9out.o \ - wrf_auxhist10out.o \ - wrf_auxhist11out.o \ - wrf_restartout.o \ wrf_bdyout.o \ - wrf_inputin.o \ - wrf_auxhist1in.o \ - wrf_auxhist2in.o \ - wrf_auxhist3in.o \ - wrf_auxhist4in.o \ - wrf_auxhist5in.o \ - wrf_auxhist6in.o \ - wrf_auxhist7in.o \ - wrf_auxhist8in.o \ - wrf_auxhist9in.o \ - wrf_auxhist10in.o \ - wrf_auxhist11in.o \ - wrf_auxinput1in.o \ - wrf_auxinput2in.o \ - wrf_auxinput3in.o \ - wrf_auxinput4in.o \ - wrf_auxinput5in.o \ - wrf_auxinput6in.o \ - wrf_auxinput7in.o \ - wrf_auxinput8in.o \ - wrf_auxinput9in.o \ - wrf_auxinput10in.o \ - wrf_auxinput11in.o \ wrf_fddaobs_in.o \ wrf_bdyin.o \ - wrf_histin.o \ - wrf_restartin.o \ wrf_tsin.o \ landread.o @@ -110,6 +60,15 @@ include ../configure.wrf nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) +#set_timekeeping_defs.inc : set_timekeeping_defs.m4 +# $(M4) set_timekeeping_defs.m4 > set_timekeeping_defs.inc + +#set_timekeeping_alarms.inc : set_timekeeping_alarms.m4 +# $(M4) set_timekeeping_alarms.m4 > set_timekeeping_alarms.inc + +#module_io_domain_defs.inc : module_io_domain_defs.m4 +# $(M4) module_io_domain_defs.m4 > module_io_domain_defs.inc + clean: @ echo 'use the clean script' @@ -133,10 +92,8 @@ module_io_domain.o: module_io_wrf.o module_date_time.o ../frame/module_io.o \ ../frame/module_domain.o ../frame/module_configure.o \ ../frame/module_state_description.o -module_io_wrf.o: module_date_time.o module_bc_time_utilities.o \ - ../frame/module_wrf_error.o ../frame/module_domain.o \ - ../frame/module_state_description.o ../frame/module_configure.o \ - ../frame/module_io.o ../frame/module_timing.o \ +module_io_wrf.o: module_date_time.o \ + ../frame/module_wrf_error.o ../frame/module_streams.o \ $(ESMF_MOD_DEPENDENCE) output_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ @@ -144,6 +101,10 @@ output_wrf.o: ../frame/module_io.o ../frame/module_wrf_error.o \ ../frame/module_configure.o module_io_wrf.o \ $(ESMF_MOD_DEPENDENCE) +wrf_fddaobs_in.o: \ + module_date_time.o \ + module_llxy.o + wrf_timeseries.o: wrf_tsin.o \ module_model_constants.o \ module_llxy.o \ @@ -206,7 +167,12 @@ mediation_integrate.o: ../frame/module_domain.o ../frame/module_configure.o \ mediation_interp_domain.o: ../frame/module_domain.o ../frame/module_configure.o \ ../frame/module_timing.o -mediation_nest_move.o: ../frame/module_domain.o ../frame/module_configure.o ../frame/module_state_description.o +mediation_nest_move.o: \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_driver_constants.o \ + module_io_domain.o #mediation_conv_emissions.o: ../frame/module_domain.o ../frame/module_configure.o \ # ../external/esmf_time_f90/ESMF_Mod.o \ diff --git a/wrfv2_fire/share/dfi.F b/wrfv2_fire/share/dfi.F index a044c4b7..d25b9f4a 100644 --- a/wrfv2_fire/share/dfi.F +++ b/wrfv2_fire/share/dfi.F @@ -1,10 +1,10 @@ SUBROUTINE dfi_accumulate( grid ) - USE module_domain - USE module_configure + USE module_domain, ONLY : domain +! USE module_configure USE module_driver_constants USE module_machine - USE module_dm +! USE module_dm USE module_model_constants USE module_state_description @@ -38,7 +38,18 @@ grid%dfi_al(:,:,:) = grid%dfi_al(:,:,:) + grid%al(:,:,:) * hn grid%dfi_alt(:,:,:) = grid%dfi_alt(:,:,:) + grid%alt(:,:,:) * hn grid%dfi_pb(:,:,:) = grid%dfi_pb(:,:,:) + grid%pb(:,:,:) * hn + ! neg. check on hydrometeor and scalar variables + grid%moist(:,:,:,:) = max(0.,grid%moist(:,:,:,:)) + grid%dfi_scalar(:,:,:,:) = max(0.,grid%dfi_scalar(:,:,:,:)) +#if ( WRF_DFI_RADAR == 1 ) + IF ( grid%dfi_radar .EQ. 0 ) then grid%dfi_moist(:,:,:,:) = grid%dfi_moist(:,:,:,:) + grid%moist(:,:,:,:) * hn + ELSE + grid%dfi_moist(:,:,:,P_QV) = grid%dfi_moist(:,:,:,P_QV) + grid%moist(:,:,:,P_QV) * hn + ENDIF +#else + grid%dfi_moist(:,:,:,:) = grid%dfi_moist(:,:,:,:) + grid%moist(:,:,:,:) * hn +#endif grid%dfi_scalar(:,:,:,:) = grid%dfi_scalar(:,:,:,:) + grid%scalar(:,:,:,:) * hn ! accumulate DFI coefficient @@ -51,8 +62,9 @@ #if (EM_CORE == 1) SUBROUTINE wrf_dfi_bck_init ( ) - USE module_domain + USE module_domain, ONLY : domain, head_grid, domain_get_stop_time, domain_get_start_time USE module_utility + USE module_state_description IMPLICIT NONE @@ -60,27 +72,27 @@ INTERFACE SUBROUTINE Setup_Timekeeping(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE Setup_Timekeeping SUBROUTINE dfi_save_arrays(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_save_arrays SUBROUTINE dfi_clear_accumulation(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_clear_accumulation SUBROUTINE optfil_driver(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE optfil_driver SUBROUTINE start_domain(grid, allowed_to_read) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain) :: grid LOGICAL, INTENT(IN) :: allowed_to_read END SUBROUTINE start_domain @@ -89,7 +101,11 @@ head_grid%dfi_stage = DFI_BCK ! Negate time step - CALL nl_set_time_step ( 1, -head_grid%time_step ) + IF ( head_grid%time_step_dfi .gt. 0 ) THEN + CALL nl_set_time_step ( 1, -head_grid%time_step_dfi ) + ELSE + CALL nl_set_time_step ( 1, -head_grid%time_step ) + ENDIF CALL Setup_Timekeeping (head_grid) @@ -99,9 +115,15 @@ CALL nl_set_ra_sw_physics( 1, 0 ) CALL nl_set_sf_surface_physics( 1, 0 ) CALL nl_set_sf_sfclay_physics( 1, 0 ) + CALL nl_set_sf_urban_physics( 1, 0 ) CALL nl_set_bl_pbl_physics( 1, 0 ) CALL nl_set_cu_physics( 1, 0 ) CALL nl_set_damp_opt( 1, 0 ) + CALL nl_set_diff_6th_opt( 1, 0 ) + CALL nl_set_sst_update( 1, 0 ) + CALL nl_set_fractional_seaice( 1, 0 ) + CALL nl_set_gwd_opt( 1, 0 ) + CALL nl_set_use_adaptive_time_step( 1, .false. ) #ifdef WRF_CHEM ! set chemistry option to zero @@ -111,7 +133,10 @@ ! set diffusion to zero for backward integration CALL nl_set_km_opt( 1, head_grid%km_opt_dfi) - CALL nl_set_moist_adv_dfi_opt( 1, head_grid%moist_adv_dfi_opt) +! CALL nl_set_moist_adv_dfi_opt( 1, head_grid%moist_adv_dfi_opt) + IF ( head_grid%moist_adv_opt == 2 ) THEN + CALL nl_set_moist_adv_opt ( 1, 0 ) + ENDIF head_grid%start_subtime = domain_get_start_time ( head_grid ) head_grid%stop_subtime = domain_get_stop_time ( head_grid ) @@ -130,8 +155,9 @@ SUBROUTINE wrf_dfi_fwd_init ( ) - USE module_domain + USE module_domain, ONLY : domain, head_grid, domain_get_stop_time, domain_get_start_time USE module_utility + USE module_state_description IMPLICIT NONE @@ -139,27 +165,27 @@ INTERFACE SUBROUTINE Setup_Timekeeping(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE Setup_Timekeeping SUBROUTINE dfi_save_arrays(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_save_arrays SUBROUTINE dfi_clear_accumulation(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_clear_accumulation SUBROUTINE optfil_driver(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE optfil_driver SUBROUTINE start_domain(grid, allowed_to_read) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain) :: grid LOGICAL, INTENT(IN) :: allowed_to_read END SUBROUTINE start_domain @@ -167,13 +193,15 @@ head_grid%dfi_stage = DFI_FWD - ! get the negative time step from the namelist and store - ! it as positive again. ! for Setup_Timekeeping to use when setting the clock ! note that this ignores fractional parts of time step - CALL nl_get_time_step( 1, head_grid%time_step ) - head_grid%time_step = abs(head_grid%time_step) - CALL nl_set_time_step( 1, head_grid%time_step ) + +! CALL nl_set_time_step( 1, head_grid%time_step_dfi ) + IF ( head_grid%time_step_dfi .gt. 0 ) THEN + CALL nl_set_time_step ( 1, head_grid%time_step_dfi ) + ELSE + CALL nl_set_time_step ( 1, head_grid%time_step ) + ENDIF head_grid%itimestep=0 head_grid%xtime=0. @@ -184,9 +212,15 @@ CALL nl_set_ra_sw_physics( 1, head_grid%ra_sw_physics) CALL nl_set_sf_surface_physics( 1, head_grid%sf_surface_physics) CALL nl_set_sf_sfclay_physics( 1, head_grid%sf_sfclay_physics) + CALL nl_set_sf_urban_physics( 1, head_grid%sf_urban_physics) CALL nl_set_bl_pbl_physics( 1, head_grid%bl_pbl_physics) CALL nl_set_cu_physics( 1, head_grid%cu_physics) CALL nl_set_damp_opt( 1, head_grid%damp_opt) + CALL nl_set_diff_6th_opt( 1, head_grid%diff_6th_opt) + CALL nl_set_sst_update( 1, 0 ) + CALL nl_set_fractional_seaice( 1, head_grid%fractional_seaice) + CALL nl_set_gwd_opt( 1, head_grid%gwd_opt) + CALL nl_set_use_adaptive_time_step( 1, .false. ) #ifdef WRF_CHEM ! reset chem option to normal @@ -218,7 +252,8 @@ SUBROUTINE wrf_dfi_fst_init ( ) - USE module_domain + USE module_domain, ONLY : domain, head_grid, domain_get_stop_time, domain_get_start_time + USE module_state_description IMPLICIT NONE @@ -226,27 +261,27 @@ INTERFACE SUBROUTINE Setup_Timekeeping(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE Setup_Timekeeping SUBROUTINE dfi_save_arrays(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_save_arrays SUBROUTINE dfi_clear_accumulation(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_clear_accumulation SUBROUTINE optfil_driver(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE optfil_driver SUBROUTINE start_domain(grid, allowed_to_read) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain) :: grid LOGICAL, INTENT(IN) :: allowed_to_read END SUBROUTINE start_domain @@ -254,8 +289,14 @@ head_grid%dfi_stage = DFI_FST + ! reset time_step to normal and adaptive_time_step + CALL nl_set_time_step( 1, head_grid%time_step ) + head_grid%itimestep=0 head_grid%xtime=0. ! BUG: This will probably not work for all DFI options +! only use adaptive time stepping for forecast + CALL nl_set_use_adaptive_time_step( 1, head_grid%use_adaptive_time_step ) +! CALL nl_set_sst_update( 1, head_grid%sst_update ) CALL Setup_Timekeeping (head_grid) head_grid%start_subtime = domain_get_start_time ( head_grid ) @@ -269,9 +310,9 @@ SUBROUTINE wrf_dfi_write_initialized_state( ) ! Driver layer - USE module_domain + USE module_domain, ONLY : head_grid USE module_io_domain - USE module_configure + USE module_configure, ONLY : grid_config_rec_type, model_config_rec IMPLICIT NONE @@ -284,16 +325,16 @@ CALL model_to_grid_config_rec ( head_grid%id , model_config_rec , config_flags ) - WRITE (wrf_err_message,'(A,I4)') 'Writing out initialized model state' + WRITE (wrf_err_message,'(A)') 'Writing out initialized model state' CALL wrf_message(TRIM(wrf_err_message)) rstname = 'wrfinput_initialized_d01' - CALL open_w_dataset ( fid, TRIM(rstname), head_grid, config_flags, output_model_input, "DATASET=INPUT", ierr ) + CALL open_w_dataset ( fid, TRIM(rstname), head_grid, config_flags, output_input, "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN WRITE( message , '("program wrf: error opening ",A," for writing")') TRIM(rstname) CALL WRF_ERROR_FATAL ( message ) END IF - CALL output_model_input ( fid, head_grid, config_flags, ierr ) + CALL output_input ( fid, head_grid, config_flags, ierr ) CALL close_dataset ( fid, config_flags, "DATASET=INPUT" ) END SUBROUTINE wrf_dfi_write_initialized_state @@ -301,13 +342,13 @@ SUBROUTINE wrf_dfi_array_reset ( ) - USE module_domain + USE module_domain, ONLY : head_grid IMPLICIT NONE INTERFACE SUBROUTINE dfi_array_reset(grid) - USE module_domain + USE module_domain, ONLY : domain TYPE (domain), POINTER :: grid END SUBROUTINE dfi_array_reset END INTERFACE @@ -321,11 +362,12 @@ SUBROUTINE optfil_driver( grid ) - USE module_domain - USE module_wrf_error - USE module_timing - USE module_date_time - USE module_configure + USE module_domain, ONLY : domain + USE module_utility +! USE module_wrf_error +! USE module_timing +! USE module_date_time +! USE module_configure USE module_state_description USE module_model_constants @@ -337,6 +379,7 @@ integer :: nstep2, nstepmax, rundfi, i, rc real :: timestep, tauc TYPE(WRFU_TimeInterval) :: run_interval + CHARACTER*80 mess timestep=abs(grid%dt) run_interval = grid%stop_subtime - grid%start_subtime @@ -354,7 +397,8 @@ ! Get DFI coefficient grid%hcoeff(:) = 0.0 IF ( grid%dfi_nfilter < 0 .OR. grid%dfi_nfilter > 8 ) THEN -write(0,*) 'Invalid filter specified in namelist.' +write(mess,*) 'Invalid filter specified in namelist.' +call wrf_message(mess) ELSE call dfcoef(nstep2-1, grid%dt, tauc, grid%dfi_nfilter, grid%hcoeff) END IF @@ -374,13 +418,13 @@ write(0,*) 'Invalid filter specified in namelist.' SUBROUTINE dfi_clear_accumulation( grid ) - USE module_domain - USE module_configure - USE module_driver_constants - USE module_machine - USE module_dm - USE module_model_constants - USE module_state_description + USE module_domain, ONLY : domain +! USE module_configure +! USE module_driver_constants +! USE module_machine +! USE module_dm +! USE module_model_constants +! USE module_state_description IMPLICIT NONE @@ -402,7 +446,15 @@ write(0,*) 'Invalid filter specified in namelist.' grid%dfi_al(:,:,:) = 0. grid%dfi_alt(:,:,:) = 0. grid%dfi_pb(:,:,:) = 0. +#if ( WRF_DFI_RADAR == 1 ) + IF ( grid%dfi_radar .EQ. 0 ) then grid%dfi_moist(:,:,:,:) = 0. + ELSE + grid%dfi_moist(:,:,:,P_QV) = 0. + ENDIF +#else + grid%dfi_moist(:,:,:,:) = 0. +#endif grid%dfi_scalar(:,:,:,:) = 0. grid%hcoeff_tot = 0.0 @@ -412,18 +464,24 @@ write(0,*) 'Invalid filter specified in namelist.' SUBROUTINE dfi_save_arrays( grid ) - USE module_domain - USE module_configure - USE module_driver_constants - USE module_machine - USE module_dm + USE module_domain, ONLY : domain +! USE module_configure +! USE module_driver_constants +! USE module_machine +! USE module_dm USE module_model_constants USE module_state_description IMPLICIT NONE + INTEGER :: its, ite, jts, jte, kts, kte, & + i, j, k + ! Input data. TYPE(domain) , POINTER :: grid + ! local + + REAL es,qs,pol,tx,temp,pres,rslf ! save surface 2-D fields grid%dfi_SNOW(:,:) = grid%SNOW(:,:) @@ -431,33 +489,86 @@ write(0,*) 'Invalid filter specified in namelist.' grid%dfi_SNOWC(:,:) = grid%SNOWC(:,:) grid%dfi_CANWAT(:,:) = grid%CANWAT(:,:) grid%dfi_TSK(:,:) = grid%TSK(:,:) - grid%dfi_QVG(:,:) = grid%QVG(:,:) - grid%dfi_SOILT1(:,:) = grid%SOILT1(:,:) - grid%dfi_TSNAV(:,:) = grid%TSNAV(:,:) ! save soil fields grid%dfi_TSLB(:,:,:) = grid%TSLB(:,:,:) grid%dfi_SMOIS(:,:,:) = grid%SMOIS(:,:,:) + ! RUC LSM only, need conditional + IF ( grid%sf_surface_physics .EQ. 3 ) then + grid%dfi_QVG(:,:) = grid%QVG(:,:) + grid%dfi_SOILT1(:,:) = grid%SOILT1(:,:) + grid%dfi_TSNAV(:,:) = grid%TSNAV(:,:) grid%dfi_SMFR3D(:,:,:) = grid%SMFR3D(:,:,:) grid%dfi_KEEPFR3DFLAG(:,:,:) = grid%KEEPFR3DFLAG(:,:,:) + ENDIF + + ! save hydrometeor fields +#if ( WRF_DFI_RADAR == 1 ) + IF ( grid%dfi_radar .EQ. 1 ) then !tgs +! grid%dfi_moist(:,:,:,:) = grid%moist(:,:,:,:) + grid%dfi_moist(:,:,:,P_QC) = grid%moist(:,:,:,P_QC) + grid%dfi_moist(:,:,:,P_QR) = grid%moist(:,:,:,P_QR) + grid%dfi_moist(:,:,:,P_QI) = grid%moist(:,:,:,P_QI) + grid%dfi_moist(:,:,:,P_QS) = grid%moist(:,:,:,P_QS) + grid%dfi_moist(:,:,:,P_QG) = grid%moist(:,:,:,P_QG) + + if(grid%dfi_stage .EQ. DFI_BCK) then +! compute initial RH field to be reintroduced after the diabatic DFI + its = grid%sp31 ; ite = grid%ep31 ; + kts = grid%sp32 ; kte = grid%ep32 ; + jts = grid%sp33 ; jte = grid%ep33 ; + DO j=jts,jte + DO i=its,ite + do k = kts , kte + temp = (grid%t_2(i,k,j)+t0)*( (grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb )& + ** (r_d / Cp) + pres = grid%p(i,k,j)+grid%pb(i,k,j) +!tgs rslf - function to compute qs from Thompson microphysics + qs = rslf(pres, temp) + grid%dfi_rh (i,k,j) = MIN(1.,MAX(0.,grid%moist(i,k,j,P_QV)/qs)) + +!tgs saturation check for points with water or ice clouds + IF ((grid%moist (i,k,j,P_QC) .GT. 1.e-6 .or. & + grid%moist (i,k,j,P_QI) .GT. 1.e-6) .and. & + grid%dfi_rh (i,k,j) .lt. 1.) THEN + grid%dfi_rh (i,k,j)=1. + ENDIF + + end do + END DO + ENDDO + endif + + ENDIF + +#endif END SUBROUTINE dfi_save_arrays SUBROUTINE dfi_array_reset( grid ) - USE module_domain - USE module_configure - USE module_driver_constants - USE module_machine - USE module_dm + USE module_domain, ONLY : domain +! USE module_configure +! USE module_driver_constants +! USE module_machine +! USE module_dm USE module_model_constants USE module_state_description IMPLICIT NONE + INTEGER :: its, ite, jts, jte, kts, kte, & + i, j, k + ! Input data. TYPE(domain) , POINTER :: grid + ! local +! real p1000mb,eps,svp1,svp2,svp3,svpt0 + real eps +! parameter (p1000mb = 1.e+05, eps=0.622,svp1=0.6112,svp3=29.65,svpt0=273.15) + parameter (eps=0.622) + REAL es,qs,pol,tx,temp,pres,rslf IF ( grid%dfi_opt .EQ. DFI_NODFI ) RETURN @@ -479,8 +590,16 @@ write(0,*) 'Invalid filter specified in namelist.' grid%al(:,:,:) = grid%dfi_al(:,:,:) / grid%hcoeff_tot grid%alt(:,:,:) = grid%dfi_alt(:,:,:) / grid%hcoeff_tot grid%pb(:,:,:) = grid%dfi_pb(:,:,:) / grid%hcoeff_tot - grid%moist(:,:,:,:) = grid%dfi_moist(:,:,:,:) / grid%hcoeff_tot - grid%scalar(:,:,:,:) = grid%dfi_scalar(:,:,:,:) / grid%hcoeff_tot +#if ( WRF_DFI_RADAR == 1 ) + IF ( grid%dfi_radar .EQ. 0 ) then ! tgs no radar assimilation + grid%moist(:,:,:,:) = max(0.,grid%dfi_moist(:,:,:,:) / grid%hcoeff_tot) + ELSE + grid%moist(:,:,:,P_QV) = max(0.,grid%dfi_moist(:,:,:,P_QV) / grid%hcoeff_tot) + ENDIF +#else + grid%moist(:,:,:,:) = max(0.,grid%dfi_moist(:,:,:,:) / grid%hcoeff_tot) +#endif + grid%scalar(:,:,:,:) = max(0.,grid%dfi_scalar(:,:,:,:) / grid%hcoeff_tot) ! restore initial fields grid%SNOW (:,:) = grid%dfi_SNOW (:,:) @@ -488,14 +607,61 @@ write(0,*) 'Invalid filter specified in namelist.' grid%SNOWC (:,:) = grid%dfi_SNOWC (:,:) grid%CANWAT(:,:) = grid%dfi_CANWAT(:,:) grid%TSK (:,:) = grid%dfi_TSK (:,:) - grid%QVG (:,:) = grid%dfi_QVG (:,:) - grid%SOILT1(:,:) = grid%dfi_SOILT1(:,:) - grid%TSNAV (:,:) = grid%dfi_TSNAV (:,:) grid%TSLB (:,:,:) = grid%dfi_TSLB (:,:,:) grid%SMOIS (:,:,:) = grid%dfi_SMOIS (:,:,:) + IF ( grid%sf_surface_physics .EQ. 3 ) then + grid%QVG (:,:) = grid%dfi_QVG (:,:) + grid%TSNAV (:,:) = grid%dfi_TSNAV (:,:) + grid%SOILT1(:,:) = grid%dfi_SOILT1(:,:) grid%SMFR3D(:,:,:) = grid%dfi_SMFR3D (:,:,:) grid%KEEPFR3DFLAG(:,:,:) = grid%dfi_KEEPFR3DFLAG(:,:,:) + ENDIF + + ! restore analized hydrometeor fileds +#if ( WRF_DFI_RADAR == 1 ) + IF ( grid%dfi_radar .EQ. 1 ) then +! grid%moist(:,:,:,:) = grid%dfi_moist(:,:,:,:) !tgs + grid%moist(:,:,:,P_QC) = grid%dfi_moist(:,:,:,P_QC) !tgs + grid%moist(:,:,:,P_QR) = grid%dfi_moist(:,:,:,P_QR) !tgs + grid%moist(:,:,:,P_QI) = grid%dfi_moist(:,:,:,P_QI) !tgs + grid%moist(:,:,:,P_QS) = grid%dfi_moist(:,:,:,P_QS) !tgs + grid%moist(:,:,:,P_QG) = grid%dfi_moist(:,:,:,P_QG) !tgs + + if(grid%dfi_stage .EQ. DFI_FWD) then +!tgs change QV to restore initial RH field after the diabatic DFI + its = grid%sp31 ; ite = grid%ep31 ; + kts = grid%sp32 ; kte = grid%ep32 ; + jts = grid%sp33 ; jte = grid%ep33 ; + DO j=jts,jte + DO i=its,ite + do k = kts , kte + temp = (grid%t_2(i,k,j)+t0)*( (grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb )& + ** (r_d / Cp) + pres = grid%p(i,k,j)+grid%pb(i,k,j) +!tgs rslf - function to compute qs from Thompson microphysics + qs = rslf(pres, temp) + +! if(i.eq. 178 .and. j.eq. 148 .and. k.eq.11) then +! print *,'temp,pres,qs-thomp',temp,pres,qs +! endif + + IF(grid%moist(i,k,j,P_QC) .GT. 1.e-6 .or. & + grid%moist(i,k,j,P_QI) .GT. 1.e-6) THEN + grid%moist (i,k,j,P_QV) = MAX(0.,grid%dfi_rh(i,k,j)*QS) + ENDIF + +! if(i.eq. 178 .and. j.eq. 148 .and. k.eq.11) then +! print *,'temp,pres,qs,grid%moist (i,k,j,P_QV)',temp,pres,qs, & +! grid%moist(i,k,j,P_QV) +! endif + enddo + ENDDO + ENDDO + endif + + ENDIF +#endif END SUBROUTINE dfi_array_reset @@ -948,7 +1114,8 @@ write(0,*) 'Invalid filter specified in namelist.' PI = 4*ATAN(1.D0) - print *, 'in dfcoef, deltat = ', deltat, 'taus=',taus + WRITE (mes,'(A,F8.2,A,F10.2)') 'In dolph, deltat = ',deltat,' taus = ',taus + CALL wrf_message(TRIM(mes)) N = 2*M+1 NM1 = N-1 @@ -961,10 +1128,12 @@ write(0,*) 'Invalid filter specified in namelist.' R = 1/RR DB = 20*LOG10(R) - - WRITE(*,'(1X,''DOLPH: M,N='',2I8)')M,N - WRITE(*,'(1X,''DOLPH: THETAS (STOP-BAND EDGE)='',F10.3)')THETAS - WRITE(*,'(1X,''DOLPH: R,DB='',2F10.3)')R, DB + WRITE (mes,'(A,2I8)') 'In dolph: M,N = ', M,N + CALL wrf_message(TRIM(mes)) + WRITE (mes,'(A,F10.3)') 'In dolph: THETAS (STOP-BAND EDGE) = ', thetas + CALL wrf_message(TRIM(mes)) + WRITE (mes,'(A,2F10.3)') 'In dolph: R,DB = ', R,DB + CALL wrf_message(TRIM(mes)) DO NT=0,M SUM = 1 @@ -977,8 +1146,8 @@ write(0,*) 'Invalid filter specified in namelist.' ENDDO W(NT) = SUM/N TIME(NT) = NT - WRITE(*,'(1X,''DOLPH: TIME, W='',F10.6,2X,E17.7)') & - TIME(NT), W(NT) + WRITE (mes,'(A,F10.6,2x,E17.7)') 'In dolph: TIME, W = ', TIME(NT), W(NT) + CALL wrf_message(TRIM(mes)) ENDDO ! fill in the negative-time values by symmetry. DO NT=0,M @@ -991,9 +1160,10 @@ write(0,*) 'Invalid filter specified in namelist.' DO NT=0,2*M SUMW = SUMW + W2(NT) ENDDO - WRITE(*,'(1X,''DOLPH: SUM OF WEIGHTS W2='',F10.4)')SUMW + WRITE (mes,'(A,F10.4)') 'In dolph: SUM OF WEIGHTS W2 = ', sumw + CALL wrf_message(TRIM(mes)) - DO NT=0,2*M + DO NT=0,M WINDOW(NT) = W2(NT) ENDDO @@ -1269,7 +1439,7 @@ write(0,*) 'Invalid filter specified in namelist.' ! DS : Deviation in stop-band (db) !---------------------------------------------------------- ! - USE module_domain + USE module_domain, ONLY : domain TYPE(domain) , POINTER :: grid @@ -1974,4 +2144,28 @@ write(0,*) 'Invalid filter specified in namelist.' GEE = P/D END FUNCTION GEE + REAL FUNCTION RSLF(P,T) + + IMPLICIT NONE + REAL, INTENT(IN):: P, T + REAL:: ESL,X + REAL, PARAMETER:: C0= .611583699E03 + REAL, PARAMETER:: C1= .444606896E02 + REAL, PARAMETER:: C2= .143177157E01 + REAL, PARAMETER:: C3= .264224321E-1 + REAL, PARAMETER:: C4= .299291081E-3 + REAL, PARAMETER:: C5= .203154182E-5 + REAL, PARAMETER:: C6= .702620698E-8 + REAL, PARAMETER:: C7= .379534310E-11 + REAL, PARAMETER:: C8=-.321582393E-13 + + X=MAX(-80.,T-273.16) + +! ESL=612.2*EXP(17.67*X/(T-29.65)) + ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) + RSLF=.622*ESL/(P-ESL) + + END FUNCTION RSLF + + #endif diff --git a/wrfv2_fire/share/init_modules.F b/wrfv2_fire/share/init_modules.F index 3f561627..75c6039e 100644 --- a/wrfv2_fire/share/init_modules.F +++ b/wrfv2_fire/share/init_modules.F @@ -1,23 +1,23 @@ !WRF:MEDIATION_LAYER ! SUBROUTINE init_modules( phase ) - USE module_bc - USE module_configure - USE module_driver_constants - USE module_model_constants - USE module_domain - USE module_machine - USE module_nesting - USE module_timing - USE module_tiles - USE module_io_wrf - USE module_io + USE module_bc , ONLY : init_module_bc + USE module_configure , ONLY : init_module_configure + USE module_driver_constants , ONLY : init_module_driver_constants + USE module_model_constants , ONLY : init_module_model_constants + USE module_domain , ONLY : init_module_domain + USE module_machine , ONLY : init_module_machine + USE module_nesting , ONLY : init_module_nesting + USE module_timing , ONLY : init_module_timing + USE module_tiles , ONLY : init_module_tiles + USE module_io_wrf , ONLY : init_module_io_wrf + USE module_io , ONLY : init_module_io #ifdef DM_PARALLEL - USE module_wrf_quilt - USE module_dm + USE module_wrf_quilt , ONLY : init_module_wrf_quilt + USE module_dm , ONLY : init_module_dm, split_communicator #endif #ifdef INTIO - USE module_ext_internal + USE module_ext_internal , ONLY : init_module_ext_internal #endif ! @@ -82,9 +82,6 @@ ELSE #if (NMM_CORE == 1) CALL init_modules_nmm #endif -#if (COAMPS_CORE == 1) - CALL init_modules_coamps -#endif ENDIF END SUBROUTINE init_modules diff --git a/wrfv2_fire/share/input_wrf.F b/wrfv2_fire/share/input_wrf.F index 99c5fd90..e546ff0c 100644 --- a/wrfv2_fire/share/input_wrf.F +++ b/wrfv2_fire/share/input_wrf.F @@ -24,6 +24,10 @@ ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe + TYPE( fieldlist ), POINTER :: p + + INTEGER newswitch, itrace + INTEGER iname(9) INTEGER iordering(3) INTEGER icurrent_date(24) @@ -44,6 +48,7 @@ CHARACTER*19 new_date CHARACTER*24 base_date CHARACTER*80 fname + CHARACTER*80 dname, memord LOGICAL dryrun INTEGER idt INTEGER itmp @@ -98,7 +103,7 @@ check_if_dryrun : IF ( .NOT. dryrun ) THEN ! simulation start time is a Singleton maintained by head_grid - IF ( ( switch .EQ. model_input_only ) .OR. & + IF ( ( switch .EQ. input_only ) .OR. & ( switch .EQ. restart_only ) ) THEN CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr ) CALL nl_get_reset_simulation_start ( 1, reset_simulation_start ) @@ -122,8 +127,8 @@ CALL nl_set_simulation_start_hour ( 1 , simulation_start_hour ) CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute ) CALL nl_set_simulation_start_second ( 1 , simulation_start_second ) - IF ( switch .EQ. model_input_only ) THEN - WRITE(wrf_err_message,*)fid,' input_wrf, model_input_only: SIMULATION_START_DATE = ', & + IF ( switch .EQ. input_only ) THEN + WRITE(wrf_err_message,*)fid,' input_wrf, input_only: SIMULATION_START_DATE = ', & simulation_start_date(1:19) CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) ELSE IF ( switch .EQ. restart_only ) THEN @@ -164,8 +169,8 @@ ! Test to make sure that the input data is the right size. Do this for input from real/ideal into ! WRF, and from the standard initialization into real. - IF ( ( switch .EQ. model_input_only ) .OR. & - ( switch .EQ. aux_model_input1_only ) ) THEN + IF ( ( switch .EQ. input_only ) .OR. & + ( switch .EQ. auxinput1_only ) ) THEN ierr = 0 CALL wrf_get_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ide_compare , 1 , icnt , ierr3 ) ierr = max( ierr, ierr3 ) @@ -330,7 +335,7 @@ ! Test here to check that config_flags%num_metgrid_soil_levels in namelist ! is equal to what is in the global attributes of the met_em files - IF ( switch .EQ. aux_model_input1_only ) THEN + IF ( switch .EQ. auxinput1_only ) THEN CALL wrf_get_dom_ti_integer ( fid, 'NUM_METGRID_SOIL_LEVELS', itmp, 1, icnt, ierr ) IF ( ierr .EQ. 0 ) THEN @@ -423,8 +428,8 @@ #if (EM_CORE == 1) !KLUDGE - is there a more elegant way to determine "old si" input - IF ( ( switch .EQ. model_input_only ) .OR. & - ( ( switch .EQ. aux_model_input1_only ) .AND. & + IF ( ( switch .EQ. input_only ) .OR. & + ( ( switch .EQ. auxinput1_only ) .AND. & ( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) ) THEN ! Test to make sure that the input data is the right size. @@ -437,7 +442,7 @@ CALL wrf_error_fatal( wrf_err_message ) ENDIF - ELSE IF ( switch .EQ. aux_model_input1_only ) THEN + ELSE IF ( switch .EQ. auxinput1_only ) THEN ! Test to make sure that the input data is the right size. @@ -455,7 +460,7 @@ #if (NMM_CORE == 1) - IF ( ( switch .EQ. aux_model_input1_only ) .AND. & + IF ( ( switch .EQ. auxinput1_only ) .AND. & ( config_flags%auxinput1_inname(1:8) .EQ. 'wrf_real' ) ) THEN CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMSNSION' , kde_compare , 1 , icnt , ierr3 ) @@ -470,7 +475,7 @@ CALL wrf_debug( 100, wrf_err_message ) ENDIF - ELSEIF ( switch .EQ. aux_model_input1_only ) THEN ! assume just WPS in this branch + ELSEIF ( switch .EQ. auxinput1_only ) THEN ! assume just WPS in this branch IF ( ( ide-1 .NE. ide_compare ) .OR. & ( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. & ( jde-1 .NE. jde_compare ) .AND. ierr3 .EQ. 0 ) THEN @@ -522,14 +527,14 @@ ! JM 20040511 ! SELECT CASE ( switch ) - CASE ( model_input_only, aux_model_input1_only, aux_model_input2_only, & - aux_model_input3_only, aux_model_input4_only, aux_model_input5_only, & - aux_model_input6_only, aux_model_input7_only, aux_model_input8_only, & - aux_model_input9_only, aux_model_input10_only ) + CASE ( input_only, auxinput1_only, auxinput2_only, & + auxinput3_only, auxinput4_only, auxinput5_only, & + auxinput6_only, auxinput7_only, auxinput8_only, & + auxinput9_only, auxinput10_only ) #ifdef WRF_CHEM IF( (config_flags%io_style_emissions .eq. 1) .and. & - ((switch.eq.aux_model_input5_only) .or. (switch.eq.aux_model_input6_only) .or. & - (switch.eq.aux_model_input7_only) .or. (switch.eq.aux_model_input8_only)) ) then + ((switch.eq.auxinput5_only) .or. (switch.eq.auxinput6_only) .or. & + (switch.eq.auxinput7_only) .or. (switch.eq.auxinput8_only)) ) then CALL wrf_message( "**WARNING** Time in input file not being checked **WARNING**" ) ELSE #endif @@ -571,68 +576,404 @@ CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) ENDIF -#if 1 - IF ( switch .EQ. model_input_only ) THEN - CALL wrf_inputin( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. history_only ) THEN - CALL wrf_histin( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input1_only ) THEN - CALL wrf_auxinput1in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input2_only ) THEN - CALL wrf_auxinput2in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input3_only ) THEN - CALL wrf_auxinput3in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input4_only ) THEN - CALL wrf_auxinput4in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input5_only ) THEN - CALL wrf_auxinput5in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input6_only ) THEN - CALL wrf_auxinput6in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input7_only ) THEN - CALL wrf_auxinput7in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input8_only ) THEN - CALL wrf_auxinput8in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input9_only ) THEN - CALL wrf_auxinput9in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input10_only ) THEN - CALL wrf_auxinput10in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_model_input11_only ) THEN - CALL wrf_auxinput11in( fid , grid , config_flags , switch , ierr ) - - - ELSE IF ( switch .EQ. aux_hist1_only ) THEN - CALL wrf_auxhist1in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist2_only ) THEN - CALL wrf_auxhist2in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist3_only ) THEN - CALL wrf_auxhist3in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist4_only ) THEN - CALL wrf_auxhist4in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist5_only ) THEN - CALL wrf_auxhist5in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist6_only ) THEN - CALL wrf_auxhist6in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist7_only ) THEN - CALL wrf_auxhist7in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist8_only ) THEN - CALL wrf_auxhist8in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist9_only ) THEN - CALL wrf_auxhist9in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist10_only ) THEN - CALL wrf_auxhist10in( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. aux_hist11_only ) THEN - CALL wrf_auxhist11in( fid , grid , config_flags , switch , ierr ) - - ELSE IF ( switch .EQ. restart_only ) THEN - CALL wrf_restartin( fid , grid , config_flags , switch , ierr ) - ELSE IF ( switch .EQ. boundary_only ) THEN - CALL wrf_bdyin( fid , grid , config_flags , switch , ierr ) + IF ( (first_input .LE. switch .AND. switch .LE. last_input) .OR. & + (first_history .LE. switch .AND. switch .LE. last_history) .OR. & + switch .EQ. restart_only ) THEN + newswitch = switch + p => grid%head_statevars%next + DO WHILE ( ASSOCIATED( p ) ) + IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream( p%streams,newswitch)) THEN + IF ( p%Ndim .EQ. 0 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + dname = p%DataName + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_0d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + '0' , & ! MemoryOrder + '' , & ! Stagger + __FILE__ // ' reading 0d real ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_0d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + '0' , & ! MemoryOrder + '' , & ! Stagger + __FILE__ // ' reading 0d double ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_0d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + '0' , & ! MemoryOrder + '' , & ! Stagger + __FILE__ // ' reading 0d integer ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ELSE IF ( p%Type .EQ. 'l' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%lfield_0d , & ! Field + WRF_LOGICAL , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + '0' , & ! MemoryOrder + '' , & ! Stagger + __FILE__ // ' reading 0d logical ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 1 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_1d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + p%Stagger , & ! Stagger + __FILE__ // ' reading 1d real ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_1d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 1d double ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_1d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 1d integer ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'l' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%lfield_1d , & ! Field + WRF_LOGICAL , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 1d logical ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 2 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_2d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 2d real ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_2d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 2d double ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_2d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 2d integer ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'l' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%lfield_2d , & ! Field + WRF_LOGICAL , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 2d logical ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 3 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_3d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 3d real ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_3d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 3d double ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_read_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_3d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 3d integer ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) +! NOTE no io on logical arrays greater than 2d + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 4 ) THEN +! Use a different write routine, wrf_ext_read_field_arr, and pass in the +! tracer indeces so that p%rfield_4d can be passsed in without arguments, +! avoiding the possiblity of a copy-in/copy-out problem for some compilers. +! Fortran is still a four letter word. JM 20091208 + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + dname = p%dname_table( grid%id, itrace ) + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_read_field_arr ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_4d , & ! Field + itrace, 1, 1, 1 , & ! see comment above + 1, 1, 1 , & ! see comment above + RWORDSIZE , & + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_read_field_arr ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_4d , & ! Field + itrace, 1, 1, 1 , & ! see comment above + 1, 1, 1 , & ! see comment above + DWORDSIZE , & + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 4d double ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_read_field_arr ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_4d , & ! Field + itrace, 1, 1, 1 , & ! see comment above + 1, 1, 1 , & ! see comment above + IWORDSIZE , & + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + __FILE__ // ' reading 4d integer ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ENDIF + ENDDO ! loop over tracers + ENDIF ! if-then-else over ndim + ENDIF + p => p%next + ENDDO + ELSE + IF ( switch .EQ. boundary_only ) THEN + CALL wrf_bdyin( fid , grid , config_flags , switch , ierr ) + ENDIF ENDIF CALL wrf_tsin( grid , ierr ) -#else - CALL wrf_message ( "ALL I/O DISABLED IN share/module_io_wrf.F") -#endif WRITE(wrf_err_message,*)'input_wrf: end, fid = ',fid CALL wrf_debug( 300 , wrf_err_message ) diff --git a/wrfv2_fire/share/interp_fcn.F b/wrfv2_fire/share/interp_fcn.F index 58271505..b67dd3e0 100644 --- a/wrfv2_fire/share/interp_fcn.F +++ b/wrfv2_fire/share/interp_fcn.F @@ -819,9 +819,13 @@ shw = 0 - ioff = 0 ; joff = 0 - IF ( xstag ) ioff = 1 - IF ( ystag ) joff = 1 + ioff = 0 ; joff = 0 + IF ( xstag ) THEN + ioff = (nri-1)/2 + ENDIF + IF ( ystag ) THEN + joff = (nrj-1)/2 + ENDIF ! Iterate over the ND tile and compute the values ! from the CD tile. diff --git a/wrfv2_fire/share/mediation_feedback_domain.F b/wrfv2_fire/share/mediation_feedback_domain.F index 62169db4..95365b9b 100644 --- a/wrfv2_fire/share/mediation_feedback_domain.F +++ b/wrfv2_fire/share/mediation_feedback_domain.F @@ -77,7 +77,7 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) ! ------------------------------------------------------ SUBROUTINE feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & ! -# include "dummy_args.inc" +# include "dummy_new_args.inc" ! ) USE module_domain @@ -85,12 +85,12 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include END SUBROUTINE feedback_domain_nmm_part1 ! SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid , nested_grid, config_flags & ! -# include "dummy_args.inc" +# include "dummy_new_args.inc" ! ) USE module_domain @@ -99,7 +99,7 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include END SUBROUTINE feedback_domain_nmm_part2 #endif @@ -128,6 +128,7 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -178,6 +179,7 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) CALL alloc_space_field ( grid, grid%id , 1 , 3 , .FALSE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -187,7 +189,7 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) # include "deref_kludge.h" CALL feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & ! -# include "actual_args.inc" +# include "actual_new_args.inc" ! ) grid => parent_grid @@ -196,7 +198,7 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) ! CALL feedback_domain_nmm_part2 ( grid , nested_grid%intermediate_grid, nested_grid , config_flags & ! -# include "actual_args.inc" +# include "actual_new_args.inc" ! ) grid => nested_grid%intermediate_grid diff --git a/wrfv2_fire/share/mediation_force_domain.F b/wrfv2_fire/share/mediation_force_domain.F index 0daa4de7..5199cf4e 100644 --- a/wrfv2_fire/share/mediation_force_domain.F +++ b/wrfv2_fire/share/mediation_force_domain.F @@ -80,7 +80,7 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags & ! -# include "dummy_args.inc" +# include "dummy_new_args.inc" ! ) USE module_domain @@ -89,12 +89,12 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include END SUBROUTINE interp_domain_nmm_part1 SUBROUTINE force_domain_nmm_part2 ( grid, nested_grid, config_flags & ! -# include "dummy_args.inc" +# include "dummy_new_args.inc" ! ) USE module_domain @@ -103,7 +103,7 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include END SUBROUTINE force_domain_nmm_part2 !======================================================================= ! End of gopal's doing. @@ -135,6 +135,7 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -232,6 +233,7 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) CALL alloc_space_field ( grid, grid%id , 1 , 3 , .FALSE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -255,7 +257,7 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) CALL interp_domain_nmm_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & ! -# include "actual_args.inc" +# include "actual_new_args.inc" ! ) ENDIF ! not restart and first force @@ -268,7 +270,7 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) CALL force_domain_nmm_part2 ( grid, nested_grid, config_flags & ! -# include "actual_args.inc" +# include "actual_new_args.inc" ! ) ENDIF ! not restart and first_force diff --git a/wrfv2_fire/share/mediation_integrate.F b/wrfv2_fire/share/mediation_integrate.F index ef3c3fa3..2d52f747 100644 --- a/wrfv2_fire/share/mediation_integrate.F +++ b/wrfv2_fire/share/mediation_integrate.F @@ -1,6 +1,7 @@ ! !WRF:MEDIATION_LAYER:IO ! +#if (DA_CORE != 1) SUBROUTINE med_calc_model_time ( grid , config_flags ) ! Driver layer @@ -38,7 +39,16 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) TYPE(domain) :: grid TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags ! Local + INTEGER :: ialarm INTEGER :: rc +#ifdef HWRF +!zhang's doing + TYPE(WRFU_Time) :: CurrTime !zhang new + INTEGER :: hr, min, sec, ms,julyr,julday + REAL :: GMT +!end of zhang's doing +#endif + CHARACTER*256 :: message #if (EM_CORE == 1) @@ -47,7 +57,7 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) #else IF( WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc )) THEN #endif - CALL med_hist_out ( grid , 0, config_flags ) + CALL med_hist_out ( grid , HISTORY_ALARM, config_flags ) CALL WRFU_AlarmRingerOff( grid%alarms( HISTORY_ALARM ), rc=rc ) ENDIF @@ -56,175 +66,60 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) CALL WRFU_AlarmRingerOff( grid%alarms( INPUTOUT_ALARM ), rc=rc ) ENDIF -! - AUX HISTORY OUTPUT - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST1_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 1, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST1_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST2_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 2, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST2_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST3_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 3, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST3_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST4_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 4, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST4_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST5_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 5, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST5_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST6_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 6, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST6_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST7_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 7, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST7_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST8_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 8, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST8_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST9_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 9, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST9_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST10_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 10, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST10_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST11_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 11, config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXHIST11_ALARM ), rc=rc ) - ENDIF - -! - AUX INPUT INPUT - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT1_ALARM ), rc=rc ) ) THEN - CALL med_auxinput1_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput1_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT1_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT2_ALARM ), rc=rc ) ) THEN - CALL med_auxinput2_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput2_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT2_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT3_ALARM ), rc=rc ) ) THEN - CALL med_auxinput3_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput3_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT3_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT4_ALARM ), rc=rc ) ) THEN - CALL med_auxinput4_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput4_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT4_ALARM ), rc=rc ) - ENDIF - -! this needs to be looked at again so we can get rid of the special -! handling of AUXINPUT5 but for now... + DO ialarm = first_auxhist, last_auxhist + IF ( .FALSE.) THEN + rc = 1 ! dummy statement + ELSE IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN + CALL med_hist_out ( grid , ialarm, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc ) + ENDIF + ENDDO -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! add for wrf_chem emiss input -! - Get chemistry data - IF( config_flags%chem_opt > 0 ) THEN + DO ialarm = first_auxinput, last_auxinput + IF ( .FALSE.) THEN + rc = 1 ! dummy statement #ifdef WRF_CHEM - IF( config_flags%emiss_inpt_opt /= 0 ) THEN - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) ) THEN - call wrf_debug(15,' CALL med_read_wrf_chem_emiss ') - CALL med_read_wrf_chem_emiss ( grid , config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) - call wrf_debug(15,' Back from CALL med_read_wrf_chem_emiss ') - ENDIF -! IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) ) THEN -! call wrf_debug(00,' CALL med_read_wrf_chem_fireemiss ') -! CALL med_read_wrf_chem_emissopt3 ( grid , config_flags ) -! CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) -! call wrf_debug(15,' Back from CALL med_read_wrf_chem_fireemiss ') -! ENDIF -! IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) ) THEN -! call wrf_debug(00,' CALL med_read_wrf_chem_gocartbg ') -! CALL med_read_wrf_chem_gocartbg ( grid , config_flags ) -! CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) -! call wrf_debug(15,' Back from CALL med_read_wrf_chem_gocartbg ') -! ENDIF - ELSE - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) ) THEN - CALL med_auxinput5_in ( grid , config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) - ENDIF - ENDIF -! end for wrf chem emiss input -#endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ELSE -#ifndef WRF_CHEM - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) ) THEN - CALL med_auxinput5_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput5_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) - ENDIF +! - Get chemistry data + ELSE IF( ialarm .EQ. AUXINPUT5_ALARM .AND. config_flags%chem_opt > 0 ) THEN + IF( config_flags%emiss_inpt_opt /= 0 ) THEN + IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN + call wrf_debug(15,' CALL med_read_wrf_chem_emiss ') + CALL med_read_wrf_chem_emiss ( grid , config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc ) + call wrf_debug(15,' Back from CALL med_read_wrf_chem_emiss ') + ENDIF + ELSE + IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN + CALL med_auxinput_in ( grid, ialarm, config_flags ) + CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc ) + ENDIF + ENDIF #endif - ENDIF - - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT6_ALARM ), rc=rc ) ) THEN - CALL med_auxinput6_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput6_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT6_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) ) THEN - CALL med_auxinput7_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput7_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT8_ALARM ), rc=rc ) ) THEN - CALL med_auxinput8_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%auxinput8_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT8_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) ) THEN - CALL med_auxinput9_in ( grid , config_flags ) - WRITE ( message , FMT='(A,A,A,i3)' ) "Input data processed for " , & - TRIM(config_flags%sgfdda_inname) , " for domain ",grid%id - CALL wrf_debug ( 0 , message ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT10_ALARM ), rc=rc ) ) THEN - CALL med_auxinput10_in ( grid , config_flags ) - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT10_ALARM ), rc=rc ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXINPUT11_ALARM ), rc=rc ) ) THEN #if ( EM_CORE == 1 ) - IF( config_flags%obs_nudge_opt .EQ. 1) THEN - CALL med_fddaobs_in ( grid , config_flags ) - ENDIF -#else - CALL med_auxinput11_in ( grid , config_flags ) + ELSE IF( ialarm .EQ. AUXINPUT11_ALARM ) THEN + IF( config_flags%obs_nudge_opt .EQ. 1) THEN + CALL med_fddaobs_in ( grid , config_flags ) + ENDIF #endif - CALL WRFU_AlarmRingerOff( grid%alarms( AUXINPUT11_ALARM ), rc=rc ) - ENDIF + ELSE IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN + CALL med_auxinput_in ( grid, ialarm, config_flags ) + WRITE ( message , FMT='(A,i3,A,i3)' ) 'Input data processed for aux input ' , & + ialarm , ' for domain ',grid%id + CALL wrf_debug ( 0 , message ) + CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc ) + ENDIF + ENDDO ! - RESTART OUTPUT IF( WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc ) ) THEN +#ifdef HWRF +!zhang's doing + CALL domain_clock_get( grid, current_time=CurrTime ) + CALL WRFU_TimeGet( CurrTime, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) + gmt=hr+real(min)/60.+real(sec)/3600.+real(ms)/(1000*3600) + if (grid%id .eq. 2) call med_namelist_out ( grid , config_flags ) +!end of zhang's doing +#endif IF ( grid%id .EQ. 1 ) THEN ! Only the parent initiates the restart writing. Otherwise, different ! domains may be written out at different times and with different @@ -750,6 +645,19 @@ SUBROUTINE med_nest_initial ( parent , nest , config_flags ) END INTERFACE +#ifdef HWRF +!zhang's doing test + if (config_flags%restart .or. nest%analysis) then + nest%first_force = .true. + else + nest%first_force = .false. + endif +!end of zhang's doing + +!zhang's doing for analysis option + IF(.not. nest%analysis .and. .not. config_flags%restart)THEN ! initialize for cold-start +#endif + !---------------------------------------------------------------------------- ! initialize nested domain configurations including setting up wbd,sbd, etc !---------------------------------------------------------------------------- @@ -853,6 +761,9 @@ SUBROUTINE med_nest_initial ( parent , nest , config_flags ) nest%imask_ystag = 0 nest%imask_xystag = 0 +#ifdef HWRF + CALL med_interp_domain( parent, nest ) +#else CALL domain_clock_get( parent, start_time=strt_time, current_time=cur_time ) IF ( .not. ( config_flags%restart .AND. strt_time .EQ. cur_time ) ) THEN @@ -877,6 +788,7 @@ SUBROUTINE med_nest_initial ( parent , nest , config_flags ) END IF +#endif !------------------------------------------------------------------------------ ! set up constants (module_initialize_real.F for nested nmm domain) !----------------------------------------------------------------------------- @@ -889,6 +801,71 @@ SUBROUTINE med_nest_initial ( parent , nest , config_flags ) CALL start_domain ( nest, .TRUE.) +#ifdef HWRF +!zhang's doing: else for analysis or restart option + +!zhang test + CALL nl_set_isice ( nest%id , config_flags%isice ) + CALL nl_set_isoilwater ( nest%id , config_flags%isoilwater ) + CALL nl_set_isurban ( nest%id , config_flags%isurban ) + CALL nl_set_gmt ( nest%id , config_flags%gmt ) + CALL nl_set_julyr (nest%id, config_flags%julyr) + CALL nl_set_julday ( nest%id , config_flags%julday ) +!zhang test ends + CALL med_analysis_out ( nest, config_flags ) + + ELSE + +!------------------------------------------------------------------------------------ +! read in analysis (equivalent of restart for the nested domains) +!------------------------------------------------------------------------------------ + +!zhang's doing + IF( nest%analysis .and. .not. config_flags%restart)THEN + CALL med_analysis_in ( nest, config_flags ) + ELSE IF (config_flags%restart)THEN + CALL med_restart_in ( nest, config_flags ) + ENDIF +!end of zhang's doing + +!---------------------------------------------------------------------------- +! initialize nested domain configurations including setting up wbd,sbd, etc +!---------------------------------------------------------------------------- + + CALL med_nest_egrid_configure ( parent , nest ) + +!------------------------------------------------------------------------- +! initialize lat-lons and determine weights (overwrite for safety) +!------------------------------------------------------------------------- + + CALL med_construct_egrid_weights ( parent, nest ) + + nest%imask_nostag = 0 + nest%imask_xstag = 0 + nest%imask_ystag = 0 + nest%imask_xystag = 0 + +!------------------------------------------------------------------------------ +! set up constants (module_initialize_real.F for nested nmm domain) +!----------------------------------------------------------------------------- + + CALL med_init_domain_constants_nmm ( parent, nest ) + +!-------------------------------------------------------------------------------------- +! set some other initial fields, fill out halos, etc. (again, safety sake only) +! Also, in order to accomodate some physics initialization after nest move, set +! analysis back to false for future use +!-------------------------------------------------------------------------------------- + + CALL start_domain ( nest, .TRUE.) + + nest%analysis=.FALSE. + CALL nl_set_analysis( nest%id, nest%analysis) + + ENDIF + +#endif + !=================================================================================== ! Added for the NMM core. End of gopal's doing. !=================================================================================== @@ -1090,6 +1067,13 @@ SUBROUTINE med_last_solve_io ( grid , config_flags ) TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags ! Local INTEGER :: rc +#ifdef HWRF +!zhang's doing + TYPE(WRFU_Time) :: CurrTime !zhang new + INTEGER :: hr, min, sec, ms,julyr,julday + REAL :: GMT +!end of zhang's doing +#endif #if (EM_CORE == 1) IF( WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc ) .AND. & @@ -1097,49 +1081,30 @@ SUBROUTINE med_last_solve_io ( grid , config_flags ) #else IF( WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc )) THEN #endif - CALL med_hist_out ( grid , 0 , config_flags ) + CALL med_hist_out ( grid , HISTORY_ALARM , config_flags ) ENDIF IF( WRFU_AlarmIsRinging( grid%alarms( INPUTOUT_ALARM ), rc=rc ) ) THEN CALL med_filter_out ( grid , config_flags ) ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST1_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 1 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST2_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 2 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST3_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 3 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST4_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 4 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST5_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 5 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST6_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 6 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST7_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 7 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST8_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 8 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST9_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 9 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST10_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 10 , config_flags ) - ENDIF - IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST11_ALARM ), rc=rc ) ) THEN - CALL med_hist_out ( grid , 11 , config_flags ) - ENDIF +! registry-generated file of the following +! IF( WRFU_AlarmIsRinging( grid%alarms( AUXHIST1_ALARM ), rc=rc ) ) THEN +! CALL med_hist_out ( grid , AUXHIST1_ALARM , config_flags ) +! ENDIF +#include "med_last_solve_io.inc" ! - RESTART OUTPUT IF( WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc ) ) THEN +#ifdef HWRF +!zhang's doing +!zhang new CALL ESMF_TimeGet( grid%current_time, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) + CALL domain_clock_get( grid, current_time=CurrTime ) + CALL WRFU_TimeGet( CurrTime, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) + gmt=hr+real(min)/60.+real(sec)/3600.+real(ms)/(1000*3600) + if (grid%id .eq. 2) call med_namelist_out ( grid , config_flags ) +!end of zhang's doing +#endif IF ( grid%id .EQ. 1 ) THEN CALL med_restart_out ( grid , config_flags ) ENDIF @@ -1151,8 +1116,131 @@ SUBROUTINE med_last_solve_io ( grid , config_flags ) RETURN END SUBROUTINE med_last_solve_io +#endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef HWRF +!================================================================================== +! Added for the NMM 3d var. This is simply an extension of med_restart_out. +! The file is simply called wrfanal***. This is gopal's doing +!=================================================================================== +! +SUBROUTINE med_analysis_in ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + ! Model layer + USE module_configure + USE module_bc_time_utilities +!zhang USE WRF_ESMF_MOD + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: rstname , outname + INTEGER :: fid , rid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc +!zhang old TYPE(ESMF_Time) :: CurrTime + TYPE(WRFU_Time) :: CurrTime + CHARACTER*80 :: timestr + + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + rid=grid%id + +!zhang's doing CALL ESMF_ClockGet( grid%domain_clock, CurrTime=CurrTime, rc=ierr ) +!zhang's doing CALL wrf_timetoa ( CurrTime, timestr ) + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( rstname ,config_flags%anl_outname, grid%id , 2 , timestr ) + + WRITE( message , '("med_analysis_in: opening ",A," for reading")' ) TRIM ( rstname ) + CALL wrf_debug( 1 , message ) + CALL open_r_dataset ( rid, TRIM(rstname), grid , & + config_flags , "DATASET=RESTART", ierr ) + + IF ( ierr .NE. 0 ) THEN +! CALL WRF_message( message ) + CALL WRF_ERROR_FATAL('NESTED DOMAIN ERROR: FOR ANALYSIS SET TO TRUE, YOU NEED wrfanal FILE') + ENDIF + CALL input_restart ( rid, grid , config_flags , ierr ) + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Reading restart for domain ",I8)' ) grid%id + CALL end_timing ( TRIM(message) ) + END IF + CALL close_dataset ( rid , config_flags , "DATASET=RESTART" ) + RETURN + +END SUBROUTINE med_analysis_in +!========================================================================================================= +!========================================================================================================= +SUBROUTINE med_analysis_out ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + ! Model layer + USE module_configure + USE module_bc_time_utilities +!zhang USE WRF_ESMF_MOD + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: rstname , outname + INTEGER :: fid , rid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc +!zhang TYPE(ESMF_Time) :: CurrTime + TYPE(WRFU_Time) :: CurrTime + CHARACTER*80 :: timestr + + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + rid=grid%id + +!zhang's doing CALL ESMF_ClockGet( grid%domain_clock, CurrTime=CurrTime, rc=ierr ) +!zhang's doing CALL wrf_timetoa ( CurrTime, timestr ) + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( rstname ,config_flags%anl_outname, grid%id , 2 , timestr ) + + WRITE( message , '("med_analysis_out: opening ",A," for writing")' ) TRIM ( rstname ) + CALL wrf_debug( 1 , message ) + CALL open_w_dataset ( rid, TRIM(rstname), grid , & + config_flags , output_restart , "DATASET=RESTART", ierr ) + + IF ( ierr .NE. 0 ) THEN + CALL WRF_message( message ) + ENDIF + CALL output_restart ( rid, grid , config_flags , ierr ) + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Writing restart for domain ",I8)' ) grid%id + CALL end_timing ( TRIM(message) ) + END IF + CALL close_dataset ( rid , config_flags , "DATASET=RESTART" ) + RETURN +END SUBROUTINE med_analysis_out + +#endif + RECURSIVE SUBROUTINE med_restart_out ( grid , config_flags ) ! Driver layer USE module_domain @@ -1183,6 +1271,9 @@ RECURSIVE SUBROUTINE med_restart_out ( grid , config_flags ) CALL start_timing END IF +! take this out - no effect - LPC +! rid=grid%id !zhang's doing + ! write out this domains restart file first CALL domain_clock_get( grid, current_timestr=timestr ) @@ -1216,6 +1307,67 @@ END SUBROUTINE med_restart_out !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef HWRF +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!zhang's doing +SUBROUTINE med_restart_in ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + ! Model layer + USE module_configure + USE module_bc_time_utilities + + IMPLICIT NONE + + ! Arguments + TYPE(domain) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + CHARACTER*80 :: rstname , outname + INTEGER :: fid , rid + CHARACTER (LEN=256) :: message + INTEGER :: ierr + INTEGER :: myproc +!zhang old TYPE(ESMF_Time) :: CurrTime + TYPE(WRFU_Time) :: CurrTime + CHARACTER*80 :: timestr + + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + rid=grid%id + +!zhang's doing CALL ESMF_ClockGet( grid%domain_clock, CurrTime=CurrTime, rc=ierr ) +!zhang's doing CALL wrf_timetoa ( CurrTime, timestr ) + CALL domain_clock_get( grid, current_timestr=timestr ) + CALL construct_filename2a ( rstname ,config_flags%rst_outname, grid%id , 2 , timestr ) + + WRITE( message , '("med_restart_in: opening ",A," for reading")' ) TRIM ( rstname ) + CALL wrf_debug( 1 , message ) + CALL open_r_dataset ( rid, TRIM(rstname), grid , & + config_flags , "DATASET=RESTART", ierr ) + + IF ( ierr .NE. 0 ) THEN +! CALL WRF_message( message ) + CALL WRF_ERROR_FATAL('NESTED DOMAIN ERROR: FOR ANALYSIS SET TO TRUE, YOU NEED wrfanal FILE') + ENDIF + CALL input_restart ( rid, grid , config_flags , ierr ) + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Reading restart for domain ",I8)' ) grid%id + CALL end_timing ( TRIM(message) ) + END IF + CALL close_dataset ( rid , config_flags , "DATASET=RESTART" ) + RETURN + +END SUBROUTINE med_restart_in +!end of zhang's doing +#endif + SUBROUTINE med_hist_out ( grid , stream, config_flags ) ! Driver layer USE module_domain @@ -1240,271 +1392,48 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags ) CALL start_timing END IF - IF ( stream .LT. 0 .OR. stream .GT. 11 ) THEN + IF ( stream .LT. first_history .OR. stream .GT. last_auxhist ) THEN WRITE(message,*)'med_hist_out: invalid history stream ',stream CALL wrf_error_fatal( message ) ENDIF SELECT CASE( stream ) - CASE ( 0 ) + CASE ( HISTORY_ALARM ) CALL open_hist_w( grid, config_flags, stream, HISTORY_ALARM, & config_flags%history_outname, grid%oid, & output_history, fname, n2, ierr ) CALL output_history ( grid%oid, grid , config_flags , ierr ) - CASE ( 1 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST1_ALARM, & - config_flags%auxhist1_outname, grid%auxhist1_oid, & - output_aux_hist1, fname, n2, ierr ) - CALL output_aux_hist1 ( grid%auxhist1_oid, grid , config_flags , ierr ) - CASE ( 2 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST2_ALARM, & - config_flags%auxhist2_outname, grid%auxhist2_oid, & - output_aux_hist2, fname, n2, ierr ) - CALL output_aux_hist2 ( grid%auxhist2_oid, grid , config_flags , ierr ) - CASE ( 3 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST3_ALARM, & - config_flags%auxhist3_outname, grid%auxhist3_oid, & - output_aux_hist3, fname, n2, ierr ) - CALL output_aux_hist3 ( grid%auxhist3_oid, grid , config_flags , ierr ) - CASE ( 4 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST4_ALARM, & - config_flags%auxhist4_outname, grid%auxhist4_oid, & - output_aux_hist4, fname, n2, ierr ) - CALL output_aux_hist4 ( grid%auxhist4_oid, grid , config_flags , ierr ) - CASE ( 5 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST5_ALARM, & - config_flags%auxhist5_outname, grid%auxhist5_oid, & - output_aux_hist5, fname, n2, ierr ) - CALL output_aux_hist5 ( grid%auxhist5_oid, grid , config_flags , ierr ) - CASE ( 6 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST6_ALARM, & - config_flags%auxhist6_outname, grid%auxhist6_oid, & - output_aux_hist6, fname, n2, ierr ) - CALL output_aux_hist6 ( grid%auxhist6_oid, grid , config_flags , ierr ) - CASE ( 7 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST7_ALARM, & - config_flags%auxhist7_outname, grid%auxhist7_oid, & - output_aux_hist7, fname, n2, ierr ) - CALL output_aux_hist7 ( grid%auxhist7_oid, grid , config_flags , ierr ) - CASE ( 8 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST8_ALARM, & - config_flags%auxhist8_outname, grid%auxhist8_oid, & - output_aux_hist8, fname, n2, ierr ) - CALL output_aux_hist8 ( grid%auxhist8_oid, grid , config_flags , ierr ) - CASE ( 9 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST9_ALARM, & - config_flags%auxhist9_outname, grid%auxhist9_oid, & - output_aux_hist9, fname, n2, ierr ) - CALL output_aux_hist9 ( grid%auxhist9_oid, grid , config_flags , ierr ) - CASE ( 10 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST10_ALARM, & - config_flags%auxhist10_outname, grid%auxhist10_oid, & - output_aux_hist10, fname, n2, ierr ) - CALL output_aux_hist10 ( grid%auxhist10_oid, grid , config_flags , ierr ) - CASE ( 11 ) - CALL open_hist_w( grid, config_flags, stream, AUXHIST11_ALARM, & - config_flags%auxhist11_outname, grid%auxhist11_oid, & - output_aux_hist11, fname, n2, ierr ) - CALL output_aux_hist11 ( grid%auxhist11_oid, grid , config_flags , ierr ) + +! registry-generated selections and calls top open_hist_w for aux streams +#include "med_hist_out_opens.inc" + END SELECT WRITE(message,*)'med_hist_out: opened ',TRIM(fname),' as ',TRIM(n2) CALL wrf_debug( 1, message ) - grid%nframes(stream) = grid%nframes(stream) + 1 - - SELECT CASE( stream ) - CASE ( 0 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_outfile ) THEN - CALL close_dataset ( grid%oid , config_flags , n2 ) - grid%oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 1 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist1 ) THEN - CALL close_dataset ( grid%auxhist1_oid , config_flags , n2 ) - grid%auxhist1_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 2 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist2 ) THEN - CALL close_dataset ( grid%auxhist2_oid , config_flags , n2 ) - grid%auxhist2_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 3 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist3 ) THEN - CALL close_dataset ( grid%auxhist3_oid , config_flags , n2 ) - grid%auxhist3_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 4 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist4 ) THEN - CALL close_dataset ( grid%auxhist4_oid , config_flags , n2 ) - grid%auxhist4_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 5 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist5 ) THEN - CALL close_dataset ( grid%auxhist5_oid , config_flags , n2 ) - grid%auxhist5_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 6 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist6 ) THEN - CALL close_dataset ( grid%auxhist6_oid , config_flags , n2 ) - grid%auxhist6_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 7 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist7 ) THEN - CALL close_dataset ( grid%auxhist7_oid , config_flags , n2 ) - grid%auxhist7_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 8 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist8 ) THEN - CALL close_dataset ( grid%auxhist8_oid , config_flags , n2 ) - grid%auxhist8_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 9 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist9 ) THEN - CALL close_dataset ( grid%auxhist9_oid , config_flags , n2 ) - grid%auxhist9_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 10 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist10 ) THEN - CALL close_dataset ( grid%auxhist10_oid , config_flags , n2 ) - grid%auxhist10_oid = 0 - grid%nframes(stream) = 0 - ENDIF - CASE ( 11 ) - IF ( grid%nframes(stream) >= config_flags%frames_per_auxhist11 ) THEN - CALL close_dataset ( grid%auxhist11_oid , config_flags , n2 ) - grid%auxhist11_oid = 0 - grid%nframes(stream) = 0 - ENDIF - END SELECT - IF ( wrf_dm_on_monitor() ) THEN - WRITE ( message , FMT = '("Writing ",A30," for domain ",I8)' )TRIM(fname),grid%id - CALL end_timing ( TRIM(message) ) - END IF - - RETURN -END SUBROUTINE med_hist_out - -SUBROUTINE med_auxinput1_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 1 , config_flags ) - RETURN -END SUBROUTINE med_auxinput1_in - -SUBROUTINE med_auxinput2_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 2 , config_flags ) - RETURN -END SUBROUTINE med_auxinput2_in - -SUBROUTINE med_auxinput3_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 3 , config_flags ) - RETURN -END SUBROUTINE med_auxinput3_in - -SUBROUTINE med_auxinput4_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 4 , config_flags ) - RETURN -END SUBROUTINE med_auxinput4_in - -SUBROUTINE med_auxinput5_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 5 , config_flags ) - RETURN -END SUBROUTINE med_auxinput5_in - -SUBROUTINE med_auxinput6_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 6 , config_flags ) - RETURN -END SUBROUTINE med_auxinput6_in - -SUBROUTINE med_auxinput7_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 7 , config_flags ) - RETURN -END SUBROUTINE med_auxinput7_in + grid%nframes(stream) = grid%nframes(stream) + 1 -SUBROUTINE med_auxinput8_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 8 , config_flags ) - RETURN -END SUBROUTINE med_auxinput8_in + SELECT CASE( stream ) + CASE ( HISTORY_ALARM ) + IF ( grid%nframes(stream) >= config_flags%frames_per_outfile ) THEN + CALL close_dataset ( grid%oid , config_flags , n2 ) + grid%oid = 0 + grid%nframes(stream) = 0 + ENDIF +! registry-generated selections and calls top close_dataset for aux streams +#include "med_hist_out_closes.inc" -SUBROUTINE med_auxinput9_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 9 , config_flags ) - RETURN -END SUBROUTINE med_auxinput9_in + END SELECT + IF ( wrf_dm_on_monitor() ) THEN + WRITE ( message , FMT = '("Writing ",A30," for domain ",I8)' )TRIM(fname),grid%id + CALL end_timing ( TRIM(message) ) + END IF -SUBROUTINE med_auxinput10_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 10 , config_flags ) RETURN -END SUBROUTINE med_auxinput10_in - -SUBROUTINE med_auxinput11_in ( grid , config_flags ) - USE module_domain - USE module_configure - IMPLICIT NONE - TYPE(domain) :: grid - TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags - CALL med_auxinput_in( grid , 11 , config_flags ) - RETURN -END SUBROUTINE med_auxinput11_in +END SUBROUTINE med_hist_out +#if (DA_CORE != 1) SUBROUTINE med_fddaobs_in ( grid , config_flags ) USE module_domain USE module_configure @@ -1514,6 +1443,7 @@ SUBROUTINE med_fddaobs_in ( grid , config_flags ) CALL wrf_fddaobs_in( grid, config_flags ) RETURN END SUBROUTINE med_fddaobs_in +#endif SUBROUTINE med_auxinput_in ( grid , stream, config_flags ) ! Driver layer @@ -1533,67 +1463,19 @@ SUBROUTINE med_auxinput_in ( grid , stream, config_flags ) CHARACTER (LEN=256) :: message INTEGER :: ierr - IF ( stream .LT. 1 .OR. stream .GT. 11 ) THEN + IF ( stream .LT. first_auxinput .OR. stream .GT. last_auxinput ) THEN WRITE(message,*)'med_auxinput_in: invalid input stream ',stream CALL wrf_error_fatal( message ) ENDIF SELECT CASE( stream ) - CASE ( 1 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT1_ALARM, & - config_flags%auxinput1_inname, grid%auxinput1_oid, & - input_aux_model_input1, ierr ) - CALL input_aux_model_input1 ( grid%auxinput1_oid, grid , config_flags , ierr ) - CASE ( 2 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT2_ALARM, & - config_flags%auxinput2_inname, grid%auxinput2_oid, & - input_aux_model_input2, ierr ) - CALL input_aux_model_input2 ( grid%auxinput2_oid, grid , config_flags , ierr ) - CASE ( 3 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT3_ALARM, & - config_flags%auxinput3_inname, grid%auxinput3_oid, & - input_aux_model_input3, ierr ) - CALL input_aux_model_input3 ( grid%auxinput3_oid, grid , config_flags , ierr ) - CASE ( 4 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT4_ALARM, & - config_flags%auxinput4_inname, grid%auxinput4_oid, & - input_aux_model_input4, ierr ) - CALL input_aux_model_input4 ( grid%auxinput4_oid, grid , config_flags , ierr ) - CASE ( 5 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT5_ALARM, & - config_flags%auxinput5_inname, grid%auxinput5_oid, & - input_aux_model_input5, ierr ) - CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) - CASE ( 6 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT6_ALARM, & - config_flags%auxinput6_inname, grid%auxinput6_oid, & - input_aux_model_input6, ierr ) - CALL input_aux_model_input6 ( grid%auxinput6_oid, grid , config_flags , ierr ) - CASE ( 7 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT7_ALARM, & - config_flags%auxinput7_inname, grid%auxinput7_oid, & - input_aux_model_input7, ierr ) - CALL input_aux_model_input7 ( grid%auxinput7_oid, grid , config_flags , ierr ) - CASE ( 8 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT8_ALARM, & - config_flags%auxinput8_inname, grid%auxinput8_oid, & - input_aux_model_input8, ierr ) - CALL input_aux_model_input8 ( grid%auxinput8_oid, grid , config_flags , ierr ) - CASE ( 9 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT9_ALARM, & - config_flags%sgfdda_inname, grid%auxinput9_oid, & - input_aux_model_input9, ierr ) - CALL input_aux_model_input9 ( grid%auxinput9_oid, grid , config_flags , ierr ) - CASE ( 10 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT10_ALARM, & - config_flags%gfdda_inname, grid%auxinput10_oid, & - input_aux_model_input10, ierr ) - CALL input_aux_model_input10 ( grid%auxinput10_oid, grid , config_flags , ierr ) - CASE ( 11 ) - CALL open_aux_u( grid, config_flags, stream, AUXINPUT11_ALARM, & - config_flags%auxinput11_inname, grid%auxinput11_oid, & - input_aux_model_input11, ierr ) - CALL input_aux_model_input11 ( grid%auxinput11_oid, grid , config_flags , ierr ) +! registry-generated file of calls to open filename +! CASE ( AUXINPUT1_ALARM ) +! CALL open_aux_u( grid, config_flags, stream, AUXINPUT1_ALARM, & +! config_flags%auxinput1_inname, grid%auxinput1_oid, & +! input_auxinput1, ierr ) +! CALL input_auxinput1 ( grid%auxinput1_oid, grid , config_flags , ierr ) +#include "med_auxinput_in.inc" END SELECT RETURN END SUBROUTINE med_auxinput_in @@ -1634,7 +1516,7 @@ SUBROUTINE med_filter_out ( grid , config_flags ) CALL wrf_debug( 1, message ) CALL open_w_dataset ( fid, TRIM(outname), grid , & - config_flags , output_model_input , "DATASET=INPUT", ierr ) + config_flags , output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN CALL wrf_error_fatal( message ) ENDIF @@ -1643,7 +1525,7 @@ SUBROUTINE med_filter_out ( grid , config_flags ) CALL wrf_error_fatal( message ) ENDIF - CALL output_model_input ( fid, grid , config_flags , ierr ) + CALL output_input ( fid, grid , config_flags , ierr ) CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) IF ( wrf_dm_on_monitor() ) THEN @@ -1855,7 +1737,7 @@ SUBROUTINE open_aux_u ( grid , config_flags, stream, alarm_id, & TYPE(WRFU_Time) :: ST,CT LOGICAL :: adjust - IF ( stream .LT. 1 .OR. stream .GT. 11 ) THEN + IF ( stream .LT. first_stream .OR. stream .GT. last_stream ) THEN WRITE(message,*)'open_aux_u: invalid input stream ',stream CALL wrf_error_fatal( message ) ENDIF @@ -1927,7 +1809,7 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & TYPE(WRFU_Time) :: ST,CT LOGICAL :: adjust - IF ( stream .LT. 0 .OR. stream .GT. 11 ) THEN + IF ( stream .LT. first_history .OR. stream .GE. last_history ) THEN WRITE(message,*)'open_hist_w: invalid history stream ',stream CALL wrf_error_fatal( message ) ENDIF @@ -1944,11 +1826,7 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & ENDIF CALL construct_filename2a ( fname , hist_outname, & grid%id , 2 , timestr ) - IF ( stream .EQ. 10 ) THEN - WRITE(n2,'("DATASET=AUXHIST10")') - ELSE IF ( stream .EQ. 11 ) THEN - WRITE(n2,'("DATASET=AUXHIST11")') - ELSE IF ( stream .EQ. 0 ) THEN + IF ( stream .EQ. history_only ) THEN WRITE(n2,'("DATASET=HISTORY")') ELSE WRITE(n2,'("DATASET=AUXHIST",I1)')stream @@ -2136,12 +2014,12 @@ SUBROUTINE med_read_wrf_chem_emiss ( grid , config_flags ) DO i=1,ihrdiff WRITE(message,'(A,I4)')'mediation_integrate: med_read_wrf_chem_emissions: Skip emissions ',i CALL wrf_message( TRIM(message) ) - CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) + CALL input_auxinput5 ( grid%auxinput5_oid, grid , config_flags , ierr ) ENDDO ENDIF - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input5' ) - CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput5' ) + CALL input_auxinput5 ( grid%auxinput5_oid, grid , config_flags , ierr ) ELSE CALL wrf_debug (100 , 'mediation_integrate: med_read_wrf_chem_emissions: Do not read emissions' ) ENDIF @@ -2170,8 +2048,8 @@ SUBROUTINE med_read_wrf_chem_emiss ( grid , config_flags ) ! ! Read the emissions data. ! - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input5' ) - CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput5' ) + CALL input_auxinput5 ( grid%auxinput5_oid, grid , config_flags , ierr ) ! ! If reached the indicated number of frames in the emissions file, close it. ! @@ -2254,8 +2132,8 @@ SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input6' ) - CALL input_aux_model_input6 ( grid%auxinput6_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput6' ) + CALL input_auxinput6 ( grid%auxinput6_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput6_oid , config_flags , "DATASET=AUXINPUT6" ) @@ -2318,8 +2196,8 @@ SUBROUTINE med_read_wrf_chem_gocartbg ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input8' ) - CALL input_aux_model_input8 ( grid%auxinput8_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput8' ) + CALL input_auxinput8 ( grid%auxinput8_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput8_oid , config_flags , "DATASET=AUXINPUT8" ) @@ -2381,8 +2259,8 @@ SUBROUTINE med_read_wrf_chem_emissopt3 ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (00 , 'mediation_integrate: calling input_aux_model_input7' ) - CALL input_aux_model_input7 ( grid%auxinput7_oid, grid , config_flags , ierr ) + CALL wrf_debug (00 , 'mediation_integrate: calling input_auxinput7' ) + CALL input_auxinput7 ( grid%auxinput7_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput7_oid , config_flags , "DATASET=AUXINPUT7" ) @@ -2523,8 +2401,8 @@ SUBROUTINE med_read_wrf_chem_fireemiss ( grid , config_flags ) WRITE(message,'(A,A)')'mediation_integrate: med_read_wrf_chem_fireemiss: Read emissions for time ',TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input7' ) - CALL input_aux_model_input7 ( grid%auxinput7_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput7' ) + CALL input_auxinput7 ( grid%auxinput7_oid, grid , config_flags , ierr ) ELSE CALL wrf_debug (100 , 'mediation_integrate: med_read_wrf_chem_fireemiss: Do not read emissions' ) ENDIF @@ -2554,8 +2432,8 @@ SUBROUTINE med_read_wrf_chem_fireemiss ( grid , config_flags ) ! ! Read the emissions data. ! - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input7' ) - CALL input_aux_model_input7 ( grid%auxinput7_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput7' ) + CALL input_auxinput7 ( grid%auxinput7_oid, grid , config_flags , ierr ) ! ! If reached the indicated number of frames in the emissions file, close it. ! @@ -2635,8 +2513,8 @@ SUBROUTINE med_read_wrf_chem_emissopt4 ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input5' ) - CALL input_aux_model_input5 ( grid%auxinput5_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput5' ) + CALL input_auxinput5 ( grid%auxinput5_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput5_oid , config_flags , "DATASET=AUXINPUT5" ) @@ -2702,8 +2580,8 @@ SUBROUTINE med_read_wrf_chem_dust_emiss ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input8' ) - CALL input_aux_model_input8 ( grid%auxinput8_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput8' ) + CALL input_auxinput8 ( grid%auxinput8_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput8_oid , config_flags , "DATASET=AUXINPUT8" ) @@ -2769,8 +2647,8 @@ SUBROUTINE med_read_wrf_chem_dms_emiss ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input7' ) - CALL input_aux_model_input7 ( grid%auxinput7_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput7' ) + CALL input_auxinput7 ( grid%auxinput7_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput7_oid , config_flags , "DATASET=AUXINPUT7" ) @@ -2836,8 +2714,8 @@ SUBROUTINE med_read_wrf_chem_gocart_bg ( grid , config_flags ) TRIM(current_date_char) CALL wrf_message( TRIM(message) ) - CALL wrf_debug (100 , 'mediation_integrate: calling input_aux_model_input8' ) - CALL input_aux_model_input8 ( grid%auxinput8_oid, grid , config_flags , ierr ) + CALL wrf_debug (100 , 'mediation_integrate: calling input_auxinput8' ) + CALL input_auxinput8 ( grid%auxinput8_oid, grid , config_flags , ierr ) CALL close_dataset ( grid%auxinput8_oid , config_flags , "DATASET=AUXINPUT8" ) @@ -2855,3 +2733,81 @@ END SUBROUTINE med_read_wrf_chem_gocart_bg #endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef HWRF +!zhang's doing for outputing restart namelist parameters +RECURSIVE SUBROUTINE med_namelist_out ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + USE module_timing + ! Model layer + USE module_configure + USE module_bc_time_utilities +!zhang new USE WRF_ESMF_MOD + USE module_utility +!zhang new ends + + IMPLICIT NONE + + ! Arguments + TYPE(domain), INTENT(IN) :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + + ! Local +!zhang new TYPE(ESMF_Time) :: CurrTime + TYPE(WRFU_Time) :: CurrTime + INTEGER :: nout,rc,kid + INTEGER :: hr, min, sec, ms,julyr,julday + REAL :: GMT + CHARACTER*80 :: prefix, outname + CHARACTER*80 :: timestr + LOGICAL :: exist + LOGICAL,EXTERNAL :: wrf_dm_on_monitor + + TYPE (grid_config_rec_type) :: kid_config_flags + +!zhang new + IF ( wrf_dm_on_monitor() ) THEN + CALL start_timing + END IF + + prefix = "wrfnamelist_d_" + nout = 99 + +!zhang new CALL ESMF_ClockGet( grid%domain_clock, CurrTime=CurrTime, rc=rc ) +!zhang new CALL wrf_timetoa ( CurrTime, timestr ) + CALL domain_clock_get( grid, current_timestr=timestr ) +!zhang new ends + CALL construct_filename2a ( outname , prefix, grid%id , 2 , timestr ) + + IF ( wrf_dm_on_monitor() ) THEN + + CLOSE (NOUT) + OPEN ( FILE = trim(outname) , UNIT = nout, STATUS = 'UNKNOWN', FORM = 'FORMATTED') +!zhang new CALL ESMF_TimeGet( grid%current_time, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) + CALL domain_clock_get( grid, current_time=CurrTime ) + CALL WRFU_TimeGet( CurrTime, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) +!zhang new ends + gmt=hr+real(min)/60.+real(sec)/3600.+real(ms)/(1000*3600) + WRITE(NOUT,*) grid%i_parent_start + WRITE(NOUT,*) grid%j_parent_start + WRITE(NOUT,*) julyr + WRITE(NOUT,*) julday + WRITE(NOUT,*) gmt + + CLOSE (NOUT) + ENDIF + + ! call recursively for children, (if any) + DO kid = 1, max_nests + IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN + CALL model_to_grid_config_rec ( grid%nests(kid)%ptr%id , model_config_rec , kid_config_flags ) + CALL med_namelist_out ( grid%nests(kid)%ptr , kid_config_flags ) + ENDIF + ENDDO + + RETURN +END SUBROUTINE med_namelist_out +!end of zhang's doing +#endif diff --git a/wrfv2_fire/share/mediation_interp_domain.F b/wrfv2_fire/share/mediation_interp_domain.F index 20cb3da1..dc27c1b6 100644 --- a/wrfv2_fire/share/mediation_interp_domain.F +++ b/wrfv2_fire/share/mediation_interp_domain.F @@ -61,7 +61,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags & ! -# include "dummy_args.inc" +# include "dummy_new_args.inc" ! ) USE module_domain @@ -70,12 +70,12 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include END SUBROUTINE interp_domain_nmm_part1 SUBROUTINE interp_domain_nmm_part2 ( grid, nested_grid, config_flags & ! -# include "dummy_args.inc" +# include "dummy_new_args.inc" ! ) USE module_domain @@ -83,7 +83,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include END SUBROUTINE interp_domain_nmm_part2 !======================================================================= @@ -116,6 +116,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -161,6 +162,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & + grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) @@ -172,7 +174,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) CALL interp_domain_nmm_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & ! -# include "actual_args.inc" +# include "actual_new_args.inc" ! ) grid => nested_grid%intermediate_grid @@ -180,7 +182,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) CALL interp_domain_nmm_part2 ( grid, nested_grid, config_flags & ! -# include "actual_args.inc" +# include "actual_new_args.inc" ! ) diff --git a/wrfv2_fire/share/mediation_nest_move.F b/wrfv2_fire/share/mediation_nest_move.F index bc5c05e8..27be7f45 100644 --- a/wrfv2_fire/share/mediation_nest_move.F +++ b/wrfv2_fire/share/mediation_nest_move.F @@ -1,11 +1,13 @@ SUBROUTINE med_nest_move ( parent, nest ) ! Driver layer - USE module_domain + USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move + USE module_utility USE module_timing - USE module_configure - USE module_io_domain - USE module_dm + USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec + USE module_state_description +! USE module_io_domain + USE module_dm, ONLY : wrf_dm_move_nest TYPE(domain) , POINTER :: parent, nest, grid INTEGER dx, dy ! number of parent domain points to move #ifdef MOVE_NESTS @@ -30,11 +32,13 @@ SUBROUTINE med_nest_move ( parent, nest ) INTERFACE SUBROUTINE med_interp_domain ( parent , nest ) - USE module_domain + USE module_domain, ONLY : domain + IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain SUBROUTINE start_domain ( grid , allowed_to_move ) - USE module_domain + USE module_domain, ONLY : domain + IMPLICIT NONE TYPE(domain) :: grid LOGICAL, INTENT(IN) :: allowed_to_move END SUBROUTINE start_domain @@ -44,9 +48,8 @@ SUBROUTINE med_nest_move ( parent, nest ) # include ! ) - USE module_domain - USE module_configure - USE module_timing + USE module_domain, ONLY : domain + USE module_state_description IMPLICIT NONE INTEGER disp_x, disp_y TYPE(domain) , POINTER :: grid @@ -56,11 +59,13 @@ SUBROUTINE med_nest_move ( parent, nest ) #if ( NMM_CORE == 1 ) SUBROUTINE med_nest_egrid_configure ( parent , nest ) USE module_domain + IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_nest_egrid_configure SUBROUTINE med_construct_egrid_weights ( parent , nest ) USE module_domain + IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_construct_egrid_weights @@ -74,7 +79,6 @@ SUBROUTINE med_nest_move ( parent, nest ) IPS,IPE,JPS,JPE,KPS,KPE ) ! - USE MODULE_MODEL_CONSTANTS IMPLICIT NONE INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME @@ -89,33 +93,34 @@ SUBROUTINE med_nest_move ( parent, nest ) END SUBROUTINE BASE_STATE_PARENT SUBROUTINE NEST_TERRAIN ( nest, config_flags ) - USE module_domain + USE module_domain, ONLY : domain + USE module_configure, ONLY : grid_config_rec_type + IMPLICIT NONE TYPE(domain) , POINTER :: nest TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags END SUBROUTINE NEST_TERRAIN SUBROUTINE med_init_domain_constants_nmm ( parent, nest ) - USE module_domain + USE module_domain, ONLY : domain + IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_init_domain_constants_nmm SUBROUTINE shift_domain_nmm ( grid, disp_x, disp_y & ! -# include +# include ! ) USE module_domain - USE module_configure - USE module_timing IMPLICIT NONE INTEGER disp_x, disp_y TYPE(domain) , POINTER :: grid -#include +#include END SUBROUTINE shift_domain_nmm #endif LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy ) - USE module_domain - USE module_utility + USE module_domain, ONLY : domain + IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest INTEGER, INTENT(OUT) :: dx , dy END FUNCTION time_for_move @@ -126,7 +131,8 @@ SUBROUTINE med_nest_move ( parent, nest ) ! LOGICAL FUNCTION nest_roam ( parent , nest , dx , dy ) !REPLACED BY KWON ! LOGICAL FUNCTION direction_of_move ( parent , nest , dx , dy ) - USE module_domain + USE module_domain, ONLY : domain + IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest INTEGER, INTENT(OUT) :: dx , dy END FUNCTION direction_of_move @@ -139,15 +145,17 @@ SUBROUTINE med_nest_move ( parent, nest ) ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) - USE module_domain + USE module_domain, ONLY : domain + IMPLICIT NONE TYPE ( domain ) :: grid INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe END SUBROUTINE input_terrain_rsmas SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) - USE module_domain - USE module_configure + USE module_domain, ONLY : domain + USE module_configure, ONLY : grid_config_rec_type + IMPLICIT NONE TYPE (domain), POINTER :: nest , parent TYPE (grid_config_rec_type) config_flags END SUBROUTINE med_nest_feedback @@ -155,6 +163,7 @@ SUBROUTINE med_nest_move ( parent, nest ) ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) + IMPLICIT NONE INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe @@ -165,6 +174,7 @@ SUBROUTINE med_nest_move ( parent, nest ) ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) + IMPLICIT NONE INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe @@ -242,7 +252,7 @@ SUBROUTINE med_nest_move ( parent, nest ) #if (NMM_CORE == 1 && NMM_NEST == 1) CALL shift_domain_nmm( grid, dx, dy & ! -# include +# include ! ) #endif @@ -311,9 +321,6 @@ SUBROUTINE med_nest_move ( parent, nest ) ENDDO #endif - - - DO J = JPS, MIN(JPE,JDE-1) DO I = IPS, MIN(IPE,IDE-1) nest%fis(I,J)=nest%hres_fis(I,J) @@ -477,11 +484,13 @@ END SUBROUTINE med_nest_move LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y ) ! Driver layer - USE module_domain - USE module_configure + USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid, adjust_domain_dims_for_move +! USE module_configure + USE module_driver_constants, ONLY : max_moves USE module_compute_geop - USE module_dm + USE module_dm, ONLY : wrf_dm_max_real, wrf_dm_move_nest USE module_utility + USE module_streams, ONLY : compute_vortex_center_alarm IMPLICIT NONE ! Arguments TYPE(domain) , POINTER :: parent, grid @@ -918,9 +927,9 @@ write(0,*)' changing grid%vc_i, move_cd_x * pgr ', grid%vc_i, move_cd_x * pgr, END FUNCTION time_for_move2 LOGICAL FUNCTION time_for_move ( parent , grid , move_cd_x, move_cd_y ) - USE module_domain - USE module_configure - USE module_dm + USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move +! USE module_configure + USE module_dm, ONLY : wrf_dm_move_nest USE module_timing USE module_utility IMPLICIT NONE @@ -942,8 +951,7 @@ USE module_timing ! interface INTERFACE LOGICAL FUNCTION time_for_move2 ( parent , nest , dx , dy ) - USE module_domain - USE module_utility + USE module_domain, ONLY : domain TYPE(domain) , POINTER :: parent , nest INTEGER, INTENT(OUT) :: dx , dy END FUNCTION time_for_move2 @@ -959,16 +967,16 @@ USE module_timing kid = 1 ! Check if it is time to move the nest - xtime = grid%xtime - CALL nl_get_time_to_move ( grid%id , time_to_move ) - if ( xtime .lt. time_to_move ) then - time_for_move = .FALSE. - move_cd_x = 0 - move_cd_y = 0 -! write(0,*) 'it is not the time to move ', xtime, time_to_move - return - endif -! +! xtime = grid%xtime +! CALL nl_get_time_to_move ( grid%id , time_to_move ) +! if ( xtime .lt. time_to_move ) then +! time_for_move = .FALSE. +! move_cd_x = 0 +! move_cd_y = 0 +!! write(0,*) 'it is not the time to move ', xtime, time_to_move +! return +! endif +!! ! find out if this is the innermost nest (will not have kids) IF ( grid%num_nests .EQ. 0 ) THEN ! code that executes on innermost nest @@ -1099,7 +1107,7 @@ END FUNCTION time_for_move ! Put any tests for non-moving options or conditions in here LOGICAL FUNCTION should_not_move ( id ) USE module_state_description - USE module_configure +! USE module_configure IMPLICIT NONE INTEGER, INTENT(IN) :: id ! Local @@ -1217,9 +1225,9 @@ END FUNCTION nest_roam !ADDED BY YOUNG KWON FOR VORTEX FOLLOWING NEST MOVE LOGICAL FUNCTION direction_of_move ( parent , grid , move_cd_x, move_cd_y ) - USE module_domain - USE module_configure - USE module_dm + USE module_domain, ONLY : domain +! USE module_configure +! USE module_dm !!! USE WRF_ESMF_MOD !!COMMENTED OUT BY KWON TO FOLLOW DUSAN'S CODING IMPLICIT NONE ! arguments diff --git a/wrfv2_fire/share/mediation_wrfmain.F b/wrfv2_fire/share/mediation_wrfmain.F index fd9b6184..d6c3c8fe 100644 --- a/wrfv2_fire/share/mediation_wrfmain.F +++ b/wrfv2_fire/share/mediation_wrfmain.F @@ -16,8 +16,6 @@ SUBROUTINE med_initialdata_input_ptr ( grid , config_flags ) END SUBROUTINE med_initialdata_input END INTERFACE CALL med_initialdata_input ( grid , config_flags ) - - END SUBROUTINE med_initialdata_input_ptr SUBROUTINE med_initialdata_input ( grid , config_flags ) @@ -68,58 +66,9 @@ use module_io WRITE( wrf_err_message , * ) 'program wrf: error opening ',TRIM(inpname),' for reading ierr=',ierr CALL WRF_ERROR_FATAL ( wrf_err_message ) ENDIF - IF ( ( grid%id .EQ. 1 ) .OR. ( config_flags%fine_input_stream .EQ. 0 ) ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_model_input' ) - CALL input_model_input ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_model_input' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 1 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input1' ) - CALL input_aux_model_input1 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input1' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 2 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input2' ) - CALL input_aux_model_input2 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input2' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 3 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input3' ) - CALL input_aux_model_input3 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input3' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 4 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input4' ) - CALL input_aux_model_input4 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input4' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 5 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input5' ) - CALL input_aux_model_input5 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input5' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 6 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input6' ) - CALL input_aux_model_input6 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input6' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 7 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input7' ) - CALL input_aux_model_input7 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input7' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 8 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input8' ) - CALL input_aux_model_input8 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input8' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 9 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input9' ) - CALL input_aux_model_input9 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input9' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 10 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input10' ) - CALL input_aux_model_input10 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input10' ) - ELSE IF ( config_flags%fine_input_stream .EQ. 11 ) THEN - CALL wrf_debug ( 0 , 'med_initialdata_input: calling input_aux_model_input11' ) - CALL input_aux_model_input11 ( fid , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'med_initialdata_input: back from input_aux_model_input11' ) - ELSE - WRITE( message , '("med_initialdata_input: bad fine_input_stream = ",I4)') config_flags%fine_input_stream - CALL WRF_ERROR_FATAL ( message ) - END IF +! registry-generated code that reads the variable set defined on a given stream +#include "fine_stream_input.inc" + CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) #ifdef MOVE_NESTS #if ( EM_CORE == 1 ) diff --git a/wrfv2_fire/share/module_bc.F b/wrfv2_fire/share/module_bc.F index 9dafc907..3631605f 100644 --- a/wrfv2_fire/share/module_bc.F +++ b/wrfv2_fire/share/module_bc.F @@ -263,7 +263,16 @@ CONTAINS config_flags%periodic_y end if - + IF ( variable == 'd' ) then !JDM + istag = 0 + jstag = 0 + ENDIF + IF ( variable == 'e' ) then !JDM + istag = 0 + ENDIF + IF ( variable == 'f' ) then !JDM + jstag = 0 + ENDIF ! periodic conditions. ! note, patch must cover full range in periodic dir, or else diff --git a/wrfv2_fire/share/module_date_time.F b/wrfv2_fire/share/module_date_time.F index 63fa3a24..3dc24c2d 100644 --- a/wrfv2_fire/share/module_date_time.F +++ b/wrfv2_fire/share/module_date_time.F @@ -913,13 +913,12 @@ END MODULE module_date_time RETURN END SUBROUTINE wrf_atotime - - ! Converts an WRFU_Time object into a WRF date-time string. ! The format of the WRF date-time strings is a slight variant on ISO 8601: ! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss". SUBROUTINE wrf_timetoa ( time, str ) - USE module_utility + USE module_utility, ONLY : WRFU_Time, WRFU_TimeGet, WRFU_SUCCESS + IMPLICIT NONE TYPE(WRFU_Time), INTENT(INOUT) :: time CHARACTER (LEN=*), INTENT(OUT) :: str INTEGER strlen, rc @@ -930,8 +929,9 @@ END MODULE module_date_time ENDIF tmpstr = '' CALL WRFU_TimeGet( time, timeString=tmpstr, rc=rc ) + WRITE(mess,*)'WRFU_TimeGet() returns ',rc,' in wrf_timetoa() FAILED: timeString >',TRIM(tmpstr),'<' CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeGet() in wrf_timetoa() FAILED', & + mess, & __FILE__ , & __LINE__ ) ! change ISO 8601 'T' to WRF '_' and hack off fraction if str is not @@ -945,11 +945,10 @@ END MODULE module_date_time RETURN END SUBROUTINE wrf_timetoa - - ! Converts an WRFU_TimeInterval object into a time-interval string. SUBROUTINE wrf_timeinttoa ( timeinterval, str ) USE module_utility + IMPLICIT NONE TYPE(WRFU_TimeInterval), INTENT(INOUT) :: timeinterval CHARACTER (LEN=*), INTENT(OUT) :: str INTEGER rc diff --git a/wrfv2_fire/share/module_io_domain.F b/wrfv2_fire/share/module_io_domain.F dissimilarity index 60% index 55be7197..564adc5a 100644 --- a/wrfv2_fire/share/module_io_domain.F +++ b/wrfv2_fire/share/module_io_domain.F @@ -1,980 +1,411 @@ -!WRF:MEDIATION_LAYER:IO -! - -MODULE module_io_domain -USE module_io -USE module_io_wrf -USE module_wrf_error -USE module_date_time -USE module_configure -USE module_domain - -CONTAINS - - SUBROUTINE open_r_dataset ( id , fname , grid , config_flags , sysdepinfo, ierr ) - TYPE (domain) :: grid - CHARACTER*(*) :: fname - CHARACTER*(*) :: sysdepinfo - INTEGER , INTENT(INOUT) :: id , ierr - LOGICAL , EXTERNAL :: wrf_dm_on_monitor - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - CHARACTER*128 :: DataSet - LOGICAL :: anyway - CALL wrf_open_for_read ( fname , & - grid%communicator , & - grid%iocommunicator , & - sysdepinfo , & - id , & - ierr ) - RETURN - END SUBROUTINE open_r_dataset - - SUBROUTINE open_w_dataset ( id , fname , grid , config_flags , outsub , sysdepinfo, ierr ) - TYPE (domain) :: grid - CHARACTER*(*) :: fname - CHARACTER*(*) :: sysdepinfo - INTEGER , INTENT(INOUT) :: id , ierr - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - LOGICAL , EXTERNAL :: wrf_dm_on_monitor - EXTERNAL outsub - CHARACTER*128 :: DataSet - LOGICAL :: anyway - CALL wrf_debug ( 100 , 'calling wrf_open_for_write_begin in open_w_dataset' ) - CALL wrf_open_for_write_begin ( fname , & - grid%communicator , & - grid%iocommunicator , & - sysdepinfo , & - id , & - ierr ) - IF ( ierr .LE. 0 ) THEN - CALL wrf_debug ( 100 , 'calling outsub in open_w_dataset' ) - CALL outsub( id , grid , config_flags , ierr ) - CALL wrf_debug ( 100 , 'back from outsub in open_w_dataset' ) - ENDIF - IF ( ierr .LE. 0 ) THEN - CALL wrf_debug ( 100 , 'calling wrf_open_for_write_commit in open_w_dataset' ) - CALL wrf_open_for_write_commit ( id , & - ierr ) - CALL wrf_debug ( 100 , 'back from wrf_open_for_write_commit in open_w_dataset' ) - ENDIF - END SUBROUTINE open_w_dataset - - SUBROUTINE open_u_dataset ( id , fname , grid , config_flags , insub , sysdepinfo, ierr ) - TYPE (domain) :: grid - CHARACTER*(*) :: fname - CHARACTER*(*) :: sysdepinfo - INTEGER , INTENT(INOUT) :: id , ierr - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - LOGICAL , EXTERNAL :: wrf_dm_on_monitor - EXTERNAL insub - CHARACTER*128 :: DataSet - LOGICAL :: anyway - CALL wrf_debug ( 100 , 'calling wrf_open_for_read_begin in open_u_dataset' ) - CALL wrf_open_for_read_begin ( fname , & - grid%communicator , & - grid%iocommunicator , & - sysdepinfo , & - id , & - ierr ) - IF ( ierr .LE. 0 ) THEN - CALL wrf_debug ( 100 , 'calling insub in open_u_dataset' ) - CALL insub( id , grid , config_flags , ierr ) - ENDIF - IF ( ierr .LE. 0 ) THEN - CALL wrf_debug ( 100 , 'calling wrf_open_for_read_commit in open_u_dataset' ) - CALL wrf_open_for_read_commit ( id , & - ierr ) - CALL wrf_debug ( 100 , 'back from wrf_open_for_read_commit in open_u_dataset' ) - ENDIF - END SUBROUTINE open_u_dataset - - SUBROUTINE close_dataset( id , config_flags, sysdepinfo ) - IMPLICIT NONE - INTEGER id , ierr - LOGICAL , EXTERNAL :: wrf_dm_on_monitor - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - CHARACTER*(*) :: sysdepinfo - CHARACTER*128 :: DataSet - LOGICAL :: anyway - CALL wrf_ioclose( id , ierr ) - END SUBROUTINE close_dataset - - -! ------------ Output model input data sets - - SUBROUTINE output_model_input ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_input .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , model_input_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_model_input - - SUBROUTINE output_aux_model_input1 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput1 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input1_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input1 - - SUBROUTINE output_aux_model_input2 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput2 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input2_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input2 - - SUBROUTINE output_aux_model_input3 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput3 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input3_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input3 - - SUBROUTINE output_aux_model_input4 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput4 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input4_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input4 - - SUBROUTINE output_aux_model_input5 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput5 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input5_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input5 - - SUBROUTINE output_aux_model_input6 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput6 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input6_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input6 - - SUBROUTINE output_aux_model_input7 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput7 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input7_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input7 - - SUBROUTINE output_aux_model_input8 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput8 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input8_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input8 - - SUBROUTINE output_aux_model_input9 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_sgfdda .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input9_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input9 - - SUBROUTINE output_aux_model_input10 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_gfdda .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input10_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input10 - - SUBROUTINE output_aux_model_input11 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput11 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_model_input11_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_model_input11 - -! ------------ Output model history data sets - - SUBROUTINE output_history ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_history .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , history_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_history - - SUBROUTINE output_aux_hist1 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist1 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist1_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist1 - - SUBROUTINE output_aux_hist2 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist2 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist2_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist2 - - SUBROUTINE output_aux_hist3 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist3 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist3_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist3 - - SUBROUTINE output_aux_hist4 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist4 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist4_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist4 - - SUBROUTINE output_aux_hist5 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist5 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist5_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist5 - - SUBROUTINE output_aux_hist6 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist6 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist6_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist6 - - SUBROUTINE output_aux_hist7 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist7 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist7_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist7 - - SUBROUTINE output_aux_hist8 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist8 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist8_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist8 - - SUBROUTINE output_aux_hist9 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist9 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist9_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist9 - - SUBROUTINE output_aux_hist10 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist10 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist10_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist10 - - SUBROUTINE output_aux_hist11 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist11 .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , aux_hist11_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_aux_hist11 - -! ------------ Output model restart data sets - - SUBROUTINE output_restart ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_restart .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , restart_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_restart - -! ------------ Output model boundary data sets - - SUBROUTINE output_boundary ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_boundary .GT. 0 ) THEN - CALL output_wrf ( fid , grid , config_flags , boundary_only , ierr ) - ENDIF - RETURN - END SUBROUTINE output_boundary - -! ------------ Input model input data sets - - SUBROUTINE input_model_input ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_input .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , model_input_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_model_input - - SUBROUTINE input_aux_model_input1 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput1 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input1_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input1 - - SUBROUTINE input_aux_model_input2 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput2 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input2_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input2 - - SUBROUTINE input_aux_model_input3 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput3 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input3_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input3 - - SUBROUTINE input_aux_model_input4 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput4 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input4_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input4 - - SUBROUTINE input_aux_model_input5 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput5 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input5_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input5 - - SUBROUTINE input_aux_model_input6 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput6 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input6_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input6 - SUBROUTINE input_aux_model_input7 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput7 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input7_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input7 - SUBROUTINE input_aux_model_input8 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput8 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input8_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input8 - SUBROUTINE input_aux_model_input9 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_sgfdda .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input9_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input9 - SUBROUTINE input_aux_model_input10 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_gfdda .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input10_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input10 - SUBROUTINE input_aux_model_input11 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxinput11 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_model_input11_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_model_input11 - -! ------------ Input model history data sets - - SUBROUTINE input_history ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_history .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , history_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_history - - SUBROUTINE input_aux_hist1 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist1 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist1_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist1 - - SUBROUTINE input_aux_hist2 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist2 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist2_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist2 - - SUBROUTINE input_aux_hist3 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist3 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist3_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist3 - - SUBROUTINE input_aux_hist4 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist4 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist4_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist4 - - SUBROUTINE input_aux_hist5 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist5 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist5_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist5 - - SUBROUTINE input_aux_hist6 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist6 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist6_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist6 - SUBROUTINE input_aux_hist7 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist7 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist7_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist7 - SUBROUTINE input_aux_hist8 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist8 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist8_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist8 - SUBROUTINE input_aux_hist9 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist9 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist9_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist9 - SUBROUTINE input_aux_hist10 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist10 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist10_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist10 - SUBROUTINE input_aux_hist11 ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_auxhist11 .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , aux_hist11_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_aux_hist11 - -! ------------ Input model restart data sets - - SUBROUTINE input_restart ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_restart .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , restart_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_restart - -! ------------ Input model boundary data sets - - SUBROUTINE input_boundary ( fid , grid , config_flags , ierr ) - IMPLICIT NONE - TYPE(domain) :: grid - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN) :: fid - INTEGER, INTENT(INOUT) :: ierr - IF ( config_flags%io_form_boundary .GT. 0 ) THEN - CALL input_wrf ( fid , grid , config_flags , boundary_only , ierr ) - ENDIF - RETURN - END SUBROUTINE input_boundary - -END MODULE module_io_domain - -! move outside module so callable without USE of module -SUBROUTINE construct_filename1( result , basename , fld1 , len1 ) - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - INTEGER , INTENT(IN) :: fld1 , len1 - CHARACTER*64 :: t1, zeros - - CALL zero_pad ( t1 , fld1 , len1 ) - result = TRIM(basename) // "_d" // TRIM(t1) - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename1 - -SUBROUTINE construct_filename2( result , basename , fld1 , len1 , date_char ) - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - CHARACTER*(*) :: date_char - - INTEGER , INTENT(IN) :: fld1 , len1 - CHARACTER*64 :: t1, zeros - CALL zero_pad ( t1 , fld1 , len1 ) - result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename2 - -! this version looks for and in the basename and replaces with the arguments - -SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char ) - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - CHARACTER*(*) :: date_char - - INTEGER , INTENT(IN) :: fld1 , len1 - CHARACTER*64 :: t1, zeros - INTEGER i, j, l - result=basename - CALL zero_pad ( t1 , fld1 , len1 ) - i = index( basename , '' ) - l = len(trim(basename)) - IF ( i .GT. 0 ) THEN - result = basename(1:i-1) // TRIM(t1) // basename(i+8:l) - ENDIF - i = index( result , '' ) - l = len(trim(result)) - IF ( i .GT. 0 ) THEN - result = result(1:i-1) // TRIM(date_char) // result(i+6:l) - ENDIF - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename2a - -SUBROUTINE construct_filename ( result , basename , fld1 , len1 , fld2 , len2 ) - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2 - CHARACTER*64 :: t1, t2, zeros - - CALL zero_pad ( t1 , fld1 , len1 ) - CALL zero_pad ( t2 , fld2 , len2 ) - result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename - -SUBROUTINE construct_filename3 ( result , basename , fld1 , len1 , fld2 , len2, fld3, len3 ) - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2, fld3, len3 - CHARACTER*64 :: t1, t2, t3, zeros - - CALL zero_pad ( t1 , fld1 , len1 ) - CALL zero_pad ( t2 , fld2 , len2 ) - CALL zero_pad ( t3 , fld3 , len3 ) - result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) // "_" // TRIM(t3) - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename3 - -SUBROUTINE construct_filename4( result , basename , fld1 , len1 , date_char , io_form ) - USE module_state_description - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - CHARACTER*(*) :: date_char - - INTEGER, EXTERNAL :: use_package - INTEGER , INTENT(IN) :: fld1 , len1 , io_form - CHARACTER*64 :: t1, zeros - CHARACTER*4 :: ext - CALL zero_pad ( t1 , fld1 , len1 ) - IF ( use_package(io_form) .EQ. IO_INTIO ) THEN - ext = '.int' - ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN - ext = '.nc ' - ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN - ext = '.nc ' - ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN - ext = '.gb ' - ELSE - CALL wrf_error_fatal ('improper io_form') - END IF - result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) // TRIM(ext) - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename4 - -! this version looks for and in the basename and replaces with the arguments - -SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , io_form ) - USE module_state_description - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - CHARACTER*(*) :: date_char - - INTEGER, EXTERNAL :: use_package - INTEGER , INTENT(IN) :: fld1 , len1 , io_form - CHARACTER*64 :: t1, zeros - CHARACTER*4 :: ext - INTEGER i, j, l - result=basename - CALL zero_pad ( t1 , fld1 , len1 ) - IF ( use_package(io_form) .EQ. IO_INTIO ) THEN - ext = '.int' - ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN - ext = '.nc ' - ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN - ext = '.nc ' - ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN - ext = '.gb ' - ELSE - CALL wrf_error_fatal ('improper io_form') - END IF - l = len(trim(basename)) - result = basename(1:l) // TRIM(ext) - i = index( result , '' ) - l = len(trim(result)) - IF ( i .GT. 0 ) THEN - result = result(1:i-1) // TRIM(t1) // result(i+8:l) - ENDIF - i = index( result , '' ) - l = len(trim(result)) - IF ( i .GT. 0 ) THEN - result = result(1:i-1) // TRIM(date_char) // result(i+6:l) - ENDIF - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE construct_filename4a - -SUBROUTINE append_to_filename ( result , basename , fld1 , len1 ) - IMPLICIT NONE - CHARACTER*(*) :: result - CHARACTER*(*) :: basename - INTEGER , INTENT(IN) :: fld1 , len1 - CHARACTER*64 :: t1, zeros - - CALL zero_pad ( t1 , fld1 , len1 ) - result = TRIM(basename) // "_" // TRIM(t1) - CALL maybe_remove_colons(result) - RETURN -END SUBROUTINE append_to_filename - -SUBROUTINE zero_pad ( result , fld1 , len1 ) - IMPLICIT NONE - CHARACTER*(*) :: result - INTEGER , INTENT (IN) :: fld1 , len1 - INTEGER :: d , x - CHARACTER*64 :: t2, zeros - x = fld1 ; d = 0 - DO WHILE ( x > 0 ) - x = x / 10 - d = d + 1 - END DO - write(t2,'(I9)')fld1 - zeros = '0000000000000000000000000000000' - result = zeros(1:len1-d) // t2(9-d+1:9) - RETURN -END SUBROUTINE zero_pad - -SUBROUTINE init_wrfio - USE module_io - IMPLICIT NONE - INTEGER ierr - CALL wrf_ioinit(ierr) -END SUBROUTINE init_wrfio - -! -! This routine figures out the nearest previous time instant -! that corresponds to a multiple of the input time interval. -! Example use is to give the time instant that corresponds to -! an I/O interval, even when the current time is a little bit -! past that time when, for example, the number of model time -! steps does not evenly divide the I/O interval. JM 20051013 -! -! -SUBROUTINE adjust_io_timestr ( TI, CT, ST, timestr ) - USE module_io_domain - IMPLICIT NONE -! Args - TYPE(WRFU_Time), INTENT(IN) :: ST,CT ! domain start and current time - TYPE(WRFU_TimeInterval), INTENT(IN) :: TI ! interval - CHARACTER*(*), INTENT(INOUT) :: timestr ! returned string -! Local - TYPE(WRFU_Time) :: OT - TYPE(WRFU_TimeInterval) :: IOI - INTEGER :: n - - IOI = CT-ST ! length of time since starting - n = WRFU_TimeIntervalDIVQuot( IOI , TI ) ! number of whole time intervals - IOI = TI * n ! amount of time since starting in whole time intervals - OT = ST + IOI ! previous nearest time instant - CALL wrf_timetoa( OT, timestr ) ! generate string - RETURN -END SUBROUTINE adjust_io_timestr - -! Modify the filename to remove things like ':' from the file name -! unless it is a drive number. Convert to '_' instead. - -SUBROUTINE maybe_remove_colons( FileName ) - USE module_configure - CHARACTER*(*) FileName - CHARACTER c, d - INTEGER i, l - LOGICAL nocolons - l = LEN(TRIM(FileName)) -! do not change first two characters (naive way of dealing with -! possiblity of drive name in a microsoft path - CALL nl_get_nocolons(1,nocolons) - IF ( nocolons ) THEN - DO i = 3, l - IF ( FileName(i:i) .EQ. ':' ) THEN - FileName(i:i) = '_' - ENDIF - ENDDO - ENDIF - RETURN -END - - - +!WRF:MEDIATION_LAYER:IO +! + +MODULE module_io_domain +USE module_io +USE module_io_wrf +USE module_configure, ONLY : grid_config_rec_type +USE module_domain, ONLY : domain + +CONTAINS + + SUBROUTINE open_r_dataset ( id , fname , grid , config_flags , sysdepinfo, ierr ) + TYPE (domain) :: grid + CHARACTER*(*) :: fname + CHARACTER*(*) :: sysdepinfo + INTEGER , INTENT(INOUT) :: id , ierr + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_open_for_read ( fname , & + grid%communicator , & + grid%iocommunicator , & + sysdepinfo , & + id , & + ierr ) + RETURN + END SUBROUTINE open_r_dataset + + SUBROUTINE open_w_dataset ( id , fname , grid , config_flags , outsub , sysdepinfo, ierr ) + TYPE (domain) :: grid + CHARACTER*(*) :: fname + CHARACTER*(*) :: sysdepinfo + INTEGER , INTENT(INOUT) :: id , ierr + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + EXTERNAL outsub + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_debug ( 100 , 'calling wrf_open_for_write_begin in open_w_dataset' ) + CALL wrf_open_for_write_begin ( fname , & + grid%communicator , & + grid%iocommunicator , & + sysdepinfo , & + id , & + ierr ) + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling outsub in open_w_dataset' ) + CALL outsub( id , grid , config_flags , ierr ) + CALL wrf_debug ( 100 , 'back from outsub in open_w_dataset' ) + ENDIF + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling wrf_open_for_write_commit in open_w_dataset' ) + CALL wrf_open_for_write_commit ( id , & + ierr ) + CALL wrf_debug ( 100 , 'back from wrf_open_for_write_commit in open_w_dataset' ) + ENDIF + END SUBROUTINE open_w_dataset + + SUBROUTINE open_u_dataset ( id , fname , grid , config_flags , insub , sysdepinfo, ierr ) + TYPE (domain) :: grid + CHARACTER*(*) :: fname + CHARACTER*(*) :: sysdepinfo + INTEGER , INTENT(INOUT) :: id , ierr + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + EXTERNAL insub + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_debug ( 100 , 'calling wrf_open_for_read_begin in open_u_dataset' ) + CALL wrf_open_for_read_begin ( fname , & + grid%communicator , & + grid%iocommunicator , & + sysdepinfo , & + id , & + ierr ) + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling insub in open_u_dataset' ) + CALL insub( id , grid , config_flags , ierr ) + ENDIF + IF ( ierr .LE. 0 ) THEN + CALL wrf_debug ( 100 , 'calling wrf_open_for_read_commit in open_u_dataset' ) + CALL wrf_open_for_read_commit ( id , & + ierr ) + CALL wrf_debug ( 100 , 'back from wrf_open_for_read_commit in open_u_dataset' ) + ENDIF + END SUBROUTINE open_u_dataset + + SUBROUTINE close_dataset( id , config_flags, sysdepinfo ) + IMPLICIT NONE + INTEGER id , ierr + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + CHARACTER*(*) :: sysdepinfo + CHARACTER*128 :: DataSet + LOGICAL :: anyway + CALL wrf_ioclose( id , ierr ) + END SUBROUTINE close_dataset + + +! ------------ Output model input data sets + +#include "module_io_domain_defs.inc" + +! ------------ Input model restart data sets + + SUBROUTINE input_restart ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_restart .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , restart_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_restart + +! ------------ Input model boundary data sets + + SUBROUTINE input_boundary ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_boundary .GT. 0 ) THEN + CALL input_wrf ( fid , grid , config_flags , boundary_only , ierr ) + ENDIF + RETURN + END SUBROUTINE input_boundary + +! ------------ Output model restart data sets + + SUBROUTINE output_restart ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_restart .GT. 0 ) THEN +#ifdef HWRF +!zhang: HWRF for bit reproducibility of random numbers when restarting + call random_seed(get=grid%nrnd1) +#endif + CALL output_wrf ( fid , grid , config_flags , restart_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_restart + +! ------------ Output model boundary data sets + + SUBROUTINE output_boundary ( fid , grid , config_flags , ierr ) + IMPLICIT NONE + TYPE(domain) :: grid + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + INTEGER, INTENT(IN) :: fid + INTEGER, INTENT(INOUT) :: ierr + IF ( config_flags%io_form_boundary .GT. 0 ) THEN + CALL output_wrf ( fid , grid , config_flags , boundary_only , ierr ) + ENDIF + RETURN + END SUBROUTINE output_boundary + +END MODULE module_io_domain + +! move outside module so callable without USE of module +SUBROUTINE construct_filename1( result , basename , fld1 , len1 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + result = TRIM(basename) // "_d" // TRIM(t1) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename1 + +SUBROUTINE construct_filename2( result , basename , fld1 , len1 , date_char ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + CALL zero_pad ( t1 , fld1 , len1 ) + result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename2 + +! this version looks for and in the basename and replaces with the arguments + +SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + INTEGER i, j, l + + result=basename + CALL zero_pad ( t1 , fld1 , len1 ) + i = index( basename , '' ) + l = len(trim(basename)) + IF ( i .GT. 0 ) THEN + result = basename(1:i-1) // TRIM(t1) // basename(i+8:l) + ENDIF + i = index( result , '' ) + l = len(trim(result)) + IF ( i .GT. 0 ) THEN + result = result(1:i-1) // TRIM(date_char) // result(i+6:l) + ENDIF + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename2a + +SUBROUTINE construct_filename ( result , basename , fld1 , len1 , fld2 , len2 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2 + CHARACTER*64 :: t1, t2, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + CALL zero_pad ( t2 , fld2 , len2 ) + result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename + +SUBROUTINE construct_filename3 ( result , basename , fld1 , len1 , fld2 , len2, fld3, len3 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2, fld3, len3 + CHARACTER*64 :: t1, t2, t3, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + CALL zero_pad ( t2 , fld2 , len2 ) + CALL zero_pad ( t3 , fld3 , len3 ) + result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) // "_" // TRIM(t3) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename3 + +SUBROUTINE construct_filename4( result , basename , fld1 , len1 , date_char , io_form ) + USE module_state_description + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER, EXTERNAL :: use_package + INTEGER , INTENT(IN) :: fld1 , len1 , io_form + CHARACTER*64 :: t1, zeros + CHARACTER*4 :: ext + CALL zero_pad ( t1 , fld1 , len1 ) + IF ( use_package(io_form) .EQ. IO_INTIO ) THEN + ext = '.int' + ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN + ext = '.nc ' + ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN + ext = '.nc ' + ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN + ext = '.gb ' + ELSE + CALL wrf_error_fatal ('improper io_form') + END IF + result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) // TRIM(ext) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename4 + +! this version looks for and in the basename and replaces with the arguments + +SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , io_form ) + USE module_state_description + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + CHARACTER*(*) :: date_char + + INTEGER, EXTERNAL :: use_package + INTEGER , INTENT(IN) :: fld1 , len1 , io_form + CHARACTER*64 :: t1, zeros + CHARACTER*4 :: ext + INTEGER i, j, l + result=basename + CALL zero_pad ( t1 , fld1 , len1 ) + IF ( use_package(io_form) .EQ. IO_INTIO ) THEN + ext = '.int' + ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN + ext = '.nc ' + ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN + ext = '.nc ' + ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN + ext = '.gb ' + ELSE + CALL wrf_error_fatal ('improper io_form') + END IF + l = len(trim(basename)) + result = basename(1:l) // TRIM(ext) + i = index( result , '' ) + l = len(trim(result)) + IF ( i .GT. 0 ) THEN + result = result(1:i-1) // TRIM(t1) // result(i+8:l) + ENDIF + i = index( result , '' ) + l = len(trim(result)) + IF ( i .GT. 0 ) THEN + result = result(1:i-1) // TRIM(date_char) // result(i+6:l) + ENDIF + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE construct_filename4a + +SUBROUTINE append_to_filename ( result , basename , fld1 , len1 ) + IMPLICIT NONE + CHARACTER*(*) :: result + CHARACTER*(*) :: basename + INTEGER , INTENT(IN) :: fld1 , len1 + CHARACTER*64 :: t1, zeros + + CALL zero_pad ( t1 , fld1 , len1 ) + result = TRIM(basename) // "_" // TRIM(t1) + CALL maybe_remove_colons(result) + RETURN +END SUBROUTINE append_to_filename + +SUBROUTINE zero_pad ( result , fld1 , len1 ) + IMPLICIT NONE + CHARACTER*(*) :: result + INTEGER , INTENT (IN) :: fld1 , len1 + INTEGER :: d , x + CHARACTER*64 :: t2, zeros + x = fld1 ; d = 0 + DO WHILE ( x > 0 ) + x = x / 10 + d = d + 1 + END DO + write(t2,'(I9)')fld1 + zeros = '0000000000000000000000000000000' + result = zeros(1:len1-d) // t2(9-d+1:9) + RETURN +END SUBROUTINE zero_pad + +SUBROUTINE init_wrfio + USE module_io, ONLY : wrf_ioinit + IMPLICIT NONE + INTEGER ierr + CALL wrf_ioinit(ierr) +END SUBROUTINE init_wrfio + +! +! This routine figures out the nearest previous time instant +! that corresponds to a multiple of the input time interval. +! Example use is to give the time instant that corresponds to +! an I/O interval, even when the current time is a little bit +! past that time when, for example, the number of model time +! steps does not evenly divide the I/O interval. JM 20051013 +! +! +SUBROUTINE adjust_io_timestr ( TI, CT, ST, timestr ) + USE module_utility + IMPLICIT NONE +! Args + TYPE(WRFU_Time), INTENT(IN) :: ST,CT ! domain start and current time + TYPE(WRFU_TimeInterval), INTENT(IN) :: TI ! interval + CHARACTER*(*), INTENT(INOUT) :: timestr ! returned string +! Local + TYPE(WRFU_Time) :: OT + TYPE(WRFU_TimeInterval) :: IOI + INTEGER :: n + + IOI = CT-ST ! length of time since starting + n = WRFU_TimeIntervalDIVQuot( IOI , TI ) ! number of whole time intervals + IOI = TI * n ! amount of time since starting in whole time intervals + OT = ST + IOI ! previous nearest time instant + CALL wrf_timetoa( OT, timestr ) ! generate string + RETURN +END SUBROUTINE adjust_io_timestr + +! Modify the filename to remove things like ':' from the file name +! unless it is a drive number. Convert to '_' instead. + +SUBROUTINE maybe_remove_colons( FileName ) + CHARACTER*(*) FileName + CHARACTER c, d + INTEGER i, l + LOGICAL nocolons + l = LEN(TRIM(FileName)) +! do not change first two characters (naive way of dealing with +! possiblity of drive name in a microsoft path + CALL nl_get_nocolons(1,nocolons) + IF ( nocolons ) THEN + DO i = 3, l + IF ( FileName(i:i) .EQ. ':' ) THEN + FileName(i:i) = '_' + ENDIF + ENDDO + ENDIF + RETURN +END + + + diff --git a/wrfv2_fire/share/module_io_wrf.F b/wrfv2_fire/share/module_io_wrf.F index 5c87ae09..a017b5db 100644 --- a/wrfv2_fire/share/module_io_wrf.F +++ b/wrfv2_fire/share/module_io_wrf.F @@ -5,34 +5,7 @@ MODULE module_io_wrf USE module_wrf_error USE module_date_time - -! switch parameters - INTEGER, PARAMETER :: history_only=1 - INTEGER, PARAMETER :: aux_hist1_only=2 - INTEGER, PARAMETER :: aux_hist2_only=3 - INTEGER, PARAMETER :: aux_hist3_only=4 - INTEGER, PARAMETER :: aux_hist4_only=5 - INTEGER, PARAMETER :: aux_hist5_only=6 - INTEGER, PARAMETER :: aux_hist6_only=7 - INTEGER, PARAMETER :: aux_hist7_only=8 - INTEGER, PARAMETER :: aux_hist8_only=9 - INTEGER, PARAMETER :: aux_hist9_only=10 - INTEGER, PARAMETER :: aux_hist10_only=11 - INTEGER, PARAMETER :: aux_hist11_only=12 - INTEGER, PARAMETER :: model_input_only=13 - INTEGER, PARAMETER :: aux_model_input1_only=14 - INTEGER, PARAMETER :: aux_model_input2_only=15 - INTEGER, PARAMETER :: aux_model_input3_only=16 - INTEGER, PARAMETER :: aux_model_input4_only=17 - INTEGER, PARAMETER :: aux_model_input5_only=18 - INTEGER, PARAMETER :: aux_model_input6_only=19 - INTEGER, PARAMETER :: aux_model_input7_only=20 - INTEGER, PARAMETER :: aux_model_input8_only=21 - INTEGER, PARAMETER :: aux_model_input9_only=22 - INTEGER, PARAMETER :: aux_model_input10_only=23 - INTEGER, PARAMETER :: aux_model_input11_only=24 - INTEGER, PARAMETER :: restart_only=25 - INTEGER, PARAMETER :: boundary_only=26 + USE module_streams CONTAINS SUBROUTINE init_module_io_wrf diff --git a/wrfv2_fire/share/module_llxy.F b/wrfv2_fire/share/module_llxy.F index 85a135ec..33858e9b 100644 --- a/wrfv2_fire/share/module_llxy.F +++ b/wrfv2_fire/share/module_llxy.F @@ -1222,11 +1222,7 @@ MODULE module_llxy ! Longitude lon = proj%stdlon + deg_per_rad * ATAN2(proj%hemi*xx,yy)/proj%cone -# if ( defined (G95) && ( DA_CORE == 1 ) ) - lon = DMOD(lon+360., 360.) -# else - lon = AMOD(lon+360., 360.) -# endif + lon = MOD(lon+360., 360.) ! Latitude. Latitude determined by solving an equation adapted ! from: diff --git a/wrfv2_fire/share/module_model_constants.F b/wrfv2_fire/share/module_model_constants.F index a87e6edb..d2c735ab 100644 --- a/wrfv2_fire/share/module_model_constants.F +++ b/wrfv2_fire/share/module_model_constants.F @@ -85,13 +85,7 @@ REAL , PARAMETER :: w_beta = 1.0 ! activation cfl number REAL , PARAMETER :: pq0=379.90516 -#ifdef HWRF -!Modified by Kwon for 0 tke - REAL , PARAMETER :: epsq2=0.0 -#else REAL , PARAMETER :: epsq2=0.2 -! REAL , PARAMETER :: epsq2=0.02 -#endif REAL , PARAMETER :: a2=17.2693882 REAL , PARAMETER :: a3=273.16 REAL , PARAMETER :: a4=35.86 diff --git a/wrfv2_fire/share/module_soil_pre.F b/wrfv2_fire/share/module_soil_pre.F index 29add91f..e351de28 100644 --- a/wrfv2_fire/share/module_soil_pre.F +++ b/wrfv2_fire/share/module_soil_pre.F @@ -5,6 +5,39 @@ MODULE module_soil_pre USE module_date_time USE module_state_description + CHARACTER (LEN=3) :: num_cat_count + INTEGER , PARAMETER , DIMENSION(0:300) :: ints = & + (/ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, & + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, & + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, & + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, & + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, & + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, & + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, & + 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, & + 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, & + 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, & + 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, & + 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, & + 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, & + 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, & + 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, & + 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, & + 160, 161, 162, 163, 164, 165, 166, 167, 168, 169, & + 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, & + 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, & + 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, & + 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, & + 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, & + 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, & + 230, 231, 232, 233, 234, 235, 236, 237, 238, 239, & + 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, & + 250, 251, 252, 253, 254, 255, 256, 257, 258, 259, & + 260, 261, 262, 263, 264, 265, 266, 267, 268, 269, & + 270, 271, 272, 273, 274, 275, 276, 277, 278, 279, & + 280, 281, 282, 283, 284, 285, 286, 287, 288, 289, & + 290, 291, 292, 293, 294, 295, 296, 297, 298, 299, 300 /) + CONTAINS SUBROUTINE adjust_for_seaice_pre ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , & @@ -131,6 +164,7 @@ CONTAINS soilcbot , tmn , vegfra , & tslb , smois , sh2o , & seaice_threshold , & + sst , flag_sst , & fractional_seaice, & num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & num_soil_layers , & @@ -153,10 +187,12 @@ CONTAINS REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot REAL , DIMENSION(ims:ime,1:num_soil_layers,jms:jme) , INTENT(INOUT):: tslb , smois , sh2o + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN):: sst INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & vegcat, xland , soilcat , tmn , & tsk_old , vegfra + INTEGER , INTENT(IN) :: flag_sst REAL , INTENT(IN) :: seaice_threshold REAL :: total_depth , mid_point_depth @@ -177,7 +213,7 @@ CONTAINS CASE ( SLABSCHEME ) - CASE ( LSMSCHEME , RUCLSMSCHEME ) + CASE ( LSMSCHEME ) DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( xice(i,j) .GT. 200.0 ) THEN @@ -257,6 +293,99 @@ CONTAINS CALL wrf_debug ( 0 , message ) END IF + CASE ( RUCLSMSCHEME ) + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( xice(i,j) .GT. 200.0 ) THEN + xice(i,j) = 0. + num_seaice_changes = num_seaice_changes + 1 + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total post number of sea ice locations removed (due to FLAG values) = ', & + num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + num_seaice_changes = 0 + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. & + ( ( tsk_old(i,j) .GT. 170 ) .AND. ( tsk_old(i,j) .LT. 400 ) ) )THEN + tsk(i,j) = tsk_old(i,j) + END IF + IF ( ( ( tsk(i,j) .LT. 170 ) .OR. ( tsk(i,j) .GT. 400 ) ) .AND. & + ( ( tsk_old(i,j) .LT. 170 ) .OR. ( tsk_old(i,j) .GT. 400 ) ) )THEN + print *,'TSK woes in seaice post, i,j=',i,j,' tsk = ',tsk(i,j), tsk_old(i,j) + CALL wrf_error_fatal ( 'TSK is unrealistic, problems for seaice post') + ELSE IF ( ( xice(i,j) .GE. xice_threshold ) .OR. & + ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN + IF ( FRACTIONAL_SEAICE == 0 ) THEN + xice(i,j) = 1.0 + ELSE + xice(i,j)=max(0.25,xice(i,j)) + ENDIF + num_seaice_changes = num_seaice_changes + 1 + if(landmask(i,j) .LT. 0.5 )tmn(i,j) = 271.4 + vegcat(i,j)=isice + ivgtyp(i,j)=isice + lu_index(i,j)=isice + landmask(i,j)=1. + xland(i,j)=1. + vegfra(i,j)=0. + DO loop=1,num_veg_cat + landusef(i,loop,j)=0. + END DO + landusef(i,ivgtyp(i,j),j)=1. + +!tgs - compute blended sea ice/water skin temperature + if(flag_sst.eq.1) then + tsk(i,j) = xice(i,j)*(min(seaice_threshold,tsk(i,j))) & + +(1-xice(i,j))*sst(i,j) + else + tsk(i,j) = xice(i,j)*(min(seaice_threshold,tsk(i,j))) & + +(1-xice(i,j))*tsk(i,j) + endif + tsk_old(i,j) = tsk(i,j) + + isltyp(i,j) = 16 + soilcat(i,j)=isltyp(i,j) + DO loop=1,num_soil_top_cat + soilctop(i,loop,j)=0 + END DO + DO loop=1,num_soil_bot_cat + soilcbot(i,loop,j)=0 + END DO + soilctop(i,isltyp(i,j),j)=1. + soilcbot(i,isltyp(i,j),j)=1. + + total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers + tslb(i,1,j) = tsk(i,j) + tslb(i,num_soil_layers,j) = tmn(i,j) + DO loop = 2,num_soil_layers-1 + mid_point_depth=(total_depth/num_soil_layers)/4. + & + (loop-2)*(total_depth/num_soil_layers) + tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + & + mid_point_depth*tmn(i,j) ) / total_depth + END DO + + DO loop=1,num_soil_layers + smois(i,loop,j) = 1.0 + sh2o(i,loop,j) = 0.0 + END DO + ELSE IF ( xice(i,j) .LT. xice_threshold ) THEN + xice(i,j) = 0. + END IF + END DO + END DO + IF ( num_seaice_changes .GT. 0 ) THEN + WRITE ( message , FMT='(A,I6)' ) & + 'Total post number of sea ice location changes (water to land) = ', num_seaice_changes + CALL wrf_debug ( 0 , message ) + END IF + + END SELECT fix_seaice END SUBROUTINE adjust_for_seaice_post @@ -356,16 +485,22 @@ change_land = 0 IF ( dominant_index .EQ. iswater ) THEN if(landmask(i,j).gt.lwthresh) then !print *,'changing to water at point ',i,j -!print '(24(i3,1x))',1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16, 17,18,19,20,21, 22, 23,24 -!print '(24(i3,1x))',nint(landuse_frac(i,:,j)*100) +!WRITE ( num_cat_count , FMT = '(I3)' ) num_veg_cat +!WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) ints(1:num_veg_cat) +!CALL wrf_debug(1,message) +!WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) nint(landuse_frac(i,:,j)*100) +!CALL wrf_debug(1,message) change_water=change_water+1 endif landmask(i,j) = 0 ELSE IF ( dominant_index .NE. iswater ) THEN if(landmask(i,j).lt.lwthresh) then !print *,'changing to land at point ',i,j -!print '(24(i3,1x))',1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16, 17,18,19,20,21, 22, 23,24 -!print '(24(i3,1x))',nint(landuse_frac(i,:,j)*100) +!WRITE ( num_cat_count , FMT = '(I3)' ) num_veg_cat +!WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) ints(1:num_veg_cat) +!CALL wrf_debug(1,message) +!WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) nint(landuse_frac(i,:,j)*100) +!CALL wrf_debug(1,message) change_land=change_land+1 endif landmask(i,j) = 1 @@ -393,11 +528,11 @@ endif WRITE ( message , FMT = '(A,I4,I4)' ) & 'based on landuse, changing soil to land at point ',i,j CALL wrf_debug(1,message) - WRITE ( message , FMT = '(16(i3,1x))' ) & - 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16 + WRITE ( num_cat_count , FMT = '(I3)' ) num_soil_top_cat + WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) ints(1:num_soil_top_cat) CALL wrf_debug(1,message) - WRITE ( message , FMT = '(16(i3,1x))' ) & - nint(soil_top_cat(i,:,j)*100) + WRITE ( message , FMT = '('//num_cat_count//'(i3,1x))' ) & + nint(soil_top_cat(i,ints(1:num_soil_top_cat),j)*100) CALL wrf_debug(1,message) dominant_index = 8 END IF @@ -2012,235 +2147,6 @@ MODULE module_soil_pre CONTAINS - SUBROUTINE adjust_for_seaice_pre ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , & - xland , landusef , isltyp , soilcat , soilctop , & - soilcbot , tmn , & - seaice_threshold , & - fractional_seaice, & - num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & - iswater , isice , & - scheme , & - ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte ) - - IMPLICIT NONE - - INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte , & - iswater , isice - INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme - - REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef - REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop - REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot - INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & - vegcat, xland , soilcat , tmn - REAL , INTENT(IN) :: seaice_threshold - - INTEGER :: i , j , num_seaice_changes , loop - CHARACTER (LEN=132) :: message - - - integer, intent(in) :: fractional_seaice - real :: xice_threshold - - IF ( FRACTIONAL_SEAICE == 0 ) THEN - xice_threshold = 0.5 - ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN - CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1") - xice_threshold = 0.02 - ENDIF - - fix_seaice : SELECT CASE ( scheme ) - - CASE ( SLABSCHEME ) - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( xice(i,j) .GT. 200.0 ) THEN - xice(i,j) = 0. - num_seaice_changes = num_seaice_changes + 1 - END IF - END DO - END DO - IF ( num_seaice_changes .GT. 0 ) THEN - WRITE ( message , FMT='(A,I6)' ) & - 'Total pre number of sea ice locations removed (due to FLAG values) = ', & - num_seaice_changes - CALL wrf_debug ( 0 , message ) - END IF - num_seaice_changes = 0 - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( ( xice(i,j) .GE. xice_threshold ) .OR. & - ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN - IF ( FRACTIONAL_SEAICE == 0 ) THEN - xice(i,j) = 1.0 - ENDIF - num_seaice_changes = num_seaice_changes + 1 - tmn(i,j) = 271.4 - vegcat(i,j)=isice - lu_index(i,j)=ivgtyp(i,j) - landmask(i,j)=1. - xland(i,j)=1. - DO loop=1,num_veg_cat - landusef(i,loop,j)=0. - END DO - landusef(i,ivgtyp(i,j),j)=1. - - isltyp(i,j) = 16 - soilcat(i,j)=isltyp(i,j) - DO loop=1,num_soil_top_cat - soilctop(i,loop,j)=0 - END DO - DO loop=1,num_soil_bot_cat - soilcbot(i,loop,j)=0 - END DO - soilctop(i,isltyp(i,j),j)=1. - soilcbot(i,isltyp(i,j),j)=1. - ELSE - xice(i,j) = 0.0 - END IF - END DO - END DO - IF ( num_seaice_changes .GT. 0 ) THEN - WRITE ( message , FMT='(A,I6)' ) & - 'Total pre number of sea ice location changes (water to land) = ', num_seaice_changes - CALL wrf_debug ( 0 , message ) - END IF - - CASE ( LSMSCHEME ) - CASE ( RUCLSMSCHEME ) - - END SELECT fix_seaice - - END SUBROUTINE adjust_for_seaice_pre - - SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk , ivgtyp , vegcat , lu_index , & - xland , landusef , isltyp , soilcat , soilctop , & - soilcbot , tmn , & - tslb , smois , sh2o , & - seaice_threshold , & - fractional_seaice, & - num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & - num_soil_layers , & - iswater , isice , & - scheme , & - ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte ) - - IMPLICIT NONE - - INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte , & - iswater , isice - INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat , scheme - INTEGER , INTENT(IN) :: num_soil_layers - - REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landusef - REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(INOUT):: soilctop - REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(INOUT):: soilcbot - REAL , DIMENSION(ims:ime,1:num_soil_layers,jms:jme) , INTENT(INOUT):: tslb , smois , sh2o - INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: landmask , xice , tsk , lu_index , & - vegcat, xland , soilcat , tmn - REAL , INTENT(IN) :: seaice_threshold - REAL :: total_depth , mid_point_depth - - INTEGER :: i , j , num_seaice_changes , loop - CHARACTER (LEN=132) :: message - - integer, intent(in) :: fractional_seaice - real :: xice_threshold - IF ( FRACTIONAL_SEAICE == 0 ) THEN - xice_threshold = 0.5 - ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN - CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1") - xice_threshold = 0.02 - ENDIF - fix_seaice : SELECT CASE ( scheme ) - - CASE ( SLABSCHEME ) - -!SBAO - CASE ( LSMSCHEME, GFDLSLAB ) - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( xice(i,j) .GT. 200.0 ) THEN - xice(i,j) = 0. - num_seaice_changes = num_seaice_changes + 1 - END IF - END DO - END DO - IF ( num_seaice_changes .GT. 0 ) THEN - WRITE ( message , FMT='(A,I6)' ) & - 'Total post number of sea ice locations removed (due to FLAG values) = ', & - num_seaice_changes - CALL wrf_debug ( 0 , message ) - END IF - num_seaice_changes = 0 - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( ( xice(i,j) .GE. xice_threshold ) .OR. & - ( ( landmask(i,j) .LT. 0.5 ) .AND. ( tsk(i,j) .LT. seaice_threshold ) ) ) THEN - IF ( FRACTIONAL_SEAICE == 0 ) THEN - xice(i,j) = 1.0 - ENDIF - num_seaice_changes = num_seaice_changes + 1 - tmn(i,j) = 271.16 - vegcat(i,j)=isice - lu_index(i,j)=ivgtyp(i,j) - landmask(i,j)=1. - xland(i,j)=1. - DO loop=1,num_veg_cat - landusef(i,loop,j)=0. - END DO - landusef(i,ivgtyp(i,j),j)=1. - - isltyp(i,j) = 16 - soilcat(i,j)=isltyp(i,j) - DO loop=1,num_soil_top_cat - soilctop(i,loop,j)=0 - END DO - DO loop=1,num_soil_bot_cat - soilcbot(i,loop,j)=0 - END DO - soilctop(i,isltyp(i,j),j)=1. - soilcbot(i,isltyp(i,j),j)=1. - - total_depth = 3. ! ice is 3 m deep, num_soil_layers equispaced layers - DO loop = 1,num_soil_layers - mid_point_depth=(total_depth/num_soil_layers)/2. + & - (loop-1)*(total_depth/num_soil_layers) - tslb(i,loop,j) = ( (total_depth-mid_point_depth)*tsk(i,j) + & - mid_point_depth*tmn(i,j) ) / total_depth - END DO - - DO loop=1,num_soil_layers - smois(i,loop,j) = 1.0 - sh2o(i,loop,j) = 0.0 - END DO - ELSE - xice(i,j) = 0.0 - END IF - END DO - END DO - IF ( num_seaice_changes .GT. 0 ) THEN - WRITE ( message , FMT='(A,I6)' ) & - 'Total post number of sea ice location changes (water to land) = ', num_seaice_changes - CALL wrf_debug ( 0 , message ) - END IF - - CASE ( RUCLSMSCHEME ) - - END SELECT fix_seaice - - END SUBROUTINE adjust_for_seaice_post - SUBROUTINE process_percent_cat_new ( landmask , & landuse_frac , soil_top_cat , soil_bot_cat , & isltyp , ivgtyp , & @@ -2374,12 +2280,12 @@ endif WRITE ( message , FMT = '(A,I4,I4)' ) & 'based on landuse, changing soil to land at point ',i,j CALL wrf_debug(1,message) - WRITE ( message , FMT = '(16(i3,1x))' ) & - 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16 - CALL wrf_debug(1,message) - WRITE ( message , FMT = '(16(i3,1x))' ) & - nint(soil_top_cat(i,:,j)*100) - CALL wrf_debug(1,message) +!atec WRITE ( message , FMT = '(16(i3,1x))' ) & +!atec 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,11,12, 13, 14, 15, 16 +!atec CALL wrf_debug(1,message) +!atec WRITE ( message , FMT = '(16(i3,1x))' ) & +!atec nint(soil_top_cat(i,:,j)*100) +!atec CALL wrf_debug(1,message) dominant_index = 8 END IF ELSE diff --git a/wrfv2_fire/share/output_wrf.F b/wrfv2_fire/share/output_wrf.F index 7e569090..8eef10e8 100644 --- a/wrfv2_fire/share/output_wrf.F +++ b/wrfv2_fire/share/output_wrf.F @@ -5,6 +5,7 @@ USE module_wrf_error USE module_io_wrf USE module_domain + USE module_domain_type, ONLY : fieldlist USE module_state_description USE module_configure ! USE module_date_time @@ -23,6 +24,10 @@ ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe + TYPE( fieldlist ), POINTER :: p + + INTEGER newswitch, itrace + INTEGER , DIMENSION(3) :: domain_start , domain_end INTEGER , DIMENSION(3) :: memory_start , memory_end INTEGER , DIMENSION(3) :: patch_start , patch_end @@ -63,6 +68,7 @@ INTEGER, EXTERNAL :: use_package INTEGER p_hr, p_min, p_sec, p_ms + CHARACTER*80 dname, memord CHARACTER*256 message CHARACTER*80 fname CHARACTER*80 char_junk @@ -89,54 +95,54 @@ ! io_form is used to determine if multi-file I/O is enabled and to ! control writing of format-specific time-independent metadata - IF ( switch .EQ. model_input_only ) THEN + IF ( switch .EQ. input_only ) THEN CALL nl_get_io_form_input( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input1_only ) THEN + ELSE IF ( switch .EQ. auxinput1_only ) THEN CALL nl_get_io_form_auxinput1( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input2_only ) THEN + ELSE IF ( switch .EQ. auxinput2_only ) THEN CALL nl_get_io_form_auxinput2( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input3_only ) THEN + ELSE IF ( switch .EQ. auxinput3_only ) THEN CALL nl_get_io_form_auxinput3( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input4_only ) THEN + ELSE IF ( switch .EQ. auxinput4_only ) THEN CALL nl_get_io_form_auxinput4( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input5_only ) THEN + ELSE IF ( switch .EQ. auxinput5_only ) THEN CALL nl_get_io_form_auxinput5( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input6_only ) THEN + ELSE IF ( switch .EQ. auxinput6_only ) THEN CALL nl_get_io_form_auxinput6( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input7_only ) THEN + ELSE IF ( switch .EQ. auxinput7_only ) THEN CALL nl_get_io_form_auxinput7( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input8_only ) THEN + ELSE IF ( switch .EQ. auxinput8_only ) THEN CALL nl_get_io_form_auxinput8( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input9_only ) THEN - CALL nl_get_io_form_sgfdda( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input10_only ) THEN - CALL nl_get_io_form_gfdda( 1, io_form ) - ELSE IF ( switch .EQ. aux_model_input11_only ) THEN + ELSE IF ( switch .EQ. auxinput9_only ) THEN + CALL nl_get_io_form_auxinput9( 1, io_form ) + ELSE IF ( switch .EQ. auxinput10_only ) THEN + CALL nl_get_io_form_auxinput10( 1, io_form ) + ELSE IF ( switch .EQ. auxinput11_only ) THEN CALL nl_get_io_form_auxinput11( 1, io_form ) ELSE IF ( switch .EQ. history_only ) THEN CALL nl_get_io_form_history( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist1_only ) THEN + ELSE IF ( switch .EQ. auxhist1_only ) THEN CALL nl_get_io_form_auxhist1( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist2_only ) THEN + ELSE IF ( switch .EQ. auxhist2_only ) THEN CALL nl_get_io_form_auxhist2( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist3_only ) THEN + ELSE IF ( switch .EQ. auxhist3_only ) THEN CALL nl_get_io_form_auxhist3( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist4_only ) THEN + ELSE IF ( switch .EQ. auxhist4_only ) THEN CALL nl_get_io_form_auxhist4( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist5_only ) THEN + ELSE IF ( switch .EQ. auxhist5_only ) THEN CALL nl_get_io_form_auxhist5( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist6_only ) THEN + ELSE IF ( switch .EQ. auxhist6_only ) THEN CALL nl_get_io_form_auxhist6( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist7_only ) THEN + ELSE IF ( switch .EQ. auxhist7_only ) THEN CALL nl_get_io_form_auxhist7( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist8_only ) THEN + ELSE IF ( switch .EQ. auxhist8_only ) THEN CALL nl_get_io_form_auxhist8( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist9_only ) THEN + ELSE IF ( switch .EQ. auxhist9_only ) THEN CALL nl_get_io_form_auxhist9( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist10_only ) THEN + ELSE IF ( switch .EQ. auxhist10_only ) THEN CALL nl_get_io_form_auxhist10( 1, io_form ) - ELSE IF ( switch .EQ. aux_hist11_only ) THEN + ELSE IF ( switch .EQ. auxhist11_only ) THEN CALL nl_get_io_form_auxhist11( 1, io_form ) ELSE IF ( switch .EQ. restart_only ) THEN @@ -187,11 +193,11 @@ CALL nl_get_diff_6th_opt ( grid%id , diff_6th_opt ) CALL nl_get_diff_6th_factor ( grid%id , diff_6th_factor ) CALL nl_get_grid_fdda ( grid%id , grid_fdda ) - CALL nl_get_gfdda_end_h( grid%id , gfdda_end_h ) - CALL nl_get_gfdda_interval_m ( grid%id , gfdda_interval_m ) + CALL nl_get_auxinput10_end_h( grid%id , gfdda_end_h ) + CALL nl_get_auxinput10_interval_m ( grid%id , gfdda_interval_m ) CALL nl_get_grid_sfdda ( grid%id , grid_sfdda ) - CALL nl_get_sgfdda_end_h( grid%id , sgfdda_end_h ) - CALL nl_get_sgfdda_interval_m ( grid%id , sgfdda_interval_m ) + CALL nl_get_auxinput9_end_h( grid%id , sgfdda_end_h ) + CALL nl_get_auxinput9_interval_m ( grid%id , sgfdda_interval_m ) IF ( grid_fdda == 1 ) THEN CALL nl_get_fgdt ( grid%id , fgdt ) @@ -287,7 +293,7 @@ start_year,start_month,start_day,start_hour,start_minute,start_second #endif CALL wrf_put_dom_ti_char ( fid , 'START_DATE', TRIM(start_date) , ierr ) - IF ( switch .EQ. model_input_only) THEN + IF ( switch .EQ. input_only) THEN CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(start_date) , ierr ) ELSE IF ( ( switch .EQ. restart_only ) .OR. ( switch .EQ. history_only ) ) THEN CALL nl_get_simulation_start_year ( 1, simulation_start_year ) @@ -574,7 +580,7 @@ CALL wrf_put_dom_ti_real ( fid , 'POLE_LAT', config_flags%pole_lat, 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'POLE_LON', config_flags%pole_lon, 1 , ierr ) #endif - IF ( switch .NE. boundary_only .AND. switch .NE. aux_model_input9_only .AND. switch .NE. aux_model_input10_only ) THEN + IF ( switch .NE. boundary_only .AND. switch .NE. auxinput9_only .AND. switch .NE. auxinput10_only ) THEN #ifdef PLANET ! When writing to restart files, use the values of the instantaneous ! time for determining the values of JULYR, JULDAY, and GMT. If the @@ -599,9 +605,7 @@ #endif ENDIF #if (NMM_CORE == 1) - write(0,*) 'MMINLU would be: ', TRIM(MMINLU) ! MMINLU='USGS' - write(0,*) 'MMINLU now: ', TRIM(MMINLU) #endif CALL wrf_put_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , ierr ) IF(MMINLU(1:1) .EQ. " ")THEN @@ -617,9 +621,14 @@ CALL wrf_put_dom_ti_integer ( fid , 'ISURBAN' , config_flags%isurban , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , ierr ) ! added these fields for restarting of moving nests, JM +!For HWRF: zhang +#ifdef HWRF + CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , grid%i_parent_start , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , grid%j_parent_start , 1 , ierr ) +#else CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , config_flags%i_parent_start , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , config_flags%j_parent_start , 1 , ierr ) - +#endif IF ( switch .EQ. boundary_only ) THEN CALL WRFU_TimeIntervalSet( bdy_increment, S=NINT(config_flags%bdyfrq),rc=rc) @@ -640,19 +649,20 @@ #if (EM_CORE == 1) save_topo_orig = grid%save_topo_from_real +! todo jm IF ( ( switch .EQ. history_only ) .OR. & - ( switch .EQ. aux_hist1_only ) .OR. & - ( switch .EQ. aux_hist2_only ) .OR. & - ( switch .EQ. aux_hist3_only ) .OR. & - ( switch .EQ. aux_hist4_only ) .OR. & - ( switch .EQ. aux_hist5_only ) .OR. & - ( switch .EQ. aux_hist6_only ) .OR. & - ( switch .EQ. aux_hist7_only ) .OR. & - ( switch .EQ. aux_hist8_only ) .OR. & - ( switch .EQ. aux_hist9_only ) .OR. & - ( switch .EQ. aux_hist10_only ) .OR. & - ( switch .EQ. aux_hist11_only ) .OR. & - ( (switch .EQ. model_input_only) .AND. (program_name(1:7) .NE. 'REAL_EM') ) .OR. & + ( switch .EQ. auxhist1_only ) .OR. & + ( switch .EQ. auxhist2_only ) .OR. & + ( switch .EQ. auxhist3_only ) .OR. & + ( switch .EQ. auxhist4_only ) .OR. & + ( switch .EQ. auxhist5_only ) .OR. & + ( switch .EQ. auxhist6_only ) .OR. & + ( switch .EQ. auxhist7_only ) .OR. & + ( switch .EQ. auxhist8_only ) .OR. & + ( switch .EQ. auxhist9_only ) .OR. & + ( switch .EQ. auxhist10_only ) .OR. & + ( switch .EQ. auxhist11_only ) .OR. & + ( (switch .EQ. input_only) .AND. (program_name(1:7) .NE. 'REAL_EM') ) .OR. & ( switch .EQ. restart_only ) ) THEN ! This flag sets the switch which defines the topography as the original @@ -669,101 +679,513 @@ CALL nl_get_adjust_output_times( grid%id, adjust ) current_date_save = current_date -#if 1 - IF ( switch .EQ. model_input_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_inputout.inc' ) - CALL wrf_inputout( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input1_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput1out.inc' ) - CALL wrf_auxinput1out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input2_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput2out.inc' ) - CALL wrf_auxinput2out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input3_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput3out.inc' ) - CALL wrf_auxinput3out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input4_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput4out.inc' ) - CALL wrf_auxinput4out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input5_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput5out.inc' ) - CALL wrf_auxinput5out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input6_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput6out.inc' ) - CALL wrf_auxinput6out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input7_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput7out.inc' ) - CALL wrf_auxinput7out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input8_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput8out.inc' ) - CALL wrf_auxinput8out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input9_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput9out.inc' ) - CALL wrf_auxinput9out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input10_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput10out.inc' ) - CALL wrf_auxinput10out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_model_input11_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput11out.inc' ) - CALL wrf_auxinput11out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. history_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_histout.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( HISTORY_ALARM ), currentTime, startTime, current_date ) - CALL wrf_histout( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist1_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist1out' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST1_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist1out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist2_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist2out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST2_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist2out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist3_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist3out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST3_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist3out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist4_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist4out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST4_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist4out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist5_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist5out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST5_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist5out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist6_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist6out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST6_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist6out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist7_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist7out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST7_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist7out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist8_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist8out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST8_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist8out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist9_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist9out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST9_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist9out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist10_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist10out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST10_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist10out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. aux_hist11_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist11out.inc' ) - IF ( adjust ) CALL adjust_io_timestr( grid%io_intervals( AUXHIST11_ALARM ), currentTime, startTime, current_date ) - CALL wrf_auxhist11out( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. restart_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_restartout.inc' ) - CALL wrf_restartout( fid , grid , config_flags, switch, dryrun, ierr ) - ELSE IF ( switch .EQ. boundary_only ) THEN - CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_bdyout.inc' ) - CALL wrf_bdyout( fid , grid , config_flags, switch, dryrun, ierr ) + + IF ( (first_input .LE. switch .AND. switch .LE. last_input) .OR. & + (first_history .LE. switch .AND. switch .LE. last_history ) .OR. & + switch .EQ. restart_only ) THEN + newswitch = switch + p => grid%head_statevars%next + DO WHILE ( ASSOCIATED( p ) ) + IF ((p%Restart.AND.switch.EQ.restart_only).OR.on_stream(p%streams,newswitch)) THEN + IF ( p%Ndim .EQ. 0 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%DataName) , & ! Data Name + p%rfield_0d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + '0' , & ! MemoryOrder + '' , & ! Stagger + '' , & ! Dimname 1 + '' , & ! Dimname 2 + '' , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 0d real ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%DataName) , & ! Data Name + p%dfield_0d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + '0' , & ! MemoryOrder + '' , & ! Stagger + '' , & ! Dimname 1 + '' , & ! Dimname 2 + '' , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 0d double ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%DataName) , & ! Data Name + p%ifield_0d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + '0' , & ! MemoryOrder + '' , & ! Stagger + '' , & ! Dimname 1 + '' , & ! Dimname 2 + '' , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 0d integer ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ELSE IF ( p%Type .EQ. 'l' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%DataName) , & ! Data Name + p%lfield_0d , & ! Field + WRF_LOGICAL , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + '0' , & ! MemoryOrder + '' , & ! Stagger + '' , & ! Dimname 1 + '' , & ! Dimname 2 + '' , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 0d logical ' // TRIM(p%VarName) , & ! Debug message + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + 1 , 1 , 1 , 1 , 1 , 1 , & + ierr ) + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 1 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_1d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 1d real ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_1d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 1d double ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_1d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 1d integer ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'l' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%lfield_1d , & ! Field + WRF_LOGICAL , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 1d logical ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 2 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_2d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 2d real ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_2d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 2d double ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_2d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 2d integer ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'l' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%lfield_2d , & ! Field + WRF_LOGICAL , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 2d logical ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 3 ) THEN + IF ( in_use_for_config(grid%id,TRIM(p%VarName)) ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN + dname = p%DataName + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%rfield_3d , & ! Field + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 3d real ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%dfield_3d , & ! Field + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 3d double ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_write_field ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(dname) , & ! Data Name + p%ifield_3d , & ! Field + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%Description) , & ! Desc + TRIM(p%Units) , & ! Units + __FILE__ // ' writing 3d integer ' // TRIM(p%VarName) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) +! NOTE no io on logical arrays greater than 2d + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 4 ) THEN + IF (switch.EQ.restart_only.OR.p%Ntl/100.EQ.mod(p%Ntl,100)) THEN +! Use a different write routine, wrf_ext_write_field_arr, and pass in the +! tracer indeces so that p%rfield_4d can be passsed in without arguments, +! avoiding the possiblity of a copy-in/copy-out problem for some compilers. +! Fortran is still a four letter word. JM 20091208 + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + dname = p%dname_table( grid%id, itrace ) + IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) + memord = p%MemoryOrder + IF ( p%Type .EQ. 'r' ) THEN + CALL wrf_ext_write_field_arr ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%dname_table( grid%id, itrace )) , & ! Data Name + p%rfield_4d , & ! Field + itrace, 1, 1, 1 , & ! see comment above + 1, 1, 1 , & ! see comment above + RWORDSIZE , & + WRF_FLOAT , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%desc_table( grid%id, itrace)) , & ! Desc + TRIM(p%units_table( grid%id, itrace)) , & ! Units + __FILE__ // ' writing 4d real ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'd' ) THEN + CALL wrf_ext_write_field_arr ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%dname_table( grid%id, itrace )) , & ! Data Name + p%dfield_4d , & ! Field + itrace, 1, 1, 1 , & ! see comment above + 1, 1, 1 , & ! see comment above + DWORDSIZE , & + WRF_DOUBLE , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%desc_table( grid%id, itrace)) , & ! Desc + TRIM(p%units_table( grid%id, itrace)) , & ! Units + __FILE__ // ' writing 4d double ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ELSE IF ( p%Type .EQ. 'i' ) THEN + CALL wrf_ext_write_field_arr ( & + fid , & ! DataHandle + current_date(1:19) , & ! DateStr + TRIM(p%dname_table( grid%id, itrace )) , & ! Data Name + p%ifield_4d , & ! Field + itrace, 1, 1, 1 , & ! see comment above + 1, 1, 1 , & ! see comment above + IWORDSIZE , & + WRF_INTEGER , & ! FieldType + grid%communicator , & ! Comm + grid%iocommunicator , & ! Comm + grid%domdesc , & ! Comm + grid%bdy_mask , & ! bdy_mask + dryrun , & ! flag + TRIM(memord) , & ! MemoryOrder + TRIM(p%Stagger) , & ! Stagger + TRIM(p%dimname1) , & ! Dimname 1 + TRIM(p%dimname2) , & ! Dimname 2 + TRIM(p%dimname3) , & ! Dimname 3 + TRIM(p%desc_table( grid%id, itrace)) , & ! Desc + TRIM(p%units_table( grid%id, itrace)) , & ! Units + __FILE__ // ' writing 4d integer ' // TRIM(p%dname_table(grid%id,itrace)) , & ! Debug message + p%sd1 , p%ed1 , p%sd2 , p%ed2 , p%sd3 , p%ed3 , & + p%sm1 , p%em1 , p%sm2 , p%em2 , p%sm3 , p%em3 , & + p%sp1 , p%ep1 , p%sp2 , p%ep2 , p%sp3 , p%ep3 , & + ierr ) + ENDIF + ENDDO ! loop over tracers + ENDIF + ENDIF ! if-then-else over dim + ENDIF + p => p%next + ENDDO + ELSE + IF ( switch .EQ. boundary_only ) THEN + CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_bdyout.inc' ) + CALL wrf_bdyout( fid , grid , config_flags, switch, dryrun, ierr ) + ENDIF ENDIF -#else - CALL wrf_message ( "ALL I/O DISABLED IN share/module_io_wrf.F") -#endif current_date = current_date_save #if (EM_CORE == 1) @@ -781,3 +1203,21 @@ RETURN END SUBROUTINE output_wrf + + SUBROUTINE traverse_statevars_debug (s,l) + USE module_domain + IMPLICIT NONE + character*(*)s + integer l + TYPE( fieldlist ), POINTER :: p + p => head_grid%head_statevars%next +! write(0,*)'traverse_statevars_debug called ',TRIM(s),' ',l + DO WHILE ( ASSOCIATED( p ) ) + if ( TRIM(p%VarName) .EQ. 'store_rand' .OR. TRIM(p%VarName) .EQ. 'STORE_RAND' ) then +! write(0,*)'traverse_statevars_debug sees ',TRIM(p%VarName),' >',p%Type,'<' + endif + p => p%next + ENDDO + RETURN + END SUBROUTINE traverse_statevars_debug + diff --git a/wrfv2_fire/share/set_timekeeping.F b/wrfv2_fire/share/set_timekeeping.F dissimilarity index 75% index 749160a8..061b0bd7 100644 --- a/wrfv2_fire/share/set_timekeeping.F +++ b/wrfv2_fire/share/set_timekeeping.F @@ -1,2183 +1,580 @@ -SUBROUTINE Setup_Timekeeping ( grid ) - USE module_domain - USE module_configure - USE module_utility - IMPLICIT NONE - TYPE(domain), POINTER :: grid -! Local - TYPE(WRFU_TimeInterval) :: begin_time, end_time, zero_time, one_minute, one_hour, padding_interval - TYPE(WRFU_TimeInterval) :: interval, run_length, dfl_length - TYPE(WRFU_Time) :: startTime, stopTime, initialTime - TYPE(WRFU_TimeInterval) :: stepTime - TYPE(WRFU_TimeInterval) :: tmp_step - INTEGER :: start_year,start_month,start_day,start_hour,start_minute,start_second - INTEGER :: end_year,end_month,end_day,end_hour,end_minute,end_second - INTEGER :: vortex_interval -#if (EM_CORE == 1) - INTEGER :: dfi_fwdstop_year,dfi_fwdstop_month,dfi_fwdstop_day,dfi_fwdstop_hour,dfi_fwdstop_minute,dfi_fwdstop_second - INTEGER :: dfi_bckstop_year,dfi_bckstop_month,dfi_bckstop_day,dfi_bckstop_hour,dfi_bckstop_minute,dfi_bckstop_second -#endif - - INTEGER :: history_interval , restart_interval , & - history_interval_d, restart_interval_d, & - history_interval_h, restart_interval_h, & - history_interval_m, restart_interval_m, & - history_interval_s, restart_interval_s - - INTEGER :: auxhist1_interval , auxhist2_interval , auxhist3_interval , & - auxhist1_interval_d, auxhist2_interval_d, auxhist3_interval_d, & - auxhist1_interval_h, auxhist2_interval_h, auxhist3_interval_h, & - auxhist1_interval_m, auxhist2_interval_m, auxhist3_interval_m, & - auxhist1_interval_s, auxhist2_interval_s, auxhist3_interval_s - - INTEGER :: auxhist4_interval , auxhist5_interval, & - auxhist4_interval_d, auxhist5_interval_d, & - auxhist4_interval_h, auxhist5_interval_h, & - auxhist4_interval_m, auxhist5_interval_m, & - auxhist4_interval_s, auxhist5_interval_s - - INTEGER :: auxhist6_interval , auxhist7_interval , auxhist8_interval , & - auxhist6_interval_d, auxhist7_interval_d, auxhist8_interval_d, & - auxhist6_interval_h, auxhist7_interval_h, auxhist8_interval_h, & - auxhist6_interval_m, auxhist7_interval_m, auxhist8_interval_m, & - auxhist6_interval_s, auxhist7_interval_s, auxhist8_interval_s - - INTEGER :: auxhist9_interval , auxhist10_interval , auxhist11_interval , & - auxhist9_interval_d, auxhist10_interval_d, auxhist11_interval_d, & - auxhist9_interval_h, auxhist10_interval_h, auxhist11_interval_h, & - auxhist9_interval_m, auxhist10_interval_m, auxhist11_interval_m, & - auxhist9_interval_s, auxhist10_interval_s, auxhist11_interval_s - - INTEGER :: auxinput1_interval , auxinput2_interval , auxinput3_interval , & - auxinput1_interval_d, auxinput2_interval_d, auxinput3_interval_d, & - auxinput1_interval_h, auxinput2_interval_h, auxinput3_interval_h, & - auxinput1_interval_m, auxinput2_interval_m, auxinput3_interval_m, & - auxinput1_interval_s, auxinput2_interval_s, auxinput3_interval_s - - INTEGER :: auxinput4_interval , auxinput5_interval , & - auxinput4_interval_d, auxinput5_interval_d, & - auxinput4_interval_h, auxinput5_interval_h, & - auxinput4_interval_m, auxinput5_interval_m, & - auxinput4_interval_s, auxinput5_interval_s - - INTEGER :: auxinput6_interval , auxinput7_interval , auxinput8_interval , & - auxinput6_interval_d, auxinput7_interval_d, auxinput8_interval_d, & - auxinput6_interval_h, auxinput7_interval_h, auxinput8_interval_h, & - auxinput6_interval_m, auxinput7_interval_m, auxinput8_interval_m, & - auxinput6_interval_s, auxinput7_interval_s, auxinput8_interval_s - - INTEGER :: sgfdda_interval , gfdda_interval , auxinput11_interval , & - sgfdda_interval_d, gfdda_interval_d, auxinput11_interval_d, & - sgfdda_interval_h, gfdda_interval_h, auxinput11_interval_h, & - sgfdda_interval_m, gfdda_interval_m, auxinput11_interval_m, & - sgfdda_interval_s, gfdda_interval_s, auxinput11_interval_s - - INTEGER :: history_begin , restart_begin , & - history_begin_y, restart_begin_y, & - history_begin_d, restart_begin_d, & - history_begin_h, restart_begin_h, & - history_begin_m, restart_begin_m, & - history_begin_s, restart_begin_s - - INTEGER :: auxhist1_begin , auxhist2_begin , auxhist3_begin , & - auxhist1_begin_y, auxhist2_begin_y, auxhist3_begin_y, & - auxhist1_begin_d, auxhist2_begin_d, auxhist3_begin_d, & - auxhist1_begin_h, auxhist2_begin_h, auxhist3_begin_h, & - auxhist1_begin_m, auxhist2_begin_m, auxhist3_begin_m, & - auxhist1_begin_s, auxhist2_begin_s, auxhist3_begin_s - - INTEGER :: auxhist4_begin , auxhist5_begin, & - auxhist4_begin_y, auxhist5_begin_y, & - auxhist4_begin_d, auxhist5_begin_d, & - auxhist4_begin_h, auxhist5_begin_h, & - auxhist4_begin_m, auxhist5_begin_m, & - auxhist4_begin_s, auxhist5_begin_s - - INTEGER :: auxhist6_begin , auxhist7_begin , auxhist8_begin , & - auxhist6_begin_y, auxhist7_begin_y, auxhist8_begin_y, & - auxhist6_begin_d, auxhist7_begin_d, auxhist8_begin_d, & - auxhist6_begin_h, auxhist7_begin_h, auxhist8_begin_h, & - auxhist6_begin_m, auxhist7_begin_m, auxhist8_begin_m, & - auxhist6_begin_s, auxhist7_begin_s, auxhist8_begin_s - - INTEGER :: auxhist9_begin , auxhist10_begin , auxhist11_begin , & - auxhist9_begin_y, auxhist10_begin_y, auxhist11_begin_y, & - auxhist9_begin_d, auxhist10_begin_d, auxhist11_begin_d, & - auxhist9_begin_h, auxhist10_begin_h, auxhist11_begin_h, & - auxhist9_begin_m, auxhist10_begin_m, auxhist11_begin_m, & - auxhist9_begin_s, auxhist10_begin_s, auxhist11_begin_s - - INTEGER :: inputout_begin , inputout_end, inputout_interval , & - inputout_begin_y, inputout_end_y, inputout_interval_y , & - inputout_begin_d, inputout_end_d, inputout_interval_d , & - inputout_begin_h, inputout_end_h, inputout_interval_h , & - inputout_begin_m, inputout_end_m, inputout_interval_m , & - inputout_begin_s, inputout_end_s, inputout_interval_s - - INTEGER :: auxinput1_begin , auxinput2_begin , auxinput3_begin , & - auxinput1_begin_y, auxinput2_begin_y, auxinput3_begin_y, & - auxinput1_begin_d, auxinput2_begin_d, auxinput3_begin_d, & - auxinput1_begin_h, auxinput2_begin_h, auxinput3_begin_h, & - auxinput1_begin_m, auxinput2_begin_m, auxinput3_begin_m, & - auxinput1_begin_s, auxinput2_begin_s, auxinput3_begin_s - - INTEGER :: auxinput4_begin , auxinput5_begin , & - auxinput4_begin_y, auxinput5_begin_y, & - auxinput4_begin_d, auxinput5_begin_d, & - auxinput4_begin_h, auxinput5_begin_h, & - auxinput4_begin_m, auxinput5_begin_m, & - auxinput4_begin_s, auxinput5_begin_s - - INTEGER :: auxinput6_begin , auxinput7_begin , auxinput8_begin , & - auxinput6_begin_y, auxinput7_begin_y, auxinput8_begin_y, & - auxinput6_begin_d, auxinput7_begin_d, auxinput8_begin_d, & - auxinput6_begin_h, auxinput7_begin_h, auxinput8_begin_h, & - auxinput6_begin_m, auxinput7_begin_m, auxinput8_begin_m, & - auxinput6_begin_s, auxinput7_begin_s, auxinput8_begin_s - - INTEGER :: sgfdda_begin , gfdda_begin , auxinput11_begin , & - sgfdda_begin_y, gfdda_begin_y, auxinput11_begin_y, & - sgfdda_begin_d, gfdda_begin_d, auxinput11_begin_d, & - sgfdda_begin_h, gfdda_begin_h, auxinput11_begin_h, & - sgfdda_begin_m, gfdda_begin_m, auxinput11_begin_m, & - sgfdda_begin_s, gfdda_begin_s, auxinput11_begin_s - - INTEGER :: history_end , restart_end , & - history_end_y, restart_end_y, & - history_end_d, restart_end_d, & - history_end_h, restart_end_h, & - history_end_m, restart_end_m, & - history_end_s, restart_end_s - - INTEGER :: auxhist1_end , auxhist2_end , auxhist3_end , & - auxhist1_end_y, auxhist2_end_y, auxhist3_end_y, & - auxhist1_end_d, auxhist2_end_d, auxhist3_end_d, & - auxhist1_end_h, auxhist2_end_h, auxhist3_end_h, & - auxhist1_end_m, auxhist2_end_m, auxhist3_end_m, & - auxhist1_end_s, auxhist2_end_s, auxhist3_end_s - - INTEGER :: auxhist4_end , auxhist5_end, & - auxhist4_end_y, auxhist5_end_y, & - auxhist4_end_d, auxhist5_end_d, & - auxhist4_end_h, auxhist5_end_h, & - auxhist4_end_m, auxhist5_end_m, & - auxhist4_end_s, auxhist5_end_s - - INTEGER :: auxhist6_end , auxhist7_end , auxhist8_end , & - auxhist6_end_y, auxhist7_end_y, auxhist8_end_y, & - auxhist6_end_d, auxhist7_end_d, auxhist8_end_d, & - auxhist6_end_h, auxhist7_end_h, auxhist8_end_h, & - auxhist6_end_m, auxhist7_end_m, auxhist8_end_m, & - auxhist6_end_s, auxhist7_end_s, auxhist8_end_s - - INTEGER :: auxhist9_end , auxhist10_end , auxhist11_end , & - auxhist9_end_y, auxhist10_end_y, auxhist11_end_y, & - auxhist9_end_d, auxhist10_end_d, auxhist11_end_d, & - auxhist9_end_h, auxhist10_end_h, auxhist11_end_h, & - auxhist9_end_m, auxhist10_end_m, auxhist11_end_m, & - auxhist9_end_s, auxhist10_end_s, auxhist11_end_s - - INTEGER :: auxinput1_end , auxinput2_end , auxinput3_end , & - auxinput1_end_y, auxinput2_end_y, auxinput3_end_y, & - auxinput1_end_d, auxinput2_end_d, auxinput3_end_d, & - auxinput1_end_h, auxinput2_end_h, auxinput3_end_h, & - auxinput1_end_m, auxinput2_end_m, auxinput3_end_m, & - auxinput1_end_s, auxinput2_end_s, auxinput3_end_s - - INTEGER :: auxinput4_end , auxinput5_end , & - auxinput4_end_y, auxinput5_end_y, & - auxinput4_end_d, auxinput5_end_d, & - auxinput4_end_h, auxinput5_end_h, & - auxinput4_end_m, auxinput5_end_m, & - auxinput4_end_s, auxinput5_end_s - - INTEGER :: auxinput6_end , auxinput7_end , auxinput8_end , & - auxinput6_end_y, auxinput7_end_y, auxinput8_end_y, & - auxinput6_end_d, auxinput7_end_d, auxinput8_end_d, & - auxinput6_end_h, auxinput7_end_h, auxinput8_end_h, & - auxinput6_end_m, auxinput7_end_m, auxinput8_end_m, & - auxinput6_end_s, auxinput7_end_s, auxinput8_end_s - - INTEGER :: sgfdda_end , gfdda_end , auxinput11_end , & - sgfdda_end_y, gfdda_end_y, auxinput11_end_y, & - sgfdda_end_d, gfdda_end_d, auxinput11_end_d, & - sgfdda_end_h, gfdda_end_h, auxinput11_end_h, & - sgfdda_end_m, gfdda_end_m, auxinput11_end_m, & - sgfdda_end_s, gfdda_end_s, auxinput11_end_s - - INTEGER :: grid_fdda, grid_sfdda - - INTEGER :: run_days, run_hours, run_minutes, run_seconds - INTEGER :: time_step, time_step_fract_num, time_step_fract_den - INTEGER :: rc - REAL :: dt - - CALL WRFU_TimeIntervalSet ( zero_time, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(zero_time) FAILED', & - __FILE__ , & - __LINE__ ) - CALL WRFU_TimeIntervalSet ( one_minute, M=1, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(one_minute) FAILED', & - __FILE__ , & - __LINE__ ) - CALL WRFU_TimeIntervalSet ( one_hour, H=1, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(one_hour) FAILED', & - __FILE__ , & - __LINE__ ) - -#if (EM_CORE == 1) - IF ( (grid%dfi_opt .EQ. DFI_NODFI) .OR. (grid%dfi_stage .EQ. DFI_SETUP) ) THEN -#endif - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeSet(startTime) FAILED', & - __FILE__ , & - __LINE__ ) -#if (EM_CORE == 1) - ELSE - IF ( grid%dfi_opt .EQ. DFI_DFL ) THEN - IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - ELSE IF ( grid%dfi_stage .EQ. DFI_FST ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - - run_length = grid%stop_subtime - grid%start_subtime - CALL WRFU_TimeIntervalGet( run_length, S=run_seconds, rc=rc ) -! What about fractional seconds? - run_seconds = run_seconds / 2 - CALL WRFU_TimeIntervalSet ( run_length, S=run_seconds, rc=rc ) - CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - startTime = startTime + run_length - CALL WRFU_TimeGet(startTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - END IF - - ELSE IF ( grid%dfi_opt .EQ. DFI_DDFI ) THEN - IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN - CALL nl_get_dfi_bckstop_year(grid%id,start_year) - CALL nl_get_dfi_bckstop_month(grid%id,start_month) - CALL nl_get_dfi_bckstop_day(grid%id,start_day) - CALL nl_get_dfi_bckstop_hour(grid%id,start_hour) - CALL nl_get_dfi_bckstop_minute(grid%id,start_minute) - CALL nl_get_dfi_bckstop_second(grid%id,start_second) - ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - ELSE IF ( grid%dfi_stage .EQ. DFI_FST ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - END IF - - ELSE IF ( grid%dfi_opt .EQ. DFI_TDFI ) THEN - IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN - CALL nl_get_dfi_bckstop_year(grid%id,start_year) - CALL nl_get_dfi_bckstop_month(grid%id,start_month) - CALL nl_get_dfi_bckstop_day(grid%id,start_day) - CALL nl_get_dfi_bckstop_hour(grid%id,start_hour) - CALL nl_get_dfi_bckstop_minute(grid%id,start_minute) - CALL nl_get_dfi_bckstop_second(grid%id,start_second) - - run_length = grid%start_subtime - grid%stop_subtime - CALL WRFU_TimeIntervalGet( run_length, S=run_seconds, rc=rc ) -! What about fractional seconds? - run_seconds = run_seconds / 2 - CALL WRFU_TimeIntervalSet ( run_length, S=run_seconds, rc=rc ) - CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - startTime = startTime + run_length - CALL WRFU_TimeGet(startTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - ELSE IF ( grid%dfi_stage .EQ. DFI_FST ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - END IF - END IF - CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeSet(startTime) FAILED', & - __FILE__ , & - __LINE__ ) - END IF -#endif - - CALL nl_get_run_days(1,run_days) - CALL nl_get_run_hours(1,run_hours) - CALL nl_get_run_minutes(1,run_minutes) - CALL nl_get_run_seconds(1,run_seconds) - -#if (EM_CORE == 1) - IF ( (grid%dfi_opt .EQ. DFI_NODFI) .OR. (grid%dfi_stage .EQ. DFI_SETUP) .OR. (grid%dfi_stage .EQ. DFI_FST)) THEN -#endif - - IF ( grid%id .EQ. head_grid%id .AND. & - ( run_days .gt. 0 .or. run_hours .gt. 0 .or. run_minutes .gt. 0 .or. run_seconds .gt. 0 )) THEN - CALL WRFU_TimeIntervalSet ( run_length , D=run_days, H=run_hours, M=run_minutes, S=run_seconds, rc=rc ) -#if (EM_CORE == 1) - IF ( grid%dfi_stage .EQ. DFI_FST .AND. grid%dfi_opt .EQ. DFI_DFL ) THEN - CALL nl_get_start_year(grid%id,start_year) - CALL nl_get_start_month(grid%id,start_month) - CALL nl_get_start_day(grid%id,start_day) - CALL nl_get_start_hour(grid%id,start_hour) - CALL nl_get_start_minute(grid%id,start_minute) - CALL nl_get_start_second(grid%id,start_second) - CALL WRFU_TimeSet(initialTime, YY=start_year, MM=start_month, DD=start_day, & - H=start_hour, M=start_minute, S=start_second,& - rc=rc) - dfl_length = startTime - initialTime - run_length = run_length - dfl_length - END IF -#endif - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(run_length) FAILED', & - __FILE__ , & - __LINE__ ) - stopTime = startTime + run_length - ELSE - CALL nl_get_end_year(grid%id,end_year) - CALL nl_get_end_month(grid%id,end_month) - CALL nl_get_end_day(grid%id,end_day) - CALL nl_get_end_hour(grid%id,end_hour) - CALL nl_get_end_minute(grid%id,end_minute) - CALL nl_get_end_second(grid%id,end_second) - CALL WRFU_TimeSet(stopTime, YY=end_year, MM=end_month, DD=end_day, & - H=end_hour, M=end_minute, S=end_second,& - rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeSet(stopTime) FAILED', & - __FILE__ , & - __LINE__ ) - run_length = stopTime - startTime - ENDIF - -#if (EM_CORE == 1) - ELSE - - IF ( grid%dfi_opt .EQ. DFI_DFL ) THEN - IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN - CALL nl_get_dfi_fwdstop_year(grid%id,end_year) - CALL nl_get_dfi_fwdstop_month(grid%id,end_month) - CALL nl_get_dfi_fwdstop_day(grid%id,end_day) - CALL nl_get_dfi_fwdstop_hour(grid%id,end_hour) - CALL nl_get_dfi_fwdstop_minute(grid%id,end_minute) - CALL nl_get_dfi_fwdstop_second(grid%id,end_second) - END IF - - ELSE IF ( grid%dfi_opt .EQ. DFI_DDFI ) THEN - IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN - CALL nl_get_dfi_fwdstop_year(grid%id,end_year) - CALL nl_get_dfi_fwdstop_month(grid%id,end_month) - CALL nl_get_dfi_fwdstop_day(grid%id,end_day) - CALL nl_get_dfi_fwdstop_hour(grid%id,end_hour) - CALL nl_get_dfi_fwdstop_minute(grid%id,end_minute) - CALL nl_get_dfi_fwdstop_second(grid%id,end_second) - ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN - CALL nl_get_dfi_bckstop_year(grid%id,end_year) - CALL nl_get_dfi_bckstop_month(grid%id,end_month) - CALL nl_get_dfi_bckstop_day(grid%id,end_day) - CALL nl_get_dfi_bckstop_hour(grid%id,end_hour) - CALL nl_get_dfi_bckstop_minute(grid%id,end_minute) - CALL nl_get_dfi_bckstop_second(grid%id,end_second) - END IF - - ELSE IF ( grid%dfi_opt .EQ. DFI_TDFI ) THEN - IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN - CALL nl_get_dfi_fwdstop_year(grid%id,end_year) - CALL nl_get_dfi_fwdstop_month(grid%id,end_month) - CALL nl_get_dfi_fwdstop_day(grid%id,end_day) - CALL nl_get_dfi_fwdstop_hour(grid%id,end_hour) - CALL nl_get_dfi_fwdstop_minute(grid%id,end_minute) - CALL nl_get_dfi_fwdstop_second(grid%id,end_second) - ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN - CALL nl_get_dfi_bckstop_year(grid%id,end_year) - CALL nl_get_dfi_bckstop_month(grid%id,end_month) - CALL nl_get_dfi_bckstop_day(grid%id,end_day) - CALL nl_get_dfi_bckstop_hour(grid%id,end_hour) - CALL nl_get_dfi_bckstop_minute(grid%id,end_minute) - CALL nl_get_dfi_bckstop_second(grid%id,end_second) - END IF - END IF - CALL WRFU_TimeSet(stopTime, YY=end_year, MM=end_month, DD=end_day, & - H=end_hour, M=end_minute, S=end_second,& - rc=rc) - - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeSet(dfistopfwdTime) FAILED', & - __FILE__ , & - __LINE__ ) - - run_length = stopTime - startTime - - END IF -#endif - - IF ( run_length .GT. zero_time ) THEN - padding_interval = one_hour - ELSE - padding_interval = zero_time - one_hour - ENDIF - - IF ( grid%id .EQ. head_grid%id ) THEN - CALL nl_get_time_step ( 1, time_step ) - CALL nl_get_time_step_fract_num( 1, time_step_fract_num ) - CALL nl_get_time_step_fract_den( 1, time_step_fract_den ) - dt = real(time_step) + real(time_step_fract_num) / real(time_step_fract_den) -#ifdef PLANET - ! 2004-12-08 ADT notes: - ! We have gotten the timestep from integers in the namelist, and they have just - ! been converted to the timestep, "dt", used by the physics code just above. - ! After this point, the integers are only used to update the clock used for, - ! and we want to leave that on a "24-hour" type schedule, so we don't need to - ! modify those integers. Theoretically they refer to a portion of the planet's - ! solar day. The only thing we have to do is convert the *real* timestep, dt, - ! to useful SI units. This is easily accomplished by multiplying it by the - ! variable P2SI, which was designed for just this purpose. After multiplication, - ! make sure every subsequent part of the model knows what the value is. - dt = dt * P2SI -#endif - CALL nl_set_dt( grid%id, dt ) - grid%dt = dt - CALL WRFU_TimeIntervalSet(stepTime, S=time_step, Sn=time_step_fract_num, Sd=time_step_fract_den, rc=rc) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(stepTime) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - tmp_step = domain_get_time_step( grid%parents(1)%ptr ) - stepTime = domain_get_time_step( grid%parents(1)%ptr ) / & - grid%parent_time_step_ratio - grid%dt = grid%parents(1)%ptr%dt / grid%parent_time_step_ratio - CALL nl_set_dt( grid%id, grid%dt ) - ENDIF - - ! create grid%domain_clock and associated state - CALL domain_clock_create( grid, TimeStep= stepTime, & - StartTime=startTime, & - StopTime= stopTime ) - CALL domain_clockprint ( 150, grid, & - 'DEBUG setup_timekeeping(): clock after creation,' ) - - ! Set default value for SIMULATION_START_DATE. - ! This is overwritten later in input_wrf(), if needed. - IF ( grid%id .EQ. head_grid%id ) THEN - CALL nl_set_simulation_start_year ( 1 , start_year ) - CALL nl_set_simulation_start_month ( 1 , start_month ) - CALL nl_set_simulation_start_day ( 1 , start_day ) - CALL nl_set_simulation_start_hour ( 1 , start_hour ) - CALL nl_set_simulation_start_minute ( 1 , start_minute ) - CALL nl_set_simulation_start_second ( 1 , start_second ) - ENDIF - -! HISTORY INTERVAL -! history_interval is left there (and means minutes) for consistency, but -! history_interval_m will take precedence if specified - - CALL nl_get_history_interval( grid%id, history_interval ) ! same as minutes - CALL nl_get_history_interval_d( grid%id, history_interval_d ) - CALL nl_get_history_interval_h( grid%id, history_interval_h ) - CALL nl_get_history_interval_m( grid%id, history_interval_m ) - CALL nl_get_history_interval_s( grid%id, history_interval_s ) - IF ( history_interval_m .EQ. 0 ) history_interval_m = history_interval - - IF ( MAX( history_interval_d, & - history_interval_h, history_interval_m , history_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=history_interval_d, & - H=history_interval_h, M=history_interval_m, S=history_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(history_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_history_begin_y( grid%id, history_begin_y ) - CALL nl_get_history_begin_d( grid%id, history_begin_d ) - CALL nl_get_history_begin_h( grid%id, history_begin_h ) - CALL nl_get_history_begin_m( grid%id, history_begin_m ) - CALL nl_get_history_begin_s( grid%id, history_begin_s ) - IF ( MAX( history_begin_y, history_begin_d, & - history_begin_h, history_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=history_begin_d, & - H=history_begin_h, M=history_begin_m, S=history_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(history_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_history_end_y( grid%id, history_end_y ) - CALL nl_get_history_end_d( grid%id, history_end_d ) - CALL nl_get_history_end_h( grid%id, history_end_h ) - CALL nl_get_history_end_m( grid%id, history_end_m ) - CALL nl_get_history_end_s( grid%id, history_end_s ) - IF ( MAX( history_end_y, history_end_d, & - history_end_h, history_end_m , history_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=history_end_d, & - H=history_end_h, M=history_end_m, S=history_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(history_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, HISTORY_ALARM, interval, begin_time, end_time ) - - IF ( begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( HISTORY_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(HISTORY_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - - -! RESTART INTERVAL -! restart_interval is left there (and means minutes) for consistency, but -! restart_interval_m will take precedence if specified - CALL nl_get_restart_interval( 1, restart_interval ) ! same as minutes - CALL nl_get_restart_interval_d( 1, restart_interval_d ) - CALL nl_get_restart_interval_h( 1, restart_interval_h ) - CALL nl_get_restart_interval_m( 1, restart_interval_m ) - CALL nl_get_restart_interval_s( 1, restart_interval_s ) - IF ( restart_interval_m .EQ. 0 ) restart_interval_m = restart_interval - IF ( MAX( restart_interval_d, & - restart_interval_h, restart_interval_m , restart_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=restart_interval_d, & - H=restart_interval_h, M=restart_interval_m, S=restart_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(restart_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - CALL domain_alarm_create( grid, RESTART_ALARM, interval ) - -! INPUTOUT INTERVAL - CALL nl_get_inputout_interval( grid%id, inputout_interval ) ! same as minutes - CALL nl_get_inputout_interval_d( grid%id, inputout_interval_d ) - CALL nl_get_inputout_interval_h( grid%id, inputout_interval_h ) - CALL nl_get_inputout_interval_m( grid%id, inputout_interval_m ) - CALL nl_get_inputout_interval_s( grid%id, inputout_interval_s ) - IF ( inputout_interval_m .EQ. 0 ) inputout_interval_m = inputout_interval - - IF ( MAX( inputout_interval_d, & - inputout_interval_h, inputout_interval_m , inputout_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=inputout_interval_d, & - H=inputout_interval_h, M=inputout_interval_m, S=inputout_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(inputout_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_inputout_begin_y( grid%id, inputout_begin_y ) - CALL nl_get_inputout_begin_d( grid%id, inputout_begin_d ) - CALL nl_get_inputout_begin_h( grid%id, inputout_begin_h ) - CALL nl_get_inputout_begin_m( grid%id, inputout_begin_m ) - CALL nl_get_inputout_begin_s( grid%id, inputout_begin_s ) - IF ( MAX( inputout_begin_y, inputout_begin_d, & - inputout_begin_h, inputout_begin_m , inputout_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=inputout_begin_d, & - H=inputout_begin_h, M=inputout_begin_m, S=inputout_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(inputout_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_inputout_end_y( grid%id, inputout_end_y ) - CALL nl_get_inputout_end_d( grid%id, inputout_end_d ) - CALL nl_get_inputout_end_h( grid%id, inputout_end_h ) - CALL nl_get_inputout_end_m( grid%id, inputout_end_m ) - CALL nl_get_inputout_end_s( grid%id, inputout_end_s ) - IF ( MAX( inputout_end_y, inputout_end_d, & - inputout_end_h, inputout_end_m , inputout_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=inputout_end_d, & - H=inputout_end_h, M=inputout_end_m, S=inputout_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(inputout_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, INPUTOUT_ALARM, interval, begin_time, end_time ) - -! AUXHIST1 INTERVAL -! auxhist1_interval is left there (and means minutes) for consistency, but -! auxhist1_interval_m will take precedence if specified - CALL nl_get_auxhist1_interval( grid%id, auxhist1_interval ) ! same as minutes - CALL nl_get_auxhist1_interval_d( grid%id, auxhist1_interval_d ) - CALL nl_get_auxhist1_interval_h( grid%id, auxhist1_interval_h ) - CALL nl_get_auxhist1_interval_m( grid%id, auxhist1_interval_m ) - CALL nl_get_auxhist1_interval_s( grid%id, auxhist1_interval_s ) - IF ( auxhist1_interval_m .EQ. 0 ) auxhist1_interval_m = auxhist1_interval - - IF ( MAX( auxhist1_interval_d, & - auxhist1_interval_h, auxhist1_interval_m , auxhist1_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist1_interval_d, & - H=auxhist1_interval_h, M=auxhist1_interval_m, S=auxhist1_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist1_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist1_begin_y( grid%id, auxhist1_begin_y ) - CALL nl_get_auxhist1_begin_d( grid%id, auxhist1_begin_d ) - CALL nl_get_auxhist1_begin_h( grid%id, auxhist1_begin_h ) - CALL nl_get_auxhist1_begin_m( grid%id, auxhist1_begin_m ) - CALL nl_get_auxhist1_begin_s( grid%id, auxhist1_begin_s ) - IF ( MAX( auxhist1_begin_y, auxhist1_begin_d, & - auxhist1_begin_h, auxhist1_begin_m , auxhist1_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist1_begin_d, & - H=auxhist1_begin_h, M=auxhist1_begin_m, S=auxhist1_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist1_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist1_end_y( grid%id, auxhist1_end_y ) - CALL nl_get_auxhist1_end_d( grid%id, auxhist1_end_d ) - CALL nl_get_auxhist1_end_h( grid%id, auxhist1_end_h ) - CALL nl_get_auxhist1_end_m( grid%id, auxhist1_end_m ) - CALL nl_get_auxhist1_end_s( grid%id, auxhist1_end_s ) - IF ( MAX( auxhist1_end_y, auxhist1_end_d, & - auxhist1_end_h, auxhist1_end_m , auxhist1_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist1_end_d, & - H=auxhist1_end_h, M=auxhist1_end_m, S=auxhist1_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist1_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST1_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST1_ALARM ), rc=rc ) - ENDIF - - -! AUXHIST2_ INTERVAL -! auxhist2_interval is left there (and means minutes) for consistency, but -! auxhist2_interval_m will take precedence if specified - CALL nl_get_auxhist2_interval( grid%id, auxhist2_interval ) ! same as minutes - CALL nl_get_auxhist2_interval_d( grid%id, auxhist2_interval_d ) - CALL nl_get_auxhist2_interval_h( grid%id, auxhist2_interval_h ) - CALL nl_get_auxhist2_interval_m( grid%id, auxhist2_interval_m ) - CALL nl_get_auxhist2_interval_s( grid%id, auxhist2_interval_s ) - IF ( auxhist2_interval_m .EQ. 0) auxhist2_interval_m = auxhist2_interval - - IF ( MAX( auxhist2_interval_d, & - auxhist2_interval_h, auxhist2_interval_m , auxhist2_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist2_interval_d, & - H=auxhist2_interval_h, M=auxhist2_interval_m, S=auxhist2_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist2_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist2_begin_y( grid%id, auxhist2_begin_y ) - CALL nl_get_auxhist2_begin_d( grid%id, auxhist2_begin_d ) - CALL nl_get_auxhist2_begin_h( grid%id, auxhist2_begin_h ) - CALL nl_get_auxhist2_begin_m( grid%id, auxhist2_begin_m ) - CALL nl_get_auxhist2_begin_s( grid%id, auxhist2_begin_s ) - IF ( MAX( auxhist2_begin_y, auxhist2_begin_d, & - auxhist2_begin_h, auxhist2_begin_m , auxhist2_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist2_begin_d, & - H=auxhist2_begin_h, M=auxhist2_begin_m, S=auxhist2_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist2_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist2_end_y( grid%id, auxhist2_end_y ) - CALL nl_get_auxhist2_end_d( grid%id, auxhist2_end_d ) - CALL nl_get_auxhist2_end_h( grid%id, auxhist2_end_h ) - CALL nl_get_auxhist2_end_m( grid%id, auxhist2_end_m ) - CALL nl_get_auxhist2_end_s( grid%id, auxhist2_end_s ) - IF ( MAX( auxhist2_end_y, auxhist2_end_d, & - auxhist2_end_h, auxhist2_end_m , auxhist2_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist2_end_d, & - H=auxhist2_end_h, M=auxhist2_end_m, S=auxhist2_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist2_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST2_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST2_ALARM ), rc=rc ) - ENDIF - -! AUXHIST3_ INTERVAL -! auxhist3_interval is left there (and means minutes) for consistency, but -! auxhist3_interval_m will take precedence if specified - CALL nl_get_auxhist3_interval( grid%id, auxhist3_interval ) ! same as minutes - CALL nl_get_auxhist3_interval_d( grid%id, auxhist3_interval_d ) - CALL nl_get_auxhist3_interval_h( grid%id, auxhist3_interval_h ) - CALL nl_get_auxhist3_interval_m( grid%id, auxhist3_interval_m ) - CALL nl_get_auxhist3_interval_s( grid%id, auxhist3_interval_s ) - IF ( auxhist3_interval_m .EQ. 0 ) auxhist3_interval_m = auxhist3_interval - - IF ( MAX( auxhist3_interval_d, & - auxhist3_interval_h, auxhist3_interval_m , auxhist3_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist3_interval_d, & - H=auxhist3_interval_h, M=auxhist3_interval_m, S=auxhist3_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist3_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist3_begin_y( grid%id, auxhist3_begin_y ) - CALL nl_get_auxhist3_begin_d( grid%id, auxhist3_begin_d ) - CALL nl_get_auxhist3_begin_h( grid%id, auxhist3_begin_h ) - CALL nl_get_auxhist3_begin_m( grid%id, auxhist3_begin_m ) - CALL nl_get_auxhist3_begin_s( grid%id, auxhist3_begin_s ) - IF ( MAX( auxhist3_begin_y, auxhist3_begin_d, & - auxhist3_begin_h, auxhist3_begin_m , auxhist3_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist3_begin_d, & - H=auxhist3_begin_h, M=auxhist3_begin_m, S=auxhist3_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist3_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist3_end_y( grid%id, auxhist3_end_y ) - CALL nl_get_auxhist3_end_d( grid%id, auxhist3_end_d ) - CALL nl_get_auxhist3_end_h( grid%id, auxhist3_end_h ) - CALL nl_get_auxhist3_end_m( grid%id, auxhist3_end_m ) - CALL nl_get_auxhist3_end_s( grid%id, auxhist3_end_s ) - IF ( MAX( auxhist3_end_y, auxhist3_end_d, & - auxhist3_end_h, auxhist3_end_m , auxhist3_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist3_end_d, & - H=auxhist3_end_h, M=auxhist3_end_m, S=auxhist3_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist3_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST3_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST3_ALARM ), rc=rc ) - ENDIF - -! AUXHIST4_ INTERVAL -! auxhist4_interval is left there (and means minutes) for consistency, but -! auxhist4_interval_m will take precedence if specified - CALL nl_get_auxhist4_interval( grid%id, auxhist4_interval ) ! same as minutes - CALL nl_get_auxhist4_interval_d( grid%id, auxhist4_interval_d ) - CALL nl_get_auxhist4_interval_h( grid%id, auxhist4_interval_h ) - CALL nl_get_auxhist4_interval_m( grid%id, auxhist4_interval_m ) - CALL nl_get_auxhist4_interval_s( grid%id, auxhist4_interval_s ) - IF ( auxhist4_interval_m .EQ. 0 ) auxhist4_interval_m = auxhist4_interval - - IF ( MAX( auxhist4_interval_d, & - auxhist4_interval_h, auxhist4_interval_m , auxhist4_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist4_interval_d, & - H=auxhist4_interval_h, M=auxhist4_interval_m, S=auxhist4_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist4_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist4_begin_y( grid%id, auxhist4_begin_y ) - CALL nl_get_auxhist4_begin_d( grid%id, auxhist4_begin_d ) - CALL nl_get_auxhist4_begin_h( grid%id, auxhist4_begin_h ) - CALL nl_get_auxhist4_begin_m( grid%id, auxhist4_begin_m ) - CALL nl_get_auxhist4_begin_s( grid%id, auxhist4_begin_s ) - IF ( MAX( auxhist4_begin_y, auxhist4_begin_d, & - auxhist4_begin_h, auxhist4_begin_m , auxhist4_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist4_begin_d, & - H=auxhist4_begin_h, M=auxhist4_begin_m, S=auxhist4_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist4_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist4_end_y( grid%id, auxhist4_end_y ) - CALL nl_get_auxhist4_end_d( grid%id, auxhist4_end_d ) - CALL nl_get_auxhist4_end_h( grid%id, auxhist4_end_h ) - CALL nl_get_auxhist4_end_m( grid%id, auxhist4_end_m ) - CALL nl_get_auxhist4_end_s( grid%id, auxhist4_end_s ) - IF ( MAX( auxhist4_end_y, auxhist4_end_d, & - auxhist4_end_h, auxhist4_end_m , auxhist4_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist4_end_d, & - H=auxhist4_end_h, M=auxhist4_end_m, S=auxhist4_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist4_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST4_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST4_ALARM ), rc=rc ) - ENDIF - -! AUXHIST5_ INTERVAL -! auxhist5_interval is left there (and means minutes) for consistency, but -! auxhist5_interval_m will take precedence if specified - CALL nl_get_auxhist5_interval( grid%id, auxhist5_interval ) ! same as minutes - CALL nl_get_auxhist5_interval_d( grid%id, auxhist5_interval_d ) - CALL nl_get_auxhist5_interval_h( grid%id, auxhist5_interval_h ) - CALL nl_get_auxhist5_interval_m( grid%id, auxhist5_interval_m ) - CALL nl_get_auxhist5_interval_s( grid%id, auxhist5_interval_s ) - IF ( auxhist5_interval_m .EQ. 0 ) auxhist5_interval_m = auxhist5_interval - - IF ( MAX( auxhist5_interval_d, & - auxhist5_interval_h, auxhist5_interval_m , auxhist5_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist5_interval_d, & - H=auxhist5_interval_h, M=auxhist5_interval_m, S=auxhist5_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist5_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist5_begin_y( grid%id, auxhist5_begin_y ) - CALL nl_get_auxhist5_begin_d( grid%id, auxhist5_begin_d ) - CALL nl_get_auxhist5_begin_h( grid%id, auxhist5_begin_h ) - CALL nl_get_auxhist5_begin_m( grid%id, auxhist5_begin_m ) - CALL nl_get_auxhist5_begin_s( grid%id, auxhist5_begin_s ) - IF ( MAX( auxhist5_begin_y, auxhist5_begin_d, & - auxhist5_begin_h, auxhist5_begin_m , auxhist5_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist5_begin_d, & - H=auxhist5_begin_h, M=auxhist5_begin_m, S=auxhist5_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist5_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist5_end_y( grid%id, auxhist5_end_y ) - CALL nl_get_auxhist5_end_d( grid%id, auxhist5_end_d ) - CALL nl_get_auxhist5_end_h( grid%id, auxhist5_end_h ) - CALL nl_get_auxhist5_end_m( grid%id, auxhist5_end_m ) - CALL nl_get_auxhist5_end_s( grid%id, auxhist5_end_s ) - IF ( MAX( auxhist5_end_y, auxhist5_end_d, & - auxhist5_end_h, auxhist5_end_m , auxhist5_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist5_end_d, & - H=auxhist5_end_h, M=auxhist5_end_m, S=auxhist5_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist5_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST5_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST5_ALARM ), rc=rc ) - ENDIF - -! AUXHIST6_ INTERVAL -! auxhist6_interval is left there (and means minutes) for consistency, but -! auxhist6_interval_m will take precedence if specified - CALL nl_get_auxhist6_interval( grid%id, auxhist6_interval ) ! same as minutes - CALL nl_get_auxhist6_interval_d( grid%id, auxhist6_interval_d ) - CALL nl_get_auxhist6_interval_h( grid%id, auxhist6_interval_h ) - CALL nl_get_auxhist6_interval_m( grid%id, auxhist6_interval_m ) - CALL nl_get_auxhist6_interval_s( grid%id, auxhist6_interval_s ) - IF ( auxhist6_interval_m .EQ. 0 ) auxhist6_interval_m = auxhist6_interval - - IF ( MAX( auxhist6_interval_d, & - auxhist6_interval_h, auxhist6_interval_m , auxhist6_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist6_interval_d, & - H=auxhist6_interval_h, M=auxhist6_interval_m, S=auxhist6_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist6_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist6_begin_y( grid%id, auxhist6_begin_y ) - CALL nl_get_auxhist6_begin_d( grid%id, auxhist6_begin_d ) - CALL nl_get_auxhist6_begin_h( grid%id, auxhist6_begin_h ) - CALL nl_get_auxhist6_begin_m( grid%id, auxhist6_begin_m ) - CALL nl_get_auxhist6_begin_s( grid%id, auxhist6_begin_s ) - IF ( MAX( auxhist6_begin_y, auxhist6_begin_d, & - auxhist6_begin_h, auxhist6_begin_m , auxhist6_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist6_begin_d, & - H=auxhist6_begin_h, M=auxhist6_begin_m, S=auxhist6_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist6_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist6_end_y( grid%id, auxhist6_end_y ) - CALL nl_get_auxhist6_end_d( grid%id, auxhist6_end_d ) - CALL nl_get_auxhist6_end_h( grid%id, auxhist6_end_h ) - CALL nl_get_auxhist6_end_m( grid%id, auxhist6_end_m ) - CALL nl_get_auxhist6_end_s( grid%id, auxhist6_end_s ) - IF ( MAX( auxhist6_end_y, auxhist6_end_d, & - auxhist6_end_h, auxhist6_end_m , auxhist6_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist6_end_d, & - H=auxhist6_end_h, M=auxhist6_end_m, S=auxhist6_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist6_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST6_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST6_ALARM ), rc=rc ) - ENDIF - - -! AUXHIST7_ INTERVAL -! auxhist7_interval is left there (and means minutes) for consistency, but -! auxhist7_interval_m will take precedence if specified - CALL nl_get_auxhist7_interval( grid%id, auxhist7_interval ) ! same as minutes - CALL nl_get_auxhist7_interval_d( grid%id, auxhist7_interval_d ) - CALL nl_get_auxhist7_interval_h( grid%id, auxhist7_interval_h ) - CALL nl_get_auxhist7_interval_m( grid%id, auxhist7_interval_m ) - CALL nl_get_auxhist7_interval_s( grid%id, auxhist7_interval_s ) - IF ( auxhist7_interval_m .EQ. 0 ) auxhist7_interval_m = auxhist7_interval - - IF ( MAX( auxhist7_interval_d, & - auxhist7_interval_h, auxhist7_interval_m , auxhist7_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist7_interval_d, & - H=auxhist7_interval_h, M=auxhist7_interval_m, S=auxhist7_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist7_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist7_begin_y( grid%id, auxhist7_begin_y ) - CALL nl_get_auxhist7_begin_d( grid%id, auxhist7_begin_d ) - CALL nl_get_auxhist7_begin_h( grid%id, auxhist7_begin_h ) - CALL nl_get_auxhist7_begin_m( grid%id, auxhist7_begin_m ) - CALL nl_get_auxhist7_begin_s( grid%id, auxhist7_begin_s ) - IF ( MAX( auxhist7_begin_y, auxhist7_begin_d, & - auxhist7_begin_h, auxhist7_begin_m , auxhist7_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist7_begin_d, & - H=auxhist7_begin_h, M=auxhist7_begin_m, S=auxhist7_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist7_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist7_end_y( grid%id, auxhist7_end_y ) - CALL nl_get_auxhist7_end_d( grid%id, auxhist7_end_d ) - CALL nl_get_auxhist7_end_h( grid%id, auxhist7_end_h ) - CALL nl_get_auxhist7_end_m( grid%id, auxhist7_end_m ) - CALL nl_get_auxhist7_end_s( grid%id, auxhist7_end_s ) - IF ( MAX( auxhist7_end_y, auxhist7_end_d, & - auxhist7_end_h, auxhist7_end_m , auxhist7_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist7_end_d, & - H=auxhist7_end_h, M=auxhist7_end_m, S=auxhist7_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist7_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST7_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST7_ALARM ), rc=rc ) - ENDIF - -! AUXHIST8_ INTERVAL -! auxhist8_interval is left there (and means minutes) for consistency, but -! auxhist8_interval_m will take precedence if specified - CALL nl_get_auxhist8_interval( grid%id, auxhist8_interval ) ! same as minutes - CALL nl_get_auxhist8_interval_d( grid%id, auxhist8_interval_d ) - CALL nl_get_auxhist8_interval_h( grid%id, auxhist8_interval_h ) - CALL nl_get_auxhist8_interval_m( grid%id, auxhist8_interval_m ) - CALL nl_get_auxhist8_interval_s( grid%id, auxhist8_interval_s ) - IF ( auxhist8_interval_m .EQ. 0 ) auxhist8_interval_m = auxhist8_interval - - IF ( MAX( auxhist8_interval_d, & - auxhist8_interval_h, auxhist8_interval_m , auxhist8_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist8_interval_d, & - H=auxhist8_interval_h, M=auxhist8_interval_m, S=auxhist8_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist8_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist8_begin_y( grid%id, auxhist8_begin_y ) - CALL nl_get_auxhist8_begin_d( grid%id, auxhist8_begin_d ) - CALL nl_get_auxhist8_begin_h( grid%id, auxhist8_begin_h ) - CALL nl_get_auxhist8_begin_m( grid%id, auxhist8_begin_m ) - CALL nl_get_auxhist8_begin_s( grid%id, auxhist8_begin_s ) - IF ( MAX( auxhist8_begin_y, auxhist8_begin_d, & - auxhist8_begin_h, auxhist8_begin_m , auxhist8_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist8_begin_d, & - H=auxhist8_begin_h, M=auxhist8_begin_m, S=auxhist8_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist8_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist8_end_y( grid%id, auxhist8_end_y ) - CALL nl_get_auxhist8_end_d( grid%id, auxhist8_end_d ) - CALL nl_get_auxhist8_end_h( grid%id, auxhist8_end_h ) - CALL nl_get_auxhist8_end_m( grid%id, auxhist8_end_m ) - CALL nl_get_auxhist8_end_s( grid%id, auxhist8_end_s ) - IF ( MAX( auxhist8_end_y, auxhist8_end_d, & - auxhist8_end_h, auxhist8_end_m , auxhist8_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist8_end_d, & - H=auxhist8_end_h, M=auxhist8_end_m, S=auxhist8_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist8_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST8_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST8_ALARM ), rc=rc ) - ENDIF - -! AUXHIST9_ INTERVAL -! auxhist9_interval is left there (and means minutes) for consistency, but -! auxhist9_interval_m will take precedence if specified - CALL nl_get_auxhist9_interval( grid%id, auxhist9_interval ) ! same as minutes - CALL nl_get_auxhist9_interval_d( grid%id, auxhist9_interval_d ) - CALL nl_get_auxhist9_interval_h( grid%id, auxhist9_interval_h ) - CALL nl_get_auxhist9_interval_m( grid%id, auxhist9_interval_m ) - CALL nl_get_auxhist9_interval_s( grid%id, auxhist9_interval_s ) - IF ( auxhist9_interval_m .EQ. 0 ) auxhist9_interval_m = auxhist9_interval - - IF ( MAX( auxhist9_interval_d, & - auxhist9_interval_h, auxhist9_interval_m , auxhist9_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist9_interval_d, & - H=auxhist9_interval_h, M=auxhist9_interval_m, S=auxhist9_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist9_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist9_begin_y( grid%id, auxhist9_begin_y ) - CALL nl_get_auxhist9_begin_d( grid%id, auxhist9_begin_d ) - CALL nl_get_auxhist9_begin_h( grid%id, auxhist9_begin_h ) - CALL nl_get_auxhist9_begin_m( grid%id, auxhist9_begin_m ) - CALL nl_get_auxhist9_begin_s( grid%id, auxhist9_begin_s ) - IF ( MAX( auxhist9_begin_y, auxhist9_begin_d, & - auxhist9_begin_h, auxhist9_begin_m , auxhist9_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist9_begin_d, & - H=auxhist9_begin_h, M=auxhist9_begin_m, S=auxhist9_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist9_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist9_end_y( grid%id, auxhist9_end_y ) - CALL nl_get_auxhist9_end_d( grid%id, auxhist9_end_d ) - CALL nl_get_auxhist9_end_h( grid%id, auxhist9_end_h ) - CALL nl_get_auxhist9_end_m( grid%id, auxhist9_end_m ) - CALL nl_get_auxhist9_end_s( grid%id, auxhist9_end_s ) - IF ( MAX( auxhist9_end_y, auxhist9_end_d, & - auxhist9_end_h, auxhist9_end_m , auxhist9_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist9_end_d, & - H=auxhist9_end_h, M=auxhist9_end_m, S=auxhist9_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist9_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST9_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST9_ALARM ), rc=rc ) - ENDIF - -! AUXHIST10_ INTERVAL -! auxhist10_interval is left there (and means minutes) for consistency, but -! auxhist10_interval_m will take precedence if specified - CALL nl_get_auxhist10_interval( grid%id, auxhist10_interval ) ! same as minutes - CALL nl_get_auxhist10_interval_d( grid%id, auxhist10_interval_d ) - CALL nl_get_auxhist10_interval_h( grid%id, auxhist10_interval_h ) - CALL nl_get_auxhist10_interval_m( grid%id, auxhist10_interval_m ) - CALL nl_get_auxhist10_interval_s( grid%id, auxhist10_interval_s ) - IF ( auxhist10_interval_m .EQ. 0 ) auxhist10_interval_m = auxhist10_interval - - IF ( MAX( auxhist10_interval_d, & - auxhist10_interval_h, auxhist10_interval_m , auxhist10_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist10_interval_d, & - H=auxhist10_interval_h, M=auxhist10_interval_m, S=auxhist10_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist10_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist10_begin_y( grid%id, auxhist10_begin_y ) - CALL nl_get_auxhist10_begin_d( grid%id, auxhist10_begin_d ) - CALL nl_get_auxhist10_begin_h( grid%id, auxhist10_begin_h ) - CALL nl_get_auxhist10_begin_m( grid%id, auxhist10_begin_m ) - CALL nl_get_auxhist10_begin_s( grid%id, auxhist10_begin_s ) - IF ( MAX( auxhist10_begin_y, auxhist10_begin_d, & - auxhist10_begin_h, auxhist10_begin_m , auxhist10_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist10_begin_d, & - H=auxhist10_begin_h, M=auxhist10_begin_m, S=auxhist10_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist10_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist10_end_y( grid%id, auxhist10_end_y ) - CALL nl_get_auxhist10_end_d( grid%id, auxhist10_end_d ) - CALL nl_get_auxhist10_end_h( grid%id, auxhist10_end_h ) - CALL nl_get_auxhist10_end_m( grid%id, auxhist10_end_m ) - CALL nl_get_auxhist10_end_s( grid%id, auxhist10_end_s ) - IF ( MAX( auxhist10_end_y, auxhist10_end_d, & - auxhist10_end_h, auxhist10_end_m , auxhist10_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist10_end_d, & - H=auxhist10_end_h, M=auxhist10_end_m, S=auxhist10_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist10_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST10_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST10_ALARM ), rc=rc ) - ENDIF - -! AUXHIST11_ INTERVAL -! auxhist11_interval is left there (and means minutes) for consistency, but -! auxhist11_interval_m will take precedence if specified - CALL nl_get_auxhist11_interval( grid%id, auxhist11_interval ) ! same as minutes - CALL nl_get_auxhist11_interval_d( grid%id, auxhist11_interval_d ) - CALL nl_get_auxhist11_interval_h( grid%id, auxhist11_interval_h ) - CALL nl_get_auxhist11_interval_m( grid%id, auxhist11_interval_m ) - CALL nl_get_auxhist11_interval_s( grid%id, auxhist11_interval_s ) - IF ( auxhist11_interval_m .EQ. 0 ) auxhist11_interval_m = auxhist11_interval - - IF ( MAX( auxhist11_interval_d, & - auxhist11_interval_h, auxhist11_interval_m , auxhist11_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxhist11_interval_d, & - H=auxhist11_interval_h, M=auxhist11_interval_m, S=auxhist11_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist11_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxhist11_begin_y( grid%id, auxhist11_begin_y ) - CALL nl_get_auxhist11_begin_d( grid%id, auxhist11_begin_d ) - CALL nl_get_auxhist11_begin_h( grid%id, auxhist11_begin_h ) - CALL nl_get_auxhist11_begin_m( grid%id, auxhist11_begin_m ) - CALL nl_get_auxhist11_begin_s( grid%id, auxhist11_begin_s ) - IF ( MAX( auxhist11_begin_y, auxhist11_begin_d, & - auxhist11_begin_h, auxhist11_begin_m , auxhist11_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxhist11_begin_d, & - H=auxhist11_begin_h, M=auxhist11_begin_m, S=auxhist11_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist11_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxhist11_end_y( grid%id, auxhist11_end_y ) - CALL nl_get_auxhist11_end_d( grid%id, auxhist11_end_d ) - CALL nl_get_auxhist11_end_h( grid%id, auxhist11_end_h ) - CALL nl_get_auxhist11_end_m( grid%id, auxhist11_end_m ) - CALL nl_get_auxhist11_end_s( grid%id, auxhist11_end_s ) - IF ( MAX( auxhist11_end_y, auxhist11_end_d, & - auxhist11_end_h, auxhist11_end_m , auxhist11_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxhist11_end_d, & - H=auxhist11_end_h, M=auxhist11_end_m, S=auxhist11_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxhist11_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXHIST11_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXHIST11_ALARM ), rc=rc ) - ENDIF - -! AUXINPUT1_ INTERVAL -! auxinput1_interval is left there (and means minutes) for consistency, but -! auxinput1_interval_m will take precedence if specified - CALL nl_get_auxinput1_interval( grid%id, auxinput1_interval ) ! same as minutes - CALL nl_get_auxinput1_interval_d( grid%id, auxinput1_interval_d ) - CALL nl_get_auxinput1_interval_h( grid%id, auxinput1_interval_h ) - CALL nl_get_auxinput1_interval_m( grid%id, auxinput1_interval_m ) - CALL nl_get_auxinput1_interval_s( grid%id, auxinput1_interval_s ) - IF ( auxinput1_interval_m .EQ. 0 ) auxinput1_interval_m = auxinput1_interval - - IF ( MAX( auxinput1_interval_d, & - auxinput1_interval_h, auxinput1_interval_m , auxinput1_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput1_interval_d, & - H=auxinput1_interval_h, M=auxinput1_interval_m, S=auxinput1_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput1_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput1_begin_y( grid%id, auxinput1_begin_y ) - CALL nl_get_auxinput1_begin_d( grid%id, auxinput1_begin_d ) - CALL nl_get_auxinput1_begin_h( grid%id, auxinput1_begin_h ) - CALL nl_get_auxinput1_begin_m( grid%id, auxinput1_begin_m ) - CALL nl_get_auxinput1_begin_s( grid%id, auxinput1_begin_s ) - IF ( MAX( auxinput1_begin_y, auxinput1_begin_d, & - auxinput1_begin_h, auxinput1_begin_m , auxinput1_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput1_begin_d, & - H=auxinput1_begin_h, M=auxinput1_begin_m, S=auxinput1_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput1_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput1_end_y( grid%id, auxinput1_end_y ) - CALL nl_get_auxinput1_end_d( grid%id, auxinput1_end_d ) - CALL nl_get_auxinput1_end_h( grid%id, auxinput1_end_h ) - CALL nl_get_auxinput1_end_m( grid%id, auxinput1_end_m ) - CALL nl_get_auxinput1_end_s( grid%id, auxinput1_end_s ) - IF ( MAX( auxinput1_end_y, auxinput1_end_d, & - auxinput1_end_h, auxinput1_end_m , auxinput1_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput1_end_d, & - H=auxinput1_end_h, M=auxinput1_end_m, S=auxinput1_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput1_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT1_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT1_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT1_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -! AUXINPUT2_ INTERVAL -! auxinput2_interval is left there (and means minutes) for consistency, but -! auxinput2_interval_m will take precedence if specified - CALL nl_get_auxinput2_interval( grid%id, auxinput2_interval ) ! same as minutes - CALL nl_get_auxinput2_interval_d( grid%id, auxinput2_interval_d ) - CALL nl_get_auxinput2_interval_h( grid%id, auxinput2_interval_h ) - CALL nl_get_auxinput2_interval_m( grid%id, auxinput2_interval_m ) - CALL nl_get_auxinput2_interval_s( grid%id, auxinput2_interval_s ) - IF ( auxinput2_interval_m .EQ. 0 ) auxinput2_interval_m = auxinput2_interval - - IF ( MAX( auxinput2_interval_d, & - auxinput2_interval_h, auxinput2_interval_m , auxinput2_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput2_interval_d, & - H=auxinput2_interval_h, M=auxinput2_interval_m, S=auxinput2_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput2_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput2_begin_y( grid%id, auxinput2_begin_y ) - CALL nl_get_auxinput2_begin_d( grid%id, auxinput2_begin_d ) - CALL nl_get_auxinput2_begin_h( grid%id, auxinput2_begin_h ) - CALL nl_get_auxinput2_begin_m( grid%id, auxinput2_begin_m ) - CALL nl_get_auxinput2_begin_s( grid%id, auxinput2_begin_s ) - IF ( MAX( auxinput2_begin_y, auxinput2_begin_d, & - auxinput2_begin_h, auxinput2_begin_m , auxinput2_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput2_begin_d, & - H=auxinput2_begin_h, M=auxinput2_begin_m, S=auxinput2_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput2_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput2_end_y( grid%id, auxinput2_end_y ) - CALL nl_get_auxinput2_end_d( grid%id, auxinput2_end_d ) - CALL nl_get_auxinput2_end_h( grid%id, auxinput2_end_h ) - CALL nl_get_auxinput2_end_m( grid%id, auxinput2_end_m ) - CALL nl_get_auxinput2_end_s( grid%id, auxinput2_end_s ) - IF ( MAX( auxinput2_end_y, auxinput2_end_d, & - auxinput2_end_h, auxinput2_end_m , auxinput2_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput2_end_d, & - H=auxinput2_end_h, M=auxinput2_end_m, S=auxinput2_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput2_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT2_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT2_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT2_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -! AUXINPUT3_ INTERVAL -! auxinput3_interval is left there (and means minutes) for consistency, but -! auxinput3_interval_m will take precedence if specified - CALL nl_get_auxinput3_interval( grid%id, auxinput3_interval ) ! same as minutes - CALL nl_get_auxinput3_interval_d( grid%id, auxinput3_interval_d ) - CALL nl_get_auxinput3_interval_h( grid%id, auxinput3_interval_h ) - CALL nl_get_auxinput3_interval_m( grid%id, auxinput3_interval_m ) - CALL nl_get_auxinput3_interval_s( grid%id, auxinput3_interval_s ) - IF ( auxinput3_interval_m .EQ. 0 ) auxinput3_interval_m = auxinput3_interval - - IF ( MAX( auxinput3_interval_d, & - auxinput3_interval_h, auxinput3_interval_m , auxinput3_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput3_interval_d, & - H=auxinput3_interval_h, M=auxinput3_interval_m, S=auxinput3_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput3_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput3_begin_y( grid%id, auxinput3_begin_y ) - CALL nl_get_auxinput3_begin_d( grid%id, auxinput3_begin_d ) - CALL nl_get_auxinput3_begin_h( grid%id, auxinput3_begin_h ) - CALL nl_get_auxinput3_begin_m( grid%id, auxinput3_begin_m ) - CALL nl_get_auxinput3_begin_s( grid%id, auxinput3_begin_s ) - IF ( MAX( auxinput3_begin_y, auxinput3_begin_d, & - auxinput3_begin_h, auxinput3_begin_m , auxinput3_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput3_begin_d, & - H=auxinput3_begin_h, M=auxinput3_begin_m, S=auxinput3_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput3_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput3_end_y( grid%id, auxinput3_end_y ) - CALL nl_get_auxinput3_end_d( grid%id, auxinput3_end_d ) - CALL nl_get_auxinput3_end_h( grid%id, auxinput3_end_h ) - CALL nl_get_auxinput3_end_m( grid%id, auxinput3_end_m ) - CALL nl_get_auxinput3_end_s( grid%id, auxinput3_end_s ) - IF ( MAX( auxinput3_end_y, auxinput3_end_d, & - auxinput3_end_h, auxinput3_end_m , auxinput3_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput3_end_d, & - H=auxinput3_end_h, M=auxinput3_end_m, S=auxinput3_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput3_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT3_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT3_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT3_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -! AUXINPUT4_ INTERVAL -! auxinput4_interval is left there (and means minutes) for consistency, but -! auxinput4_interval_m will take precedence if specified - CALL nl_get_auxinput4_interval( grid%id, auxinput4_interval ) ! same as minutes - CALL nl_get_auxinput4_interval_d( grid%id, auxinput4_interval_d ) - CALL nl_get_auxinput4_interval_h( grid%id, auxinput4_interval_h ) - CALL nl_get_auxinput4_interval_m( grid%id, auxinput4_interval_m ) - CALL nl_get_auxinput4_interval_s( grid%id, auxinput4_interval_s ) - IF ( auxinput4_interval_m .EQ. 0 ) auxinput4_interval_m = auxinput4_interval - - IF ( MAX( auxinput4_interval_d, & - auxinput4_interval_h, auxinput4_interval_m , auxinput4_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput4_interval_d, & - H=auxinput4_interval_h, M=auxinput4_interval_m, S=auxinput4_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput4_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput4_begin_y( grid%id, auxinput4_begin_y ) - CALL nl_get_auxinput4_begin_d( grid%id, auxinput4_begin_d ) - CALL nl_get_auxinput4_begin_h( grid%id, auxinput4_begin_h ) - CALL nl_get_auxinput4_begin_m( grid%id, auxinput4_begin_m ) - CALL nl_get_auxinput4_begin_s( grid%id, auxinput4_begin_s ) - IF ( MAX( auxinput4_begin_y, auxinput4_begin_d, & - auxinput4_begin_h, auxinput4_begin_m , auxinput4_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput4_begin_d, & - H=auxinput4_begin_h, M=auxinput4_begin_m, S=auxinput4_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput4_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput4_end_y( grid%id, auxinput4_end_y ) - CALL nl_get_auxinput4_end_d( grid%id, auxinput4_end_d ) - CALL nl_get_auxinput4_end_h( grid%id, auxinput4_end_h ) - CALL nl_get_auxinput4_end_m( grid%id, auxinput4_end_m ) - CALL nl_get_auxinput4_end_s( grid%id, auxinput4_end_s ) - IF ( MAX( auxinput4_end_y, auxinput4_end_d, & - auxinput4_end_h, auxinput4_end_m , auxinput4_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput4_end_d, & - H=auxinput4_end_h, M=auxinput4_end_m, S=auxinput4_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput4_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT4_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT4_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT4_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -! AUXINPUT5_ INTERVAL -! auxinput5_interval is left there (and means minutes) for consistency, but -! auxinput5_interval_m will take precedence if specified - CALL nl_get_auxinput5_interval( grid%id, auxinput5_interval ) ! same as minutes - CALL nl_get_auxinput5_interval_d( grid%id, auxinput5_interval_d ) - CALL nl_get_auxinput5_interval_h( grid%id, auxinput5_interval_h ) - CALL nl_get_auxinput5_interval_m( grid%id, auxinput5_interval_m ) - CALL nl_get_auxinput5_interval_s( grid%id, auxinput5_interval_s ) - IF ( auxinput5_interval_m .EQ. 0 ) auxinput5_interval_m = auxinput5_interval - - IF ( MAX( auxinput5_interval_d, & - auxinput5_interval_h, auxinput5_interval_m , auxinput5_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput5_interval_d, & - H=auxinput5_interval_h, M=auxinput5_interval_m, S=auxinput5_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput5_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput5_begin_y( grid%id, auxinput5_begin_y ) - CALL nl_get_auxinput5_begin_d( grid%id, auxinput5_begin_d ) - CALL nl_get_auxinput5_begin_h( grid%id, auxinput5_begin_h ) - CALL nl_get_auxinput5_begin_m( grid%id, auxinput5_begin_m ) - CALL nl_get_auxinput5_begin_s( grid%id, auxinput5_begin_s ) - IF ( MAX( auxinput5_begin_y, auxinput5_begin_d, & - auxinput5_begin_h, auxinput5_begin_m , auxinput5_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput5_begin_d, & - H=auxinput5_begin_h, M=auxinput5_begin_m, S=auxinput5_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput5_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput5_end_y( grid%id, auxinput5_end_y ) - CALL nl_get_auxinput5_end_d( grid%id, auxinput5_end_d ) - CALL nl_get_auxinput5_end_h( grid%id, auxinput5_end_h ) - CALL nl_get_auxinput5_end_m( grid%id, auxinput5_end_m ) - CALL nl_get_auxinput5_end_s( grid%id, auxinput5_end_s ) - IF ( MAX( auxinput5_end_y, auxinput5_end_d, & - auxinput5_end_h, auxinput5_end_m , auxinput5_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput5_end_d, & - H=auxinput5_end_h, M=auxinput5_end_m, S=auxinput5_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput5_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT5_ALARM, interval, begin_time, end_time ) - -!TBH: Should be OK to remove the "#else" section and the code it contains -!TBH: because later code overwrites grid%alarms( AUXINPUT5_ALARM )... -!TBH: In fact, by setting namelist values for auxinput5 correctly, it ought -!TBH: to be possible to get rid of all "#ifdef WRF_CHEM" bits in this file... -#ifndef WRF_CHEM - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT5_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF -#else - CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) -#endif - - - CALL domain_alarm_create( grid, BOUNDARY_ALARM ) - - CALL WRFU_AlarmEnable( grid%alarms( BOUNDARY_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmEnable(BOUNDARY_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - CALL WRFU_AlarmRingerOn( grid%alarms( BOUNDARY_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(BOUNDARY_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - -#ifdef WRF_CHEM -! TBH: NOTE: Proper setting of namelist variables for auxinput5 ought to -! TBH: make this hard-coded bit unnecessary. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! add for wrf_chem emiss input - CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) -! end for wrf chem emiss input -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#endif - -! AUXINPUT6_ INTERVAL -! auxinput6_interval is left there (and means minutes) for consistency, but -! auxinput6_interval_m will take precedence if specified - CALL nl_get_auxinput6_interval( grid%id, auxinput6_interval ) ! same as minutes - CALL nl_get_auxinput6_interval_d( grid%id, auxinput6_interval_d ) - CALL nl_get_auxinput6_interval_h( grid%id, auxinput6_interval_h ) - CALL nl_get_auxinput6_interval_m( grid%id, auxinput6_interval_m ) - CALL nl_get_auxinput6_interval_s( grid%id, auxinput6_interval_s ) - IF ( auxinput6_interval_m .EQ. 0 ) auxinput6_interval_m = auxinput6_interval - - IF ( MAX( auxinput6_interval_d, & - auxinput6_interval_h, auxinput6_interval_m , auxinput6_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput6_interval_d, & - H=auxinput6_interval_h, M=auxinput6_interval_m, S=auxinput6_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput6_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput6_begin_y( grid%id, auxinput6_begin_y ) - CALL nl_get_auxinput6_begin_d( grid%id, auxinput6_begin_d ) - CALL nl_get_auxinput6_begin_h( grid%id, auxinput6_begin_h ) - CALL nl_get_auxinput6_begin_m( grid%id, auxinput6_begin_m ) - CALL nl_get_auxinput6_begin_s( grid%id, auxinput6_begin_s ) - IF ( MAX( auxinput6_begin_y, auxinput6_begin_d, & - auxinput6_begin_h, auxinput6_begin_m , auxinput6_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput6_begin_d, & - H=auxinput6_begin_h, M=auxinput6_begin_m, S=auxinput6_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput6_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput6_end_y( grid%id, auxinput6_end_y ) - CALL nl_get_auxinput6_end_d( grid%id, auxinput6_end_d ) - CALL nl_get_auxinput6_end_h( grid%id, auxinput6_end_h ) - CALL nl_get_auxinput6_end_m( grid%id, auxinput6_end_m ) - CALL nl_get_auxinput6_end_s( grid%id, auxinput6_end_s ) - IF ( MAX( auxinput6_end_y, auxinput6_end_d, & - auxinput6_end_h, auxinput6_end_m , auxinput6_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput6_end_d, & - H=auxinput6_end_h, M=auxinput6_end_m, S=auxinput6_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput6_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT6_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT6_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT6_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - - -! AUXINPUT7_ INTERVAL -! auxinput7_interval is left there (and means minutes) for consistency, but -! auxinput7_interval_m will take precedence if specified - CALL nl_get_auxinput7_interval( grid%id, auxinput7_interval ) ! same as minutes - CALL nl_get_auxinput7_interval_d( grid%id, auxinput7_interval_d ) - CALL nl_get_auxinput7_interval_h( grid%id, auxinput7_interval_h ) - CALL nl_get_auxinput7_interval_m( grid%id, auxinput7_interval_m ) - CALL nl_get_auxinput7_interval_s( grid%id, auxinput7_interval_s ) - IF ( auxinput7_interval_m .EQ. 0 ) auxinput7_interval_m = auxinput7_interval - - IF ( MAX( auxinput7_interval_d, & - auxinput7_interval_h, auxinput7_interval_m , auxinput7_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput7_interval_d, & - H=auxinput7_interval_h, M=auxinput7_interval_m, S=auxinput7_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput7_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput7_begin_y( grid%id, auxinput7_begin_y ) - CALL nl_get_auxinput7_begin_d( grid%id, auxinput7_begin_d ) - CALL nl_get_auxinput7_begin_h( grid%id, auxinput7_begin_h ) - CALL nl_get_auxinput7_begin_m( grid%id, auxinput7_begin_m ) - CALL nl_get_auxinput7_begin_s( grid%id, auxinput7_begin_s ) - IF ( MAX( auxinput7_begin_y, auxinput7_begin_d, & - auxinput7_begin_h, auxinput7_begin_m , auxinput7_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput7_begin_d, & - H=auxinput7_begin_h, M=auxinput7_begin_m, S=auxinput7_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput7_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput7_end_y( grid%id, auxinput7_end_y ) - CALL nl_get_auxinput7_end_d( grid%id, auxinput7_end_d ) - CALL nl_get_auxinput7_end_h( grid%id, auxinput7_end_h ) - CALL nl_get_auxinput7_end_m( grid%id, auxinput7_end_m ) - CALL nl_get_auxinput7_end_s( grid%id, auxinput7_end_s ) - IF ( MAX( auxinput7_end_y, auxinput7_end_d, & - auxinput7_end_h, auxinput7_end_m , auxinput7_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput7_end_d, & - H=auxinput7_end_h, M=auxinput7_end_m, S=auxinput7_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput7_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT7_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT7_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT7_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - - - -! AUXINPUT8_ INTERVAL -! auxinput8_interval is left there (and means minutes) for consistency, but -! auxinput8_interval_m will take precedence if specified - CALL nl_get_auxinput8_interval( grid%id, auxinput8_interval ) ! same as minutes - CALL nl_get_auxinput8_interval_d( grid%id, auxinput8_interval_d ) - CALL nl_get_auxinput8_interval_h( grid%id, auxinput8_interval_h ) - CALL nl_get_auxinput8_interval_m( grid%id, auxinput8_interval_m ) - CALL nl_get_auxinput8_interval_s( grid%id, auxinput8_interval_s ) - IF ( auxinput8_interval_m .EQ. 0 ) auxinput8_interval_m = auxinput8_interval - - IF ( MAX( auxinput8_interval_d, & - auxinput8_interval_h, auxinput8_interval_m , auxinput8_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput8_interval_d, & - H=auxinput8_interval_h, M=auxinput8_interval_m, S=auxinput8_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput8_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput8_begin_y( grid%id, auxinput8_begin_y ) - CALL nl_get_auxinput8_begin_d( grid%id, auxinput8_begin_d ) - CALL nl_get_auxinput8_begin_h( grid%id, auxinput8_begin_h ) - CALL nl_get_auxinput8_begin_m( grid%id, auxinput8_begin_m ) - CALL nl_get_auxinput8_begin_s( grid%id, auxinput8_begin_s ) - IF ( MAX( auxinput8_begin_y, auxinput8_begin_d, & - auxinput8_begin_h, auxinput8_begin_m , auxinput8_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput8_begin_d, & - H=auxinput8_begin_h, M=auxinput8_begin_m, S=auxinput8_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput8_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput8_end_y( grid%id, auxinput8_end_y ) - CALL nl_get_auxinput8_end_d( grid%id, auxinput8_end_d ) - CALL nl_get_auxinput8_end_h( grid%id, auxinput8_end_h ) - CALL nl_get_auxinput8_end_m( grid%id, auxinput8_end_m ) - CALL nl_get_auxinput8_end_s( grid%id, auxinput8_end_s ) - IF ( MAX( auxinput8_end_y, auxinput8_end_d, & - auxinput8_end_h, auxinput8_end_m , auxinput8_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput8_end_d, & - H=auxinput8_end_h, M=auxinput8_end_m, S=auxinput8_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput8_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT8_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT8_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT8_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -#if (EM_CORE == 1) - CALL nl_get_grid_sfdda( grid%id, grid_sfdda ) -#endif -! AUXINPUT9_ INTERVAL -! sgfdda_interval is left there (and means minutes) for consistency, but -! sgfdda_interval_m will take precedence if specified - CALL nl_get_sgfdda_interval( grid%id, sgfdda_interval ) ! same as minutes - CALL nl_get_sgfdda_interval_d( grid%id, sgfdda_interval_d ) - CALL nl_get_sgfdda_interval_h( grid%id, sgfdda_interval_h ) - CALL nl_get_sgfdda_interval_m( grid%id, sgfdda_interval_m ) - CALL nl_get_sgfdda_interval_s( grid%id, sgfdda_interval_s ) - IF ( sgfdda_interval_m .EQ. 0 ) sgfdda_interval_m = sgfdda_interval - - IF ( MAX( sgfdda_interval_d, & - sgfdda_interval_h, sgfdda_interval_m , sgfdda_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=sgfdda_interval_d, & - H=sgfdda_interval_h, M=sgfdda_interval_m, S=sgfdda_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(sgfdda_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF -#if (EM_CORE == 1) - IF( grid_sfdda == 0 ) interval = run_length + padding_interval -#endif - - CALL nl_get_sgfdda_begin_y( grid%id, sgfdda_begin_y ) - CALL nl_get_sgfdda_begin_d( grid%id, sgfdda_begin_d ) - CALL nl_get_sgfdda_begin_h( grid%id, sgfdda_begin_h ) - CALL nl_get_sgfdda_begin_m( grid%id, sgfdda_begin_m ) - CALL nl_get_sgfdda_begin_s( grid%id, sgfdda_begin_s ) - IF ( MAX( sgfdda_begin_y, sgfdda_begin_d, & - sgfdda_begin_h, sgfdda_begin_m , sgfdda_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=sgfdda_begin_d, & - H=sgfdda_begin_h, M=sgfdda_begin_m, S=sgfdda_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(sgfdda_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_sgfdda_end_y( grid%id, sgfdda_end_y ) - CALL nl_get_sgfdda_end_d( grid%id, sgfdda_end_d ) - CALL nl_get_sgfdda_end_h( grid%id, sgfdda_end_h ) -#if (EM_CORE == 1) - IF( grid_sfdda == 1 ) sgfdda_end_h = sgfdda_end_h - NINT( sgfdda_interval_m/60.0 ) -#endif - CALL nl_get_sgfdda_end_m( grid%id, sgfdda_end_m ) - CALL nl_get_sgfdda_end_s( grid%id, sgfdda_end_s ) - IF ( MAX( sgfdda_end_y, sgfdda_end_d, & - sgfdda_end_h, sgfdda_end_m , sgfdda_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=sgfdda_end_d, & - H=sgfdda_end_h, M=sgfdda_end_m, S=sgfdda_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(sgfdda_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF -#if (EM_CORE == 1) - IF( grid_sfdda == 0 ) end_time = run_length + padding_interval -#endif - - CALL domain_alarm_create( grid, AUXINPUT9_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT9_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT9_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -#if (EM_CORE == 1) - CALL nl_get_grid_fdda( grid%id, grid_fdda ) -#endif - -! AUXINPUT10_ INTERVAL (GFDDA) -! gfdda_interval is left there (and means minutes) for consistency, but -! gfdda_interval_m will take precedence if specified - CALL nl_get_gfdda_interval( grid%id, gfdda_interval ) ! same as minutes - CALL nl_get_gfdda_interval_d( grid%id, gfdda_interval_d ) - CALL nl_get_gfdda_interval_h( grid%id, gfdda_interval_h ) - CALL nl_get_gfdda_interval_m( grid%id, gfdda_interval_m ) - CALL nl_get_gfdda_interval_s( grid%id, gfdda_interval_s ) - IF ( gfdda_interval_m .EQ. 0 ) gfdda_interval_m = gfdda_interval - - IF ( MAX( gfdda_interval_d, & - gfdda_interval_h, gfdda_interval_m , gfdda_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=gfdda_interval_d, & - H=gfdda_interval_h, M=gfdda_interval_m, S=gfdda_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(gfdda_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF -#if (EM_CORE == 1) - IF( grid_fdda == 0 ) interval = run_length + padding_interval -#endif - - CALL nl_get_gfdda_begin_y( grid%id, gfdda_begin_y ) - CALL nl_get_gfdda_begin_d( grid%id, gfdda_begin_d ) - CALL nl_get_gfdda_begin_h( grid%id, gfdda_begin_h ) - CALL nl_get_gfdda_begin_m( grid%id, gfdda_begin_m ) - CALL nl_get_gfdda_begin_s( grid%id, gfdda_begin_s ) - IF ( MAX( gfdda_begin_y, gfdda_begin_d, & - gfdda_begin_h, gfdda_begin_m , gfdda_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=gfdda_begin_d, & - H=gfdda_begin_h, M=gfdda_begin_m, S=gfdda_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(gfdda_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_gfdda_end_y( grid%id, gfdda_end_y ) - CALL nl_get_gfdda_end_d( grid%id, gfdda_end_d ) - CALL nl_get_gfdda_end_h( grid%id, gfdda_end_h ) -#if (EM_CORE == 1) - IF( grid_fdda >= 1 ) gfdda_end_h = gfdda_end_h - NINT( gfdda_interval_m/60.0 ) -#endif - CALL nl_get_gfdda_end_m( grid%id, gfdda_end_m ) - CALL nl_get_gfdda_end_s( grid%id, gfdda_end_s ) - IF ( MAX( gfdda_end_y, gfdda_end_d, & - gfdda_end_h, gfdda_end_m , gfdda_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=gfdda_end_d, & - H=gfdda_end_h, M=gfdda_end_m, S=gfdda_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(gfdda_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF -#if (EM_CORE == 1) - IF( grid_fdda == 0 ) end_time = run_length + padding_interval -#endif - - CALL domain_alarm_create( grid, AUXINPUT10_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT10_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT10_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -! AUXINPUT11_ INTERVAL -! auxinput11_interval is left there (and means minutes) for consistency, but -! auxinput11_interval_m will take precedence if specified - CALL nl_get_auxinput11_interval( grid%id, auxinput11_interval ) ! same as minutes - CALL nl_get_auxinput11_interval_d( grid%id, auxinput11_interval_d ) - CALL nl_get_auxinput11_interval_h( grid%id, auxinput11_interval_h ) - CALL nl_get_auxinput11_interval_m( grid%id, auxinput11_interval_m ) - CALL nl_get_auxinput11_interval_s( grid%id, auxinput11_interval_s ) - IF ( auxinput11_interval_m .EQ. 0 ) auxinput11_interval_m = auxinput11_interval - - IF ( MAX( auxinput11_interval_d, & - auxinput11_interval_h, auxinput11_interval_m , auxinput11_interval_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( interval, D=auxinput11_interval_d, & - H=auxinput11_interval_h, M=auxinput11_interval_m, S=auxinput11_interval_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput11_interval) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - interval = run_length + padding_interval - ENDIF - - CALL nl_get_auxinput11_begin_y( grid%id, auxinput11_begin_y ) - CALL nl_get_auxinput11_begin_d( grid%id, auxinput11_begin_d ) - CALL nl_get_auxinput11_begin_h( grid%id, auxinput11_begin_h ) - CALL nl_get_auxinput11_begin_m( grid%id, auxinput11_begin_m ) - CALL nl_get_auxinput11_begin_s( grid%id, auxinput11_begin_s ) - IF ( MAX( auxinput11_begin_y, auxinput11_begin_d, & - auxinput11_begin_h, auxinput11_begin_m , auxinput11_begin_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( begin_time , D=auxinput11_begin_d, & - H=auxinput11_begin_h, M=auxinput11_begin_m, S=auxinput11_begin_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput11_begin) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - begin_time = zero_time - ENDIF - - CALL nl_get_auxinput11_end_y( grid%id, auxinput11_end_y ) - CALL nl_get_auxinput11_end_d( grid%id, auxinput11_end_d ) - CALL nl_get_auxinput11_end_h( grid%id, auxinput11_end_h ) - CALL nl_get_auxinput11_end_m( grid%id, auxinput11_end_m ) - CALL nl_get_auxinput11_end_s( grid%id, auxinput11_end_s ) - IF ( MAX( auxinput11_end_y, auxinput11_end_d, & - auxinput11_end_h, auxinput11_end_m , auxinput11_end_s ) .GT. 0 ) THEN - CALL WRFU_TimeIntervalSet( end_time , D=auxinput11_end_d, & - H=auxinput11_end_h, M=auxinput11_end_m, S=auxinput11_end_s, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(auxinput11_end) FAILED', & - __FILE__ , & - __LINE__ ) - ELSE - end_time = run_length + padding_interval - ENDIF - - CALL domain_alarm_create( grid, AUXINPUT11_ALARM, interval, begin_time, end_time ) - - IF ( interval .NE. run_length + padding_interval .AND. begin_time .EQ. zero_time ) THEN - CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT11_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(AUXINPUT11_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - ENDIF - -! This is the interval at which the code in time_for_move in share/mediation_integrate.F -! will recompute the center of the Vortex. Other times, it will use the last position. -! - vortex_interval = 0 -#ifdef MOVE_NESTS - CALL nl_get_vortex_interval ( grid%id , vortex_interval ) -#endif - CALL WRFU_TimeIntervalSet( interval, M=vortex_interval, rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_TimeIntervalSet(interval) for computing vortex center FAILED', & - __FILE__ , & - __LINE__ ) - CALL domain_alarm_create( grid, COMPUTE_VORTEX_CENTER_ALARM, interval ) -#ifdef MOVE_NESTS - CALL WRFU_AlarmEnable( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmEnable(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) - CALL WRFU_AlarmRingerOn( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmRingerOn(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) -#else -! Go ahead and let the alarm be defined, but disable it, since we are not using moving nests here. - CALL WRFU_AlarmDisable( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) - CALL wrf_check_error( WRFU_SUCCESS, rc, & - 'WRFU_AlarmDisable(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & - __FILE__ , & - __LINE__ ) -#endif - - grid%time_set = .TRUE. - - ! Initialize derived time quantities in grid state. - ! These are updated in domain_clockadvance(). - CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime ) - CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian ) - WRITE(wrf_err_message,*) 'setup_timekeeping: set xtime to ',grid%xtime - CALL wrf_debug ( 100, TRIM(wrf_err_message) ) - WRITE(wrf_err_message,*) 'setup_timekeeping: set julian to ',grid%julian - CALL wrf_debug ( 100, TRIM(wrf_err_message) ) - - CALL wrf_debug ( 100 , 'setup_timekeeping: returning...' ) - -END SUBROUTINE Setup_Timekeeping - - +SUBROUTINE Setup_Timekeeping ( grid ) + USE module_domain + USE module_configure + USE module_utility + IMPLICIT NONE + TYPE(domain), POINTER :: grid +! Local + TYPE(WRFU_TimeInterval) :: begin_time, end_time, zero_time, one_minute, one_hour, padding_interval + TYPE(WRFU_TimeInterval) :: interval, run_length, dfl_length + TYPE(WRFU_Time) :: startTime, stopTime, initialTime + TYPE(WRFU_TimeInterval) :: stepTime + TYPE(WRFU_TimeInterval) :: tmp_step + INTEGER :: start_year,start_month,start_day,start_hour,start_minute,start_second + INTEGER :: end_year,end_month,end_day,end_hour,end_minute,end_second + INTEGER :: vortex_interval +#ifdef HWRF +!zhang's doing + real (kind=8) :: day_in_sec + REAL :: tstart +!end of zhang's doing +#endif + +#if (EM_CORE == 1) + INTEGER :: dfi_fwdstop_year,dfi_fwdstop_month,dfi_fwdstop_day,dfi_fwdstop_hour,dfi_fwdstop_minute,dfi_fwdstop_second + INTEGER :: dfi_bckstop_year,dfi_bckstop_month,dfi_bckstop_day,dfi_bckstop_hour,dfi_bckstop_minute,dfi_bckstop_second +#endif + + INTEGER :: restart_interval_d + INTEGER :: inputout_interval_d + INTEGER :: inputout_begin_y + INTEGER :: inputout_end_y + INTEGER :: inputout_begin_m + INTEGER :: inputout_begin_s + INTEGER :: inputout_begin_d + INTEGER :: inputout_begin_h + INTEGER :: inputout_end_m + INTEGER :: inputout_end_s + INTEGER :: inputout_end_d + INTEGER :: inputout_end_h + INTEGER :: restart_interval_m + INTEGER :: restart_interval_s + INTEGER :: restart_interval + INTEGER :: restart_interval_h + INTEGER :: inputout_interval_m + INTEGER :: inputout_interval_s + INTEGER :: inputout_interval + INTEGER :: inputout_interval_h + +# include "set_timekeeping_defs.inc" + + INTEGER :: grid_fdda, grid_sfdda + + INTEGER :: run_days, run_hours, run_minutes, run_seconds + INTEGER :: time_step, time_step_fract_num, time_step_fract_den + INTEGER :: rc + REAL :: dt + + CALL WRFU_TimeIntervalSet ( zero_time, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(zero_time) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeIntervalSet ( one_minute, M=1, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(one_minute) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_TimeIntervalSet ( one_hour, H=1, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(one_hour) FAILED', & + __FILE__ , & + __LINE__ ) + +#if (EM_CORE == 1) + IF ( (grid%dfi_opt .EQ. DFI_NODFI) .OR. (grid%dfi_stage .EQ. DFI_SETUP) ) THEN +#endif + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) +#ifdef HWRF +!zhang's doing - check with zhan before adding this bit +! CALL nl_get_tstart ( grid%id , tstart ) +! CALL jdn_sec(day_in_sec,start_year,start_month,start_day,start_hour,start_minute,start_second) +! day_in_sec = day_in_sec + tstart*3600. +! CALL jdn_ymd_hms(day_in_sec,start_year,start_month,start_day,start_hour,start_minute,start_second) +!end of zhang's doing +#endif + CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet(startTime) FAILED', & + __FILE__ , & + __LINE__ ) +#if (EM_CORE == 1) + ELSE + IF ( grid%dfi_opt .EQ. DFI_DFL ) THEN + IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + ELSE IF ( grid%dfi_stage .EQ. DFI_FST ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + + run_length = grid%stop_subtime - grid%start_subtime + CALL WRFU_TimeIntervalGet( run_length, S=run_seconds, rc=rc ) +! What about fractional seconds? + run_seconds = run_seconds / 2 + CALL WRFU_TimeIntervalSet ( run_length, S=run_seconds, rc=rc ) + CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + startTime = startTime + run_length + CALL WRFU_TimeGet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + END IF + + ELSE IF ( grid%dfi_opt .EQ. DFI_DDFI ) THEN + IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN + CALL nl_get_dfi_bckstop_year(grid%id,start_year) + CALL nl_get_dfi_bckstop_month(grid%id,start_month) + CALL nl_get_dfi_bckstop_day(grid%id,start_day) + CALL nl_get_dfi_bckstop_hour(grid%id,start_hour) + CALL nl_get_dfi_bckstop_minute(grid%id,start_minute) + CALL nl_get_dfi_bckstop_second(grid%id,start_second) + ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + ELSE IF ( grid%dfi_stage .EQ. DFI_FST ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + END IF + + ELSE IF ( grid%dfi_opt .EQ. DFI_TDFI ) THEN + IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN + CALL nl_get_dfi_bckstop_year(grid%id,start_year) + CALL nl_get_dfi_bckstop_month(grid%id,start_month) + CALL nl_get_dfi_bckstop_day(grid%id,start_day) + CALL nl_get_dfi_bckstop_hour(grid%id,start_hour) + CALL nl_get_dfi_bckstop_minute(grid%id,start_minute) + CALL nl_get_dfi_bckstop_second(grid%id,start_second) + + run_length = grid%start_subtime - grid%stop_subtime + CALL WRFU_TimeIntervalGet( run_length, S=run_seconds, rc=rc ) +! What about fractional seconds? + run_seconds = run_seconds / 2 + CALL WRFU_TimeIntervalSet ( run_length, S=run_seconds, rc=rc ) + CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + startTime = startTime + run_length + CALL WRFU_TimeGet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + ELSE IF ( grid%dfi_stage .EQ. DFI_FST ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + END IF + END IF + CALL WRFU_TimeSet(startTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet(startTime) FAILED', & + __FILE__ , & + __LINE__ ) + END IF +#endif + + CALL nl_get_run_days(1,run_days) + CALL nl_get_run_hours(1,run_hours) + CALL nl_get_run_minutes(1,run_minutes) + CALL nl_get_run_seconds(1,run_seconds) + +#if (EM_CORE == 1) + IF ( (grid%dfi_opt .EQ. DFI_NODFI) .OR. (grid%dfi_stage .EQ. DFI_SETUP) .OR. (grid%dfi_stage .EQ. DFI_FST)) THEN +#endif + + IF ( grid%id .EQ. head_grid%id .AND. & + ( run_days .gt. 0 .or. run_hours .gt. 0 .or. run_minutes .gt. 0 .or. run_seconds .gt. 0 )) THEN + CALL WRFU_TimeIntervalSet ( run_length , D=run_days, H=run_hours, M=run_minutes, S=run_seconds, rc=rc ) +#if (EM_CORE == 1) + IF ( grid%dfi_stage .EQ. DFI_FST .AND. grid%dfi_opt .EQ. DFI_DFL ) THEN + CALL nl_get_start_year(grid%id,start_year) + CALL nl_get_start_month(grid%id,start_month) + CALL nl_get_start_day(grid%id,start_day) + CALL nl_get_start_hour(grid%id,start_hour) + CALL nl_get_start_minute(grid%id,start_minute) + CALL nl_get_start_second(grid%id,start_second) + CALL WRFU_TimeSet(initialTime, YY=start_year, MM=start_month, DD=start_day, & + H=start_hour, M=start_minute, S=start_second,& + rc=rc) + dfl_length = startTime - initialTime + run_length = run_length - dfl_length + END IF +#endif + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(run_length) FAILED', & + __FILE__ , & + __LINE__ ) + stopTime = startTime + run_length + ELSE + CALL nl_get_end_year(grid%id,end_year) + CALL nl_get_end_month(grid%id,end_month) + CALL nl_get_end_day(grid%id,end_day) + CALL nl_get_end_hour(grid%id,end_hour) + CALL nl_get_end_minute(grid%id,end_minute) + CALL nl_get_end_second(grid%id,end_second) + CALL WRFU_TimeSet(stopTime, YY=end_year, MM=end_month, DD=end_day, & + H=end_hour, M=end_minute, S=end_second,& + rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet(stopTime) FAILED', & + __FILE__ , & + __LINE__ ) + run_length = stopTime - startTime + ENDIF + +#if (EM_CORE == 1) + ELSE + + IF ( grid%dfi_opt .EQ. DFI_DFL ) THEN + IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN + CALL nl_get_dfi_fwdstop_year(grid%id,end_year) + CALL nl_get_dfi_fwdstop_month(grid%id,end_month) + CALL nl_get_dfi_fwdstop_day(grid%id,end_day) + CALL nl_get_dfi_fwdstop_hour(grid%id,end_hour) + CALL nl_get_dfi_fwdstop_minute(grid%id,end_minute) + CALL nl_get_dfi_fwdstop_second(grid%id,end_second) + END IF + + ELSE IF ( grid%dfi_opt .EQ. DFI_DDFI ) THEN + IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN + CALL nl_get_dfi_fwdstop_year(grid%id,end_year) + CALL nl_get_dfi_fwdstop_month(grid%id,end_month) + CALL nl_get_dfi_fwdstop_day(grid%id,end_day) + CALL nl_get_dfi_fwdstop_hour(grid%id,end_hour) + CALL nl_get_dfi_fwdstop_minute(grid%id,end_minute) + CALL nl_get_dfi_fwdstop_second(grid%id,end_second) + ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN + CALL nl_get_dfi_bckstop_year(grid%id,end_year) + CALL nl_get_dfi_bckstop_month(grid%id,end_month) + CALL nl_get_dfi_bckstop_day(grid%id,end_day) + CALL nl_get_dfi_bckstop_hour(grid%id,end_hour) + CALL nl_get_dfi_bckstop_minute(grid%id,end_minute) + CALL nl_get_dfi_bckstop_second(grid%id,end_second) + END IF + + ELSE IF ( grid%dfi_opt .EQ. DFI_TDFI ) THEN + IF ( grid%dfi_stage .EQ. DFI_FWD ) THEN + CALL nl_get_dfi_fwdstop_year(grid%id,end_year) + CALL nl_get_dfi_fwdstop_month(grid%id,end_month) + CALL nl_get_dfi_fwdstop_day(grid%id,end_day) + CALL nl_get_dfi_fwdstop_hour(grid%id,end_hour) + CALL nl_get_dfi_fwdstop_minute(grid%id,end_minute) + CALL nl_get_dfi_fwdstop_second(grid%id,end_second) + ELSE IF ( grid%dfi_stage .EQ. DFI_BCK ) THEN + CALL nl_get_dfi_bckstop_year(grid%id,end_year) + CALL nl_get_dfi_bckstop_month(grid%id,end_month) + CALL nl_get_dfi_bckstop_day(grid%id,end_day) + CALL nl_get_dfi_bckstop_hour(grid%id,end_hour) + CALL nl_get_dfi_bckstop_minute(grid%id,end_minute) + CALL nl_get_dfi_bckstop_second(grid%id,end_second) + END IF + END IF + CALL WRFU_TimeSet(stopTime, YY=end_year, MM=end_month, DD=end_day, & + H=end_hour, M=end_minute, S=end_second,& + rc=rc) + + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeSet(dfistopfwdTime) FAILED', & + __FILE__ , & + __LINE__ ) + + run_length = stopTime - startTime + + END IF +#endif + + IF ( run_length .GT. zero_time ) THEN + padding_interval = one_hour + ELSE + padding_interval = zero_time - one_hour + ENDIF + + IF ( grid%id .EQ. head_grid%id ) THEN + CALL nl_get_time_step ( 1, time_step ) + CALL nl_get_time_step_fract_num( 1, time_step_fract_num ) + CALL nl_get_time_step_fract_den( 1, time_step_fract_den ) + dt = real(time_step) + real(time_step_fract_num) / real(time_step_fract_den) +#ifdef PLANET + ! 2004-12-08 ADT notes: + ! We have gotten the timestep from integers in the namelist, and they have just + ! been converted to the timestep, "dt", used by the physics code just above. + ! After this point, the integers are only used to update the clock used for, + ! and we want to leave that on a "24-hour" type schedule, so we don't need to + ! modify those integers. Theoretically they refer to a portion of the planet's + ! solar day. The only thing we have to do is convert the *real* timestep, dt, + ! to useful SI units. This is easily accomplished by multiplying it by the + ! variable P2SI, which was designed for just this purpose. After multiplication, + ! make sure every subsequent part of the model knows what the value is. + dt = dt * P2SI +#endif + CALL nl_set_dt( grid%id, dt ) + grid%dt = dt + CALL WRFU_TimeIntervalSet(stepTime, S=time_step, Sn=time_step_fract_num, Sd=time_step_fract_den, rc=rc) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(stepTime) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + tmp_step = domain_get_time_step( grid%parents(1)%ptr ) + stepTime = domain_get_time_step( grid%parents(1)%ptr ) / & + grid%parent_time_step_ratio + grid%dt = grid%parents(1)%ptr%dt / grid%parent_time_step_ratio + CALL nl_set_dt( grid%id, grid%dt ) + ENDIF + + ! create grid%domain_clock and associated state + CALL domain_clock_create( grid, TimeStep= stepTime, & + StartTime=startTime, & + StopTime= stopTime ) + CALL domain_clockprint ( 150, grid, & + 'DEBUG setup_timekeeping(): clock after creation,' ) + + ! Set default value for SIMULATION_START_DATE. + ! This is overwritten later in input_wrf(), if needed. + IF ( grid%id .EQ. head_grid%id ) THEN + CALL nl_set_simulation_start_year ( 1 , start_year ) + CALL nl_set_simulation_start_month ( 1 , start_month ) + CALL nl_set_simulation_start_day ( 1 , start_day ) + CALL nl_set_simulation_start_hour ( 1 , start_hour ) + CALL nl_set_simulation_start_minute ( 1 , start_minute ) + CALL nl_set_simulation_start_second ( 1 , start_second ) + ENDIF + +#include "set_timekeeping_alarms.inc" + +! RESTART INTERVAL +! restart_interval is left there (and means minutes) for consistency, but +! restart_interval_m will take precedence if specified + CALL nl_get_restart_interval( 1, restart_interval ) ! same as minutes + CALL nl_get_restart_interval_d( 1, restart_interval_d ) + CALL nl_get_restart_interval_h( 1, restart_interval_h ) + CALL nl_get_restart_interval_m( 1, restart_interval_m ) + CALL nl_get_restart_interval_s( 1, restart_interval_s ) + IF ( restart_interval_m .EQ. 0 ) restart_interval_m = restart_interval + IF ( MAX( restart_interval_d, & + restart_interval_h, restart_interval_m , restart_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, D=restart_interval_d, & + H=restart_interval_h, M=restart_interval_m, S=restart_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(restart_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + CALL domain_alarm_create( grid, RESTART_ALARM, interval ) + +! INPUTOUT INTERVAL + CALL nl_get_inputout_interval( grid%id, inputout_interval ) ! same as minutes + CALL nl_get_inputout_interval_d( grid%id, inputout_interval_d ) + CALL nl_get_inputout_interval_h( grid%id, inputout_interval_h ) + CALL nl_get_inputout_interval_m( grid%id, inputout_interval_m ) + CALL nl_get_inputout_interval_s( grid%id, inputout_interval_s ) + IF ( inputout_interval_m .EQ. 0 ) inputout_interval_m = inputout_interval + + IF ( MAX( inputout_interval_d, & + inputout_interval_h, inputout_interval_m , inputout_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, D=inputout_interval_d, & + H=inputout_interval_h, M=inputout_interval_m, S=inputout_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(inputout_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_inputout_begin_y( grid%id, inputout_begin_y ) + CALL nl_get_inputout_begin_d( grid%id, inputout_begin_d ) + CALL nl_get_inputout_begin_h( grid%id, inputout_begin_h ) + CALL nl_get_inputout_begin_m( grid%id, inputout_begin_m ) + CALL nl_get_inputout_begin_s( grid%id, inputout_begin_s ) + IF ( MAX( inputout_begin_y, inputout_begin_d, & + inputout_begin_h, inputout_begin_m , inputout_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , D=inputout_begin_d, & + H=inputout_begin_h, M=inputout_begin_m, S=inputout_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(inputout_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + + CALL nl_get_inputout_end_y( grid%id, inputout_end_y ) + CALL nl_get_inputout_end_d( grid%id, inputout_end_d ) + CALL nl_get_inputout_end_h( grid%id, inputout_end_h ) + CALL nl_get_inputout_end_m( grid%id, inputout_end_m ) + CALL nl_get_inputout_end_s( grid%id, inputout_end_s ) + IF ( MAX( inputout_end_y, inputout_end_d, & + inputout_end_h, inputout_end_m , inputout_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , D=inputout_end_d, & + H=inputout_end_h, M=inputout_end_m, S=inputout_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(inputout_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + + CALL domain_alarm_create( grid, INPUTOUT_ALARM, interval, begin_time, end_time ) + +#ifdef WRF_CHEM +! AUXINPUT5_ INTERVAL +! auxinput5_interval is left there (and means minutes) for consistency, but +! auxinput5_interval_m will take precedence if specified + CALL nl_get_auxinput5_interval( grid%id, auxinput5_interval ) ! same as minutes + CALL nl_get_auxinput5_interval_d( grid%id, auxinput5_interval_d ) + CALL nl_get_auxinput5_interval_h( grid%id, auxinput5_interval_h ) + CALL nl_get_auxinput5_interval_m( grid%id, auxinput5_interval_m ) + CALL nl_get_auxinput5_interval_s( grid%id, auxinput5_interval_s ) + IF ( auxinput5_interval_m .EQ. 0 ) auxinput5_interval_m = auxinput5_interval + + IF ( MAX( auxinput5_interval_d, & + auxinput5_interval_h, auxinput5_interval_m , auxinput5_interval_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( interval, D=auxinput5_interval_d, & + H=auxinput5_interval_h, M=auxinput5_interval_m, S=auxinput5_interval_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput5_interval) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + interval = run_length + padding_interval + ENDIF + + CALL nl_get_auxinput5_begin_y( grid%id, auxinput5_begin_y ) + CALL nl_get_auxinput5_begin_d( grid%id, auxinput5_begin_d ) + CALL nl_get_auxinput5_begin_h( grid%id, auxinput5_begin_h ) + CALL nl_get_auxinput5_begin_m( grid%id, auxinput5_begin_m ) + CALL nl_get_auxinput5_begin_s( grid%id, auxinput5_begin_s ) + IF ( MAX( auxinput5_begin_y, auxinput5_begin_d, & + auxinput5_begin_h, auxinput5_begin_m , auxinput5_begin_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( begin_time , D=auxinput5_begin_d, & + H=auxinput5_begin_h, M=auxinput5_begin_m, S=auxinput5_begin_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput5_begin) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + begin_time = zero_time + ENDIF + CALL nl_get_auxinput5_end_y( grid%id, auxinput5_end_y ) + CALL nl_get_auxinput5_end_d( grid%id, auxinput5_end_d ) + CALL nl_get_auxinput5_end_h( grid%id, auxinput5_end_h ) + CALL nl_get_auxinput5_end_m( grid%id, auxinput5_end_m ) + CALL nl_get_auxinput5_end_s( grid%id, auxinput5_end_s ) + IF ( MAX( auxinput5_end_y, auxinput5_end_d, & + auxinput5_end_h, auxinput5_end_m , auxinput5_end_s ) .GT. 0 ) THEN + CALL WRFU_TimeIntervalSet( end_time , D=auxinput5_end_d, & + H=auxinput5_end_h, M=auxinput5_end_m, S=auxinput5_end_s, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(auxinput5_end) FAILED', & + __FILE__ , & + __LINE__ ) + ELSE + end_time = run_length + padding_interval + ENDIF + CALL domain_alarm_create( grid, AUXINPUT5_ALARM, interval, begin_time, end_time ) +!TBH: Should be OK to remove the "#else" section and the code it contains +!TBH: because later code overwrites grid%alarms( AUXINPUT5_ALARM )... +!TBH: In fact, by setting namelist values for auxinput5 correctly, it ought +!TBH: to be possible to get rid of all "#ifdef WRF_CHEM" bits in this file... + CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) +! TBH: NOTE: Proper setting of namelist variables for auxinput5 ought to +! TBH: make this hard-coded bit unnecessary. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! add for wrf_chem emiss input + CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) + CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) +! end for wrf chem emiss input +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#endif + + CALL domain_alarm_create( grid, BOUNDARY_ALARM ) + CALL WRFU_AlarmEnable( grid%alarms( BOUNDARY_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmEnable(BOUNDARY_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_AlarmRingerOn( grid%alarms( BOUNDARY_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(BOUNDARY_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + +! This is the interval at which the code in time_for_move in share/mediation_integrate.F +! will recompute the center of the Vortex. Other times, it will use the last position. +! + vortex_interval = 0 +#ifdef MOVE_NESTS + CALL nl_get_vortex_interval ( grid%id , vortex_interval ) +#endif + CALL WRFU_TimeIntervalSet( interval, M=vortex_interval, rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_TimeIntervalSet(interval) for computing vortex center FAILED', & + __FILE__ , & + __LINE__ ) + CALL domain_alarm_create( grid, COMPUTE_VORTEX_CENTER_ALARM, interval ) +#ifdef MOVE_NESTS + CALL WRFU_AlarmEnable( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmEnable(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) + CALL WRFU_AlarmRingerOn( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmRingerOn(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) +#else +! Go ahead and let the alarm be defined, but disable it, since we are not using moving nests here. + CALL WRFU_AlarmDisable( grid%alarms( COMPUTE_VORTEX_CENTER_ALARM ), rc=rc ) + CALL wrf_check_error( WRFU_SUCCESS, rc, & + 'WRFU_AlarmDisable(COMPUTE_VORTEX_CENTER_ALARM) FAILED', & + __FILE__ , & + __LINE__ ) +#endif + + grid%time_set = .TRUE. + + ! Initialize derived time quantities in grid state. + ! These are updated in domain_clockadvance(). + CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime ) + CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian ) + WRITE(wrf_err_message,*) 'setup_timekeeping: set xtime to ',grid%xtime + CALL wrf_debug ( 100, TRIM(wrf_err_message) ) + WRITE(wrf_err_message,*) 'setup_timekeeping: set julian to ',grid%julian + CALL wrf_debug ( 100, TRIM(wrf_err_message) ) + + CALL wrf_debug ( 100 , 'setup_timekeeping: returning...' ) + +END SUBROUTINE Setup_Timekeeping + + diff --git a/wrfv2_fire/share/solve_interface.F b/wrfv2_fire/share/solve_interface.F index dbced419..334c5032 100644 --- a/wrfv2_fire/share/solve_interface.F +++ b/wrfv2_fire/share/solve_interface.F @@ -55,7 +55,7 @@ SUBROUTINE solve_interface ( grid ) #if (NMM_CORE == 1) CALL solve_nmm ( grid , config_flags & ! -# include +# include ! ) # ifdef WRF_CHEM @@ -72,7 +72,7 @@ SUBROUTINE solve_interface ( grid ) #if (COAMPS_CORE == 1) CALL solve_coamps ( grid , config_flags & ! -# include +# include ! ) #endif diff --git a/wrfv2_fire/share/solve_nmm.int b/wrfv2_fire/share/solve_nmm.int index 631398af..c09e8509 100644 --- a/wrfv2_fire/share/solve_nmm.int +++ b/wrfv2_fire/share/solve_nmm.int @@ -1,7 +1,7 @@ SUBROUTINE solve_nmm ( grid , config_flags & ! -#include +#include ! ) @@ -13,7 +13,7 @@ SUBROUTINE solve_nmm ( grid , config_flags & TYPE(domain) , INTENT(INOUT) :: grid TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags -#include +#include END SUBROUTINE solve_nmm diff --git a/wrfv2_fire/share/start_domain.F b/wrfv2_fire/share/start_domain.F index d9e65dac..9c303806 100644 --- a/wrfv2_fire/share/start_domain.F +++ b/wrfv2_fire/share/start_domain.F @@ -21,10 +21,12 @@ SUBROUTINE start_domain ( grid , allowed_to_read ) #if (NMM_CORE == 1) # include "start_domain_nmm.int" #endif +#if (DA_CORE != 1) SUBROUTINE calc_ts_locations( grid ) USE module_domain TYPE (domain) :: grid END SUBROUTINE calc_ts_locations +#endif END INTERFACE CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) @@ -39,19 +41,21 @@ SUBROUTINE start_domain ( grid , allowed_to_read ) #if (NMM_CORE == 1) CALL start_domain_nmm( grid, allowed_to_read & ! -# include +# include ! ) #endif #if (COAMPS_CORE == 1) CALL start_domain_coamps( grid, allowed_to_read & ! -# include +# include ! ) #endif +#if (DA_CORE != 1) CALL calc_ts_locations( grid ) +#endif END SUBROUTINE start_domain diff --git a/wrfv2_fire/share/start_domain_nmm.int b/wrfv2_fire/share/start_domain_nmm.int index da95b9d6..c17249b7 100644 --- a/wrfv2_fire/share/start_domain_nmm.int +++ b/wrfv2_fire/share/start_domain_nmm.int @@ -1,6 +1,6 @@ SUBROUTINE start_domain_nmm ( grid, allowed_to_read & ! -# include +# include ! ) USE module_domain diff --git a/wrfv2_fire/share/wrf_ext_read_field.F b/wrfv2_fire/share/wrf_ext_read_field.F index 0127a127..500e7221 100644 --- a/wrfv2_fire/share/wrf_ext_read_field.F +++ b/wrfv2_fire/share/wrf_ext_read_field.F @@ -1,4 +1,76 @@ !WRF:MEDIATION:IO + + SUBROUTINE wrf_ext_read_field_arr(DataHandle,DateStr,Var & + ,Field & + ,idx4, idx5, idx6, idx7 & + ,nx4 , nx5 , nx6 & + ,TypeSizeInBytes & + ,FieldType,Comm,IOComm & + ,DomainDesc & + ,bdy_mask & + ,MemoryOrder & + ,Stagger & + ,debug_message & + ,ds1, de1, ds2, de2, ds3, de3 & + ,ms1, me1, ms2, me2, ms3, me3 & + ,ps1, pe1, ps2, pe2, ps3, pe3, Status ) + USE module_io + USE module_wrf_error + USE module_state_description + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: idx4, idx5, idx6, idx7 + INTEGER, INTENT(IN) :: nx4 , nx5 , nx6 + INTEGER, INTENT(IN) :: TypeSizeInBytes + INTEGER ,INTENT(IN ) :: DataHandle + CHARACTER*(*) ,INTENT(IN ) :: DateStr + CHARACTER*(*) ,INTENT(IN ) :: Var + INTEGER ,INTENT(INOUT) :: Field(*) + INTEGER ,INTENT(IN ) :: FieldType + INTEGER ,INTENT(IN ) :: Comm + INTEGER ,INTENT(IN ) :: IOComm + INTEGER ,INTENT(IN ) :: DomainDesc + CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder + LOGICAL, DIMENSION(4) ,INTENT(IN ) :: bdy_mask + CHARACTER*(*) ,INTENT(IN ) :: Stagger + CHARACTER*(*) ,INTENT(IN ) :: debug_message + + INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3 + INTEGER , INTENT(INOUT) :: Status +! Local + INTEGER tsfac ! Type size factor + CHARACTER*256 mess + + tsfac = TypeSizeInBytes / IWORDSIZE + + IF ( tsfac .LE. 0 ) THEN + CALL wrf_message('wrf_ext_read_field_arr') + WRITE(mess,*)'Internal error: email this message to wrfhelp@ucar.edu ',TypeSizeInBytes,IWORDSIZE + CALL wrf_error_fatal(mess) + ENDIF + + CALL wrf_ext_read_field( DataHandle,DateStr,Var & + ,Field(1 & + +tsfac*(0 & + +(idx4-1)*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & + +(idx5-1)*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & + +(idx6-1)*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & + +(idx7-1)*nx6*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1))) & + ,FieldType,Comm,IOComm & + ,DomainDesc & + ,bdy_mask & + ,MemoryOrder & + ,Stagger & + ,debug_message & + ,ds1, de1, ds2, de2, ds3, de3 & + ,ms1, me1, ms2, me2, ms3, me3 & + ,ps1, pe1, ps2, pe2, ps3, pe3, Status ) + + END SUBROUTINE wrf_ext_read_field_arr + SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & DomainDesc, bdy_mask, MemoryOrder,Stagger, & debug_message , & diff --git a/wrfv2_fire/share/wrf_ext_write_field.F b/wrfv2_fire/share/wrf_ext_write_field.F index 4d48aafa..12e362fd 100644 --- a/wrfv2_fire/share/wrf_ext_write_field.F +++ b/wrfv2_fire/share/wrf_ext_write_field.F @@ -1,4 +1,85 @@ !WRF:MEDIATION:IO + SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var & + ,Field & + ,idx4, idx5, idx6, idx7 & + ,nx4 , nx5 , nx6 & + ,TypeSizeInBytes & + ,FieldType,Comm,IOComm & + ,DomainDesc & + ,bdy_mask & + ,dryrun & + ,MemoryOrder & + ,Stagger & + ,Dimname1, Dimname2, Dimname3 & + ,Desc, Units & + ,debug_message & + ,ds1, de1, ds2, de2, ds3, de3 & + ,ms1, me1, ms2, me2, ms3, me3 & + ,ps1, pe1, ps2, pe2, ps3, pe3, Status ) + USE module_io + USE module_wrf_error + USE module_state_description + USE module_timing + IMPLICIT NONE + + INTEGER, INTENT(IN) :: idx4, idx5, idx6, idx7 + INTEGER, INTENT(IN) :: nx4 , nx5 , nx6 + INTEGER, INTENT(IN) :: TypeSizeInBytes + INTEGER ,INTENT(IN ) :: DataHandle + CHARACTER*(*) ,INTENT(IN ) :: DateStr + CHARACTER*(*) ,INTENT(IN ) :: Var + INTEGER ,INTENT(IN ) :: Field(*) + INTEGER ,INTENT(IN ) :: FieldType + INTEGER ,INTENT(IN ) :: Comm + INTEGER ,INTENT(IN ) :: IOComm + INTEGER ,INTENT(IN ) :: DomainDesc + LOGICAL ,INTENT(IN ) :: dryrun + CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder + LOGICAL, DIMENSION(4) ,INTENT(IN ) :: bdy_mask + CHARACTER*(*) ,INTENT(IN ) :: Stagger + CHARACTER*(*) ,INTENT(IN ) :: Dimname1, Dimname2, Dimname3 + CHARACTER*(*) ,INTENT(IN ) :: Desc, Units + CHARACTER*(*) ,INTENT(IN ) :: debug_message + + INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3 + INTEGER , INTENT(INOUT) :: Status +! Local + INTEGER tsfac ! Type size factor + CHARACTER*256 mess + + tsfac = TypeSizeInBytes / IWORDSIZE + + IF ( tsfac .LE. 0 ) THEN + CALL wrf_message('wrf_ext_write_field_arr') + WRITE(mess,*)'Internal error: email this message to wrfhelp@ucar.edu ',TypeSizeInBytes,IWORDSIZE + CALL wrf_error_fatal(mess) + ENDIF + + CALL wrf_ext_write_field( DataHandle,DateStr,Var & + ,Field(1 & + +tsfac*(0 & + +(idx4-1)*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & + +(idx5-1)*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & + +(idx6-1)*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & + +(idx7-1)*nx6*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1))) & + ,FieldType,Comm,IOComm & + ,DomainDesc & + ,bdy_mask & + ,dryrun & + ,MemoryOrder & + ,Stagger & + ,Dimname1, Dimname2, Dimname3 & + ,Desc, Units & + ,debug_message & + ,ds1, de1, ds2, de2, ds3, de3 & + ,ms1, me1, ms2, me2, ms3, me3 & + ,ps1, pe1, ps2, pe2, ps3, pe3, Status ) + + END SUBROUTINE wrf_ext_write_field_arr + + SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & DomainDesc, & bdy_mask , & @@ -17,28 +98,27 @@ USE module_timing IMPLICIT NONE - INTEGER itrace - integer :: DataHandle - character*(*) :: DateStr - character*(*) :: Var - integer :: Field(*) - integer :: FieldType - integer :: Comm - integer :: IOComm - integer :: DomainDesc - logical :: dryrun - character*(*) :: MemoryOrder - logical, dimension(4) :: bdy_mask - character*(*) :: Stagger - character*(*) :: Dimname1, Dimname2, Dimname3 - character*(*) :: Desc, Units - character*(*) :: debug_message + INTEGER ,INTENT(IN ) :: DataHandle + CHARACTER*(*) ,INTENT(IN ) :: DateStr + CHARACTER*(*) ,INTENT(IN ) :: Var + INTEGER ,INTENT(IN ) :: Field(*) + INTEGER ,INTENT(IN ) :: FieldType + INTEGER ,INTENT(IN ) :: Comm + INTEGER ,INTENT(IN ) :: IOComm + INTEGER ,INTENT(IN ) :: DomainDesc + LOGICAL ,INTENT(IN ) :: dryrun + CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder + LOGICAL, DIMENSION(4) ,INTENT(IN ) :: bdy_mask + CHARACTER*(*) ,INTENT(IN ) :: Stagger + CHARACTER*(*) ,INTENT(IN ) :: Dimname1, Dimname2, Dimname3 + CHARACTER*(*) ,INTENT(IN ) :: Desc, Units + CHARACTER*(*) ,INTENT(IN ) :: debug_message INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & ms1, me1, ms2, me2, ms3, me3, & ps1, pe1, ps2, pe2, ps3, pe3 - +! Local INTEGER , DIMENSION(3) :: domain_start , domain_end INTEGER , DIMENSION(3) :: memory_start , memory_end INTEGER , DIMENSION(3) :: patch_start , patch_end diff --git a/wrfv2_fire/share/wrf_fddaobs_in.F b/wrfv2_fire/share/wrf_fddaobs_in.F index 088aa671..c7eb1e54 100644 --- a/wrfv2_fire/share/wrf_fddaobs_in.F +++ b/wrfv2_fire/share/wrf_fddaobs_in.F @@ -73,7 +73,7 @@ .OR.(ktau.EQ.krest) ) then ! Calculate forecast time. dtmin = grid%dt/60. - xtime = dtmin*grid%itimestep + xtime = grid%xtime CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & @@ -89,7 +89,8 @@ jts = grid%j_start(ij) jte = min(grid%j_end(ij),jde-1) - CALL in4dob(inest, xtime, ktau, krest, dtmin, grid%julday, grid%gmt, & + CALL in4dob(inest, xtime, ktau, krest, dtmin, & + grid%julyr, grid%julday, grid%gmt, & !obsnypatch grid%obs_nudge_opt, grid%obs_nudge_wind, grid%obs_nudge_temp, & grid%obs_nudge_mois, grid%obs_nudge_pstr, grid%obs_coef_wind, & grid%obs_coef_temp, grid%obs_coef_mois, grid%obs_coef_pstr, & @@ -132,7 +133,8 @@ !------------------------------------------------------------------------------ ! Begin subroutine in4dob and its subroutines !------------------------------------------------------------------------------ - SUBROUTINE in4dob(inest, xtime, ktau, ktaur, dtmin, julday, gmt, & + SUBROUTINE in4dob(inest, xtime, ktau, ktaur, dtmin, & + myear, julday, gmt, & !obsnypatch nudge_opt, iswind, istemp, & ismois, ispstr, giv, & git, giq, gip, & @@ -164,6 +166,7 @@ USE module_domain USE module_model_constants, ONLY : rcp + USE module_date_time , ONLY : geth_idts USE module_llxy IMPLICIT NONE @@ -197,13 +200,14 @@ INTEGER, intent(in) :: KTAU ! current timestep INTEGER, intent(in) :: KTAUR ! restart timestep REAL, intent(in) :: dtmin ! dt in minutes + INTEGER, intent(in) :: myear ! model year !obsnypatch INTEGER, intent(in) :: julday ! Julian day - REAL, intent(in) :: gmt ! Greenwich Mean Time + REAL, intent(in) :: gmt ! Model GMT at start of run INTEGER, intent(in) :: nudge_opt ! obs-nudge flag for this nest INTEGER, intent(in) :: iswind ! nudge flag for wind INTEGER, intent(in) :: istemp ! nudge flag for temperature INTEGER, intent(in) :: ismois ! nudge flag for moisture - INTEGER, intent(in) :: ispstr ! nudge flag for pressure + INTEGER, intent(in) :: ispstr ! nudge flag for pressure (obsolete) REAL, intent(in) :: giv ! coefficient for wind REAL, intent(in) :: git ! coefficient for temperature REAL, intent(in) :: giq ! coefficient for moisture @@ -284,6 +288,8 @@ ! Local variables TYPE (PROJ_INFO) :: obs_proj ! Structure for obs projection information. character*14 date_char + character*19 obs_date !obsnypatch + integer idts !obsnypatch character*40 platform,source,id,namef character*2 fonc character(len=200) :: msg ! Argument to wrf_message @@ -297,6 +303,9 @@ data ieof/0,0,0,0,0/ data ifon/0,0,0,0,0/ integer :: nmove, nvola + integer :: iyear, itimob !obsnypatch +! external :: fcst_hours !obsnypatch +! real :: fcst_hours !obsnypatch DATA NMOVE/0/,NVOLA/61/ ! if(ieof(inest).eq.2.and.fdob%nstat.eq.0)then @@ -315,11 +324,13 @@ DO N=1,NIOBF TIMEOB(N)=99999. ENDDO + fdob%xtime_at_rest = xtime !yliu 20080127 ENDIF ! set number of obs=0 if at start or restart IF(KTAU.EQ.KTAUR)fdob%NSTAT=0 NSTA=fdob%NSTAT - XHOUR=(XTIME-DTMIN)/60. + + XHOUR=XTIME/60. XHOUR=AMAX1(XHOUR,0.0) 10 CONTINUE @@ -329,11 +340,15 @@ TFORWD=XHOUR+TWINDO IF (iprt) then - write(msg,'(2(a,f8.3),a,i2)') 'TBACK = ',tback, & - ' TFORWD = ',tforwd,' for nest = ',inest + write(msg,fmt='(2(a,f8.3),a,i2)') & + 'OBS NUDGING: Reading new obs for time window TBACK = ', & + tback,' TFORWD = ',tforwd,' for grid = ',inest call wrf_message(msg) ENDIF +! For obs that have become invalid because they are too old for the current time +! window, mark with 99999 to set up for removal from the rolling valid-obs list. + IF(NSTA.NE.0) THEN NDUM=0 t_window : DO N=1,NSTA+1 @@ -344,6 +359,12 @@ NDUM=N ENDDO t_window + IF (iprt .and. ndum>0) THEN + write(msg,'(a,i5,2a)') 'OBS NUDGING: ',ndum,' previously read obs ', & + 'are now too old for the current window and have been removed.' + call wrf_message(msg) + ENDIF + ! REMOVE OLD OBS DENOTED BY 99999. AT THE FRONT OF TIMEOB ARRAY ! IF (iprt) print *,'ndum at 20=',ndum NDUM=ABS(NDUM) @@ -435,6 +456,7 @@ ! DATA FILE. CONTINUE READING UNTIL THE REACHING THE EOF ! (DATA TIME IS NEGATIVE) OR FIRST TIME PAST TFORWD. THE ! LAST OBS CURRENTLY AVAILABLE IS IN N=NMOVE. + N=NLAST IF(N.EQ.0)GOTO 110 @@ -467,6 +489,7 @@ ! THE TIME OF THE MOST RECENTLY ACQUIRED OBS IS .LE. TFORWD, ! SO CONTINUE READING 110 continue + IF(N.GT.NIOBF-1)GOTO 120 ! REPLACE NVOLA WITH LUN 70, AND USE NVOLA AS A FILE COUNTER NVOL=NVOLA+INEST-1 @@ -476,27 +499,20 @@ n=n+1 - read(date_char(3:10),'(i8)')idate - read(date_char(11:12),'(i2)')imm - read(date_char(13:14),'(i2)')iss -! output is rjdate (jjjhh.) and timanl (time in minutes since model start) - call julgmt(idate,rjdate1,timanl1,julday,gmt,0) - rtimob=rjdate1+real(imm)/60.+real(iss)/3600. +! Convert the form of the observation date for geth_idts. + call fmt_date(date_char, obs_date) + +! Compute the time period in seconds from the model reference +! date (fdob%sdate) until the observation date. + + call geth_idts(obs_date, fdob%sdate(1:19), idts) + +! Convert time in seconds to hours. + ! In case of restart, correct for new sdate. + idts = idts + nint(fdob%xtime_at_rest*60.) ! yliu 20080127 + + rtimob =float(idts)/3600. timeob(n)=rtimob - timeob(n) = int(timeob(n)*1000)/1000.0 - -! CONVERT TIMEOB FROM JULIAN DATE AND GMT FORM TO FORECAST -! TIME IN HOURS (EX. TIMEOB=13002.4 REPRESENTS JULDAY 130 -! AND GMT (HOUR) = 2.4) - JULOB=TIMEOB(N)/100.+0.000001 - RJULOB=FLOAT(JULOB)*100. - tempob = (timeob(n)*1000.) - tempob = int(tempob) - tempob = tempob/1000. - timeob(n) = tempob - HOUROB=TIMEOB(N)-RJULOB - TIMEOB(N)=FLOAT(JULOB-JULDAY)*24.-GMT+HOUROB - rtimob=timeob(n) ! print *,'read in ob ',n,timeob(n),rtimob IF(IDYNIN.EQ.1.AND.TIMEOB(N)*60..GT.fdob%DATEND) THEN @@ -513,7 +529,7 @@ rtimob=timeob(n) ENDIF read(nvol,102)latitude,longitude - 102 FORMAT(2x,2(f7.2,3x)) + 102 FORMAT(2x,2(f9.4,1x)) ! save obs and model latitude and longitude for printout CALL collect_obs_info(newpass,inest,n,latitude,longitude,nprev,niobf, & @@ -584,7 +600,7 @@ ! yliu: end if(plfo(n).eq.99.) then IF (iprt) then - write(msg,*) 'n=',n,' unknown ob of type',platform + write(msg,*) 'n=',n,' unknown ob of type ',platform call wrf_message(msg) ENDIF endif @@ -704,7 +720,7 @@ if( (pressure_qc.ge.0..and.pressure_qc.lt.30000.) .or. & (height_qc .ge.0..and.height_qc .lt.30000.) ) then - + varobs(3,n) = temperature_data else varobs(3,n)=-888888. @@ -1078,7 +1094,6 @@ ! check if ob is in the domain if( (ri.lt.2.).or.(ri.gt.real(e_we-1)).or.(rj.lt.2.).or. & (rj.gt.real(e_sn-1)) ) then -! ajb bugfix end n=n-meas_count !ajb Reset timeob for discarded indices. @@ -1086,7 +1101,7 @@ timeob(imc) = 99999. enddo goto 100 - endif + endif ! check if an upper air ob is too high ! the ptop here is hardwired @@ -1163,8 +1178,9 @@ ! "OLD" OBS FIRST... 130 CONTINUE -! get here if at end of file, or if obs time is beyond what we -! need right now +! Get here if at end of file, or if obs time is beyond what we need right now. +! On startup, we report the index of the last obs read. +! For restarts, we need to remove any old obs and then repack obs list. IF(KTAU.EQ.KTAUR)THEN NSTA=0 keep_obs : DO N=1,NIOBF @@ -1174,11 +1190,15 @@ IF(TIMEOB(N).GT.9.e4) EXIT keep_obs if(timeob(n).gt.tforwd) then if(iprt) then - write(msg,951)inest,n,timeob(n),tforwd + write(msg,950) inest + call wrf_message(msg) + write(msg,951) n,timeob(n),tforwd call wrf_message(msg) endif - 951 FORMAT('saving ob beyond window,inest,n,timeob,tforwd=', & - 2i5,2f13.4) + 950 FORMAT('Saving index of first ob after end of current time window ', & + 'for nest = ', i3,':') + 951 FORMAT(' ob index = ',i8,', time of ob = ',f8.4, & + ' hrs, end of time window = ',f8.4,' hrs') endif NSTA=N ENDDO keep_obs @@ -1196,10 +1216,12 @@ ENDDO old_obs ! REMOVE OLD OBS DENOTED BY 99999. AT THE FRONT OF TIMEOB ARRAY - IF (iprt) THEN - write(msg,*) 'after 190 ndum=',ndum,nsta + IF (iprt .and. ktaur > 0) THEN + write(msg,fmt='(a,i5,a)') 'OBS NUDGING: Upon restart, skipped over ',ndum, & + ' obs that are now too old for the current obs window.' call wrf_message(msg) ENDIF + NDUM=ABS(NDUM) NMOVE=NIOBF-NDUM IF( NMOVE.GT.0 .AND. NDUM.NE.0) THEN @@ -1263,30 +1285,28 @@ IF(ISWIND.EQ.1) then write(msg,1450) GIV call wrf_message(msg) + ELSE + write(msg,1455) + call wrf_message(msg) ENDIF IF(ISTEMP.EQ.1) then write(msg,1451) GIT call wrf_message(msg) + ELSE + write(msg,1456) + call wrf_message(msg) ENDIF IF(ISMOIS.EQ.1) then write(msg,1452) GIQ call wrf_message(msg) - ENDIF - IF(ISPSTR.EQ.1) then - write(msg,1453) GIP + ELSE + write(msg,1457) call wrf_message(msg) ENDIF ENDIF ENDIF ENDIF IF(KTAU.EQ.KTAUR)THEN -!ajb 05042009 These messages are incorrect, remnant of MM5? -! IF (iprt) THEN -! write(msg,553) -! call wrf_message(msg) -! write(msg,554) -! call wrf_message(msg) -! ENDIF IF(fdob%IWTSIG.NE.1)THEN IF (iprt) THEN write(msg,555) @@ -1298,6 +1318,7 @@ call wrf_error_fatal ( 'wrf_fddaobs_in: in4dob STOP 556' ) ENDIF ! IS MINIMUM GREATER THAN MAXIMUM? + IF (iprt) then write(msg,557) fdob%DPSMX*10.,fdob%DCON call wrf_message(msg) @@ -1325,27 +1346,25 @@ 557 FORMAT(1X,' IN THE SURFACE LAYER, WXY IS A FUNCTION OF ', & 'DPSMX = ',F7.2,' MB WITH DCON = ',E11.3, & ' - SEE SUBROUTINE NUDOB') -601 FORMAT('0','FOR EFFICIENCY, THE OBS NUDGING FREQUENCY ', & +601 FORMAT('FOR EFFICIENCY, THE OBS NUDGING FREQUENCY ', & 'FOR MESH #',I2,' IS ',1I2,' CGM TIMESTEPS ') -121 FORMAT('0',' WARNING: NOBS = ',I4,' IS GREATER THAN NIOBF = ', & +121 FORMAT(' WARNING: NOBS = ',I4,' IS GREATER THAN NIOBF = ', & I4,': INCREASE PARAMETER NIOBF') 5403 FORMAT(1H0,'-------------EOF REACHED FOR NVOL = ',I3, & ' AND XTIME = ',F10.2,'-------------------') 122 FORMAT(1X,' ...OR THE CODE WILL REDUCE THE TIME WINDOW') -160 FORMAT('0','****** CALL IN4DOB AT KTAU = ',I5,' AND XTIME = ', & +160 FORMAT('****** CALL IN4DOB AT KTAU = ',I5,' AND XTIME = ', & F10.2,': NSTA = ',I7,' ******') -1449 FORMAT(1H0,'*****NUDGING INDIVIDUAL OBS ON MESH #',I2, & +1449 FORMAT('*****NUDGING INDIVIDUAL OBS ON MESH #',I2, & ' WITH RINXY = ', & E11.3,' KM, RINSIG = ',E11.3,' AND TWINDO (HALF-PERIOD) = ', & E11.3,' MIN') 1450 FORMAT(1X,'NUDGING IND. OBS WINDS WITH GIV = ',E11.3) 1451 FORMAT(1X,'NUDGING IND. OBS TEMPERATURE WITH GIT = ',E11.3) 1452 FORMAT(1X,'NUDGING IND. OBS MOISTURE WITH GIQ = ',E11.3) -1453 FORMAT(1X,'NUDGING IND. OBS SURFACE PRESSURE WITH GIP = ,'E11.3) -553 FORMAT(1X,'BY DEFAULT: OBS NUDGING OF TEMPERATURE AND MOISTURE ', & - 'IS RESTRICTED TO ABOVE THE BOUNDARY LAYER') -554 FORMAT(1X,'...WHILE OBS NUDGING OF WIND IS INDEPENDENT OF THE ', & - 'BOUNDARY LAYER') +1455 FORMAT(1X,'*** OBS WIND NUDGING TURNED OFF FOR THIS MESH!!') +1456 FORMAT(1X,'*** OBS TEMPERATURE NUDGING IS TURNED OFF FOR THIS MESH!!') +1457 FORMAT(1X,'*** OBS MOISTURE NUDGING IS TURNED OFF FOR THIS MESH!!') RETURN END SUBROUTINE in4dob @@ -1633,6 +1652,33 @@ END SUBROUTINE rh2rb END SUBROUTINE set_projection + SUBROUTINE fmt_date(idate,odate) !obsnypatch + +!************************************************************************* +! Purpose: Re-format a character date string from YYYYMMDDHHmmss form +! to YYYY-MM-DD_HH:mm:ss form. +! INPUT: +! IDATE - Date string as YYYYMMDDHHmmss +! OUTPUT: +! ODATE - Date string as YYYY-MM-DD_HH:mm:ss +!************************************************************************* + + IMPLICIT NONE + + CHARACTER*14, intent(in) :: idate ! input date string + CHARACTER*19, intent(out) :: odate ! output date string + + odate(1:19) = "0000-00-00_00:00:00" + odate(1:4) = idate(1:4) ! Year + odate(6:7) = idate(5:6) ! Month + odate(9:10) = idate(7:8) ! Day + odate(12:13) = idate(9:10) ! Hours + odate(15:16) = idate(11:12) ! Minutes + odate(18:19) = idate(13:14) ! Seconds + + RETURN + END SUBROUTINE fmt_date + INTEGER FUNCTION nvals_le_limit(isize, values, limit) !------------------------------------------------------------------------------ ! PURPOSE: Return the number of values in a (real) non-decreasing array that diff --git a/wrfv2_fire/share/wrf_timeseries.F b/wrfv2_fire/share/wrf_timeseries.F index 780504e7..65a9bfec 100644 --- a/wrfv2_fire/share/wrf_timeseries.F +++ b/wrfv2_fire/share/wrf_timeseries.F @@ -6,10 +6,11 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE calc_ts_locations( grid ) - USE module_domain - USE module_configure - USE module_dm + USE module_domain, ONLY : domain, get_ijk_from_grid + USE module_configure, ONLY : model_config_rec, grid_config_rec_type, model_to_grid_config_rec + USE module_dm, ONLY : wrf_dm_min_real USE module_llxy + USE module_state_description IMPLICIT NONE @@ -80,7 +81,7 @@ SUBROUTINE calc_ts_locations( grid ) ! Lambert conformal ELSE IF (config_flags%map_proj == PROJ_LC) THEN - CALL map_set(PROJ_LC, ts_proj, & + CALL map_set(PROJ_LC, ts_proj, & truelat1 = config_flags%truelat1, & truelat2 = config_flags%truelat2, & stdlon = config_flags%stand_lon, & @@ -101,6 +102,7 @@ SUBROUTINE calc_ts_locations( grid ) knownj = 1., & dx = config_flags%dx) +#if (EM_CORE == 1) ! Cassini (global ARW) ELSE IF (config_flags%map_proj == PROJ_CASSINI) THEN CALL map_set(PROJ_CASSINI, ts_proj, & @@ -108,13 +110,12 @@ SUBROUTINE calc_ts_locations( grid ) loninc = grid%dx*360.0/(2.0*EARTH_RADIUS_M*PI), & lat1 = known_lat, & lon1 = known_lon, & -! We still need to get POLE_LAT and POLE_LON metadata variables before -! this will work for rotated poles. - lat0 = 90.0, & - lon0 = 0.0, & + lat0 = config_flags%pole_lat, & + lon0 = config_flags%pole_lon, & knowni = 1., & knownj = 1., & stdlon = config_flags%stand_lon) +#endif ! Rotated latitude-longitude ELSE IF (config_flags%map_proj == PROJ_ROTLL) THEN @@ -141,7 +142,13 @@ SUBROUTINE calc_ts_locations( grid ) ntsloc_temp = 0 DO k=1,grid%ntsloc - CALL latlon_to_ij(ts_proj, grid%lattsloc(k), grid%lontsloc(k), ts_rx, ts_ry) + IF (config_flags%map_proj == 0) THEN ! For idealized cases, no map transformation needed + ts_rx = grid%lattsloc(k) ! NB: (x,y) = (lat,lon) rather than (x,y) = (lon,lat) + ts_ry = grid%lontsloc(k) + ELSE + CALL latlon_to_ij(ts_proj, grid%lattsloc(k), grid%lontsloc(k), ts_rx, ts_ry) + END IF + ntsloc_temp = ntsloc_temp + 1 grid%itsloc(ntsloc_temp) = NINT(ts_rx) @@ -367,8 +374,9 @@ END SUBROUTINE calc_ts SUBROUTINE write_ts( grid ) - USE module_domain - USE module_dm + USE module_domain, ONLY : domain + USE module_dm, ONLY : wrf_dm_min_reals + USE module_state_description IMPLICIT NONE diff --git a/wrfv2_fire/test/nmm_real/namelist.input b/wrfv2_fire/test/nmm_real/namelist.input index 9dc18e0c..9e55fc57 100644 --- a/wrfv2_fire/test/nmm_real/namelist.input +++ b/wrfv2_fire/test/nmm_real/namelist.input @@ -80,6 +80,9 @@ / &dynamics + euler_adv = .false., + idtadt = 1, + idtadc = 1 / &bdy_control @@ -88,9 +91,6 @@ nested = .false. / - &fdda - / - &grib2 / diff --git a/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm b/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm index 9238b542..07d7cee2 100644 --- a/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm +++ b/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm @@ -86,6 +86,9 @@ / &dynamics + euler_advect = .false., + idtadt = 1, + idtadc = 1 / &bdy_control diff --git a/wrfv2_fire/tools/Makefile b/wrfv2_fire/tools/Makefile index 5da2d044..b9ded505 100644 --- a/wrfv2_fire/tools/Makefile +++ b/wrfv2_fire/tools/Makefile @@ -6,8 +6,9 @@ LDFLAGS = DEBUG = -g OBJ = registry.o my_strtok.o reg_parse.o data.o type.o misc.o \ gen_defs.o gen_allocs.o gen_mod_state_descr.o gen_scalar_indices.o \ - gen_args.o gen_config.o sym.o symtab_gen.o gen_wrf_io.o \ - gen_model_data_ord.o gen_interp.o gen_comms.o gen_scalar_derefs.o + gen_args.o gen_config.o sym.o symtab_gen.o \ + gen_model_data_ord.o gen_interp.o gen_comms.o gen_scalar_derefs.o set_dim_strs.o gen_wrf_io.o\ + gen_streams.o registry : $(OBJ) standard.exe $(CC_TOOLS) -o registry $(DEBUG) $(LDFLAGS) $(OBJ) @@ -45,3 +46,4 @@ registry.o: protos.h registry.h data.h sym.o: sym.h type.o: registry.h protos.h data.h gen_interp.o: registry.h protos.h data.h +gen_streams.o: registry.h protos.h data.h diff --git a/wrfv2_fire/tools/data.h b/wrfv2_fire/tools/data.h index 8a0fed3e..c07ebd83 100644 --- a/wrfv2_fire/tools/data.h +++ b/wrfv2_fire/tools/data.h @@ -1,4 +1,5 @@ #ifndef DATA_H +#include "../inc/streams.h" #include "registry.h" typedef struct node_struct { @@ -29,34 +30,11 @@ typedef struct node_struct { struct node_struct * members ; /* I/O flags */ - int io_mask ; - int history ; - int auxhist1 ; - int auxhist2 ; - int auxhist3 ; - int auxhist4 ; - int auxhist5 ; - int auxhist6 ; - int auxhist7 ; - int auxhist8 ; - int auxhist9 ; - int auxhist10 ; - int auxhist11 ; - int restart ; - int input ; - int auxinput1 ; - int auxinput2 ; - int auxinput3 ; - int auxinput4 ; - int auxinput5 ; - int auxinput6 ; - int auxinput7 ; - int auxinput8 ; - int auxinput9 ; - int auxinput10 ; - int auxinput11 ; - int boundary ; - int namelist ; + unsigned int io_mask[ IO_MASK_SIZE ] ; + unsigned int nest_mask ; + int restart ; + int boundary ; + int namelist ; char namelistsection[NAMELEN] ; struct node_struct * next ; struct node_struct * next4d ; diff --git a/wrfv2_fire/tools/gen_allocs.c b/wrfv2_fire/tools/gen_allocs.c index dec24558..07795b57 100644 --- a/wrfv2_fire/tools/gen_allocs.c +++ b/wrfv2_fire/tools/gen_allocs.c @@ -8,6 +8,7 @@ #include "protos.h" #include "registry.h" #include "data.h" +#include "sym.h" int gen_alloc ( char * dirname ) @@ -18,36 +19,177 @@ gen_alloc ( char * dirname ) } int +get_count_for_alloc( node_t *node , int *numguys, int *stats) ; /* forward */ + +int gen_alloc1 ( char * dirname ) { FILE * fp ; char fname[NAMELEN] ; char * fn = "allocs.inc" ; + int startpiece, fraction, iguy, numguys ; + int stats[4] ; +#define FRAC 8 if ( dirname == NULL ) return(1) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } else { sprintf(fname,"%s",fn) ; } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; - gen_alloc2( fp , "grid%", &Domain, 1 ) ; + startpiece = 0 ; + fraction = 0 ; + numguys = 0 ; + iguy = -1 ; + stats[0] = 0 ; stats[1] = 0 ; stats[2] = 0 ; stats[3] = 0 ; + get_count_for_alloc( &Domain, &numguys , stats) ; /* howmany deez guys? */ + fprintf(stderr,"Registry INFO variable counts: 0d %d 1d %d 2d %d 3d %d\n",stats[0],stats[1],stats[2],stats[3]) ; + fprintf(fp,"#if 1\n") ; + gen_alloc2( fp , "grid%", &Domain, &startpiece , &iguy, &fraction, numguys, FRAC, 1 ) ; + fprintf(fp,"#endif\n") ; close_the_file( fp ) ; return(0) ; } int -gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allocate, 2 = just count */ +get_count_for_alloc( node_t *node , int *numguys, int * stats ) +{ + node_t * p ; + for ( p = node->fields ; p != NULL ; p = p->next ) { + if ( p->type != NULL && p->type->type_type == DERIVED ) { + get_count_for_alloc( p->type , numguys, stats ) ; + } else if (p->ndims >= 0) { + (*numguys)++ ; + if ( p->ndims == 0 ) { + stats[p->ndims]++ ; + } else if ( p->ndims == 1 ) { + stats[p->ndims]++ ; + } else if ( p->ndims == 2 ) { + stats[p->ndims]++ ; + } else if ( p->ndims == 3 ) { + stats[p->ndims]++ ; + } + } + } +} + +int +nolistthese( char * ) ; + +int +gen_alloc2 ( FILE * fp , char * structname , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ) /* 1 = allocate, 2 = just count */ { node_t * p ; int tag ; char post[NAMELEN], post_for_count[NAMELEN] ; - char fname[NAMELEN] ; + char fname[NAMELEN], dname[NAMELEN], dname_tmp[NAMELEN] ; char x[NAMELEN] ; + char dimname[3][NAMELEN] ; char tchar ; + unsigned int *io_mask ; + int nd ; + int restart ; if ( node == NULL ) return(1) ; for ( p = node->fields ; p != NULL ; p = p->next ) { + (*iguy)++ ; + + if ( (*iguy % ((numguys+1)/frac+1)) == 0 ) { + fprintf(fp,"#endif\n") ; + fprintf(fp,"#if (NNN == %d)\n",(*j)++) ; + } + + nd = p->ndims + ((p->node_kind & FOURD)?1:0) ; + + /* construct data name -- maybe same as vname if dname not spec'd */ + if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") || p->dname[0] == ' ' ) + { strcpy(dname_tmp,p->name) ; } + else { strcpy(dname_tmp,p->dname) ; } + make_upper_case(dname_tmp) ; + +/* + Generate error if input or output for two state variables would be generated with the same dataname + + example wrong: + misc tg "SOILTB" -> gen_tg,SOILTB + misc soiltb "SOILTB" -> gen_soiltb,SOILTB + +*/ +if ( tag == 1 ) +{ + char dname_symbol[128] ; + sym_nodeptr sym_node ; + + sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ; + /* check and see if it is in the symbol table already */ + + if ((sym_node = sym_get( dname_symbol )) == NULL ) { + /* add it */ + sym_node = sym_add ( dname_symbol ) ; + strcpy( sym_node->internal_name , p->name ) ; + } else { + fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s -- %s\n", + dname_tmp,p->name,p->dname ) ; + } +} +/* end July 2004 */ + + + if ( p->ndims == 0 ) { + if ( p->type->name[0] != 'c' && p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) ) { + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ; + else strcpy(dname,dname_tmp) ; + +/* fprintf(fp," IF (.NOT.inter_domain) THEN\n") ; */ + fprintf(fp," IF (.NOT.grid%%is_intermediate) THEN\n") ; + fprintf(fp," ALLOCATE( grid%%tail_statevars%%next )\n") ; + fprintf(fp," grid%%tail_statevars => grid%%tail_statevars%%next\n") ; + fprintf(fp," NULLIFY( grid%%tail_statevars%%next )\n" ) ; + fprintf(fp," grid%%tail_statevars%%VarName = '%s'\n",fname ) ; + fprintf(fp," grid%%tail_statevars%%DataName = '%s'\n",dname ) ; + fprintf(fp," grid%%tail_statevars%%Type = '%c'\n",p->type->name[0]) ; + fprintf(fp," grid%%tail_statevars%%Ntl = %d\n",p->ntl<2?0:tag+p->ntl*100 ) ; /* if single tl, then 0, else tl itself */ + fprintf(fp," grid%%tail_statevars%%Restart = %s\n", (p->restart)?".TRUE.":".FALSE." ) ; + fprintf(fp," grid%%tail_statevars%%Ndim = %d\n",p->ndims ) ; + fprintf(fp," grid%%tail_statevars%%scalar_array = .FALSE. \n" ) ; + fprintf(fp," grid%%tail_statevars%%%cfield_%1dd => %s%s\n",p->type->name[0],p->ndims, structname, fname ) ; + io_mask = p->io_mask ; + if ( io_mask != NULL ) { + int i ; + for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) { + fprintf(fp," grid%%tail_statevars%%streams(%d) = %d ! %08x \n", i+1, io_mask[i], io_mask[i] ) ; + } + } + fprintf(fp," ENDIF\n") ; + } + } + if ( sw == 1 ) { + for ( tag = 1 ; tag <= p->ntl ; tag++ ) + { + strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; + if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ; + else strcpy(dname,dname_tmp) ; + if( !strcmp( p->type->name , "real" ) || + !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */ + fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n", + structname , + fname ) ; + } else if ( !strcmp( p->type->name , "integer" ) ) { + fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n", + structname , + fname ) ; + } else if ( !strcmp( p->type->name , "logical" ) ) { + fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n", + structname , + fname ) ; + } + } + } + } if ( (p->ndims > 0 || p->boundary_array) && ( /* any array or a boundary array and... */ (p->node_kind & FIELD) || /* scalar arrays */ (p->node_kind & FOURD) ) /* scalar arrays */ @@ -77,10 +219,12 @@ gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allo if ( ! p->boundary_array ) { fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ; } else { fprintf(fp,"IF(.TRUE.") ; } + if ( ! ( p->node_kind & FOURD ) && sw == 1 && - ! ( p->io_mask & INTERP_DOWN || p->io_mask & FORCE_DOWN || p->io_mask & INTERP_UP || p->io_mask & SMOOTH_UP ) ) + ! ( p->nest_mask & INTERP_DOWN || p->nest_mask & FORCE_DOWN || p->nest_mask & INTERP_UP || p->nest_mask & SMOOTH_UP ) ) { - fprintf(fp,".AND.(.NOT.inter_domain)",tag) ; +/* fprintf(fp,".AND.(.NOT.inter_domain)",tag) ; */ + fprintf(fp,".AND.(.NOT.grid%%is_intermediate)",tag) ; } if ( p->ntl > 1 && sw == 1 ) { fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ; @@ -128,7 +272,7 @@ gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allo fprintf(fp, " IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname); if( p->type != NULL && (!strcmp( p->type->name , "real" ) - || !strcmp( p->type->name , "doubleprecision") ) ) { + || !strcmp( p->type->name , "doubleprecision") ) ) { /* if a real */ fprintf(fp, "initial_data_value\n"); } else if ( !strcmp( p->type->name , "logical" ) ) { @@ -136,6 +280,160 @@ gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allo } else if ( !strcmp( p->type->name , "integer" ) ) { fprintf(fp, "0\n"); } + + if ( p->type->name[0] == 'l' && p->ndims >= 3 ) { + fprintf(stderr,"ADVISORY: %1dd logical array %s is allowed but cannot be input or output\n", + p->ndims, p->name ) ; + + } + + if ( p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) && + ! ( p->type->name[0] == 'l' && p->ndims >= 3 ) ) /* dont list logical arrays larger than 2d */ + { + char memord[NAMELEN], stagstr[NAMELEN] ; + + + strcpy(stagstr, "") ; + if ( p->node_kind & FOURD ) { + set_mem_order( p->members, memord , NAMELEN) ; + if ( p->members->stag_x ) strcat(stagstr, "X") ; + if ( p->members->stag_y ) strcat(stagstr, "Y") ; + if ( p->members->stag_z ) strcat(stagstr, "Z") ; + } else { + set_mem_order( p, memord , NAMELEN) ; + if ( p->stag_x ) strcat(stagstr, "X") ; + if ( p->stag_y ) strcat(stagstr, "Y") ; + if ( p->stag_z ) strcat(stagstr, "Z") ; + } + memord[3] = '\0' ; /* snip off any extra dimensions */ + + if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ; + else strcpy(dname,dname_tmp) ; + + fprintf(fp," IF (.NOT.grid%%is_intermediate) THEN\n") ; /*{*/ + fprintf(fp," ALLOCATE( grid%%tail_statevars%%next )\n" ) ; + fprintf(fp," grid%%tail_statevars => grid%%tail_statevars%%next\n") ; + fprintf(fp," NULLIFY( grid%%tail_statevars%%next )\n") ; + fprintf(fp," grid%%tail_statevars%%VarName = '%s'\n", fname) ; + fprintf(fp," grid%%tail_statevars%%DataName = '%s'\n", dname) ; + fprintf(fp," grid%%tail_statevars%%Type = '%c'\n", p->type->name[0]) ; + fprintf(fp," grid%%tail_statevars%%MemoryOrder = '%s'\n", memord) ; + fprintf(fp," grid%%tail_statevars%%Stagger = '%s'\n", stagstr) ; + /* in next line for Ntl, if single tl, then zero, otherwise tl itself */ + fprintf(fp," grid%%tail_statevars%%Ntl = %d\n", p->ntl<2?0:tag+p->ntl*100 ) ; + fprintf(fp," grid%%tail_statevars%%Ndim = %d\n", nd ) ; + restart = 0 ; + if ( p->node_kind & FOURD ) { + node_t *q ; + for ( q = p->members ; q->next != NULL ; q = q->next ) { /* use the last one */ + if ( q != NULL ) { + restart = q->restart ; + } + } + } else { + restart = p->restart ; + } + fprintf(fp," grid%%tail_statevars%%Restart = %s\n", (restart)?".TRUE.":".FALSE." ) ; + fprintf(fp," grid%%tail_statevars%%scalar_array = %s\n", (p->node_kind & FOURD)?".TRUE.":".FALSE.") ; + fprintf(fp," grid%%tail_statevars%%%cfield_%1dd => %s%s\n", p->type->name[0],nd, structname, fname ) ; + if ( p->node_kind & FOURD ) { + fprintf(fp," grid%%tail_statevars%%num_table => %s_num_table\n", p->name ) ; + fprintf(fp," grid%%tail_statevars%%index_table => %s_index_table\n", p->name ) ; + fprintf(fp," grid%%tail_statevars%%boundary_table => %s_boundary_table\n", p->name ) ; + fprintf(fp," grid%%tail_statevars%%dname_table => %s_dname_table\n", p->name ) ; + fprintf(fp," grid%%tail_statevars%%desc_table => %s_desc_table\n", p->name ) ; + fprintf(fp," grid%%tail_statevars%%units_table => %s_units_table\n", p->name ) ; + } + + if ( p->node_kind & FOURD ) { + node_t *q ; + io_mask = NULL ; + for ( q = p->members ; q->next != NULL ; q = q->next ) { /* use the last one */ + if ( q != NULL ) { + io_mask = q->io_mask ; + } + } + } else { + io_mask = p->io_mask ; + } + + if ( io_mask != NULL ) { + int i ; + for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) { + fprintf(fp," grid%%tail_statevars%%streams(%d) = %d ! %08x \n", i+1, io_mask[i], io_mask[i] ) ; + } + } + + { + char ddim[3][2][NAMELEN] ; + char mdim[3][2][NAMELEN] ; + char pdim[3][2][NAMELEN] ; + + set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */ + + fprintf(fp," grid%%tail_statevars%%sd1 = %s\n", ddim[0][0] ) ; + fprintf(fp," grid%%tail_statevars%%ed1 = %s\n", ddim[0][1] ) ; + fprintf(fp," grid%%tail_statevars%%sd2 = %s\n", ddim[1][0] ) ; + fprintf(fp," grid%%tail_statevars%%ed2 = %s\n", ddim[1][1] ) ; + fprintf(fp," grid%%tail_statevars%%sd3 = %s\n", ddim[2][0] ) ; + fprintf(fp," grid%%tail_statevars%%ed3 = %s\n", ddim[2][1] ) ; + fprintf(fp," grid%%tail_statevars%%sm1 = %s\n", mdim[0][0] ) ; + fprintf(fp," grid%%tail_statevars%%em1 = %s\n", mdim[0][1] ) ; + fprintf(fp," grid%%tail_statevars%%sm2 = %s\n", mdim[1][0] ) ; + fprintf(fp," grid%%tail_statevars%%em2 = %s\n", mdim[1][1] ) ; + fprintf(fp," grid%%tail_statevars%%sm3 = %s\n", mdim[2][0] ) ; + fprintf(fp," grid%%tail_statevars%%em3 = %s\n", mdim[2][1] ) ; + fprintf(fp," grid%%tail_statevars%%sp1 = %s\n", pdim[0][0] ) ; + fprintf(fp," grid%%tail_statevars%%ep1 = %s\n", pdim[0][1] ) ; + fprintf(fp," grid%%tail_statevars%%sp2 = %s\n", pdim[1][0] ) ; + fprintf(fp," grid%%tail_statevars%%ep2 = %s\n", pdim[1][1] ) ; + fprintf(fp," grid%%tail_statevars%%sp3 = %s\n", pdim[2][0] ) ; + fprintf(fp," grid%%tail_statevars%%ep3 = %s\n", pdim[2][1] ) ; + + } + { + int i ; + node_t * dimnode ; + for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; + for ( i = 0 ; i < 3 ; i++ ) + { + if (( dimnode = p->dims[i]) != NULL ) + { + switch ( dimnode->coord_axis ) + { + case (COORD_X) : + if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else if ( p->dims[i]->subgrid ) + { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + case (COORD_Y) : + if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else if ( p->dims[i]->subgrid ) + { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + case (COORD_Z) : + if ( p->stag_z ) + { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } + else if ( p->dims[i]->subgrid ) + { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } + else + { strcpy( dimname[i], dimnode->dim_data_name) ; } + break ; + } + } + } + fprintf(fp," grid%%tail_statevars%%dimname1 = '%s'\n", dimname[0] ) ; + fprintf(fp," grid%%tail_statevars%%dimname2 = '%s'\n", dimname[1] ) ; + fprintf(fp," grid%%tail_statevars%%dimname3 = '%s'\n", dimname[2] ) ; + } + fprintf(fp," ENDIF\n") ; /*}*/ + } } } @@ -162,41 +460,17 @@ gen_alloc2 ( FILE * fp , char * structname , node_t * node, int sw ) /* 1 = allo } if ( p->type != NULL ) { - if ( p->type->type_type == SIMPLE && p->ndims == 0 && - (!strcmp(p->type->name,"integer") || - !strcmp(p->type->name,"logical") || - !strcmp(p->type->name,"real") || - !strcmp(p->type->name,"doubleprecision")) - ) - { - strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ; - if ( sw == 1 ) { - if( !strcmp( p->type->name , "real" ) || - !strcmp( p->type->name , "doubleprecision" ) ) { /* if a real */ - fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n", - structname , - fname ) ; - } else if ( !strcmp( p->type->name , "integer" ) ) { - fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n", - structname , - fname ) ; - } else if ( !strcmp( p->type->name , "logical" ) ) { - fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n", - structname , - fname ) ; - } - } - } - else if ( p->type->type_type == DERIVED ) + if ( p->type->type_type == DERIVED ) { sprintf(x,"%s%s%%",structname,p->name ) ; - gen_alloc2(fp,x, p->type, sw) ; + gen_alloc2(fp,x, p->type, j, iguy, fraction, numguys, 1, sw) ; } } - } + } /* fraction loop */ return(0) ; } +#if 0 int gen_alloc_count ( char * dirname ) { @@ -220,6 +494,7 @@ gen_alloc_count1 ( char * dirname ) close_the_file( fp ) ; return(0) ; } +#endif int gen_ddt_write ( char * dirname ) @@ -329,7 +604,7 @@ gen_dealloc2 ( FILE * fp , char * structname , node_t * node ) fprintf(fp, "IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ; fprintf(fp, -" DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s%s. ')\n endif\n", +" DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s%s. ')\n endif\n", structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ; fprintf(fp, " NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ; @@ -341,7 +616,7 @@ gen_dealloc2 ( FILE * fp , char * structname , node_t * node ) fprintf(fp, "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ; fprintf(fp, -" DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to dallocate %s%s. ')\n endif\n", +" DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s. ')\n endif\n", structname, fname, structname, fname ) ; fprintf(fp, " NULLIFY(%s%s)\n",structname, fname ) ; @@ -370,3 +645,13 @@ structname, fname, structname, fname ) ; } return(0) ; } + +int +nolistthese( char * name ) +{ + return( + !strncmp(name,"auxhist",7) + || !strncmp(name,"auxinput",8) + || !strncmp(name,"oid",3) + ) ; +} diff --git a/wrfv2_fire/tools/gen_config.c b/wrfv2_fire/tools/gen_config.c index 810ba82c..18389743 100644 --- a/wrfv2_fire/tools/gen_config.c +++ b/wrfv2_fire/tools/gen_config.c @@ -207,31 +207,38 @@ gen_get_nl_config ( char * dirname ) { FILE * fp ; char fname[NAMELEN] ; - char * fn = "_nl_config.inc" ; + char * fn = "nl_config.inc" ; char * gs, * intnt ; char howset[NAMELEN] ; node_t *p ; int sw ; int num_rconfigs = 0 ; - int i, half, j ; + int i, fraction, j ; +#define FRAC 8 + + strcpy( fname, fn ) ; + if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } + if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; + print_warning(fp,fname) ; for ( p = Domain.fields ; p != NULL ; p = p-> next ) { if ( p->node_kind & RCONFIG ) { num_rconfigs++ ; } } /* howmany deez guys? */ - for ( half = 0, j=0 ; half < num_rconfigs ; half += (num_rconfigs+1)/2, j++ ) { /* break the files in half so we don't kill the compilers as much */ for ( sw = 0 ; sw < 2 ; sw++ ) { if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; } - strcpy( fname, fn ) ; - if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%d%s",dirname,gs,j,fn) ; } - if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; - print_warning(fp,fname) ; + fprintf(fp,"#ifdef NL_%s_ROUTINES\n",gs) ; + + for ( fraction = 0, j=0 ; fraction < num_rconfigs ; fraction += ((num_rconfigs+1)/FRAC+1), j++ ) { /* break the files in pieces + so we don't kill the + compilers as much */ + fprintf(fp,"#if (NNN == %d)\n",j) ; for ( p = Domain.fields, i = -1 ; p != NULL ; p = p-> next ) { if ( p->node_kind & RCONFIG ) { i++ ; - if ( (i >= half) && (i < half + (num_rconfigs+1)/2) ) + if ( (i >= fraction) && (i < fraction + (num_rconfigs+1)/FRAC+1) ) { strcpy(howset,p->howset) ; fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ; @@ -240,7 +247,7 @@ gen_get_nl_config ( char * dirname ) } fprintf(fp," %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ; fprintf(fp," INTEGER id_id\n") ; - fprintf(fp," CHARACTER*80 emess\n") ; + if ( ! sw_fort_kludge ) fprintf(fp," CHARACTER*80 emess\n") ; if ( sw == 0 ) /* get */ { if ( !strcmp( p->nentries, "1" )) { @@ -326,9 +333,11 @@ gen_get_nl_config ( char * dirname ) } } } - close_the_file( fp ) ; + fprintf(fp,"#endif\n") ; + } /* fraction */ + fprintf(fp,"#endif\n") ; } - } /* halfs */ + close_the_file( fp ) ; return(0) ; } diff --git a/wrfv2_fire/tools/gen_defs.c b/wrfv2_fire/tools/gen_defs.c index 58bb9aa6..020bbac3 100644 --- a/wrfv2_fire/tools/gen_defs.c +++ b/wrfv2_fire/tools/gen_defs.c @@ -190,6 +190,7 @@ gen_decls ( FILE * fp , node_t * node , int sw_ranges, int sw_point , int mask , if ( bdyonly && p->node_kind & FIELD && ! p->boundary_array ) continue ; /* short circuit all fields except bdy arrrays */ if ( p->boundary_array && sw_new_bdys ) { + if ( layer == DRIVER_LAYER || associated_with_4d_array(p) ) { int bdy ; for ( bdy = 1; bdy <=4 ; bdy++ ) { switch ( sw_ranges ) @@ -208,6 +209,7 @@ gen_decls ( FILE * fp , node_t * node , int sw_ranges, int sw_point , int mask , (sw_point==POINTERDECL)?declare_array_as_pointer(t3,p):"" , fname, bdy_indicator( bdy ) ) ; } + } } else { switch ( sw_ranges ) { diff --git a/wrfv2_fire/tools/gen_interp.c b/wrfv2_fire/tools/gen_interp.c index ffc6006c..00391fe4 100644 --- a/wrfv2_fire/tools/gen_interp.c +++ b/wrfv2_fire/tools/gen_interp.c @@ -98,7 +98,7 @@ gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , char * fn = "nest_interp.inc" ; char fname[NAMELEN] ; node_t *p, *p1, *dim ; - int d2, d3, xdex, ydex, zdex, io_mask ; + int d2, d3, xdex, ydex, zdex, nest_mask ; char ddim[3][2][NAMELEN] ; char mdim[3][2][NAMELEN] ; char pdim[3][2][NAMELEN] ; @@ -128,18 +128,18 @@ gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , if ( p1->node_kind & FOURD ) { if ( p1->members->next ) { - io_mask = p1->members->next->io_mask ; + nest_mask = p1->members->next->nest_mask ; } else { continue ; } } else { - io_mask = p1->io_mask ; + nest_mask = p1->nest_mask ; } p = p1 ; - if ( io_mask & down_path ) + if ( nest_mask & down_path ) { if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; } else { sprintf(tag,"") ; sprintf(tag2,"") ; } @@ -321,11 +321,19 @@ fprintf(fp," ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio int bdy ; for ( bdy = 1 ; bdy <= 4 ; bdy++ ) { if ( strcmp( nd->use , "_4d_bdy_array_" ) ) { +#if 0 fprintf(fp,",%s%s,ngrid%%%s%s &\n", nd->name, bdy_indicator(bdy), nd->name, bdy_indicator(bdy) ) ; +#else + fprintf(fp,",dummy_%s,ngrid%%%s%s &\n", + bdy_indicator(bdy), + nd->name, bdy_indicator(bdy) ) ; +#endif } else { char c ; c = 'i' ; if ( bdy <= 2 ) c = 'j' ; - fprintf(fp,",%s%s(c%cms,1,1,itrace),ngrid%%%s%s(n%cms,1,1,itrace) &\n", nd->name, bdy_indicator(bdy), c, nd->name, bdy_indicator(bdy), c ) ; + fprintf(fp,",%s%s(c%cms,1,1,itrace),ngrid%%%s%s(n%cms,1,1,itrace) &\n", + nd->name, bdy_indicator(bdy), c, + nd->name, bdy_indicator(bdy), c ) ; } } } else { diff --git a/wrfv2_fire/tools/gen_scalar_indices.c b/wrfv2_fire/tools/gen_scalar_indices.c index 63adaa9a..7f616d0f 100644 --- a/wrfv2_fire/tools/gen_scalar_indices.c +++ b/wrfv2_fire/tools/gen_scalar_indices.c @@ -45,7 +45,6 @@ gen_scalar_indices ( char * dirname ) if ((fp5[i] = fopen( fname5 , "w" )) == NULL ) return(1) ; print_warning(fp5[i],fname) ; } - gen_scalar_indices1 ( fp, fp5 ) ; close_the_file( fp ) ; for ( i = 0 ; i < 7 ; i++ ) { @@ -82,12 +81,12 @@ gen_scalar_tables ( FILE * fp ) node_t * p ; for ( p = FourD ; p != NULL ; p=p->next4d ) { - fprintf(fp," INTEGER :: %s_index_table( param_num_%s, max_domains )\n",p->name,p->name ) ; - fprintf(fp," INTEGER :: %s_num_table( max_domains )\n", p->name,p->name ) ; - fprintf(fp," INTEGER :: %s_stream_table( max_domains, param_num_%s )\n", p->name,p->name ) ; - fprintf(fp," CHARACTER*256 :: %s_dname_table( max_domains, param_num_%s )\n", p->name,p->name ) ; - fprintf(fp," CHARACTER*256 :: %s_desc_table( max_domains, param_num_%s )\n", p->name,p->name ) ; - fprintf(fp," CHARACTER*256 :: %s_units_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," INTEGER, TARGET :: %s_index_table( param_num_%s, max_domains )\n",p->name,p->name ) ; + fprintf(fp," INTEGER, TARGET :: %s_num_table( max_domains )\n", p->name,p->name ) ; + fprintf(fp," LOGICAL, TARGET :: %s_boundary_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," CHARACTER*256, TARGET :: %s_dname_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," CHARACTER*256, TARGET :: %s_desc_table( max_domains, param_num_%s )\n", p->name,p->name ) ; + fprintf(fp," CHARACTER*256, TARGET :: %s_units_table( max_domains, param_num_%s )\n", p->name,p->name ) ; } return(0) ; } @@ -169,10 +168,11 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 ) /* arrays */ sprintf(fourd_bnd,"%s_b",assoc_4d) ; if ( get_entry( fourd_bnd ,Domain.fields) != NULL ) { - x->io_mask |= BOUNDARY ; + x->boundary = 1 ; } } - fprintf(fp," %s_stream_table( idomain, P_%s ) = %d\n",assoc_4d,c, x->io_mask ) ; + fprintf(fp," %s_boundary_table( idomain, P_%s ) = %s\n",assoc_4d,c, (x->boundary==1)?".TRUE.":".FALSE." ) ; + /* fprintf(fp," %s_stream_table( idomain, P_%s ) = %d\n",assoc_4d,c, x->io_mask ) ; */ fprintf(fp," %s_dname_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->dname) ; fprintf(fp," %s_desc_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->descrip) ; fprintf(fp," %s_units_table( idomain, P_%s ) = '%s'\n",assoc_4d,c,x->units) ; diff --git a/wrfv2_fire/tools/gen_wrf_io.c b/wrfv2_fire/tools/gen_wrf_io.c index 03699bc0..d7b5cdc5 100644 --- a/wrfv2_fire/tools/gen_wrf_io.c +++ b/wrfv2_fire/tools/gen_wrf_io.c @@ -33,205 +33,18 @@ gen_wrf_io ( char * dirname ) if ( dirname == NULL ) return(1) ; -#if 1 - - OP_F(fp,"wrf_metaput_input.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | INPUT , GEN_OUTPUT ) ; - - OP_F(fp,"wrf_metaput_restart.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | RESTART , GEN_OUTPUT ) ; - - OP_F(fp,"wrf_metaput_history.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | HISTORY , GEN_OUTPUT ) ; - - OP_F(fp,"wrf_metaput_boundary.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | BOUNDARY , GEN_OUTPUT ) ; - - OP_F(fp,"wrf_histout.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist1out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist2out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist3out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist4out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist5out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist6out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist7out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist8out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist9out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist10out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist11out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_OUTPUT ) ; - close_the_file(fp) ; - - OP_F(fp,"wrf_inputout.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput1out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput2out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput3out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput4out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput5out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput6out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput7out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput8out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput9out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput10out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput11out.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_OUTPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_restartout.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_OUTPUT ) ; - close_the_file(fp) ; OP_F(fp,"wrf_bdyout.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_OUTPUT ) ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , GEN_OUTPUT ) ; close_the_file(fp) ; -#endif - -#if 1 - OP_F(fp,"wrf_metaget_input.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | INPUT , GEN_INPUT ) ; - - OP_F(fp,"wrf_metaget_restart.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | RESTART , GEN_INPUT ) ; - - OP_F(fp,"wrf_metaget_history.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | HISTORY , GEN_INPUT ) ; - OP_F(fp,"wrf_metaget_boundary.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , - METADATA | BOUNDARY , GEN_INPUT ) ; - - OP_F(fp,"wrf_histin.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist1in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist2in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist3in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist4in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist5in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist6in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist7in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist8in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist9in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist10in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxhist11in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_inputin.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput1in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput2in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput3in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput4in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput5in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput6in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput7in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput8in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput9in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput10in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_auxinput11in.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_INPUT ) ; - close_the_file(fp) ; - OP_F(fp,"wrf_restartin.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_INPUT ) ; - close_the_file(fp) ; OP_F(fp,"wrf_bdyin.inc") ; - gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_INPUT ) ; + gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , GEN_INPUT ) ; close_the_file(fp) ; -#endif return(0) ; } +#if 0 static int set_dim_strs_x ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag, int sw_reorder ) { @@ -360,9 +173,10 @@ set_dim_strs2 ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN { set_dim_strs_x ( node , ddim, mdim, pdim, prepend , sw_disregard_stag, 0 ) ; /* 0 = reorder according to strg order */ } +#endif int -gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, node_t * node , int io_mask , int sw_io ) +gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, node_t * node , int sw_io ) { node_t * p ; int i , ii ; @@ -392,21 +206,7 @@ gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, no collect/distribute message passing so that history and restart I/O is to separate files but input and boundary I/O is unaffected */ - ok_to_collect_distribute = !sw_distrib_io_layer && - sw_dm_parallel && - !(sw_dm_serial_in_only && ((io_mask&HISTORY) || - (io_mask&AUXHIST1) || - (io_mask&AUXHIST2) || - (io_mask&AUXHIST3) || - (io_mask&AUXHIST4) || - (io_mask&AUXHIST5) || - (io_mask&AUXHIST6) || - (io_mask&AUXHIST7) || - (io_mask&AUXHIST8) || - (io_mask&AUXHIST9) || - (io_mask&AUXHIST10) || - (io_mask&AUXHIST11) || - (io_mask&RESTART))) ; + ok_to_collect_distribute = !sw_distrib_io_layer && sw_dm_parallel ; if ( node == NULL ) return(1) ; if ( structname == NULL ) return(1) ; @@ -441,130 +241,7 @@ gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, no set_dim_strs( p->members, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */ - if ( ! ( io_mask & BOUNDARY ) ) - { - int d ; - char moredims[80], formatdims[80], temp[10], temp2[80],tx[80],r[80], *colon ; - set_mem_order( p->members, memord , NAMELEN) ; - memord[3] = '\0' ; /* snip off any extra dimensions */ -fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ; - strcpy(moredims,"") ; strcpy(formatdims,"") ; - for ( d = 3 ; d < p->ndims ; d++ ) { - strcpy(r,""); - range_of_dimension( r, tx , d , p , "config_flags%" ) ; - colon = index(tx,':') ; if ( colon != NULL ) *colon = ',' ; - sprintf(temp,"idim%d",d-2) ; - strcat(moredims,",") ; strcat(moredims,temp) ; - strcat(formatdims,"\"_\",I5.5,") ; -fprintf(fp," DO %s = %s\n",temp,tx ) ; - } - formatdims[strlen(formatdims)-1] = '\0' ; - strcat(moredims,",") ; -fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; - if ( p->ndims > 3 ) { - strcpy(temp2,moredims+1) ; temp2[strlen(temp2)-1] = '\0' ; -fprintf(fp," WRITE(extradims,'(%s)')%s\n",formatdims,temp2) ; - } -fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ; -fprintf(fp," fid , & ! DataHandle\n") ; -fprintf(fp," current_date(1:19) , & ! DateStr\n") ; - if ( p->ndims > 3 ) { -fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace ))//TRIM(extradims), & !data name\n",p->name) ; - } else { -fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ; - } - strcpy( tl, "" ) ; - if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ; - if ( ok_to_collect_distribute ) { -fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ; - } else { - if ( !strcmp(memord,"XYZ") ) { -fprintf(fp," grid%%%s%s(ims,jms,kms%sitrace) , & ! Field\n",p->name,tl,moredims) ; - } else if ( !strcmp(memord,"YXZ") ) { -fprintf(fp," grid%%%s%s(jms,ims,kms%sitrace) , & ! Field\n",p->name,tl,moredims) ; - } else if ( !strcmp(memord,"XZY") ) { -fprintf(fp," grid%%%s%s(ims,kms,jms%sitrace) , & ! Field\n",p->name,tl,moredims) ; - } else if ( !strcmp(memord,"YZX") ) { -fprintf(fp," grid%%%s%s(jms,kms,ims%sitrace) , & ! Field\n",p->name,tl,moredims) ; - } else if ( !strcmp(memord,"ZXY") ) { -fprintf(fp," grid%%%s%s(kms,ims,jms%sitrace) , & ! Field\n",p->name,tl,moredims) ; - } else if ( !strcmp(memord,"ZYX") ) { -fprintf(fp," grid%%%s%s(kms,jms,ims%sitrace) , & ! Field\n",p->name,tl,moredims) ; - } - } - if (!strncmp(p->members->type->name,"real",4)) { - fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; - } else { - fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ; - } -fprintf(fp," grid%%communicator , & ! Comm\n") ; -fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; -fprintf(fp," grid%%domdesc , & ! Comm\n") ; -fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; - if ( sw_io == GEN_OUTPUT ) { -fprintf(fp," dryrun , & ! flag\n") ; - } -/* fprintf(stderr,"name %s memord %s\n",p->name,memord) ; */ -fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ; - strcpy(stagstr, "") ; - if ( p->members->stag_x ) strcat(stagstr, "X") ; - if ( p->members->stag_y ) strcat(stagstr, "Y") ; - if ( p->members->stag_z ) strcat(stagstr, "Z") ; -fprintf(fp," '%s' , & ! Stagger\n",stagstr) ; - if ( sw_io == GEN_OUTPUT ) { - for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; - for ( i = 0 ; i < 3 ; i++ ) - { - if (( dimnode = p->members->dims[i]) != NULL ) - { - switch ( dimnode->coord_axis ) - { - case (COORD_X) : - if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) ) - { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } - else - { strcpy( dimname[i], dimnode->dim_data_name) ; } - break ; - case (COORD_Y) : - if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) ) - { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } - else - { strcpy( dimname[i], dimnode->dim_data_name) ; } - break ; - case (COORD_Z) : - if ( p->members->stag_z ) - { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } - else - { strcpy( dimname[i], dimnode->dim_data_name) ; } - break ; - } - } - } -fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; -fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; -fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; -fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ; -fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ; - } -fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name, memord ) ; - /* global dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } - fprintf(fp," & \n") ; - /* mem dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } - fprintf(fp," & \n") ; - /* patch dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } - fprintf(fp," & \n") ; -fprintf(fp," ierr )\n" ) ; -fprintf(fp, " ENDIF\n" ) ; - for ( d = 3 ; d < p->ndims ; d++ ) { -fprintf(fp," ENDDO ! idim%d \n",d-2 ) ; - } -fprintf(fp, "ENDDO\n") ; - } /* BOUNDARY FOR 4-D TRACER */ - else if ( io_mask & BOUNDARY ) { int ibdy ; int idx ; @@ -596,7 +273,8 @@ fprintf(fp, "ENDDO\n") ; } for ( pass = 0 ; pass < 2 ; pass++ ) { fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ; -fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; +/*fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ; */ +fprintf(fp," IF ( %s_boundary_table(grid%%id, itrace ) ) THEN\n",p->name) ; for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ ) { if ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ; /* west bdy */ @@ -723,8 +401,7 @@ fprintf(fp, "ENDDO\n") ; /* //////// BOUNDARY ///////////////////// */ - if ( p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA ) - && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) ) + if ( p->boundary && strcmp( p->use, "_4d_bdy_array_" ) || ( p->boundary && fourdname ) ) { int ibdy ; int idx ; @@ -941,493 +618,6 @@ fprintf(fp, "ENDDO\n") ; } } -/* //////// NOT BOUNDARY ///////////////////// */ - else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY)) - { - -/* Aug 2004 - -Namelist variables - -The i r and h settings will be reenabled but it will work a little -differently than i/o of regular state variables: - -1) rather than being read or written as records to the dataset, they -will be gotten or put as time invariant meta data; in other words, they -will only be written once when the dataset is created as the other -metadata is now. This has the benefit of reducing the amount of I/O -traffic on each write (I can't remember, but that may be why the -reading and writing of rconfig data was turned off in the first -place). - -2) All the rconfig variables will be gotten/put as metadata to input, -restart, history, and boundary datasets, regardless of what the 'i', -'r', and 'h' settings are. Instead those settings will control the -behavior with respect to the input-from-namelist vs input-from-dataset -precedence issue that Bill raised. - -In other words, if an rconfig entry has an 'i', 'r', or 'h' in the -Registry, the dataset value takes precedence over the namelist value. -Otherwise, say it is missing the 'i', the reconfig variable's value -still appears as metadata in the dataset but the value of the variable -in the program does not change as a result of inputting the dataset. - -*/ - - if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) ) - { - char c ; - char dname[NAMELEN] ; - - strcpy( dname, p->dname ) ; - make_upper_case( dname ) ; - if ( !strcmp( p->type->name , "integer" ) ) { c = 'i' ; } - else if ( !strcmp( p->type->name , "real" ) ) { c = 'r' ; } - else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; } - else if ( !strcmp( p->type->name , "logical" ) ) { c = 'l' ; } - else { - fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ; - } - if ( sw_io == GEN_OUTPUT ) { - if ( io_mask & p->io_mask ) { - fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ; - fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ; - } - } else { - if ( io_mask & p->io_mask ) { - fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ; - fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ; - fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ; - fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ; - } - } - } -/* end Aug 2004 */ -#if 0 - else if ( ! (io_mask & METADATA) ) /* state vars */ -#else - else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) ) /* state vars */ -#endif - { - if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ; - else passes = 1 ; - - for ( pass = 0 ; pass < passes ; pass++ ) /* for multi timelevel vars */ - { - /* for multi time level variables gen read for both levels - for restart, only _2 for others */ - if ( p->ntl > 1 ) { - if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ; - else sprintf(tag,"_%d",p->ntl) ; - } - else sprintf(tag,"") ; - - /* construct variable name */ - if ( p->scalar_array_member ) - { - strcpy(dexes,"") ; - for (ii = 0; ii < p->ndims; ii++ ) - { - switch(p->dims[ii]->coord_axis) - { - case(COORD_X): strcat(dexes,"ims,") ; break ; - case(COORD_Y): strcat(dexes,"jms,") ; break ; - case(COORD_Z): strcat(dexes,"kms,") ; break ; - default : break ; - } - } - sprintf(vname,"%s%s(%sP_%s)",p->use,tag,dexes,p->name) ; - sprintf(vname_2,"%s%s(%sP_%s)",p->use,"_2",":,:,:,",p->name) ; - sprintf(vname_1,"%s%s(%sP_%s)",p->use,"_1",":,:,:,",p->name) ; - sprintf(vname_x,"%s%s(%sP_%s)",p->use,tag,":,:,:,",p->name) ; - } - else - { - sprintf(vname,"%s%s",p->name,tag) ; - sprintf(vname_x,"%s%s",p->name,tag) ; - sprintf(vname_1,"%s%s",p->name,"_1") ; - sprintf(vname_2,"%s%s",p->name,"_2") ; - } - - - /* construct data name -- maybe same as vname if dname not spec'd */ - if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; } - else { strcpy(dname_tmp,p->dname) ; } - make_upper_case(dname_tmp) ; - -/* - July 2004 - - New code to generate error if input or output for two state variables would be generated with the same dataname - - example wrong: - misc tg "SOILTB" -> gen_tg,SOILTB - misc soiltb "SOILTB" -> gen_soiltb,SOILTB - -*/ -if ( pass == 0 ) -{ - char dname_symbol[128] ; - sym_nodeptr sym_node ; - - sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ; - /* check and see if it is in the symbol table already */ - - if ((sym_node = sym_get( dname_symbol )) == NULL ) { - /* add it */ - sym_node = sym_add ( dname_symbol ) ; - strcpy( sym_node->internal_name , p->name ) ; - } else { - fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s \n", - dname_tmp,p->name ) ; - } -} -/* end July 2004 */ - - if ( io_mask & RESTART && p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ; - else strcpy(dname,dname_tmp) ; - - set_mem_order( p, memord , NAMELEN) ; - -/* kludge for WRF 3DVAR I/O with MM5 analysis kernel */ - if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ; - if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ; - - if ( strlen(dname) < 1 ) { - fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ; - } - if ( p->io_mask & io_mask && sw_io == GEN_INPUT ) - { - if ( p->scalar_array_member ) - fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ; - if ( ok_to_collect_distribute ) - fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; - - strcpy(indices,"") ; - sprintf(post,")") ; - if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */ - { - sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ; - } - - fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s') ) THEN\n",vname) ; - fprintf(fp,"CALL wrf_ext_read_field ( &\n") ; - fprintf(fp," fid , & ! DataHandle \n" ) ; - fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; - fprintf(fp," '%s' , & ! Data Name \n", dname ) ; - if ( p->ndims >= 2 && ok_to_collect_distribute ) - fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ; - else - fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices) ; - - if (!strncmp(p->type->name,"real",4)) { - fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; - } else { - fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; - } - - fprintf(fp," grid%%communicator , & ! Comm\n") ; - fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; - fprintf(fp," grid%%domdesc , & ! Comm\n") ; - fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; - fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; - fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; - fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; - /* global dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } - fprintf(fp," & \n") ; - -/* the first two cases here have to do with if we're running on multiple distributed - memory processors and the i/o api layer can't handle decomposed data. So code is - generated to read the data on processor zero into a globally sized buffer. In this - case, then the domain, memory, and patch dimensions for the globally sized buffer - are all just the domain dimensions. Two D arrays are handled separately - from three-d arrays because in threeD arrays the middle index is K. In the last - case, where the code is either calling a version of the API that supports parallelism - or we aren't running in DM-parallel, the field itself and not a global buffer are - passed, so we pass the domain, memory, and patch indices directly to the read routine. */ - - if ( p->ndims == 3 && ok_to_collect_distribute ) - { - /* mem dimensions are actually domain dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; } - fprintf(fp," & \n") ; - /* patch dimensions are actually domain dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim [i][0], ddim [i][1]) ; } - fprintf(fp," & \n") ; - } - else if ( p->ndims == 2 && ok_to_collect_distribute ) - { - if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) - { - /* mem dimensions are actually domain dimensions */ - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], - ddim_no[yi][0],ddim_no[yi][1] ) ; - /* patch dimensions are actually domain dimensions */ - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim [xi][0],ddim [xi][1], - ddim [yi][0],ddim [yi][1] ) ; - } - } - else - { - /* mem dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } - fprintf(fp," & \n") ; - /* patch dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } - fprintf(fp," & \n") ; - } - fprintf(fp," ierr )\n") ; - fprintf(fp,"END IF\n" ) ; - - if ( ok_to_collect_distribute ) - fprintf(fp,"END IF\n" ) ; - -/* In case we have read into a global buffer, generate code to distribute the data just read in */ - if ( p->ndims == 3 && ok_to_collect_distribute ) - { - if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0) - { - fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ; - fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; - fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1], - ddim_no[yi][0],ddim_no[yi][1], - ddim_no[zi][0],ddim_no[zi][1]) ; - fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1], - mdim_no[yi][0],mdim_no[yi][1], - mdim_no[zi][0],mdim_no[zi][1]) ; - fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1], - pdim_no[yi][0],pdim_no[yi][1], - pdim_no[zi][0],pdim_no[zi][1]) ; - } - } - else if ( p->ndims == 2 && ok_to_collect_distribute ) - { - if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) - { - fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ; - fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], - ddim_no[yi][0],ddim_no[yi][1] ) ; - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1], - mdim_no[yi][0],mdim_no[yi][1] ) ; - fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1], - pdim_no[yi][0],pdim_no[yi][1] ) ; - } - else - { - fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ; - } - } - else if ( !strcmp(memord,"Z") && ok_to_collect_distribute ) - { - fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ; - } - else if ( !strcmp(memord,"0") && ok_to_collect_distribute ) - { - fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ; - - } - else if ( ok_to_collect_distribute ) - { - fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ; - } - - if ( io_mask & INPUT && p->ntl > 1 ) { - /* copy time level two into time level one */ - if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ; - if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ; - } - - if ( p->scalar_array_member ) - { - fprintf(fp,"END IF\n" ) ; - } - - } - else if ( sw_io == GEN_OUTPUT ) - { - if ( p->scalar_array_member ) - fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ; - -/* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data */ - - if ( p->ndims == 3 && ok_to_collect_distribute ) - { - if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0) - { - fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ; - fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; -/* fprintf(fp, "ids , ide , jds , jde , kds , kde , &\n") ; */ - fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1], - ddim_no[yi][0],ddim_no[yi][1], - ddim_no[zi][0],ddim_no[zi][1]) ; - fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1], - mdim_no[yi][0],mdim_no[yi][1], - mdim_no[zi][0],mdim_no[zi][1]) ; - fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1], - pdim_no[yi][0],pdim_no[yi][1], - pdim_no[zi][0],pdim_no[zi][1]) ; - } - } - else if ( p->ndims == 2 && ok_to_collect_distribute ) - { - if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) - { - fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ; - fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ; -/* fprintf(fp, "ids , ide , jds , jde , 1 , 1 , &\n") ; */ - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], - ddim_no[yi][0],ddim_no[yi][1] ) ; - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1], - mdim_no[yi][0],mdim_no[yi][1] ) ; - fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1], - pdim_no[yi][0],pdim_no[yi][1] ) ; - } - else - { - fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ; - } - } - - for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ; - for ( i = 0 ; i < 3 ; i++ ) - { - if (( dimnode = p->dims[i]) != NULL ) - { - switch ( dimnode->coord_axis ) - { - case (COORD_X) : - if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) ) - { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } - else if ( p->dims[i]->subgrid ) - { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } - else - { strcpy( dimname[i], dimnode->dim_data_name) ; } - break ; - case (COORD_Y) : - if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) ) - { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } - else if ( p->dims[i]->subgrid ) - { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } - else - { strcpy( dimname[i], dimnode->dim_data_name) ; } - break ; - case (COORD_Z) : - if ( p->stag_z ) - { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } - else if ( p->dims[i]->subgrid ) - { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; } - else - { strcpy( dimname[i], dimnode->dim_data_name) ; } - break ; - } - } - } - - if ( ok_to_collect_distribute ) - fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ; - - strcpy(indices,"") ; - sprintf(post,")") ; - if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */ - { - sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ; - } - - if ( !(p->scalar_array_member) ) { - fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s') ) THEN\n",vname) ; - fprintf(fp,"CALL wrf_ext_write_field ( &\n") ; - fprintf(fp," fid , & ! DataHandle \n" ) ; - fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ; - fprintf(fp," '%s' , & ! Data Name \n", dname ) ; - if ( p->ndims >= 2 && ok_to_collect_distribute ) - fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ; - else - fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices ) ; - if (!strncmp(p->type->name,"real",4)) { - fprintf(fp," WRF_FLOAT , & ! FieldType \n") ; - } else { - fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; - } - fprintf(fp," grid%%communicator , & ! Comm\n") ; - fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; - fprintf(fp," grid%%domdesc , & ! Comm\n") ; - fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; - fprintf(fp," dryrun , & ! flag\n" ) ; - fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; - fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ; - fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ; - fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ; - fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ; - fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ; - fprintf(fp," '%s' , & ! Units \n",p->units ) ; - fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ; - /* global dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } - fprintf(fp," & \n") ; - -/* the first two cases here have to do with if we're running on multiple distributed - memory processors and the i/o api layer can't handle decomposed data. So code is - generated to read the data on processor zero into a globally sized buffer. In this - case, then the domain, memory, and patch dimensions for the globally sized buffer - are all just the domain domain dimensions. Two D arrays are handled separately - from three-d arrays because in threeD arrays the middle index is K. In the last - case, where the code is either calling a version of the API that supports parallelism - or we aren't running in DM-parallel, the field itself and not a global buffer are - passed, so we pass the domain, memory, and patch indices directly to the read routine. */ - - if ( p->ndims == 3 && ok_to_collect_distribute ) - { - /* mem dimensions are actually domain dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; } - fprintf(fp," & \n") ; - /* patch dimensions are actually domain dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; } - fprintf(fp," & \n") ; - } - else if ( p->ndims == 2 && ok_to_collect_distribute ) - { - if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0) - { - /* mem dimensions are actually domain dimensions */ - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1], - ddim_no[yi][0],ddim_no[yi][1] ) ; - /* patch dimensions are actually domain dimensions */ - fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1], - ddim[yi][0],ddim[yi][1] ) ; - } - } - else - { - /* mem dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; } - fprintf(fp," & \n") ; - /* patch dimensions */ - for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; } - fprintf(fp," & \n") ; - } - fprintf(fp," ierr )\n") ; - fprintf(fp,"ENDIF\n") ; - - if ( ok_to_collect_distribute ) - fprintf(fp,"END IF\n" ) ; - -/* - if ( p->scalar_array_member ) - fprintf(fp,"END IF\n" ) ; -*/ - - } - } - } - } - } - } - if ( p->type->type_type == DERIVED ) - { - sprintf(x,"%s%s%%",structname,p->name ) ; - gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ; } } diff --git a/wrfv2_fire/tools/misc.c b/wrfv2_fire/tools/misc.c index 2633e78f..7559ec7b 100644 --- a/wrfv2_fire/tools/misc.c +++ b/wrfv2_fire/tools/misc.c @@ -324,8 +324,10 @@ char * declare_array_as_pointer( char * tmp , node_t * p ) { strcpy( tmp , "" ) ; - if ( p != NULL ) + if ( p != NULL ) { if ( p->ndims > 0 || p->boundary_array ) strcpy ( tmp, ",POINTER" ) ; + /*if ( p->ndims == 0 ) strcpy ( tmp, ",TARGET" ) ; */ + } return(tmp); } @@ -638,3 +640,75 @@ dimension_size_expression ( char * r , char * tx , int i , node_t * p , char * n sprintf(tx,"((%s)-(%s)+1)", e , s ) ; } + +void +reset_mask ( unsigned int * mask , int e ) +{ + int w ; + unsigned int m, n ; + + w = e / (8*sizeof(int)-1) ; + n = 1 ; + m = ~( n << e % (8*sizeof(int)-1) ) ; + if ( w >= 0 && w < IO_MASK_SIZE ) { + mask[w] &= m ; + } +} + +void +set_mask ( unsigned int * mask , int e ) +{ + int w ; + unsigned int m, n ; + + w = e / (8*sizeof(int)-1) ; + n = 1 ; + m = ( n << e % (8*sizeof(int)-1) ) ; + if ( w >= 0 && w < IO_MASK_SIZE ) { + mask[w] |= m ; + } +} + +int +get_mask ( unsigned int * mask , int e ) +{ + int w ; + unsigned int m, n ; + + w = e / (8*sizeof(int)-1) ; /* 8 is number of bits per byte */ + if ( w >= 0 && w < IO_MASK_SIZE ) { + m = mask[w] ; + n = ( 1 << e % (8*sizeof(int)-1) ) ;; + return ( (m & n) != 0 ) ; + } else { + return(0) ; + } +} + +#if 0 +main() +{ + unsigned int m[5] ; + int i, ii ; + + for ( i = 0 ; i < 5*32 ; i++ ) { + for ( ii = 0 ; ii < 5 ; ii++ ) { m[ii] = 0xffffffff ; } + reset_mask( m, i ) ; + for ( ii = 4 ; ii >= 0 ; ii-- ) { printf(" %08x ", m[ii]) ; } + printf("\n") ; + } + + for ( i = 0 ; i < 5*32 ; i++ ) { + for ( ii = 0 ; ii < 5 ; ii++ ) { m[ii] = 0x0 ; } + set_mask( m, i ) ; + for ( ii = 4 ; ii >= 0 ; ii-- ) { printf(" %08x ", m[ii]) ; } + printf("\n") ; + } + + for ( ii = 0 ; ii < 5 ; ii++ ) { m[ii] = 0x0 ; } + set_mask( m, 82 ) ; + for ( i = 0 ; i < 5*32 ; i++ ) { + printf("%d %0d\n",i,get_mask(m,i) ) ; + } +} +#endif diff --git a/wrfv2_fire/tools/protos.h b/wrfv2_fire/tools/protos.h index dfe9a17c..0cdcca95 100644 --- a/wrfv2_fire/tools/protos.h +++ b/wrfv2_fire/tools/protos.h @@ -67,7 +67,7 @@ char * get_typename_i(int i) ; int gen_alloc ( char * dirname ) ; int gen_alloc1 ( char * dirname ) ; -int gen_alloc2 ( FILE * fp , char * structname , node_t * node , int sw ) ; +int gen_alloc2 ( FILE * fp , char * structname , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ); int gen_module_state_description ( char * dirname ) ; int gen_module_state_description1 ( FILE * fp , node_t * node ) ; @@ -98,7 +98,8 @@ char * set_mem_order( node_t * node , char * str , int n ) ; int gen_wrf_io ( char * dirname ) ; int set_dim_strs ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend, int sw_allow_stagger ) ; -int gen_wrf_io2 ( FILE * fp , char * fname , char * structname , char * fourdname , node_t * node , int io_mask , int sw_io ) ; +int set_dim_strs2 ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag ) ; +int gen_wrf_io2 ( FILE * fp , char * fname , char * structname , char * fourdname , node_t * node , int sw_io ) ; int gen_namelist_defines ( char * dirname , int sw_dimension ) ; int gen_namelist_defaults ( char * dirname ) ; @@ -143,6 +144,10 @@ int gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path ); int count_fields ( node_t * node , int * d2 , int * d3 , char * fourd_names, int down_path ); int gen_debug ( char * dirname ); +void reset_mask ( unsigned int * mask , int e ) ; +void set_mask ( unsigned int * mask , int e ) ; +int get_mask ( unsigned int * mask , int e ) ; + #define PROTOS_H #endif diff --git a/wrfv2_fire/tools/reg_parse.c b/wrfv2_fire/tools/reg_parse.c index aabae04e..d48dfc2a 100644 --- a/wrfv2_fire/tools/reg_parse.c +++ b/wrfv2_fire/tools/reg_parse.c @@ -364,6 +364,17 @@ reg_parse( FILE * infile ) } if ( !strcmp( tokens[ TABLE ] , "rconfig" ) ) { + + char *pp, value[256] ; + for ( pp = tokens[RCNF_SYM_PRE] ; (*pp == ' ' || *pp == ' ') && *pp ; pp++ ) ; + sprintf(value, "RCONFIG_%s" ,pp) ; + if ( sym_get(value) == NULL ) { + sym_add(value) ; + } else { + parseline[0] = '\0' ; /* reset parseline */ + continue ; + } + /* turn a rconfig entry into a typedef to define a field in the top-level built-in type domain */ for ( i = 0 ; i < MAXTOKENS ; i++ ) { toktmp[i] = tokens[i] ; tokens[i] = "-" ; } tokens[TABLE] = "typedef" ; @@ -444,28 +455,89 @@ reg_parse( FILE * infile ) if ( tolower(tokens[FIELD_STAG][i]) == 'z' ) field_struct->stag_z = 1 ; } - field_struct->history = 0 ; field_struct->input = 0 ; - field_struct->auxhist1 = 0 ; field_struct->auxinput1 = 0 ; - field_struct->auxhist2 = 0 ; field_struct->auxinput2 = 0 ; - field_struct->auxhist3 = 0 ; field_struct->auxinput3 = 0 ; - field_struct->auxhist4 = 0 ; field_struct->auxinput4 = 0 ; - field_struct->auxhist5 = 0 ; field_struct->auxinput5 = 0 ; field_struct->restart = 0 ; field_struct->boundary = 0 ; - field_struct->io_mask = 0 ; + for ( i = 0 ; i < MAX_STREAMS ; i++ ) { + reset_mask( field_struct->io_mask, i ) ; + } + { char prev = '\0' ; char x ; + char tmp[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ; int len_of_tok ; char fcn_name[2048], aux_fields[2048] ; + strcpy(tmp,tokens[FIELD_IO]) ; + if (( p = index(tmp,'=') ) != NULL ) { *p = '\0' ; } + for ( i = 0 ; i < strlen(tmp) ; i++ ) + { + x = tolower(tmp[i]) ; + if ( x == 'h' || x == 'i' ) { + char c, *p, *pp ; + int unitid ; + int stream ; + unsigned int * mask ; + stream = ( x == 'h' )?HISTORY_STREAM:INPUT_STREAM ; + mask = field_struct->io_mask ; + set_mask( mask , stream ) ; + strcpy(tmp1, &(tmp[++i])) ; + for ( p = tmp1 ; *p ; i++, p++ ) { + c = tolower(*p) ; if ( c >= 'a' && c <= 'z' ) { *p = '\0' ; break ; } + reset_mask( mask , stream ) ; + } + for ( p = tmp1 ; *p ; p++ ) { + x = *p ; + if ( x >= '0' && x <= '9' ) { + set_mask( mask , stream + x - '0' ) ; + } + else if ( x == '{' ) { + strcpy(tmp2,p+1) ; + if (( pp = index(tmp2,'}') ) != NULL ) { + *pp = '\0' ; + unitid = atoi(tmp+i+1) ; /* JM 20091102 */ + if ( unitid >= 0 || unitid < MAX_STREAMS && stream + unitid < MAX_HISTORY ) { + set_mask( mask , stream + unitid ) ; + } + } else { + fprintf(stderr,"registry syntax error: unmatched {} in the io string for definition of %s\n",tokens[FIELD_SYM]) ; + exit(9) ; + } + } + } + } + } + for ( i = 0 ; i < (len_of_tok = strlen(tokens[FIELD_IO])) ; i++ ) { + int unitid = -1 ; x = tolower(tokens[FIELD_IO][i]) ; - if ( x >= 'a' && x <= 'z' && ! ( x == 'g' || x == 'o' ) ) { - if ( x == 'h' ) {field_struct->history = 10 ; field_struct->io_mask |= HISTORY ;} - if ( x == 'i' ) {field_struct->input = 10 ; field_struct->io_mask |= INPUT ;} - if ( x == 'r' ) {field_struct->restart = 10 ; field_struct->io_mask |= RESTART ;} - if ( x == 'b' ) {field_struct->boundary = 10 ; field_struct->io_mask |= BOUNDARY ;} + if ( x == '{' ) { + int ii,iii ; + char * pp ; + char tmp[NAMELEN] ; + strcpy(tmp,tokens[FIELD_IO]) ; + + if (( pp = index(tmp,'}') ) != NULL ) { + *pp = '\0' ; + iii = pp - (tmp + i + 1) ; + unitid = atoi(tmp+i+1) ; /* JM 20091102 */ + if ( unitid >= 0 || unitid < MAX_STREAMS && unitid < MAX_HISTORY ) { + if ( prev == 'i' ) { + set_mask( field_struct->io_mask , unitid + MAX_HISTORY ) ; + } else if ( prev == 'h' ) { + set_mask( field_struct->io_mask , unitid ) ; + } + } + i += iii ; + continue ; + } else { + fprintf(stderr,"registry syntax error: unmatched {} in the io string for definition of %s\n",tokens[FIELD_SYM]) ; + exit(9) ; + } + + } else if ( x >= 'a' && x <= 'z' ) { + if ( x == 'r' ) { field_struct->restart = 1 ; set_mask( field_struct->io_mask , RESTART_STREAM ) ; } + if ( x == 'b' ) { field_struct->boundary = 1 ; set_mask( field_struct->io_mask , BOUNDARY_STREAM ) ; } if ( x == 'f' || x == 'd' || x == 'u' || x == 's' ) { strcpy(aux_fields,"") ; strcpy(fcn_name,"") ; @@ -509,93 +581,29 @@ reg_parse( FILE * infile ) if ( x == 's' ) strcpy(fcn_name,"smoother") ; } if ( x == 'f' ) { - field_struct->io_mask |= FORCE_DOWN ; + field_struct->nest_mask |= FORCE_DOWN ; strcpy(field_struct->force_fcn_name, fcn_name ) ; strcpy(field_struct->force_aux_fields, aux_fields ) ; } else if ( x == 'd' ) { - field_struct->io_mask |= INTERP_DOWN ; + field_struct->nest_mask |= INTERP_DOWN ; strcpy(field_struct->interpd_fcn_name, fcn_name ) ; strcpy(field_struct->interpd_aux_fields, aux_fields ) ; } else if ( x == 's' ) { - field_struct->io_mask |= SMOOTH_UP ; + field_struct->nest_mask |= SMOOTH_UP ; strcpy(field_struct->smoothu_fcn_name, fcn_name ) ; strcpy(field_struct->smoothu_aux_fields, aux_fields ) ; } else if ( x == 'u' ) { - field_struct->io_mask |= INTERP_UP ; + field_struct->nest_mask |= INTERP_UP ; strcpy(field_struct->interpu_fcn_name, fcn_name ) ; strcpy(field_struct->interpu_aux_fields, aux_fields ) ; } } prev = x ; - } else if ( x >= '0' && x <= '9' || x == 'g' || x == 'o' ) - { - if ( prev == 'i' ) - { - field_struct->io_mask &= ! INPUT ; /* turn off setting from 'i' */ - field_struct->input = field_struct->input % 10 ; /* turn off setting from 'i' */ - if ( x == '0' ) field_struct->input = 1 ; - if ( x == '1' ) field_struct->auxinput1 = 1 ; - if ( x == '2' ) field_struct->auxinput2 = 1 ; - if ( x == '3' ) field_struct->auxinput3 = 1 ; - if ( x == '4' ) field_struct->auxinput4 = 1 ; - if ( x == '5' ) field_struct->auxinput5 = 1 ; - if ( x == '6' ) field_struct->auxinput6 = 1 ; - if ( x == '7' ) field_struct->auxinput7 = 1 ; - if ( x == '8' ) field_struct->auxinput8 = 1 ; - if ( x == '9' ) field_struct->auxinput9 = 1 ; - if ( x == 'g' ) field_struct->auxinput10 = 1 ; - if ( x == 'o' ) field_struct->auxinput11 = 1 ; - } - if ( prev == 'h' ) - { - field_struct->io_mask &= ! HISTORY ; /* turn off setting from 'h' */ - field_struct->history = field_struct->history % 10 ; /* turn off setting from 'h' */ - if ( x == '0' ) field_struct->history = 1 ; - if ( x == '1' ) field_struct->auxhist1 = 1 ; - if ( x == '2' ) field_struct->auxhist2 = 1 ; - if ( x == '3' ) field_struct->auxhist3 = 1 ; - if ( x == '4' ) field_struct->auxhist4 = 1 ; - if ( x == '5' ) field_struct->auxhist5 = 1 ; - if ( x == '6' ) field_struct->auxhist6 = 1 ; - if ( x == '7' ) field_struct->auxhist7 = 1 ; - if ( x == '8' ) field_struct->auxhist8 = 1 ; - if ( x == '9' ) field_struct->auxhist9 = 1 ; - if ( x == 'g' ) field_struct->auxhist10 = 1 ; - if ( x == 'o' ) field_struct->auxhist11 = 1 ; - } } } - if ( field_struct->history > 0 ) { field_struct->history = 1 ; field_struct->io_mask |= HISTORY ; } - if ( field_struct->auxhist1 > 0 ) { field_struct->auxhist1 = 1 ; field_struct->io_mask |= AUXHIST1 ; } - if ( field_struct->auxhist2 > 0 ) { field_struct->auxhist2 = 1 ; field_struct->io_mask |= AUXHIST2 ; } - if ( field_struct->auxhist3 > 0 ) { field_struct->auxhist3 = 1 ; field_struct->io_mask |= AUXHIST3 ; } - if ( field_struct->auxhist4 > 0 ) { field_struct->auxhist4 = 1 ; field_struct->io_mask |= AUXHIST4 ; } - if ( field_struct->auxhist5 > 0 ) { field_struct->auxhist5 = 1 ; field_struct->io_mask |= AUXHIST5 ; } - if ( field_struct->auxhist6 > 0 ) { field_struct->auxhist6 = 1 ; field_struct->io_mask |= AUXHIST6 ; } - if ( field_struct->auxhist7 > 0 ) { field_struct->auxhist7 = 1 ; field_struct->io_mask |= AUXHIST7 ; } - if ( field_struct->auxhist8 > 0 ) { field_struct->auxhist8 = 1 ; field_struct->io_mask |= AUXHIST8 ; } - if ( field_struct->auxhist9 > 0 ) { field_struct->auxhist9 = 1 ; field_struct->io_mask |= AUXHIST9 ; } - if ( field_struct->auxhist10 > 0 ) { field_struct->auxhist10 = 1 ; field_struct->io_mask |= AUXHIST10 ; } - if ( field_struct->auxhist11 > 0 ) { field_struct->auxhist11 = 1 ; field_struct->io_mask |= AUXHIST11 ; } - - if ( field_struct->input > 0 ) { field_struct->input = 1 ; field_struct->io_mask |= INPUT ; } - if ( field_struct->auxinput1 > 0 ) { field_struct->auxinput1 = 1 ; field_struct->io_mask |= AUXINPUT1 ; } - if ( field_struct->auxinput2 > 0 ) { field_struct->auxinput2 = 1 ; field_struct->io_mask |= AUXINPUT2 ; } - if ( field_struct->auxinput3 > 0 ) { field_struct->auxinput3 = 1 ; field_struct->io_mask |= AUXINPUT3 ; } - if ( field_struct->auxinput4 > 0 ) { field_struct->auxinput4 = 1 ; field_struct->io_mask |= AUXINPUT4 ; } - if ( field_struct->auxinput5 > 0 ) { field_struct->auxinput5 = 1 ; field_struct->io_mask |= AUXINPUT5 ; } - if ( field_struct->auxinput6 > 0 ) { field_struct->auxinput6 = 1 ; field_struct->io_mask |= AUXINPUT6 ; } - if ( field_struct->auxinput7 > 0 ) { field_struct->auxinput7 = 1 ; field_struct->io_mask |= AUXINPUT7 ; } - if ( field_struct->auxinput8 > 0 ) { field_struct->auxinput8 = 1 ; field_struct->io_mask |= AUXINPUT8 ; } - if ( field_struct->auxinput9 > 0 ) { field_struct->auxinput9 = 1 ; field_struct->io_mask |= AUXINPUT9 ; } - if ( field_struct->auxinput10 > 0 ) { field_struct->auxinput10 = 1 ; field_struct->io_mask |= AUXINPUT10 ; } - if ( field_struct->auxinput11 > 0 ) { field_struct->auxinput11 = 1 ; field_struct->io_mask |= AUXINPUT11 ; } - - if ( field_struct->restart > 0 ) { field_struct->restart = 1 ; field_struct->io_mask |= RESTART ; } - if ( field_struct->boundary > 0 ) { field_struct->boundary = 1 ; field_struct->io_mask |= BOUNDARY ; } } field_struct->dname[0] = '\0' ; @@ -681,8 +689,13 @@ reg_parse( FILE * infile ) strcpy( member->descrip , field_struct->descrip ) ; strcpy( member->units , field_struct->units ) ; member->next = NULL ; - member->io_mask = field_struct->io_mask ; + for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) { + member->io_mask[i] = field_struct->io_mask[i] ; + } + member->nest_mask = field_struct->nest_mask ; member->ndims = field_struct->ndims ; + member->restart = field_struct->restart ; + member->boundary = field_struct->boundary ; strcpy( member->interpd_fcn_name, field_struct->interpd_fcn_name) ; strcpy( member->interpd_aux_fields, field_struct->interpd_aux_fields) ; strcpy( member->interpu_fcn_name, field_struct->interpu_fcn_name) ; @@ -835,7 +848,9 @@ get_dim_entry( char *s ) node_t * p ; for ( p = Dim ; p != NULL ; p = p->next ) { - if ( !strcmp(p->dim_name, s ) ) return( p ) ; + if ( !strcmp(p->dim_name, s ) ) { + return( p ) ; + } } return(NULL) ; } diff --git a/wrfv2_fire/tools/registry.c b/wrfv2_fire/tools/registry.c index 347d8e86..f03cab9c 100644 --- a/wrfv2_fire/tools/registry.c +++ b/wrfv2_fire/tools/registry.c @@ -1,9 +1,5 @@ #include #include -#include -#include -#include -#include #ifdef _WIN32 # include # define rindex(X,Y) strrchr(X,Y) @@ -12,6 +8,7 @@ # include # include # include +# include # include #endif @@ -55,9 +52,8 @@ main( int argc, char *argv[], char *env[] ) #ifndef _WIN32 rlim.rlim_cur = RLIM_INFINITY ; rlim.rlim_max = RLIM_INFINITY ; -#endif - setrlimit ( RLIMIT_STACK , &rlim ) ; +#endif sym_forget() ; thisprog = *argv ; @@ -128,6 +124,8 @@ main( int argc, char *argv[], char *env[] ) argv++ ; } + gen_io_boilerplate() ; /* 20091213 jm. Generate the io_boilerplate_temporary.inc file */ + init_parser() ; init_type_table() ; init_dim_table() ; @@ -166,6 +164,7 @@ main( int argc, char *argv[], char *env[] ) goto cleanup ; } + reg_parse(fp_tmp) ; fclose(fp_tmp) ; @@ -175,7 +174,7 @@ main( int argc, char *argv[], char *env[] ) gen_state_struct( "inc" ) ; gen_state_subtypes( "inc" ) ; gen_alloc( "inc" ) ; - gen_alloc_count( "inc" ) ; + /* gen_alloc_count( "inc" ) ; */ gen_dealloc( "inc" ) ; gen_scalar_indices( "inc" ) ; gen_module_state_description( "frame" ) ; @@ -198,6 +197,7 @@ main( int argc, char *argv[], char *env[] ) gen_model_data_ord( "inc" ) ; gen_nest_interp( "inc" ) ; gen_scalar_derefs( "inc" ) ; + gen_streams("inc") ; /* this has to happen after gen_nest_interp, which adds halos to the AST */ gen_comms( "inc" ) ; /* this is either package supplied (by copying a */ diff --git a/wrfv2_fire/tools/registry.h b/wrfv2_fire/tools/registry.h index 95bed994..a109a07a 100644 --- a/wrfv2_fire/tools/registry.h +++ b/wrfv2_fire/tools/registry.h @@ -38,31 +38,6 @@ enum proc_orient { ALL_Z_ON_PROC , ALL_X_ON_PROC , ALL_Y_ON_PROC } ; #define FOURD1 8192 #define BDYONLY 16384 -/* I/O mask settings bit */ -#define HISTORY 0x00000002 /* 1 */ -#define AUXHIST1 0x00000004 /* 2 */ -#define AUXHIST2 0x00000008 /* 3 */ -#define AUXHIST3 0x00000010 /* 4 */ -#define AUXHIST4 0x00000020 /* 5 */ -#define AUXHIST5 0x00000040 /* 6 */ -#define AUXHIST6 0x00000080 /* 7 */ -#define AUXHIST7 0x00000100 /* 8 */ -#define AUXHIST8 0x00000200 /* 9 */ -#define AUXHIST9 0x00000400 /* 0 */ -#define AUXHIST10 0x00000800 /* 11 */ -#define AUXHIST11 0x00001000 /* 12 */ -#define INPUT 0x00002000 /* 13 */ -#define AUXINPUT1 0x00004000 /* 14 */ -#define AUXINPUT2 0x00008000 /* 15 */ -#define AUXINPUT3 0x00010000 /* 16 */ -#define AUXINPUT4 0x00020000 /* 17 */ -#define AUXINPUT5 0x00040000 /* 18 */ -#define AUXINPUT6 0x00080000 /* 19 */ -#define AUXINPUT7 0x00100000 /* 10 */ -#define AUXINPUT8 0x00200000 /* 21 */ -#define AUXINPUT9 0x00400000 /* 22 */ -#define AUXINPUT10 0x00800000 /* 23 */ -#define AUXINPUT11 0x01000000 /* 24 */ #define RESTART 0x02000000 /* 25 */ #define BOUNDARY 0x04000000 /* 26 */ #define INTERP_DOWN 0x08000000 /* 27 */ diff --git a/wrfv2_fire/tools/regtest.csh b/wrfv2_fire/tools/regtest.csh index 21f000e7..73b7f38b 100644 --- a/wrfv2_fire/tools/regtest.csh +++ b/wrfv2_fire/tools/regtest.csh @@ -33,12 +33,15 @@ # Intel 1.2 GHz (4-pe) : 3.0 hours (empty) # IBM P4 : 2.0 hours (empty) +setenv WRF_NMM_NEST 1 + if ( `uname` == AIX ) then xlf -qversion - source ~gill/sourceme_modules - module load xlf12 - xlf -qversion + #source ~gill/sourceme_modules + #module load xlf12.01.0000.0005.091127 + #module load xlf12 + #xlf -qversion set VERSION = `xlf -qversion | grep AIX | cut -f2 -d, | cut -f2 -dV | cut -f1 -d.` if ( $VERSION != 12 ) then @@ -1054,7 +1057,7 @@ cat >! damp_real_8 << EOF EOF cat >! phys_real_9 << EOF - mp_physics = 10, 10, 10, + mp_physics = 9, 9, 9, ra_lw_physics = 4, 4, 4, ra_sw_physics = 4, 4, 4, radt = 30, 30, 30, @@ -1094,7 +1097,7 @@ cat >! damp_real_9 << EOF EOF cat >! phys_real_10 << EOF - mp_physics = 14, 14, 14, + mp_physics = 10, 10, 10, ra_lw_physics = 1, 1, 1, ra_sw_physics = 2, 2, 2, radt = 30, 30, 30, @@ -1134,7 +1137,7 @@ cat >! damp_real_10 << EOF EOF cat >! phys_real_11 << EOF - mp_physics = 16, 16, 16, + mp_physics = 14, 14, 14, ra_lw_physics = 3, 3, 3, ra_sw_physics = 3, 3, 3, radt = 30, 30, 30, @@ -1182,7 +1185,7 @@ cat >! damp_real_11 << EOF EOF cat >! phys_real_12 << EOF - mp_physics = 98, 98, 98, + mp_physics = 16, 16, 16, ra_lw_physics = 4, 4, 4, ra_sw_physics = 4, 4, 4, radt = 30, 30, 30, @@ -1223,7 +1226,7 @@ cat >! damp_real_12 << EOF EOF cat >! phys_real_13 << EOF - mp_physics = 3, 3, 3, + mp_physics = 98, 98, 98, ra_lw_physics = 1, 1, 1, ra_sw_physics = 1, 1, 1, radt = 30, 30, 30, @@ -1264,13 +1267,14 @@ cat >! nest_real_13 << EOF EOF cat >! damp_real_13 << EOF + gwd_opt = 1, damp_opt = 3, zdamp = 5000., 5000., 5000., dampcoef = 0.05, 0.05, 0.05 EOF cat >! phys_real_14 << EOF - mp_physics = 4, 4, 4, + mp_physics = 3, 3, 3, ra_lw_physics = 3, 3, 3, ra_sw_physics = 3, 3, 3, radt = 30, 30, 30, @@ -1315,7 +1319,7 @@ cat >! damp_real_14 << EOF EOF cat >! phys_real_15 << EOF - mp_physics = 6, 6, 6, + mp_physics = 4, 4, 4, ra_lw_physics = 4, 4, 4, ra_sw_physics = 4, 4, 4, radt = 30, 30, 30, @@ -3542,7 +3546,22 @@ banner 29 else set RIGHT_SIZE_MPI = FALSE endif - + + ! For some reason, Chemistry files are the wrong size, but the headers are identical, and the + ! bit-wise comparisons are OK. So, we just check to see if the files have two times worth of + ! data in them. If this is a chem run, and we have the right number of time periods of data, + ! and the files do nto have the same size, we just say, welp, they ARE the same size. Might be + ! able to get rid of this test later. Dec 2009. + + if ( ( $KPP == TRUE ) || ( $CHEM == TRUE ) ) then + set times1 = ( ` ncdump -h $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[1] | grep Time | grep UNLIMITED | grep currently | cut -d"(" -f 2 | cut -d" " -f1 `) + set times3 = ( ` ncdump -h $TMPDIR/wrfout_d01_${filetag}.${core}.${phys_option}.$COMPOPTS[3] | grep Time | grep UNLIMITED | grep currently | cut -d"(" -f 2 | cut -d" " -f1 `) + if ( ( $RIGHT_SIZE_MPI != TRUE ) && ( $times1 == 2 ) && ( $times3 == 2 ) ) then + echo "--- RIGHT_SIZE_MPI false ---" >>! ${DEF_DIR}/wrftest.output + set RIGHT_SIZE_MPI = TRUE + endif + endif + # Are we skipping the OpenMP runs? if ( $ZAP_OPENMP == TRUE ) then diff --git a/wrfv2_fire/tools/standard.c b/wrfv2_fire/tools/standard.c index 01928f1b..1ceecb2b 100644 --- a/wrfv2_fire/tools/standard.c +++ b/wrfv2_fire/tools/standard.c @@ -110,7 +110,7 @@ main( int argc , char *argv[] ) col-- ; if ( col <= 0 ) { col = 130 ; - putchar('&') ; putchar('\n') ; putchar('&') ; + if (*q!=')' || *(q+1) ) { putchar('&') ; putchar('\n') ; putchar('&') ; } } } putchar('\n') ; diff --git a/wrfv2_fire/var/Makefile b/wrfv2_fire/var/Makefile index 9905f994..a20550bf 100644 --- a/wrfv2_fire/var/Makefile +++ b/wrfv2_fire/var/Makefile @@ -8,10 +8,10 @@ superclean : /bin/rm -rf *.o *.mod *.b *.a *.f frame/*.F diffwrf \ Registry_tmp* module_state_description.f90 \ inc/dm_comm_cpp_flags testall.csh *.exe *.f90 *.F90 *.F inc/*.inc *.int *.c *.h *.m4 *.code \ - *.sed qual_threshold.nl rsl_cpp_flags version_decl module_dm_warning \ + *.sed qual_threshold.nl inc/rsl_cpp_flags inc/version_decl module_dm_warning \ decode_l2_airs.README time_window.nl Test1.out.correct \ links README* landread.c.dist Makefile \ - depend depend.txt ./inc/namelist_script.inc ) + depend inc/*.inc inc/*.h ) ( cd da; /bin/rm -f *.exe ) ( cd da/makedepf90-2.8.8; /bin/rm -f makedepf90 config.log Makefile config.status ) ( cd gen_be; /bin/rm -f *.exe ) diff --git a/wrfv2_fire/var/build/da.make b/wrfv2_fire/var/build/da.make index 0cabad7c..758b7a05 100644 --- a/wrfv2_fire/var/build/da.make +++ b/wrfv2_fire/var/build/da.make @@ -17,9 +17,14 @@ WRFVAR_OBJS = \ da_blas.o \ da_lapack.o \ bort_exit.o \ - da_bufr.o \ wrdesc.o \ restd.o \ + ccbfl.o \ + cobfl.o \ + crbmg.o \ + cwbmg.o \ + rbytes.o \ + da_bufr.o \ da_par_util.o \ da_par_util1.o \ da_setup_structures.o \ @@ -67,7 +72,6 @@ WRFVAR_OBJS = \ da_grid_definitions.o \ da_statistics.o \ da_define_structures.o \ - da_control.o \ gamma1.o \ da_spectral.o \ da_radiance.o \ @@ -87,7 +91,6 @@ WRFVAR_OBJS = \ module_wrf_error.o \ module_configure.o \ module_state_description.o \ - module_alloc_space.o \ module_timing.o \ module_driver_constants.o \ module_domain.o \ @@ -110,16 +113,6 @@ WRFVAR_OBJS = \ module_quilt_outbuf_ops.o \ module_get_file_names.o \ module_bc_time_utilities.o \ - solve_interface.o \ - mediation_feedback_domain.o \ - mediation_force_domain.o \ - mediation_interp_domain.o \ - nl_get_0_routines.o \ - nl_get_1_routines.o \ - nl_set_0_routines.o \ - nl_set_1_routines.o \ - nest_init_utils.o \ - wrf_fddaobs_in.o \ landread.o \ da_memory.o \ wrf_debug.o \ @@ -130,70 +123,46 @@ WRFVAR_OBJS = \ mediation_integrate.o \ Meat.o \ wrf_num_bytes_between.o \ - wrf_timeseries.o \ wrf_tsin.o \ - module_llxy.o \ input_wrf.o \ - wrf_auxhist1in.o \ - wrf_auxhist2in.o \ - wrf_auxhist3in.o \ - wrf_auxhist4in.o \ - wrf_auxhist5in.o \ - wrf_auxhist6in.o \ - wrf_auxhist7in.o \ - wrf_auxhist8in.o \ - wrf_auxhist9in.o \ - wrf_auxhist10in.o \ - wrf_auxhist11in.o \ - wrf_auxhist1out.o \ - wrf_auxhist2out.o \ - wrf_auxhist3out.o \ - wrf_auxhist4out.o \ - wrf_auxhist5out.o \ - wrf_auxhist6out.o \ - wrf_auxhist7out.o \ - wrf_auxhist8out.o \ - wrf_auxhist9out.o \ - wrf_auxhist10out.o \ - wrf_auxhist11out.o \ - wrf_auxinput1in.o \ - wrf_auxinput2in.o \ - wrf_auxinput3in.o \ - wrf_auxinput4in.o \ - wrf_auxinput5in.o \ - wrf_auxinput6in.o \ - wrf_auxinput7in.o \ - wrf_auxinput8in.o \ - wrf_auxinput9in.o \ - wrf_auxinput10in.o \ - wrf_auxinput11in.o \ - wrf_auxinput1out.o \ - wrf_auxinput2out.o \ - wrf_auxinput3out.o \ - wrf_auxinput4out.o \ - wrf_auxinput5out.o \ - wrf_auxinput6out.o \ - wrf_auxinput7out.o \ - wrf_auxinput8out.o \ - wrf_auxinput9out.o \ - wrf_auxinput10out.o \ - wrf_auxinput11out.o \ wrf_bdyin.o \ wrf_bdyout.o \ - wrf_restartin.o \ - wrf_restartout.o \ output_wrf.o \ - wrf_restartin.o \ - wrf_histin.o \ - wrf_histout.o \ - wrf_inputout.o \ - wrf_inputin.o \ wrf_ext_read_field.o \ wrf_ext_write_field.o \ collect_on_comm.o \ start_domain.o \ - interp_fcn.o \ - couple_or_uncouple_em.o + module_comm_dm.o \ + module_comm_dm_0.o \ + module_comm_dm_1.o \ + module_comm_dm_2.o \ + module_comm_dm_3.o \ + module_alloc_space_0.o \ + module_alloc_space_1.o \ + module_alloc_space_2.o \ + module_alloc_space_3.o \ + module_alloc_space_4.o \ + module_alloc_space_5.o \ + module_alloc_space_6.o \ + module_alloc_space_7.o \ + module_alloc_space_8.o \ + module_alloc_space_9.o \ + nl_get_0_routines.o \ + nl_get_1_routines.o \ + nl_get_2_routines.o \ + nl_get_3_routines.o \ + nl_get_4_routines.o \ + nl_get_5_routines.o \ + nl_get_6_routines.o \ + nl_get_7_routines.o \ + nl_set_0_routines.o \ + nl_set_1_routines.o \ + nl_set_2_routines.o \ + nl_set_3_routines.o \ + nl_set_4_routines.o \ + nl_set_5_routines.o \ + nl_set_6_routines.o \ + nl_set_7_routines.o # Aliases var : wrfvar @@ -205,10 +174,10 @@ wrfvar_esmf : setup da_wrfvar_esmf.exe da_advance_time.exe da_update_bc.exe da_wrfvar.exe : $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \ $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \ - $(WRFVAR_LIBS) da_wrfvar_main.o + da_control.o $(WRFVAR_LIBS) da_wrfvar_main.o $(RM) $@ - $(LD) -o da_wrfvar.exe $(FCFLAGS) $(MODULE_DIRS) $(ESMF_IO_INC) da_wrfvar_main.o \ - -L. -lwrfvar $(CRTM_LIB) $(RTTOV_LIB) \ + $(LD) -o da_wrfvar.exe $(LDFLAGS) $(MODULE_DIRS) $(ESMF_IO_INC) \ + da_control.o da_wrfvar_main.o -L. -lwrfvar $(CRTM_LIB) $(RTTOV_LIB) \ ${MADIS_LIB} $(LIB) @ if test -x $@ ; then cd ../da; $(LN) ../build/$@ . ; fi @@ -223,7 +192,7 @@ da_advance_time.exe : da_advance_time.o inc/da_generic_boilerplate.inc: da_generic_boilerplate.m4 @ $(RM) inc/da_generic_boilerplate.inc - $(M4) da_generic_boilerplate.m4 > inc/da_generic_boilerplate.inc + $(M4) da_generic_boilerplate.m4 > $(WRF_SRC_ROOT_DIR)/inc/da_generic_boilerplate.inc da_utils : setup \ da_tune_obs_hollingsworth1.exe \ @@ -232,7 +201,7 @@ da_utils : setup \ da_update_bc.exe \ da_advance_time.exe \ da_verif_obs.exe \ - da_verif_anal.exe \ + da_verif_grid.exe \ da_bias_airmass.exe \ da_bias_sele.exe \ da_bias_scan.exe \ @@ -245,9 +214,9 @@ da_verif_obs.exe : da_verif_obs.o da_verif_obs_control.o da_verif_obs_init.o $(SFC) -o $@ da_verif_obs.o da_verif_obs_control.o da_verif_obs_init.o @ if test -x $@ ; then cd ../da; $(LN) ../build/$@ . ; fi -da_verif_anal.exe : da_verif_anal.o da_verif_anal_control.o da_netcdf_interface.o $(WRF_SRC_ROOT_DIR)/external/io_netcdf/libwrfio_nf.a - $(SFC) $(LDFLAGS) -o $@ da_verif_anal.o da_netcdf_interface.o \ - da_verif_anal_control.o $(LIB_EXTERNAL) +da_verif_grid.exe : da_verif_grid.o da_verif_grid_control.o da_netcdf_interface.o $(WRF_SRC_ROOT_DIR)/external/io_netcdf/libwrfio_nf.a + $(SFC) $(LDFLAGS) -o $@ da_verif_grid.o da_netcdf_interface.o \ + da_verif_grid_control.o $(LIB_EXTERNAL) @ if test -x $@ ; then cd ../da; $(LN) ../build/$@ . ; fi da_tune_obs_hollingsworth1.exe: da_tune_obs_hollingsworth1.o @@ -300,7 +269,7 @@ diffwrf: ../../external/io_netcdf/diffwrf.F90 fi $(SFC) -c $(FCFLAGS) -I$(NETCDFPATH)/include -I../../external/ioapi_share -I../../external/io_netcdf diffwrf.f echo "diffwrf io_netcdf is being built now. " ; \ - $(SFC) $(FCFLAGS) -I$(NETCDFPATH)/include -I../../external/ioapi_share $(LDFLAGS) -o diffwrf diffwrf.o ../../external/io_netcdf/wrf_io.o ../../external/io_netcdf/field_routines.o ../../external/io_netcdf/module_wrfsi_static.o ../../external/io_netcdf/bitwise_operators.o wrf_debug.o module_wrf_error.o $(ESMF_IO_LIB_EXT) $(LIB_EXTERNAL) + $(SFC) $(FCFLAGS) -I$(NETCDFPATH)/include -I../../external/ioapi_share $(LDFLAGS) -o diffwrf diffwrf.o ../../external/io_netcdf/wrf_io.o ../../external/io_netcdf/field_routines.o ../../external/io_netcdf/module_wrfsi_static.o wrf_debug.o module_wrf_error.o $(ESMF_IO_LIB_EXT) $(LIB_EXTERNAL) # Special cases, either needing special include files or too big to # optimise/debug @@ -309,11 +278,16 @@ wrf_num_bytes_between.o : $(CC) -c $(CFLAGS) wrf_num_bytes_between.c module_state_description.F : ../../Registry/$(REGISTRY) - ../../tools/registry $(ARCHFLAGS) -DNEW_BDYS ../../Registry/$(REGISTRY) - $(LN) ./frame/module_state_description.F . + (cd $(WRF_SRC_ROOT_DIR); tools/registry $(ARCHFLAGS) -DNEW_BDYS Registry/$(REGISTRY) ; cd $(WRF_SRC_ROOT_DIR)/var/build ) + $(LN) $(WRF_SRC_ROOT_DIR)/frame/module_state_description.F . + @ $(LN) $(WRF_SRC_ROOT_DIR)/inc/* inc/. md_calls.inc : md_calls.m4 - $(M4) md_calls.m4 > md_calls.inc + if [ "$(M4)" = NA ] ; then \ + /bin/cp $(WRF_SRC_ROOT_DIR)/arch/md_calls.inc . ; \ + else \ + $(M4) md_calls.m4 > md_calls.inc ; \ + fi $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o : $(RM) $@ @@ -326,24 +300,24 @@ $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o : init_modules.o : $(RM) $@ $(SED_FTN) $*.F > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b > $*.f $(RM) $*.b $(SFC) -c $(FCFLAGS) $(PROMOTION) -I../../external/io_int $*.f da_bias_verif.o da_bias_scan.o da_bias_sele.o da_bias_airmass.o da_rad_diags.o \ da_tune_obs_hollingsworth1.o da_tune_obs_hollingsworth2.o da_tune_obs_desroziers.o \ -da_verif_obs_control.o da_verif_obs_init.o da_verif_anal_control.o \ -da_verif_anal.o : +da_verif_obs_control.o da_verif_obs_init.o da_verif_grid_control.o \ +da_verif_grid.o : $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) -I$(NETCDF)/include $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) -I$(NETCDF)/include $*.b > $*.f $(RM) $*.b $(SFC) -c $(FCFLAGS) $(PROMOTION) -I$(NETCDF)/include $*.f rad_bias.o pythag.o tqli.o tred2.o regress_one.o da_update_bc.o : $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b > $*.f $(RM) $*.b $(SFC) -c $(FCFLAGS) $(PROMOTION) -I$(NETCDF)/include $*.f @@ -351,14 +325,14 @@ da_netcdf_interface.o da_module_couple_uv.o gen_be_etkf.o netcdf_interface.o \ da_gen_be.o gen_be_ensmean.o: $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) -I$(NETCDF)/include $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) -I$(NETCDF)/include $*.b > $*.f $(RM) $*.b $(SFC) -c $(FCFLAGS) $(PROMOTION) $*.f da_etkf.o da_tools.o : $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b > $*.f $(RM) $*.b $(FC) -c $(FCFLAGS) $(PROMOTION) $*.f @@ -378,12 +352,25 @@ da_wrfvar_main.o \ da_wrfvar_top.o : $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $(RTTOV_SRC) $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $(RTTOV_SRC) $*.b > $*.f $(RM) $*.b - $(FC) -c $(FCFLAGS) $(PROMOTION) $(CRTM_SRC) $(RTTOV_SRC) $*.f + if $(FGREP) '!$$OMP' $*.f ; then \ + if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITH OMP ; fi ; \ + $(FC) -c $(FCFLAGS) $(OMP) $(PROMOTION) $(CRTM_SRC) $(RTTOV_SRC) $*.f ; \ + else \ + if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITHOUT OMP ; fi ; \ + $(FC) -c $(FCFLAGS) $(PROMOTION) $ $(CRTM_SRC) $(RTTOV_SRC) $*.f ; \ + fi + da_blas.o \ -da_lapack.o \ +da_lapack.o : + $(RM) $@ + $(SED_FTN) $*.f90 > $*.b + $(CPP) $*.b > $*.f + $(RM) $*.b + $(SFC) -c $(FCFLAGS) $*.f + bort2.o \ bort.o \ irev.o \ @@ -401,19 +388,19 @@ uptdd.o : $(SED_FTN) $*.f90 > $*.b $(CPP) $*.b > $*.f $(RM) $*.b - $(FC) -c $(FCFLAGS) $*.f + $(SFC) -c $(FCDEBUG) $(FORMAT_FREE) $(FCOPTIM) $*.f da_bufr.o : $(RM) $@ $(SED_FTN) $*.f90 > $*.b $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f $(RM) $*.b - $(FC) -c $(FCFLAGS) $*.f + $(SFC) -c $(FCDEBUG) $(FORMAT_FREE) $(FCOPTIM) $*.f da_spectral.o da_be_spectral.o : $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b > $*.f $(RM) $*.b $(FC) -c $(FCFLAGS) $(PROMOTION) -I../../external/fftpack/fftpack5 $*.f @@ -423,9 +410,9 @@ da_advance_time.o : x=`echo "$(SFC)" | awk '{print $$1}'` ; export x ; \ if [ $$x = "gfortran" ] ; then \ echo removing external declaration of iargc for gfortran ; \ - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b | sed '/integer *, *external.*iargc/d' > $*.f ;\ + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b | sed '/integer *, *external.*iargc/d' > $*.f ;\ else \ - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f ; \ + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b > $*.f ; \ fi $(RM) $*.b $(SFC) -c $(FCFLAGS) $(PROMOTION) -I$(NETCDF)/include $*.f @@ -442,3 +429,85 @@ input_wrf.o : if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \ $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \ fi + +nl_set_0_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=0 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx0.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx0.f90 + $(RM) xx0.f90 + +nl_set_1_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=1 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx1.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx1.f90 + $(RM) xx1.f90 + +nl_set_2_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=2 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx2.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx2.f90 + $(RM) xx2.f90 + +nl_set_3_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=3 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx3.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx3.f90 + $(RM) xx3.f90 + +nl_set_4_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=4 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx4.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx4.f90 + $(RM) xx4.f90 + +nl_set_5_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=5 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx5.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx5.f90 + $(RM) xx5.f90 + +nl_set_6_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=6 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx6.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx6.f90 + $(RM) xx6.f90 + +nl_set_7_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=7 -I./inc -DNL_set_ROUTINES nl_access_routines.F > xx7.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) xx7.f90 + $(RM) xx7.f90 + +nl_get_0_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=0 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy0.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy0.f90 + $(RM) yy0.f90 + +nl_get_1_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=1 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy1.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy1.f90 + $(RM) yy1.f90 + +nl_get_2_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=2 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy2.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy2.f90 + $(RM) yy2.f90 + +nl_get_3_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=3 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy3.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy3.f90 + $(RM) yy3.f90 + +nl_get_4_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=4 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy4.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy4.f90 + $(RM) yy4.f90 + +nl_get_5_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=5 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy5.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy5.f90 + $(RM) yy5.f90 + +nl_get_6_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=6 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy6.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy6.f90 + $(RM) yy6.f90 + +nl_get_7_routines.o : nl_access_routines.F module_configure.o + $(CPP) -DNNN=7 -I./inc -DNL_get_ROUTINES nl_access_routines.F > yy7.f90 + $(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) yy7.f90 + $(RM) yy7.f90 + +# DO NOT DELETE diff --git a/wrfv2_fire/var/build/gen_be.make b/wrfv2_fire/var/build/gen_be.make index e3dd03c7..98d0554c 100644 --- a/wrfv2_fire/var/build/gen_be.make +++ b/wrfv2_fire/var/build/gen_be.make @@ -50,7 +50,13 @@ gen_be_stage0_wrf.exe : gen_be_stage0_wrf.o $(GEN_BE_OBJS) $(GEN_BE_LIBS) $(CPP) $(CPPFLAGS) $(FPPFLAGS) gen_be_stage0_wrf.b > gen_be_stage0_wrf.f ; \ fi $(RM) gen_be_stage0_wrf.b - $(SFC) -c $(FCFLAGS) $(PROMOTION) gen_be_stage0_wrf.f + if $(FGREP) '!$$OMP' gen_be_stage0_wrf.f ; then \ + if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITH OMP ; fi ; \ + $(SFC) -c $(FCFLAGS) $(PROMOTION) gen_be_stage0_wrf.f ; \ + else \ + if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITHOUT OMP ; fi ; \ + $(SFC) -c $(FCFLAGS) $(PROMOTION) gen_be_stage0_wrf.f ; \ + fi $(SFC) -o $@ $(LDFLAGS) $(GEN_BE_OBJS) gen_be_stage0_wrf.o $(GEN_BE_LIB) @ if test -x $@ ; then cd ../da; $(LN) ../build/$@ . ; fi diff --git a/wrfv2_fire/var/build/makefile b/wrfv2_fire/var/build/makefile index 605237bd..9d07c2b6 100644 --- a/wrfv2_fire/var/build/makefile +++ b/wrfv2_fire/var/build/makefile @@ -9,11 +9,9 @@ links : @ cp makefile makefile.old @ $(LN) ../../dyn_em/* . @ $(LN) ../gen_be/* . - @ $(LN) ../../inc/* . @ $(LN) ../../share/* . @ $(LN) ../../frame/* . @ if test -e module_dm_stubs.F; then rm -rf module_dm_stubs.F; fi - @ $(LN) ../../share/* . @ $(LN) ../da/da*/* . @ $(LN) ../external/*/* . @ $(LN) ../../arch/*.sed . @@ -26,22 +24,16 @@ links : @ mv makefile.old makefile @ touch links -WRFVAR_LIBS = libwrfvar.a $(ESMF_TIME_LIBS) $(NETCDF_LIBS) $(PNETCDF_LIBS) \ - $(GRIB1_LIBS) $(GRIB2_LIBS) $(GRIB_SHARE_LIBS) $(MPI_LIBS) $(FFTPACK_LIB) +WRFVAR_LIBS = libwrfvar.a -WRFVAR_LIB = -L. -lwrfvar $(LAPACK_LIB) $(NETCDF_LIB) $(PNETCDF_LIB) \ - $(GRIB1_LIB) $(GRIB2_LIB) $(GRIB_SHARE_LIB) \ - $(ESMF_TIME_LIB) \ - $(FFTPACK_LIB) \ - $(RTTOV_LIB) $(CRTM_LIB) $(MPI_LIB) $(LOCAL_LIB) +WRFVAR_LIB = -L. -lwrfvar $(RTTOV_LIB) $(CRTM_LIB) FPPFLAGS = -I$(WRF_SRC_ROOT_DIR)/inc depend : links module_state_description.F md_calls.inc \ inc/da_generic_boilerplate.inc - $(LN) $(WRF_SRC_ROOT_DIR)/var/build/inc/* $(WRF_SRC_ROOT_DIR)/inc/. - (cd $(WRF_SRC_ROOT_DIR)/var/da/makedepf90-2.8.8; ./setup_makedepf90) - $(WRF_SRC_ROOT_DIR)/var/da/makedepf90-2.8.8/makedepf90 -free $(ARCHFLAGS) -DNEW_BDYS *.F *.f90 *.F90 2>/dev/null > depend.txt +# (cd $(WRF_SRC_ROOT_DIR)/var/da/makedepf90-2.8.8; ./setup_makedepf90) +# $(WRF_SRC_ROOT_DIR)/var/da/makedepf90-2.8.8/makedepf90 -free $(ARCHFLAGS) -DNEW_BDYS *.F *.f90 *.F90 2>/dev/null > depend.txt touch depend include depend.txt @@ -61,7 +53,13 @@ libwrfvar.a : $(WRFVAR_OBJS) .f90.o: $(RM) $@ $(SED_FTN) $*.f90 > $*.b - $(CPP) $(CPPFLAGS) $(FPPFLAGS) $*.b > $*.f + $(CPP) $(CPPFLAGS) $(OMPCPP) $(FPPFLAGS) $*.b > $*.f $(RM) $*.b - $(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $*.f + if $(FGREP) '!$$OMP' $*.f ; then \ + if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITH OMP ; fi ; \ + $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(PROMOTION) $*.f ; \ + else \ + if [ -n "$(OMP)" ] ; then echo COMPILING $*.f90 WITHOUT OMP ; fi ; \ + $(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $*.f ; \ + fi diff --git a/wrfv2_fire/var/build/setup.csh b/wrfv2_fire/var/build/setup.csh index 729f8de8..e79b15a8 100755 --- a/wrfv2_fire/var/build/setup.csh +++ b/wrfv2_fire/var/build/setup.csh @@ -107,9 +107,9 @@ endif #if (-d ${EXT_DIR}/fftpack/fftpack5/${COMPILER}_${PROCESSOR}) then # setenv FFTPACK ${EXT_DIR}/fftpack/fftpack5/${COMPILER}_${PROCESSOR} #endif -#if (-d ${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR}) then -# setenv BUFR ${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR} -#endif +if (-d ${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR}) then + setenv BUFR ${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR} +endif if (-d ${EXT_DIR}/zlib/zlib-1.2.3/${COMPILER}_${PROCESSOR}) then setenv ZLIB ${EXT_DIR}/zlib/zlib-1.2.3/${COMPILER}_${PROCESSOR} endif @@ -131,29 +131,14 @@ endif if (-d ${EXT_DIR}/netcdf/pnetcdf-1.0.1/${COMPILER}_${PROCESSOR}) then setenv PNETCDF ${EXT_DIR}/netcdf/pnetcdf-1.0.1/${COMPILER}_${PROCESSOR} endif -if (-d ${EXT_DIR}/madis/${COMPILER}_${PROCESSOR}) then - setenv MADIS ${EXT_DIR}/madis/${COMPILER}_${PROCESSOR} -endif +#if (-d ${EXT_DIR}/madis/${COMPILER}_${PROCESSOR}) then +# setenv MADIS ${EXT_DIR}/madis/${COMPILER}_${PROCESSOR} +#endif if (-d /usr/lpp/ppe.poe) then setenv MPIHOME /usr/lpp/ppe.poe endif -# Lightning - -if ( $MACHINE == "lightning" ) then - if ( $COMPILER == "pathscale" ) then - setenv MPIHOME /contrib/2.6/mpich-gm/1.2.6..14a-pathscale-2.4-64 - endif - if ( $COMPILER == "pgi" ) then - setenv MPIHOME /contrib/2.6/mpich-gm/1.2.6..14a-pgi-6.2-64 - endif - if ( $COMPILER == "intel" ) then - source /contrib/2.6/intel/9.1.036-64/bin/ifortvars.csh - setenv MPIHOME /contrib/2.6/mpich-gm/1.2.6..14a-intel-9.1.042-64 - endif -endif - setenv LINUX_MPIHOME $MPIHOME setenv PATH $MPIHOME/bin:$PATH @@ -210,9 +195,9 @@ endif if ($?PNETCDF) then echo "PNETCDF " $PNETCDF endif -if ($?MADIS) then - echo "MADIS " $MADIS -endif +#if ($?MADIS) then +# echo "MADIS " $MADIS +#endif if ($?SUBMIT) then echo "SUBMIT " $SUBMIT endif diff --git a/wrfv2_fire/var/build/setup.ksh b/wrfv2_fire/var/build/setup.ksh index 80170208..825199d5 100755 --- a/wrfv2_fire/var/build/setup.ksh +++ b/wrfv2_fire/var/build/setup.ksh @@ -84,9 +84,9 @@ fi #if test -d ${EXT_DIR}/fftpack/fftpack5/${COMPILER}_${PROCESSOR}; then # export FFTPACK=${EXT_DIR}/fftpack/fftpack5/${COMPILER}_${PROCESSOR} #fi -#if test -d ${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR}; then -# export BUFR=${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR} -#fi +if test -d ${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR}; then + export BUFR=${EXT_DIR}/bufr/bufr_ncep_nco/${COMPILER}_${PROCESSOR} +fi if test -d ${EXT_DIR}/zlib/zlib-1.2.3/${COMPILER}_${PROCESSOR}; then export ZLIB=${EXT_DIR}/zlib/zlib-1.2.3/${COMPILER}_${PROCESSOR} fi @@ -108,29 +108,14 @@ fi if test -d ${EXT_DIR}/netcdf/pnetcdf-1.0.1/${COMPILER}_${PROCESSOR}; then export PNETCDF=${EXT_DIR}/netcdf/pnetcdf-1.0.1/${COMPILER}_${PROCESSOR} fi -if test -d ${EXT_DIR}/madis/${COMPILER}_${PROCESSOR}; then - export PNETCDF=${EXT_DIR}/madis/${COMPILER}_${PROCESSOR} -fi +#if test -d ${EXT_DIR}/madis/${COMPILER}_${PROCESSOR}; then +# export MADIS=${EXT_DIR}/madis/${COMPILER}_${PROCESSOR} +#fi if test -d /usr/lpp/ppe.poe; then export MPIHOME=/usr/lpp/ppe.poe fi -# Lightning - -if test $MACHINE = "lightning"; then - if test $COMPILER = pathscale; then - export MPIHOME=/contrib/2.6/mpich-gm/1.2.6..14a-pathscale-2.4-64 - fi - if test $COMPILER = pgi; then - export MPIHOME=/contrib/2.6/mpich-gm/1.2.6..14a-pgi-6.2-64 - fi - if test $COMPILER = intel; then - . /contrib/2.6/intel/9.1.036-64/bin/ifortvars.sh - export MPIHOME=/contrib/2.6/mpich-gm/1.2.6..14a-intel-9.1.042-64 - fi -fi - export LINUX_MPIHOME=$MPIHOME export MANPATH=$MPIHOME/man:$MANPATH @@ -151,7 +136,7 @@ echo "HDF5 " $HDF5 echo "HDFEOS " $HDFEOS echo "JASPER " $JASPER echo "PNETCDF " $PNETCDF -echo "MADIS " $MADIS +#echo "MADIS " $MADIS echo "SUBMIT " $SUBMIT if test "$SUBMIT_OPTIONS1." != '.'; then echo "SUBMIT_OPTIONS1 $SUBMIT_OPTIONS1" diff --git a/wrfv2_fire/var/da/da_airep/da_check_max_iv_airep.inc b/wrfv2_fire/var/da/da_airep/da_check_max_iv_airep.inc index 39337ac2..1d416580 100644 --- a/wrfv2_fire/var/da/da_airep/da_check_max_iv_airep.inc +++ b/wrfv2_fire/var/da/da_airep/da_check_max_iv_airep.inc @@ -2,6 +2,8 @@ subroutine da_check_max_iv_airep(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -23,50 +25,41 @@ subroutine da_check_max_iv_airep(iv, it, num_qcstat_conv) do k = 1, iv%info(airep)%levels(n) call da_get_print_lvl(iv%airep(n)%p(k),ipr) - if( iv%airep(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%airep(n)%u(k)%qc =0 - if( iv%airep(n)%u(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%airep(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(airep), n, iv%airep(n)%u(k), max_error_uv,failed) if( iv%info(airep)%proc_domain(k,n) ) then - num_qcstat_conv(1,airep,1,ipr) = num_qcstat_conv(1,airep,1,ipr) + 1 + num_qcstat_conv(1,airep,1,ipr) = num_qcstat_conv(1,airep,1,ipr) + 1 if(failed) then num_qcstat_conv(2,airep,1,ipr) = num_qcstat_conv(2,airep,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'airep',ob_vars(1),iv%info(airep)%lat(k,n),iv%info(airep)%lon(k,n),0.01*iv%airep(n)%p(k) end if - end if - end if + end if - if( iv%airep(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%airep(n)%v(k)%qc =0 - if( iv%airep(n)%v(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%airep(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(airep), n, iv%airep(n)%v(k), max_error_uv,failed) if( iv%info(airep)%proc_domain(k,n) ) then - num_qcstat_conv(1,airep,2,ipr) = num_qcstat_conv(1,airep,2,ipr) + 1 + num_qcstat_conv(1,airep,2,ipr) = num_qcstat_conv(1,airep,2,ipr) + 1 if(failed)then num_qcstat_conv(2,airep,2,ipr) = num_qcstat_conv(2,airep,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'airep',ob_vars(2),iv%info(airep)%lat(k,n),iv%info(airep)%lon(k,n),0.01*iv%airep(n)%p(k) end if - end if - end if + end if - if( iv%airep(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%airep(n)%t(k)%qc =0 - if( iv%airep(n)%t(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%airep(n)%t(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(airep), n, iv%airep(n)%t(k), max_error_t,failed) if( iv%info(airep)%proc_domain(k,n) ) then - num_qcstat_conv(1,airep,3,ipr) = num_qcstat_conv(1,airep,3,ipr) + 1 + num_qcstat_conv(1,airep,3,ipr) = num_qcstat_conv(1,airep,3,ipr) + 1 if(failed) then num_qcstat_conv(2,airep,3,ipr) = num_qcstat_conv(2,airep,3,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'airep',ob_vars(3),iv%info(airep)%lat(k,n),iv%info(airep)%lon(k,n),0.01*iv%airep(n)%p(k) end if - end if - end if + end if end do end do diff --git a/wrfv2_fire/var/da/da_airep/da_get_innov_vector_airep.inc b/wrfv2_fire/var/da/da_airep/da_get_innov_vector_airep.inc index 7bb27048..75786d6b 100644 --- a/wrfv2_fire/var/da/da_airep/da_get_innov_vector_airep.inc +++ b/wrfv2_fire/var/da/da_airep/da_get_innov_vector_airep.inc @@ -40,6 +40,16 @@ subroutine da_get_innov_vector_airep( it,num_qcstat_conv, grid, ob, iv) model_v(:,:) = 0.0 model_t(:,:) = 0.0 + if ( it > 1) then + do n=iv%info(airep)%n1, iv%info(airep)%n2 + do k=1, iv%info(airep)%levels(n) + if (iv%airep(n)%u(k)%qc == fails_error_max) iv%airep(n)%u(k)%qc = 0 + if (iv%airep(n)%v(k)%qc == fails_error_max) iv%airep(n)%v(k)%qc = 0 + if (iv%airep(n)%t(k)%qc == fails_error_max) iv%airep(n)%t(k)%qc = 0 + end do + end do + end if + do n=iv%info(airep)%n1, iv%info(airep)%n2 if (iv%info(airep)%levels(n) < 1) cycle @@ -137,7 +147,8 @@ subroutine da_get_innov_vector_airep( it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------- - call da_check_max_iv_airep (iv, it,num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_airep (iv, it,num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_airsr/da_check_max_iv_airsr.inc b/wrfv2_fire/var/da/da_airsr/da_check_max_iv_airsr.inc index 705ec370..022f4f60 100644 --- a/wrfv2_fire/var/da/da_airsr/da_check_max_iv_airsr.inc +++ b/wrfv2_fire/var/da/da_airsr/da_check_max_iv_airsr.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_airsr(iv, it,num_qcstat_conv) !------------------------------------------------------------------------- ! Purpose: Applies max error check on AIRS retrievals + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !------------------------------------------------------------------------- implicit none @@ -22,41 +25,29 @@ subroutine da_check_max_iv_airsr(iv, it,num_qcstat_conv) do n=iv%info(airsr)%n1,iv%info(airsr)%n2 do k = 1, iv%info(airsr)%levels(n) call da_get_print_lvl(iv%airsr(n)%p(k),ipr) - if( iv%airsr(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%airsr(n)%t(k)%qc =0 - if( iv%airsr(n)%t(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed = .false. + if( iv%airsr(n)%t(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(airsr), n, iv%airsr(n)%t(k), max_error_t ,failed) if( iv%info(airsr)%proc_domain(k,n) ) then - num_qcstat_conv(1,airsr,3,ipr) = num_qcstat_conv(1,airsr,3,ipr) + 1 + num_qcstat_conv(1,airsr,3,ipr) = num_qcstat_conv(1,airsr,3,ipr) + 1 if(failed)then num_qcstat_conv(2,airsr,3,ipr) = num_qcstat_conv(2,airsr,3,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'airsr',ob_vars(3),iv%info(airsr)%lat(k,n),iv%info(airsr)%lon(k,n),0.01*iv%airsr(n)%p(k) endif - endif - endif + endif - if( iv%airsr(n)%q(k)%qc == fails_error_max .and. it > 1 )iv%airsr(n)%q(k)%qc =0 - if( iv%airsr(n)%q(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( iv%airsr(n)%t(k)%qc == fails_error_max ) then - failed=.true. - iv%airsr(n)%q(k)%qc = fails_error_max - iv%airsr(n)%q(k)%inv = 0.0 - else - if( check_max_iv) & + failed = .false. + if( iv%airsr(n)%q(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(airsr), n, iv%airsr(n)%q(k), max_error_q ,failed) - endif if( iv%info(airsr)%proc_domain(k,n) ) then - num_qcstat_conv(1,airsr,4,ipr) = num_qcstat_conv(1,airsr,4,ipr) + 1 + num_qcstat_conv(1,airsr,4,ipr) = num_qcstat_conv(1,airsr,4,ipr) + 1 if(failed)then num_qcstat_conv(2,airsr,4,ipr) = num_qcstat_conv(2,airsr,4,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'airsr',ob_vars(4),iv%info(airsr)%lat(k,n),iv%info(airsr)%lon(k,n),0.01*iv%airsr(n)%p(k) endif - endif - endif + endif end do end do diff --git a/wrfv2_fire/var/da/da_airsr/da_get_innov_vector_airsr.inc b/wrfv2_fire/var/da/da_airsr/da_get_innov_vector_airsr.inc index f4762abf..1077aa7e 100644 --- a/wrfv2_fire/var/da/da_airsr/da_get_innov_vector_airsr.inc +++ b/wrfv2_fire/var/da/da_airsr/da_get_innov_vector_airsr.inc @@ -40,6 +40,15 @@ subroutine da_get_innov_vector_airsr( it,num_qcstat_conv, grid, ob, iv) model_t(:,:) = 0.0 model_q(:,:) = 0.0 + if ( it > 1 ) then + do n = iv%info(airsr)%n1, iv%info(airsr)%n2 + do k = 1, iv%info(airsr)%levels(n) + if (iv%airsr(n)%t(k)%qc == fails_error_max) iv%airsr(n)%t(k)%qc = 0 + if (iv%airsr(n)%q(k)%qc == fails_error_max) iv%airsr(n)%q(k)%qc = 0 + end do + end do + end if + do n=iv%info(airsr)%n1, iv%info(airsr)%n2 num_levs = iv%info(airsr)%levels(n) @@ -106,7 +115,8 @@ subroutine da_get_innov_vector_airsr( it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_airsr(iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_airsr(iv, it, num_qcstat_conv) deallocate (model_t) deallocate (model_q) diff --git a/wrfv2_fire/var/da/da_bogus/da_check_max_iv_bogus.inc b/wrfv2_fire/var/da/da_bogus/da_check_max_iv_bogus.inc index 5ad04d81..52bc1868 100644 --- a/wrfv2_fire/var/da/da_bogus/da_check_max_iv_bogus.inc +++ b/wrfv2_fire/var/da/da_bogus/da_check_max_iv_bogus.inc @@ -2,6 +2,8 @@ subroutine da_check_max_iv_bogus(iv,ob, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -22,94 +24,71 @@ subroutine da_check_max_iv_bogus(iv,ob, it, num_qcstat_conv) ! [1.0] Perform maximum innovation vector check: !--------------------------------------------------------------------------- - failed = .false. - do n = iv%info(bogus)%n1,iv%info(bogus)%n2 do k = 1, iv%info(bogus)%levels(n) call da_get_print_lvl(iv%bogus(n)%p(k),ipr) - if( iv%bogus(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%bogus(n)%u(k)%qc =0 - if( iv%bogus(n)%u(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%bogus(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(bogus), n, iv%bogus(n)%u(k), max_error_buv,failed) if( iv%info(bogus)%proc_domain(k,n) ) then - num_qcstat_conv(1,bogus,1,ipr) = num_qcstat_conv(1,bogus,1,ipr) + 1 + num_qcstat_conv(1,bogus,1,ipr) = num_qcstat_conv(1,bogus,1,ipr) + 1 if(failed)then num_qcstat_conv(2,bogus,1,ipr) = num_qcstat_conv(2,bogus,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'bogus',ob_vars(1),iv%info(bogus)%lat(k,n),iv%info(bogus)%lon(k,n),0.01*iv%bogus(n)%p(k) end if - end if - end if + end if - if( iv%bogus(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%bogus(n)%v(k)%qc =0 - if( iv%bogus(n)%v(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%bogus(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(bogus), n, iv%bogus(n)%v(k), max_error_buv,failed) if( iv%info(bogus)%proc_domain(k,n) ) then - num_qcstat_conv(1,bogus,2,ipr) = num_qcstat_conv(1,bogus,2,ipr) + 1 + num_qcstat_conv(1,bogus,2,ipr) = num_qcstat_conv(1,bogus,2,ipr) + 1 if(failed)then num_qcstat_conv(2,bogus,2,ipr) = num_qcstat_conv(2,bogus,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'bogus',ob_vars(2),iv%info(bogus)%lat(k,n),iv%info(bogus)%lon(k,n),0.01*iv%bogus(n)%p(k) end if - end if - end if + end if - if( iv%bogus(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%bogus(n)%t(k)%qc =0 - if( iv%bogus(n)%t(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%bogus(n)%t(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(bogus), n, iv%bogus(n)%t(k), max_error_bt ,failed) if( iv%info(bogus)%proc_domain(k,n) ) then - num_qcstat_conv(1,bogus,3,ipr) = num_qcstat_conv(1,bogus,3,ipr) + 1 + num_qcstat_conv(1,bogus,3,ipr) = num_qcstat_conv(1,bogus,3,ipr) + 1 if(failed)then num_qcstat_conv(2,bogus,3,ipr) = num_qcstat_conv(2,bogus,3,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'bogus',ob_vars(3),iv%info(bogus)%lat(k,n),iv%info(bogus)%lon(k,n),0.01*iv%bogus(n)%p(k) end if - end if - end if + end if - if( iv%bogus(n)%q(k)%qc == fails_error_max .and. it > 1 )iv%bogus(n)%q(k)%qc =0 - if( iv%bogus(n)%q(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( iv%bogus(n)%t(k)%qc == fails_error_max ) then - failed=.true. - iv%bogus(n)%q(k)%qc = fails_error_max - iv%bogus(n)%q(k)%inv = 0. - else - if( check_max_iv) & + failed=.false. + if( iv%bogus(n)%q(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(bogus), n, iv%bogus(n)%q(k), max_error_bq ,failed) - endif if( iv%info(bogus)%proc_domain(k,n) ) then - num_qcstat_conv(1,bogus,4,ipr) = num_qcstat_conv(1,bogus,4,ipr) + 1 + num_qcstat_conv(1,bogus,4,ipr) = num_qcstat_conv(1,bogus,4,ipr) + 1 if(failed)then num_qcstat_conv(2,bogus,4,ipr) = num_qcstat_conv(2,bogus,4,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'bogus',ob_vars(4),iv%info(bogus)%lat(k,n),iv%info(bogus)%lon(k,n),0.01*iv%bogus(n)%p(k) end if - end if - end if + end if end do ! Sea Level Pressure if( iv%info(bogus)%proc_domain(1,n) ) then - if( iv%bogus(n)%slp%qc == fails_error_max .and. it > 1 )iv%bogus(n)%slp%qc =0 - if( iv%bogus(n)%slp%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%bogus(n)%slp%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(bogus), n, iv%bogus(n)%slp, max_error_slp ,failed) - num_qcstat_conv(1,bogus,5,1) = num_qcstat_conv(1,bogus,5,1) + 1 + num_qcstat_conv(1,bogus,5,1) = num_qcstat_conv(1,bogus,5,1) + 1 if(failed) then num_qcstat_conv(2,bogus,5,1) = num_qcstat_conv(2,bogus,5,1) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'bogus',ob_vars(5),iv%info(bogus)%lat(1,n),iv%info(bogus)%lon(1,n),ob%bogus(n)%slp endif - endif endif end do diff --git a/wrfv2_fire/var/da/da_bogus/da_get_innov_vector_bogus.inc b/wrfv2_fire/var/da/da_bogus/da_get_innov_vector_bogus.inc index b5eb0bf5..7441e7d6 100644 --- a/wrfv2_fire/var/da/da_bogus/da_get_innov_vector_bogus.inc +++ b/wrfv2_fire/var/da/da_bogus/da_get_innov_vector_bogus.inc @@ -42,6 +42,17 @@ subroutine da_get_innov_vector_bogus(it,num_qcstat_conv, grid, ob, iv) model_t(:,:) = 0.0 model_q(:,:) = 0.0 + if ( it > 1 ) then + do n=iv%info(bogus)%n1,iv%info(bogus)%n2 + do k=1, iv%info(bogus)%levels(n) + if (iv%bogus(n)%u(k)%qc == fails_error_max) iv%bogus(n)%u(k)%qc = 0 + if (iv%bogus(n)%v(k)%qc == fails_error_max) iv%bogus(n)%v(k)%qc = 0 + if (iv%bogus(n)%t(k)%qc == fails_error_max) iv%bogus(n)%t(k)%qc = 0 + if (iv%bogus(n)%q(k)%qc == fails_error_max) iv%bogus(n)%q(k)%qc = 0 + end do + end do + end if + do n=iv%info(bogus)%n1,iv%info(bogus)%n2 num_levs = iv%info(bogus)%levels(n) @@ -159,7 +170,8 @@ subroutine da_get_innov_vector_bogus(it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_bogus(iv,ob, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_bogus(iv,ob, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_buoy/da_check_max_iv_buoy.inc b/wrfv2_fire/var/da/da_buoy/da_check_max_iv_buoy.inc index d2231a67..8c1450c8 100644 --- a/wrfv2_fire/var/da/da_buoy/da_check_max_iv_buoy.inc +++ b/wrfv2_fire/var/da/da_buoy/da_check_max_iv_buoy.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -24,10 +27,8 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) !--------------------------------------------------------------------------- do n=iv%info(buoy)%n1,iv%info(buoy)%n2 - if( iv%buoy(n)%u%qc == fails_error_max .and. it > 1 )iv%buoy(n)%u%qc =0 - if( iv%buoy(n)%u%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%buoy(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(buoy), n, iv%buoy(n)%u, max_error_uv, failed) if( iv%info(buoy)%proc_domain(1,n) ) then num_qcstat_conv(1,buoy,1,1)= num_qcstat_conv(1,buoy,1,1) + 1 @@ -37,12 +38,9 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) 'buoy',ob_vars(1),iv%info(buoy)%lat(1,n),iv%info(buoy)%lon(1,n),0.01*ob%buoy(n)%p end if end if - end if - if( iv%buoy(n)%v%qc == fails_error_max .and. it > 1 )iv%buoy(n)%v%qc =0 - if( iv%buoy(n)%v%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%buoy(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(buoy), n, iv%buoy(n)%v, max_error_uv, failed) if( iv%info(buoy)%proc_domain(1,n) ) then num_qcstat_conv(1,buoy,2,1)= num_qcstat_conv(1,buoy,2,1) + 1 @@ -52,12 +50,9 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) 'buoy',ob_vars(2),iv%info(buoy)%lat(1,n),iv%info(buoy)%lon(1,n),0.01*ob%buoy(n)%p end if end if - end if - if( iv%buoy(n)%t%qc == fails_error_max .and. it > 1 )iv%buoy(n)%t%qc =0 - if( iv%buoy(n)%t%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%buoy(n)%t%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(buoy), n, iv%buoy(n)%t, max_error_t , failed) if( iv%info(buoy)%proc_domain(1,n) ) then num_qcstat_conv(1,buoy,3,1)= num_qcstat_conv(1,buoy,3,1) + 1 @@ -67,12 +62,9 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) 'buoy',ob_vars(3),iv%info(buoy)%lat(1,n),iv%info(buoy)%lon(1,n),0.01*ob%buoy(n)%p end if end if - end if - if( iv%buoy(n)%p%qc == fails_error_max .and. it > 1 )iv%buoy(n)%p%qc =0 - if( iv%buoy(n)%p%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%buoy(n)%p%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(buoy), n, iv%buoy(n)%p, max_error_p , failed) if( iv%info(buoy)%proc_domain(1,n) ) then num_qcstat_conv(1,buoy,5,1)= num_qcstat_conv(1,buoy,5,1) + 1 @@ -82,19 +74,17 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) 'buoy',ob_vars(5),iv%info(buoy)%lat(1,n),iv%info(buoy)%lon(1,n),0.01*ob%buoy(n)%p end if end if - end if - if( iv%buoy(n)%q%qc == fails_error_max .and. it > 1)iv%buoy(n)%q%qc =0 - if( iv%buoy(n)%q%qc >= obs_qc_pointer ) then + failed=.false. - if( iv%buoy(n)%t%qc == fails_error_max .or. iv%buoy(n)%p%qc == fails_error_max) then - failed=.true. - iv%buoy(n)%q%qc = fails_error_max - iv%buoy(n)%q%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it, iv%info(buoy), n, iv%buoy(n)%q, max_error_q , failed) - endif + if( iv%buoy(n)%q%qc >= obs_qc_pointer ) then + if( iv%buoy(n)%t%qc == fails_error_max .or. iv%buoy(n)%p%qc == fails_error_max) then + failed=.true. + iv%buoy(n)%q%qc = fails_error_max + iv%buoy(n)%q%inv = 0.0 + else + call da_max_error_qc (it, iv%info(buoy), n, iv%buoy(n)%q, max_error_q , failed) + endif if( iv%info(buoy)%proc_domain(1,n) ) then num_qcstat_conv(1,buoy,4,1)= num_qcstat_conv(1,buoy,4,1) + 1 if(failed) then @@ -104,6 +94,7 @@ subroutine da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) end if end if end if + end do if (trace_use_dull) call da_trace_exit("da_check_max_iv_buoy") diff --git a/wrfv2_fire/var/da/da_buoy/da_get_innov_vector_buoy.inc b/wrfv2_fire/var/da/da_buoy/da_get_innov_vector_buoy.inc index ce657fd9..a6fb5434 100644 --- a/wrfv2_fire/var/da/da_buoy/da_get_innov_vector_buoy.inc +++ b/wrfv2_fire/var/da/da_buoy/da_get_innov_vector_buoy.inc @@ -41,6 +41,16 @@ subroutine da_get_innov_vector_buoy( it,num_qcstat_conv, grid, ob, iv) allocate (model_q(1,iv%info(buoy)%n1:iv%info(buoy)%n2)) allocate (model_hsm(1,iv%info(buoy)%n1:iv%info(buoy)%n2)) + if ( it > 1 ) then + do n=iv%info(buoy)%n1,iv%info(buoy)%n2 + if (iv%buoy(n)%u%qc == fails_error_max) iv%buoy(n)%u%qc = 0 + if (iv%buoy(n)%v%qc == fails_error_max) iv%buoy(n)%v%qc = 0 + if (iv%buoy(n)%t%qc == fails_error_max) iv%buoy(n)%t%qc = 0 + if (iv%buoy(n)%p%qc == fails_error_max) iv%buoy(n)%p%qc = 0 + if (iv%buoy(n)%q%qc == fails_error_max) iv%buoy(n)%q%qc = 0 + end do + end if + if (sfc_assi_options == sfc_assi_options_1) then do n=iv%info(buoy)%n1,iv%info(buoy)%n2 ! [1.1] Get horizontal interpolation weights: @@ -72,15 +82,6 @@ subroutine da_get_innov_vector_buoy( it,num_qcstat_conv, grid, ob, iv) iv%info(buoy)%zk(:,n) = 1.0+1.0e-6 call da_obs_sfc_correction(iv%info(buoy), iv%buoy(n), n, grid%xb) - ! To keep the original "ob" with no change for multiple - ! outer-loops use: - - ! ob%buoy(n)%p = iv%buoy(n)%p%inv - ! ob%buoy(n)%t = iv%buoy(n)%t%inv - ! ob%buoy(n)%q = iv%buoy(n)%q%inv - ! ob%buoy(n)%u = iv%buoy(n)%u%inv - ! ob%buoy(n)%v = iv%buoy(n)%v%inv - else call da_to_zk(iv % buoy(n) % h, v_h, v_interp_h, iv%info(buoy)%zk(1,n)) end if @@ -126,9 +127,9 @@ subroutine da_get_innov_vector_buoy( it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_3d (grid%xb%t, iv%info(buoy),model_t) call da_interp_lin_3d (grid%xb%q, iv%info(buoy),model_q) call da_interp_lin_3d (grid%xb%p, iv%info(buoy),model_p) - else if (sfc_assi_options == 2) then + else if (sfc_assi_options == sfc_assi_options_2) then - ! Surface data assmiilation approach 2 + ! Surface data assimilation approach 2 ! ----------------------------------- ! 1.2.1 Surface assmiilation approach 2(10-m u, v, 2-m t, q, @@ -141,6 +142,13 @@ subroutine da_get_innov_vector_buoy( it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_2d (grid%xb%psfc, iv%info(buoy), 1,model_p) do n=iv%info(buoy)%n1,iv%info(buoy)%n2 + + iv%buoy(n)%p%inv = ob%buoy(n)%p + iv%buoy(n)%t%inv = ob%buoy(n)%t + iv%buoy(n)%q%inv = ob%buoy(n)%q + iv%buoy(n)%u%inv = ob%buoy(n)%u + iv%buoy(n)%v%inv = ob%buoy(n)%v + if (iv%buoy(n)%p%qc >= 0) then ! model surface p, t, q, h at observed site: @@ -207,7 +215,8 @@ subroutine da_get_innov_vector_buoy( it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !----------------------------------------------------------------------- - call da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_buoy(iv,ob, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_control/da_control.f90 b/wrfv2_fire/var/da/da_control/da_control.f90 index 4abda65a..9d71e5c6 100644 --- a/wrfv2_fire/var/da/da_control/da_control.f90 +++ b/wrfv2_fire/var/da/da_control/da_control.f90 @@ -4,7 +4,7 @@ module da_control ! Purpose: Common reference point for WRFVAR control. !-------------------------------------------------------------------------- - use module_driver_constants, only : max_domains, max_eta, max_moves, & + use module_driver_constants, only : max_domains, max_eta, max_moves, max_bogus, & max_outer_iterations, max_instruments implicit none diff --git a/wrfv2_fire/var/da/da_define_structures/da_random_seed.inc b/wrfv2_fire/var/da/da_define_structures/da_random_seed.inc index d543d701..126099ed 100644 --- a/wrfv2_fire/var/da/da_define_structures/da_random_seed.inc +++ b/wrfv2_fire/var/da/da_define_structures/da_random_seed.inc @@ -38,7 +38,7 @@ subroutine da_random_seed end if seed_array(1) = seed_array1 - seed_array(2) = seed_array2 + myproc*10000000 + seed_array(2) = seed_array2 * seed_array1 + myproc*10000000 write(unit=stdout,fmt='(a,i16)')' Setting seed_array(1) = ', seed_array(1) write(unit=stdout,fmt='(a,i16)')' Setting seed_array(2) = ', seed_array(2) call random_seed(put=seed_array(1:seed_size)) ! Set random seed. diff --git a/wrfv2_fire/var/da/da_define_structures/da_zero_vp_type.inc b/wrfv2_fire/var/da/da_define_structures/da_zero_vp_type.inc index dbc3eeaf..a18302ec 100644 --- a/wrfv2_fire/var/da/da_define_structures/da_zero_vp_type.inc +++ b/wrfv2_fire/var/da/da_define_structures/da_zero_vp_type.inc @@ -18,7 +18,7 @@ subroutine da_zero_vp_type( vp ) if (associated(vp % v5)) vp % v5(:,:,:) = 0.0 ! Flow-dependent control variables: - if (associated(vp % alpha) ) vp % alpha(:,:,:) = 0.0 + if (associated(vp % alpha) ) vp % alpha(:,:,:,:) = 0.0 if (trace_use_dull) call da_trace_exit("da_zero_vp_type") diff --git a/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv.inc b/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv.inc index 333e36af..ac619b1a 100644 --- a/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv.inc +++ b/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv.inc @@ -58,6 +58,8 @@ subroutine da_psichi_to_uv(psi, chi, coefx,coefy, u, v) end if + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, k) do k = kts, kte !------------------------------------------------------------------------ ! [2.0] Compute u, v at interior points (2nd order central finite diffs): @@ -258,6 +260,7 @@ subroutine da_psichi_to_uv(psi, chi, coefx,coefy, u, v) v(ite,jte,k) = 0.5 * (v(ite-1,jte,k) + v(ite,jte-1,k)) end if end do + !$OMP END PARALLEL DO !--------------------------------------------------------------------------- ! [5.0] For Global application, set Wast-Eest Periodic boundary diff --git a/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv_adj.inc b/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv_adj.inc index 6553b730..3a2be7a8 100644 --- a/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv_adj.inc +++ b/wrfv2_fire/var/da/da_dynamics/da_psichi_to_uv_adj.inc @@ -64,6 +64,8 @@ subroutine da_psichi_to_uv_adj(u, v, coefx, coefy, psi, chi) if (its == ids) is = ids+1 if (ite == ide) ie = ide-1 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( k ) do k = kts, kte !--------------------------------------------------------------------- @@ -124,11 +126,14 @@ subroutine da_psichi_to_uv_adj(u, v, coefx, coefy, psi, chi) v(ite,jte-1,k) = v(ite,jte-1,k) + 0.5 * v(ite,jte,k) end if end do + !$OMP END PARALLEL DO end if ! [3.0] Compute u, v at domain boundaries: + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, message ) do k = kts, kte #ifdef A2C if (.not. (fg_format == fg_format_kma_global) ) then @@ -322,6 +327,7 @@ subroutine da_psichi_to_uv_adj(u, v, coefx, coefy, psi, chi) end do end do end do ! loop over levels + !$OMP END PARALLEL DO !--------------------------------------------------------------------------- ! [5.0] For Global application, set Wast-Eest Periodic boundary diff --git a/wrfv2_fire/var/da/da_geoamv/da_check_max_iv_geoamv.inc b/wrfv2_fire/var/da/da_geoamv/da_check_max_iv_geoamv.inc index da4ddd62..9c3fbe08 100644 --- a/wrfv2_fire/var/da/da_geoamv/da_check_max_iv_geoamv.inc +++ b/wrfv2_fire/var/da/da_geoamv/da_check_max_iv_geoamv.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_geoamv(iv, it, num_qcstat_conv) !------------------------------------------------------------------------- ! Purpose: Innovation vector check for Geo. AMVs + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !------------------------------------------------------------------------- implicit none @@ -23,35 +26,29 @@ subroutine da_check_max_iv_geoamv(iv, it, num_qcstat_conv) do k = 1, iv%info(geoamv)%levels(n) call da_get_print_lvl(iv%geoamv(n)%p(k),ipr) - if( iv%geoamv(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%geoamv(n)%u(k)%qc =0 - if( iv%geoamv(n)%u(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%geoamv(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(geoamv), n, iv%geoamv(n)%u(k), max_error_uv,failed) if( iv%info(geoamv)%proc_domain(k,n) ) then - num_qcstat_conv(1,geoamv,1,ipr) = num_qcstat_conv(1,geoamv,1,ipr) + 1 + num_qcstat_conv(1,geoamv,1,ipr) = num_qcstat_conv(1,geoamv,1,ipr) + 1 if(failed) then num_qcstat_conv(2,geoamv,1,ipr) = num_qcstat_conv(2,geoamv,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'geoamv',ob_vars(1),iv%info(geoamv)%lat(k,n),iv%info(geoamv)%lon(k,n),0.01*iv%geoamv(n)%p(k) end if end if - end if - if( iv%geoamv(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%geoamv(n)%v(k)%qc =0 - if( iv%geoamv(n)%v(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%geoamv(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(geoamv), n, iv%geoamv(n)%v(k), max_error_uv,failed) if( iv%info(geoamv)%proc_domain(k,n) ) then - num_qcstat_conv(1,geoamv,2,ipr) = num_qcstat_conv(1,geoamv,2,ipr) + 1 + num_qcstat_conv(1,geoamv,2,ipr) = num_qcstat_conv(1,geoamv,2,ipr) + 1 if(failed)then num_qcstat_conv(2,geoamv,2,ipr) = num_qcstat_conv(2,geoamv,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'geoamv',ob_vars(2),iv%info(geoamv)%lat(k,n),iv%info(geoamv)%lon(k,n),0.01*iv%geoamv(n)%p(k) end if end if - end if end do end do diff --git a/wrfv2_fire/var/da/da_geoamv/da_get_innov_vector_geoamv.inc b/wrfv2_fire/var/da/da_geoamv/da_get_innov_vector_geoamv.inc index 329af876..13a38d5d 100644 --- a/wrfv2_fire/var/da/da_geoamv/da_get_innov_vector_geoamv.inc +++ b/wrfv2_fire/var/da/da_geoamv/da_get_innov_vector_geoamv.inc @@ -39,6 +39,15 @@ subroutine da_get_innov_vector_geoamv( it,num_qcstat_conv, grid, ob, iv) model_u(:,:) = 0.0 model_v(:,:) = 0.0 + if ( it > 1 ) then + do n = iv%info(geoamv)%n1, iv%info(geoamv)%n2 + do k = 1, iv%info(geoamv)%levels(n) + if (iv%geoamv(n)%u(k)%qc == fails_error_max) iv%geoamv(n)%u(k)%qc = 0 + if (iv%geoamv(n)%v(k)%qc == fails_error_max) iv%geoamv(n)%v(k)%qc = 0 + end do + end do + end if + do n = iv%info(geoamv)%n1, iv%info(geoamv)%n2 ! [1.3] Get horizontal interpolation weights: @@ -117,7 +126,8 @@ subroutine da_get_innov_vector_geoamv( it,num_qcstat_conv, grid, ob, iv) !------------------------------------------------------------------------ ! Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_geoamv(iv,it,num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_geoamv(iv,it,num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_gpspw/da_check_max_iv_gpspw.inc b/wrfv2_fire/var/da/da_gpspw/da_check_max_iv_gpspw.inc index d5216767..4d08c979 100644 --- a/wrfv2_fire/var/da/da_gpspw/da_check_max_iv_gpspw.inc +++ b/wrfv2_fire/var/da/da_gpspw/da_check_max_iv_gpspw.inc @@ -20,7 +20,7 @@ subroutine da_check_max_iv_gpspw(iv, it, num_qcstat_conv) do n=iv%info(gpspw)%n1,iv%info(gpspw)%n2 - if( iv%gpspw(n)%tpw%qc == fails_error_max .and. it > 1)iv%gpspw(n)%tpw%qc =0 +! if( iv%gpspw(n)%tpw%qc == fails_error_max .and. it > 1)iv%gpspw(n)%tpw%qc =0 if( iv%gpspw(n)%tpw%qc >= obs_qc_pointer ) then failed=.false. if( check_max_iv) & diff --git a/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpspw.inc b/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpspw.inc index 4a871e52..967d2555 100644 --- a/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpspw.inc +++ b/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpspw.inc @@ -36,7 +36,8 @@ subroutine da_get_innov_vector_gpspw (it,num_qcstat_conv, grid, ob, iv) !--------------------------------------------------------------------------- ! GPS TPW Pseudo OBS test: - if (pseudo_var(1:3) == 'tpw' .and. num_pseudo > 0) then + if ( (pseudo_var(1:3) == 'tpw' .and. num_pseudo > 0) .and. & + it == 1 ) then ! Deallocate: if (iv%info(gpspw)%nlocal > 0) then write(unit=stdout, fmt='(a,i4)') 'iv%info(gpspw)%nlocal =', iv%info(gpspw)%nlocal @@ -56,7 +57,8 @@ subroutine da_get_innov_vector_gpspw (it,num_qcstat_conv, grid, ob, iv) iv%info(gpspw)%n1 = 1 iv%info(gpspw)%n2 = 1 allocate (ob % gpspw (1:num_pseudo)) - + ob % gpspw(1) % tpw = 0.0 + print '(a,i2)','==> GPS TPW pseudo OBS test: num_pseudo=',num_pseudo iv%info(gpspw)%x(:,1) = pseudo_x @@ -109,6 +111,9 @@ subroutine da_get_innov_vector_gpspw (it,num_qcstat_conv, grid, ob, iv) do n=iv%info(gpspw)%n1,iv%info(gpspw)%n2 + if( iv % gpspw(n) % tpw % qc == fails_error_max .and. it > 1) & + iv % gpspw(n) % tpw % qc = 0 + ! [1.1] Get horizontal interpolation weights: i = iv%info(gpspw)%i(1,n) @@ -121,11 +126,8 @@ subroutine da_get_innov_vector_gpspw (it,num_qcstat_conv, grid, ob, iv) model_tpw = dym*(dxm*grid%xb%tpw(i,j) + dx*grid%xb%tpw(i+1,j)) + & dy *(dxm*grid%xb%tpw(i,j+1) + dx*grid%xb%tpw(i+1,j+1)) - if (pseudo_var(1:3) == 'tpw' .and. num_pseudo > 0) then - ! To compute the 'ob': - ob % gpspw(n) % tpw = iv % gpspw(n) % tpw % inv + model_tpw - else ! To compute the 'inv': + if (.not.(pseudo_var(1:3) == 'tpw' .and. num_pseudo > 0) ) & iv % gpspw(n) % tpw % inv = 0.0 if (ob % gpspw(n) % tpw > missing_r .AND. & iv % gpspw(n) % tpw % qc >= obs_qc_pointer) then @@ -161,16 +163,25 @@ subroutine da_get_innov_vector_gpspw (it,num_qcstat_conv, grid, ob, iv) dpw = dpw + ddpw end do end if - iv % gpspw(n) % tpw % inv = ob % gpspw(n) % tpw - model_tpw + 0.1*dpw + if ( (pseudo_var(1:3) == 'tpw' .and. num_pseudo > 0) .and. it == 1 ) then + ! To compute the 'ob': + ob % gpspw(n) % tpw = iv % gpspw(n) % tpw % inv + model_tpw - 0.1*dpw + else + iv % gpspw(n) % tpw % inv = ob % gpspw(n) % tpw - model_tpw + 0.1*dpw + end if end if - end if - !------------------------------------------------------------------------ - ! [5.0] Perform optional maximum error check: - !------------------------------------------------------------------------ +! print '("n,inv,qc,error,ob:",i3,e13.5,i8,2e13.5)', & +! n, iv % gpspw(n) % tpw % inv, iv % gpspw(n) % tpw % qc, & +! iv % gpspw(n) % tpw % error, ob % gpspw(n) % tpw end do - call da_check_max_iv_gpspw(iv, it, num_qcstat_conv) + + !------------------------------------------------------------------------ + ! [5.0] Perform optional maximum error check: + !------------------------------------------------------------------------ + if (.not.(pseudo_var(1:3) == 'tpw' .and. num_pseudo > 0) .and. check_max_iv ) & + call da_check_max_iv_gpspw(iv, it, num_qcstat_conv) end if if (trace_use_dull) call da_trace_exit("da_get_innov_vector_gpspw") diff --git a/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpsztd.inc b/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpsztd.inc index 7d8cb7e8..bd42a656 100644 --- a/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpsztd.inc +++ b/wrfv2_fire/var/da/da_gpspw/da_get_innov_vector_gpsztd.inc @@ -47,7 +47,8 @@ SUBROUTINE da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) ! ! GPS ZTD Pseudo OBS test: ! - if ( pseudo_var(1:3) == 'ztd' .and. num_pseudo > 0 ) then + if ( (pseudo_var(1:3) == 'ztd' .and. num_pseudo > 0) .and. & + it == 1 ) then ! Deallocate: if (iv%info(gpspw)%nlocal > 0) then @@ -68,6 +69,7 @@ SUBROUTINE da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) iv%info(gpspw)%n1 = 1 iv%info(gpspw)%n2 = 1 allocate (ob % gpspw (1:num_pseudo)) + ob % gpspw(1) % tpw = 0.0 print '(a,i2)','==> GPS ZTD pseudo OBS test: num_pseudo=',num_pseudo @@ -130,6 +132,9 @@ SUBROUTINE da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) do n=iv%info(gpspw)%n1,iv%info(gpspw)%n2 + if( iv % gpspw(n) % tpw % qc == fails_error_max .and. it > 1) & + iv % gpspw(n) % tpw % qc = 0 + ! [1.1] Get horizontal interpolation weights: i = iv%info(gpspw)%i(1,n) @@ -142,16 +147,10 @@ SUBROUTINE da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) mdl_ztd = dym*(dxm*grid%xb%ztd(i,j) + dx*grid%xb%ztd(i+1,j)) + & dy *(dxm*grid%xb%ztd(i,j+1) + dx*grid%xb%ztd(i+1,j+1)) - if (pseudo_var(1:3) == 'ztd' .and. num_pseudo > 0) then - -! To compute the 'ob': - ob % gpspw(n) % tpw = iv % gpspw(n) % tpw % inv + mdl_ztd - - else - ! To compute the 'inv': - iv % gpspw(n) % tpw % inv = 0.0 - if ( ob % gpspw(n) % tpw > missing_r .and. & + if ( .not.(pseudo_var(1:3) == 'ztd' .and. num_pseudo > 0) ) & + iv % gpspw(n) % tpw % inv = 0.0 + if ( ob % gpspw(n) % tpw > missing_r .and. & iv % gpspw(n) % tpw % qc >= obs_qc_pointer ) then dzd = 0.0 @@ -189,6 +188,14 @@ SUBROUTINE da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) end do end if + if ( (pseudo_var(1:3) == 'ztd' .and. num_pseudo > 0) .and. it == 1 ) then + +! To compute the 'ob': + ob % gpspw(n) % tpw = iv % gpspw(n) % tpw % inv + mdl_ztd - 1.e-4 * dzd + + else + + iv % gpspw(n) % tpw % inv = ob % gpspw(n) % tpw - mdl_ztd & + 1.e-4 * dzd ! @@ -211,7 +218,8 @@ SUBROUTINE da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) !------------------------------------------------------------------------ ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_gpspw(iv, it, num_qcstat_conv) + if ( .not.(pseudo_var(1:3) == 'ztd' .and. num_pseudo > 0) .and. check_max_iv ) & + call da_check_max_iv_gpspw(iv, it, num_qcstat_conv) end if if (trace_use_dull) call da_trace_exit("da_get_innov_vector_gpsztd") diff --git a/wrfv2_fire/var/da/da_gpsref/da_check_max_iv_gpsref.inc b/wrfv2_fire/var/da/da_gpsref/da_check_max_iv_gpsref.inc index 6db7aa98..ecd5dc07 100644 --- a/wrfv2_fire/var/da/da_gpsref/da_check_max_iv_gpsref.inc +++ b/wrfv2_fire/var/da/da_gpsref/da_check_max_iv_gpsref.inc @@ -22,7 +22,7 @@ subroutine da_check_max_iv_gpsref(iv,it, num_qcstat_conv) do n = iv%info(gpsref)%n1,iv%info(gpsref)%n2 do k = 1, iv%info(gpsref)%levels(n) call da_get_print_lvl(iv%gpsref(n)%p(k)%inv,ipr) - if( iv%gpsref(n)%ref(k)%qc == fails_error_max .and. it > 1 )iv%gpsref(n)%ref(k)%qc =0 +! if( iv%gpsref(n)%ref(k)%qc == fails_error_max .and. it > 1 )iv%gpsref(n)%ref(k)%qc =0 if( iv%gpsref(n)%ref(k)%qc >= obs_qc_pointer ) then failed=.false. if( check_max_iv) & diff --git a/wrfv2_fire/var/da/da_gpsref/da_get_innov_vector_gpsref.inc b/wrfv2_fire/var/da/da_gpsref/da_get_innov_vector_gpsref.inc index e2719a0b..237e17b7 100644 --- a/wrfv2_fire/var/da/da_gpsref/da_get_innov_vector_gpsref.inc +++ b/wrfv2_fire/var/da/da_gpsref/da_get_innov_vector_gpsref.inc @@ -20,6 +20,14 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) real :: dy, dym ! Interpolation weights. real,allocatable :: model_ref(:,:) !Model gpsref at ob loc real :: v_h(kms:kme) ! Model value h at ob + + integer :: Iu_ref, l + integer,allocatable :: used_lev(:,:) ! for obs. data thinning + ! record the closest level with model + integer,allocatable :: qc(:) ! record iv%gpsref(n)%ref(k)%qc + ! hor. location. + real :: distance_h ! cal. h-difference between obs and model + real,allocatable :: min_dis(:) ! minimum difference ! hor. location. ! For quality control @@ -30,6 +38,11 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) ! real , parameter :: pcnt1 = 0.02, pcnt2 = 0.01, pcnt3 = 0.03 integer, parameter :: qc_below = -31, qc_middle = -32, qc_above = -33 + integer, parameter :: qc_step1 = -34, qc_step2 = -35 ! refer to Poli et al. (2009) + integer :: top_level + real, allocatable :: dndz_obs(:),dndz_mod(:) + real, allocatable :: dndz2_obs(:),dndz2_mod(:) + integer :: nn, na, ntotal, nqc0, nqc1, nqc2, nqc3 real :: percnt real :: height_below(5000) @@ -39,16 +52,17 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) ! GPS REF Pseudo OBS test: - if (pseudo_var(1:3) == 'ref' .and. num_pseudo > 0) then + if ( (pseudo_var(1:3) == 'ref' .and. num_pseudo > 0) .and. & + it == 1 ) then ! Deallocate: if (iv%info(gpsref)%nlocal > 0) then do n = 1, iv%info(gpsref)%nlocal - deallocate(iv % gpsref(n) % h) deallocate(iv % gpsref(n) % ref) - deallocate(iv % gpsref(n) % p) - deallocate(iv % gpsref(n) % t) - deallocate(iv % gpsref(n) % q) + deallocate(iv % gpsref(n) % h) + deallocate(iv % gpsref(n) % p) + deallocate(iv % gpsref(n) % t) + deallocate(iv % gpsref(n) % q) deallocate(ob % gpsref(n) % ref) end do deallocate(iv % gpsref) @@ -57,13 +71,21 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) use_gpsrefobs = .true. - ! Allocate: iv%info(gpsref)%nlocal = num_pseudo iv%info(gpsref)%plocal(1) = num_pseudo + iv%info(gpsref)%ntotal = num_pseudo + iv%info(gpsref)%max_lev = 1 iv%info(pseudo)%nlocal = 0 - allocate(iv % gpsref(1:num_pseudo)) + call da_allocate_observations (iv) + iv%info(gpsref)%n1 = 1 + iv%info(gpsref)%n2 = 1 + allocate(iv%gpsref(num_pseudo)%ref(1:1)) + allocate(iv%gpsref(num_pseudo)% h(1:1)) + allocate(iv%gpsref(num_pseudo)% p(1:1)) + allocate(iv%gpsref(num_pseudo)% t(1:1)) + allocate(iv%gpsref(num_pseudo)% q(1:1)) allocate(ob%gpsref(1:num_pseudo)) allocate(ob%gpsref(num_pseudo)%ref(1:1)) @@ -76,6 +98,7 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) iv%info(gpsref)%i(:,1) = int(pseudo_x) iv%info(gpsref)%j(:,1) = int(pseudo_y) + iv % gpsref(1) % h(1) = pseudo_z iv%info(gpsref)%dx(:,1) = pseudo_x-real(iv%info(gpsref)%i(1,1)) iv%info(gpsref)%dy(:,1) = pseudo_y-real(iv%info(gpsref)%j(1,1)) @@ -111,8 +134,16 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) model_ref(:,:) = 0.0 + allocate (used_lev(kms:kme,iv%info(gpsref)%n1:iv%info(gpsref)%n2)) + used_lev(:,:) = missing_data + do n=iv%info(gpsref)%n1,iv%info(gpsref)%n2 + do k=1, iv%info(gpsref)%levels(n) + if( iv%gpsref(n)%ref(k)%qc == fails_error_max .and. it > 1 ) & + iv%gpsref(n)%ref(k)%qc = 0 + end do + ! Get cross pt. horizontal interpolation weights: i = iv%info(gpsref)%i(1,n) @@ -147,7 +178,8 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) call da_interp_lin_3d (grid%xb%ref, iv%info(gpsref), model_ref) do n=iv%info(gpsref)%n1,iv%info(gpsref)%n2 - if (.not.(pseudo_var(1:3) == 'ref' .and. num_pseudo > 0)) then + if ( (.not.(pseudo_var(1:3) == 'ref' .and. num_pseudo > 0)) .or. & + it > 1 ) then do k = 1, iv%info(gpsref)%levels(n) iv%gpsref(n)%ref(k)%inv = 0.0 @@ -161,7 +193,86 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) end if end do +! refer to Poli et al. (2009) ------------------------------------------------ +! flag if fit in each of these two qc steps for both of obs. and model +! qc_step1: dN/dz < -50 km^-1 +! qc_step2: abs(d^2N/dz^2) > 100 km^-2 +! Shu-Ya Chen (2009-07-29) + do n=iv%info(gpsref)%n1,iv%info(gpsref)%n2 + do k=1,iv%info(gpsref)%levels(n) + if (model_ref(k,n) > 0.0) top_level=k + end do +! print*,'top_level=',top_level + allocate(dndz_obs(top_level)) + allocate(dndz_mod(top_level)) + allocate(dndz2_obs(top_level)) + allocate(dndz2_mod(top_level)) + + ! QC_STEP1 + + if (.not. anal_type_verify) then + if (.not.(pseudo_var(1:3) == 'ref' .and. num_pseudo > 0)) then + + ! check for bottom boundary (Forward Difference) + dndz_obs(1)=(ob%gpsref(n)%ref(2)-ob%gpsref(n)%ref(1))/ & + ((iv%gpsref(n)%h(2)-iv%gpsref(n)%h(1))/1000.) + dndz_mod(1)=(model_ref(2,n)-model_ref(1,n))/ & + ((iv%gpsref(n)%h(2)-iv%gpsref(n)%h(1))/1000.) + ! check for upper boundary (Backward Difference) + dndz_obs(top_level)= & + (ob%gpsref(n)%ref(top_level)-ob%gpsref(n)%ref(top_level-1))/ & + ((iv%gpsref(n)%h(top_level)-iv%gpsref(n)%h(top_level-1))/1000.) + dndz_mod(top_level)= & + (model_ref(top_level,n)-model_ref(top_level-1,n))/ & + ((iv%gpsref(n)%h(top_level)-iv%gpsref(n)%h(top_level-1))/1000.) + ! check for middle levels (Central Difference) + do k=2, top_level-1 + dndz_obs(k)=(ob%gpsref(n)%ref(k+1)-ob%gpsref(n)%ref(k-1))/ & + ((iv%gpsref(n)%h(k+1)-iv%gpsref(n)%h(k-1))/1000.) + dndz_mod(k)=(model_ref(k+1,n)-model_ref(k-1,n))/ & + ((iv%gpsref(n)%h(k+1)-iv%gpsref(n)%h(k-1))/1000.) + end do + do k=1, top_level + if ((dndz_obs(k) < -50.) .or. (dndz_mod(k) < -50.)) then + iv%gpsref(n)%ref(k)%qc = qc_step1 +! print*,'QC_STEP1:',n,k,iv%gpsref(n)%h(k)/1000.,dndz_obs(k),dndz_mod(k) + end if + end do + ! QC_STEP2 + + ! check for bottom boundary + dndz2_obs(1)=(dndz_obs(2)-dndz_obs(1))/ & + ((iv%gpsref(n)%h(2)-iv%gpsref(n)%h(1))/1000.) + dndz2_mod(1)=(dndz_mod(2)-dndz_mod(1))/ & + ((iv%gpsref(n)%h(2)-iv%gpsref(n)%h(1))/1000.) + ! check for upper boundary + dndz2_obs(top_level)=(dndz_obs(top_level)-dndz_obs(top_level-1))/ & + ((iv%gpsref(n)%h(top_level)-iv%gpsref(n)%h(top_level-1))/1000.) + dndz2_mod(top_level)=(dndz_mod(top_level)-dndz_mod(top_level-1))/ & + ((iv%gpsref(n)%h(top_level)-iv%gpsref(n)%h(top_level-1))/1000.) + ! check for middle levels + do k=2, top_level-1 + dndz2_obs(k)=(dndz_obs(k+1)-dndz_obs(k-1))/ & + ((iv%gpsref(n)%h(k+1)-iv%gpsref(n)%h(k-1))/1000.) + dndz2_mod(k)=(dndz_mod(k+1)-dndz_mod(k-1))/ & + ((iv%gpsref(n)%h(k+1)-iv%gpsref(n)%h(k-1))/1000.) + end do + do k=1, top_level + if ((abs(dndz2_obs(k)) > 100.) .or. (abs(dndz2_mod(k)) > 100.)) then + iv%gpsref(n)%ref(k)%qc = qc_step2 +! print*,'QC_STEP2:',n,k,iv%gpsref(n)%h(k)/1000.,dndz2_obs(k),dndz2_mod(k) + end if + end do + end if ! end of if pseudo check + + end if ! end of if verify check + deallocate(dndz_obs,dndz_mod) + deallocate(dndz2_obs,dndz2_mod) + end do ! end of do iv%info(gpsref)%n1~n2 +! +! End of Poli's check. (2009) ------------------------------------------------- +! do n=iv%info(gpsref)%n1,iv%info(gpsref)%n2 ! Quality check 2: Error percentage check. @@ -245,8 +356,108 @@ subroutine da_get_innov_vector_gpsref(it, num_qcstat_conv, grid, ob, iv) ! ! Quality check 1: Gross error(departure from the background) check - call da_check_max_iv_gpsref(iv, it, num_qcstat_conv) + if (.not.(pseudo_var(1:3) == 'ref' .and. num_pseudo > 0) .and. check_max_iv ) & + call da_check_max_iv_gpsref(iv, it, num_qcstat_conv) +! ------------------------------------------------------------------------------ +! GPSRO thinning (Shu-Ya Chen 20090701) + if (.not. anal_type_verify) then + if (.not.(pseudo_var(1:3) == 'ref' .and. num_pseudo > 0)) then + IF ( gpsref_thinning ) THEN + DO n=iv%info(gpsref)%n1,iv%info(gpsref)%n2 + allocate(min_dis(kms:kme)) + allocate(qc(iv%info(gpsref)%levels(n))) + i = iv%info(gpsref)%i(1,n) + j = iv%info(gpsref)%j(1,n) + dx = iv%info(gpsref)%dx(1,n) + dy = iv%info(gpsref)%dy(1,n) + dxm = iv%info(gpsref)%dxm(1,n) + dym = iv%info(gpsref)%dym(1,n) + + if (.not.(pseudo_var(1:3) == 'ref' .and. num_pseudo > 0)) then + ! Get the zk from gpsref%h: + do k=kts,kte + v_h(k) = dym*(dxm*grid%xb%h(i,j ,k) + dx*grid%xb%h(i+1,j ,k)) & + + dy *(dxm*grid%xb%h(i,j+1,k) + dx*grid%xb%h(i+1,j+1,k)) + end do + do k=kts,kte + min_dis(k)=1.0E10 + do l=1, iv%info(gpsref)%levels(n) + if ( iv%gpsref(n)%ref(l)%qc >= obs_qc_pointer ) then + distance_h=abs(iv%gpsref(n)%h(l)-v_h(k)) + min_dis(k)=min(min_dis(k),distance_h) + if ( min_dis(k) == distance_h ) used_lev(k,n)=l + end if + end do + end do + + write(533,*) 'obs_qc_pointer=',obs_qc_pointer,'missing_data=',missing_data + do k=kts,kte + write(533,*) n,k,'used_lev=',used_lev(k,n) + enddo + + do l=1, iv%info(gpsref)%levels(n) + write(533,*) n,l,iv%gpsref(n)%ref(l)%qc + enddo + + do l=1, iv%info(gpsref)%levels(n) + qc(l)=iv%gpsref(n)%ref(l)%qc + end do + do k=kts,kte + qc(used_lev(k,n))=1 ! which level is closest to model level + end do + ! data thinning (set thinned levels to be -99) + do l=1, iv%info(gpsref)%levels(n) + if ( iv%gpsref(n)%ref(l)%qc >= obs_qc_pointer & + .and. qc(l) /= 1 ) then + iv%gpsref(n)%ref(l)%qc = -99 + end if + end do + end if + deallocate(min_dis) + deallocate(qc) + END DO + END IF + + goto 12345 + +! Write out GPS Ref data: + + DO n=iv%info(gpsref)%n1,iv%info(gpsref)%n2 + Iu_ref = 336 + open (unit=Iu_ref, file='RO_Innov_'//iv%info(gpsref)%date_char(n), & + form='formatted') + write(unit=Iu_ref, fmt='(/i5,2x,a,2x,a,2x,4f10.3,i5)') n, & + iv%info(gpsref)%date_char(n), iv%info(gpsref)%id(n), & + iv%info(gpsref)%lat(1,n) , iv%info(gpsref)%lon(1,n), & + iv%info(gpsref)%x(1,n) , iv%info(gpsref)%y(1,n), & + iv%info(gpsref)%levels(n) + write(unit=Iu_ref, fmt='(a5,3x,6a14)') 'level',' height ', & + ' Obs_ref ',' model_ref ',' Innov_ref ', & + ' error_ref ',' qc_ref ' + do k = 1, iv%info(gpsref)%levels(n) +! if ( gpsref_thinning ) then +! if ( iv%gpsref(n)%ref(l)%qc >= obs_qc_pointer ) then +! write(unit=Iu_ref, fmt='(i3,1x,5f14.3,i10)') k, & +! iv%gpsref(n)%h(k), ob%gpsref(n)%ref(k), & +! model_ref(k,n), iv%gpsref(n)%ref(k)%inv, & +! iv%gpsref(n)%ref(k)%error, iv%gpsref(n)%ref(k)%qc +! end if +! else + write(unit=Iu_ref, fmt='(i3,1x,5f14.3,i10)') k, & + iv%gpsref(n)%h(k), ob%gpsref(n)%ref(k), & + model_ref(k,n), iv%gpsref(n)%ref(k)%inv, & + iv%gpsref(n)%ref(k)%error, iv%gpsref(n)%ref(k)%qc +! end if + end do + close(Iu_ref) + END DO +12345 continue + ! ......................................................................... + end if ! end of pseudo test + end if ! end of verify check + + deallocate (used_lev) deallocate (model_ref) if (trace_use_dull) call da_trace_exit("da_get_innov_vector_gpsref") diff --git a/wrfv2_fire/var/da/da_gpsref/da_gpsref.f90 b/wrfv2_fire/var/da/da_gpsref/da_gpsref.f90 index d2c65fff..bb1c2138 100644 --- a/wrfv2_fire/var/da/da_gpsref/da_gpsref.f90 +++ b/wrfv2_fire/var/da/da_gpsref/da_gpsref.f90 @@ -4,17 +4,17 @@ module da_gpsref use module_dm, only : wrf_dm_sum_real use da_control, only : obs_qc_pointer,max_ob_levels,missing_r, & - v_interp_p, v_interp_h, check_max_iv_print, & + v_interp_p, v_interp_h, check_max_iv_print, radian, & missing, max_error_uv, max_error_t, rootproc,fails_error_max, & max_error_p,max_error_q, check_max_iv_unit,check_max_iv, qcstat_conv_unit, & max_stheight_diff,missing_data,max_error_bq,max_error_slp, ob_vars, & max_error_bt, max_error_buv, gpsref,max_error_thickness, & pseudo_var, num_pseudo, kms,kme,kts,kte, trace_use_dull, & anal_type_verify,fails_error_max,pseudo_err,pseudo_x, pseudo_y, stdout, & - use_gpsrefobs,pseudo_z,pseudo_val,max_error_ref, pseudo, jts, jte,its,ite + use_gpsrefobs, gpsref_thinning, pseudo_z,pseudo_val,max_error_ref, pseudo, jts, jte,its,ite use da_define_structures, only : maxmin_type, iv_type, y_type, jo_type, & bad_data_type, x_type, number_type, bad_data_type, & - maxmin_type + maxmin_type, da_allocate_observations use da_interpolation, only : da_interp_lin_3d,da_interp_lin_3d_adj, & da_to_zk use da_par_util, only : da_proc_stats_combine diff --git a/wrfv2_fire/var/da/da_gpsref/da_residual_gpsref.inc b/wrfv2_fire/var/da/da_gpsref/da_residual_gpsref.inc index 3cbbff7d..f0aaa4b3 100644 --- a/wrfv2_fire/var/da/da_gpsref/da_residual_gpsref.inc +++ b/wrfv2_fire/var/da/da_gpsref/da_residual_gpsref.inc @@ -6,7 +6,7 @@ subroutine da_residual_gpsref(iv, y, re, np_missing, np_bad_data, np_obs_used, n implicit none - type (iv_type),intent(in) :: iv ! Innovation vector (O-B). + type (iv_type),intent(inout) :: iv ! Innovation vector (O-B). type (y_type) ,intent(in) :: y ! y = H (xa) type (y_type) ,intent(inout) :: re ! Residual vector (O-A). @@ -17,16 +17,47 @@ subroutine da_residual_gpsref(iv, y, re, np_missing, np_bad_data, np_obs_used, n type (bad_data_type) :: n_obs_bad integer :: n, k +! + real :: constant0, g_lat, g_height, weight1, weight2, & + gpsref_org if (trace_use_dull) call da_trace_entry("da_residual_gpsref") +! Assuming the highest latitude is 90.0 degree: + constant0= sin(radian * 90.0) + n_obs_bad % gpsref % num = number_type(0, 0, 0) do n=1, iv%info(gpsref)%nlocal do k=1, iv%info(gpsref)%levels(n) np_available = np_available + 1 +! +! Weighted the GPSREF innovation with the latitude: + if (iv%gpsref(n)%ref(k)%qc >= obs_qc_pointer ) then + +! depend on the height: above 7km, set to 1.0, below 7km, decrease to 0.0: + g_height = iv%gpsref(n)% h(k) + weight1 = 1.0 - (7000.0 - g_height) / 7000.0 + if ( weight1 > 1.0 ) weight1 = 1.0 +! not depend on height: + weight1 = 1.0 + +! depend on the latitude, at 90 degree, weight = 1.0, at 0 degree, weight = 0.0 + g_lat = iv%info(gpsref)%lat(k,n) + weight2 = abs(sin(radian * g_lat) / constant0) +! not depend on the latitude: + weight2 = 1.0 + + gpsref_org = iv%gpsref(n)%ref(k)%inv + iv%gpsref(n)%ref(k)%inv = gpsref_org * weight1 * weight2 + endif +!............................................................. re%gpsref(n)%ref(k) = & da_residual(n, k, y%gpsref(n)%ref(k), iv%gpsref(n)%ref(k), n_obs_bad%gpsref) +! + if (iv%gpsref(n)%ref(k)%qc >= obs_qc_pointer ) & + iv%gpsref(n)%ref(k)%inv = gpsref_org + end do end do diff --git a/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d.inc b/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d.inc index 0d1f548e..8cef8d79 100644 --- a/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d.inc +++ b/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d.inc @@ -15,10 +15,13 @@ subroutine da_interp_lin_2d(fm2d, info, k, fo2d) if (trace_use_frequent) call da_trace_entry("da_interp_lin_2d") + !$OMP PARALLEL DO & + !$OMP PRIVATE (n) do n=info%n1,info%n2 fo2d(n) = info%dym(k,n)*(info%dxm(k,n)*fm2d(info%i(k,n),info%j(k,n)) + info%dx(k,n)*fm2d(info%i(k,n)+1,info%j(k,n))) & + info%dy(k,n) *(info%dxm(k,n)*fm2d(info%i(k,n),info%j(k,n)+1) + info%dx(k,n)*fm2d(info%i(k,n)+1,info%j(k,n)+1)) end do + !$OMP END PARALLEL DO if (trace_use_frequent) call da_trace_exit("da_interp_lin_2d") diff --git a/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d_partial.inc b/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d_partial.inc index 21e3cf24..fb028e02 100644 --- a/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d_partial.inc +++ b/wrfv2_fire/var/da/da_interpolation/da_interp_lin_2d_partial.inc @@ -16,10 +16,13 @@ subroutine da_interp_lin_2d_partial(fm2d, info, k, n1, n2, fo2d) if (trace_use_frequent) call da_trace_entry("da_interp_lin_2d_partial") + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n ) do n=n1,n2 fo2d(n) = info%dym(k,n)*(info%dxm(k,n)*fm2d(info%i(k,n),info%j(k,n)) + info%dx(k,n)*fm2d(info%i(k,n)+1,info%j(k,n))) & + info%dy(k,n) *(info%dxm(k,n)*fm2d(info%i(k,n),info%j(k,n)+1) + info%dx(k,n)*fm2d(info%i(k,n)+1,info%j(k,n)+1)) end do + !$OMP END PARALLEL DO if (trace_use_frequent) call da_trace_exit("da_interp_lin_2d_partial") diff --git a/wrfv2_fire/var/da/da_interpolation/da_interp_lin_3d.inc b/wrfv2_fire/var/da/da_interpolation/da_interp_lin_3d.inc index 12cd8ceb..ee9e5e8e 100644 --- a/wrfv2_fire/var/da/da_interpolation/da_interp_lin_3d.inc +++ b/wrfv2_fire/var/da/da_interpolation/da_interp_lin_3d.inc @@ -30,6 +30,8 @@ subroutine da_interp_lin_3d(fm3d, info, fo3d) fo3d(:,:) = 0.0 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n, fmz, k ) do n=info%n1,info%n2 fmz(:)=0.0 @@ -78,6 +80,7 @@ subroutine da_interp_lin_3d(fm3d, info, fo3d) end if end do end do + !$OMP END PARALLEL DO if (trace_use) call da_trace_exit("da_interp_lin_3d") diff --git a/wrfv2_fire/var/da/da_main/da_med_initialdata_input.inc b/wrfv2_fire/var/da/da_main/da_med_initialdata_input.inc index c7d3f2f6..d8b7598f 100644 --- a/wrfv2_fire/var/da/da_main/da_med_initialdata_input.inc +++ b/wrfv2_fire/var/da/da_main/da_med_initialdata_input.inc @@ -110,7 +110,7 @@ subroutine da_med_initialdata_input (grid, config_flags, filename, in_date) end do end if - call input_model_input (fid , grid , config_flags , ierr) + call input_input (fid , grid , config_flags , ierr) call close_dataset (fid , config_flags , "DATASET=INPUT") diff --git a/wrfv2_fire/var/da/da_main/da_med_initialdata_output.inc b/wrfv2_fire/var/da/da_main/da_med_initialdata_output.inc index d5cb2682..701678a7 100644 --- a/wrfv2_fire/var/da/da_main/da_med_initialdata_output.inc +++ b/wrfv2_fire/var/da/da_main/da_med_initialdata_output.inc @@ -26,7 +26,7 @@ subroutine da_med_initialdata_output (grid , config_flags, out_filename) call da_trace ("da_med_initialdata_ouput",Message="Writing wrfvar output") call open_w_dataset (fid, trim(file_name), grid , config_flags , & - output_model_input , "DATASET=INPUT,REAL_OUTPUT_SIZE=4", ierr) + output_input , "DATASET=INPUT,REAL_OUTPUT_SIZE=4", ierr) if (ierr /= 0) then write(unit=message(1),fmt=*) 'Error opening ', & @@ -41,7 +41,7 @@ subroutine da_med_initialdata_output (grid , config_flags, out_filename) config_flags%julyr = julyr config_flags%julday = julday - call output_model_input (fid, grid , config_flags , ierr) + call output_input (fid, grid , config_flags , ierr) call close_dataset (fid , config_flags, "DATASET=INPUT,REAL_OUTPUT_SIZE=4") diff --git a/wrfv2_fire/var/da/da_main/da_solve.inc b/wrfv2_fire/var/da/da_main/da_solve.inc index 5feaff9f..4088dd14 100644 --- a/wrfv2_fire/var/da/da_main/da_solve.inc +++ b/wrfv2_fire/var/da/da_main/da_solve.inc @@ -29,6 +29,7 @@ real :: j_grad_norm_target ! Target j norm. character (len=3) :: ci + character (len=2) :: outerloop #ifdef DM_PARALLEL integer :: wrf_done_unit @@ -45,6 +46,10 @@ call nl_get_base_temp ( 1 , base_temp ) call nl_get_base_lapse ( 1 , base_lapse ) call nl_get_iso_temp ( 1 , iso_temp ) + grid%p00 = base_pres + grid%t00 = base_temp + grid%tlp = base_lapse + grid%tiso = iso_temp else base_pres = grid%p00 base_temp = grid%t00 @@ -165,7 +170,8 @@ grid%ep % ne = be % ne if (be % ne > 0) then - call da_setup_flow_predictors (ide, jde, kde, be % ne, grid%ep ) + call da_setup_flow_predictors ( ide, jde, kde, be % ne, grid%ep, & + its, ite, jts, jte, kts, kte ) end if !--------------------------------------------------------------------------- @@ -193,12 +199,18 @@ j_grad_norm_target = 1.0 do it = 1, max_ext_its +! Re-scale the variances and the scale-length for outer-loop > 1: + if (it > 1 .and. cv_options == 5) then + print '(/10X,"===> Re-set BE SCALINGS for outer-loop=",i2)', it + call da_scale_background_errors ( be, it ) + endif + call da_initialize_cv (cv_size, xhat) ! [8.1] Calculate nonlinear model trajectory - if (var4d .and. multi_inc /= 2 ) then -! if (var4d) then +! if (var4d .and. multi_inc /= 2 ) then + if (var4d) then call da_trace ("da_solve","Starting da_run_wrf_nl.ksh") #ifdef DM_PARALLEL if (var4d_coupling == var4d_coupling_disk_simul) then @@ -298,10 +310,23 @@ ! Write "clean" QCed observations if requested: if (anal_type_qcobs) then - if (it == 1) then - call da_write_filtered_obs (grid, ob, iv, & + ! if (it == 1) then + if (write_mod_filtered_obs) then !cys_change + call da_write_modified_filtered_obs (grid, ob, iv, & + coarse_ix, coarse_jy, start_x, start_y) + else + call da_write_filtered_obs (it, grid, ob, iv, & coarse_ix, coarse_jy, start_x, start_y) end if + ! end if + end if + + ! [8.7.1] Write Ascii radar OMB and OMA file + + if (use_radarobs) then + write(unit=stdout,fmt='(A)') 'Writing radar OMB and OMA ascii file' + write(unit=stdout,fmt=*) " " + call da_write_oa_radar_ascii (ob,iv,re) end if ! [8.3] Interpolate x_g to low resolution grid @@ -312,19 +337,27 @@ if (write_oa_rad_ascii) then write(unit=stdout,fmt='(A)') 'Writing radiance OMB and OMA ascii file' write(unit=stdout,fmt=*) " " - call da_write_oa_rad_ascii (ob,iv,re) + call da_write_oa_rad_ascii (it,ob,iv,re) end if #endif ! [8.9] Update VarBC parameters and write output file #if defined(CRTM) || defined(RTTOV) - if ( (use_varbc).or.(freeze_varbc) ) call da_varbc_update(cv_size, xhat, iv) + if ( (use_varbc).or.(freeze_varbc) ) & + call da_varbc_update(it, cv_size, xhat, iv) #endif !------------------------------------------------------------------------ ! [8.10] Output WRFVAR analysis and analysis increments: !------------------------------------------------------------------------ call da_transfer_xatoanalysis (it, xbx, grid, config_flags) + + + if ( it < max_ext_its .and. print_detail_outerloop ) then + write(outerloop,'(i2.2)') it + call da_med_initialdata_output (grid , config_flags, 'wrfvar_output_'//outerloop) + end if + end do !--------------------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_main/da_wrfvar_finalize.inc b/wrfv2_fire/var/da/da_main/da_wrfvar_finalize.inc index d2e5da69..54978ff3 100644 --- a/wrfv2_fire/var/da/da_main/da_wrfvar_finalize.inc +++ b/wrfv2_fire/var/da/da_main/da_wrfvar_finalize.inc @@ -50,13 +50,15 @@ subroutine da_wrfvar_finalize if (rootproc) then close (cost_unit) close (grad_unit) - close (stats_unit) + if (.not. print_detail_outerloop) then + close (stats_unit) + call da_free_unit (stats_unit) + end if close (jo_unit) close (check_max_iv_unit) close (check_buddy_unit) call da_free_unit (cost_unit) call da_free_unit (grad_unit) - call da_free_unit (stats_unit) call da_free_unit (jo_unit) call da_free_unit (check_max_iv_unit) call da_free_unit (check_buddy_unit ) diff --git a/wrfv2_fire/var/da/da_main/da_wrfvar_init1.inc b/wrfv2_fire/var/da/da_main/da_wrfvar_init1.inc index 0ce147d7..5ef61a1d 100644 --- a/wrfv2_fire/var/da/da_main/da_wrfvar_init1.inc +++ b/wrfv2_fire/var/da/da_main/da_wrfvar_init1.inc @@ -22,7 +22,7 @@ subroutine da_wrfvar_init1(no_init1) ! ! FIX? keep this version so netcdf files are the same until near release - program_name = "WRFVAR V3.1 (COMPATIBLE WITH WRF V3.1) MODEL" + program_name = "WRFVAR V3.1.1 (COMPATIBLE WITH WRF V3.1.1) MODEL" ! program_name = "WRFVAR "//release_version ! Initialize WRF modules: diff --git a/wrfv2_fire/var/da/da_main/da_wrfvar_init2.inc b/wrfv2_fire/var/da/da_main/da_wrfvar_init2.inc index 6ef8b945..f0068df9 100644 --- a/wrfv2_fire/var/da/da_main/da_wrfvar_init2.inc +++ b/wrfv2_fire/var/da/da_main/da_wrfvar_init2.inc @@ -11,6 +11,17 @@ subroutine da_wrfvar_init2 if (trace_use) call da_trace_entry("da_wrfvar_init2") +! Override the start time with the "analysis_date": + read(analysis_date, fmt='(i4,5(1x,i2))') & + start_year(1), start_month(1), start_day(1), start_hour(1), & + start_minute(1), start_second(1) + model_config_rec% start_year = start_year + model_config_rec% start_month = start_month + model_config_rec% start_day = start_day + model_config_rec% start_hour = start_hour + model_config_rec% start_minute = start_minute + model_config_rec% start_second = start_second + if (analysis_type(1:6) == "VERIFY" .or. analysis_type(1:6) == "verify") then anal_type_verify=.true. else @@ -136,13 +147,15 @@ subroutine da_wrfvar_init2 if (rootproc) then call da_get_unit (cost_unit) call da_get_unit (grad_unit) - call da_get_unit (stats_unit) call da_get_unit (jo_unit) call da_get_unit (check_max_iv_unit) call da_get_unit (check_buddy_unit) open(unit=cost_unit,file="cost_fn",status="replace") open(unit=grad_unit,file="grad_fn",status="replace") - open(unit=stats_unit,file="statistics",status="replace") + if (.not. print_detail_outerloop) then + call da_get_unit (stats_unit) + open(unit=stats_unit,file="statistics",status="replace") + end if open(unit=jo_unit,file="jo",status="replace") open(unit=check_max_iv_unit,file="check_max_iv",status="replace") open(unit=check_buddy_unit ,file="buddy_check" ,status="replace") diff --git a/wrfv2_fire/var/da/da_main/da_wrfvar_interface.inc b/wrfv2_fire/var/da/da_main/da_wrfvar_interface.inc index bd1f2475..864df85a 100644 --- a/wrfv2_fire/var/da/da_main/da_wrfvar_interface.inc +++ b/wrfv2_fire/var/da/da_main/da_wrfvar_interface.inc @@ -9,15 +9,15 @@ subroutine da_wrfvar_interface (grid, config_flags) type(domain), intent(inout) :: grid type(grid_config_rec_type), intent(inout) :: config_flags - integer :: idum1, idum2 + ! integer :: idum1, idum2 call da_trace_entry("da_wrfvar_interface") ! call mediation_setup_step (grid , config_flags , 1 , 1 , 1) - call set_scalar_indices_from_config (grid%id , idum1 , idum2) + ! call set_scalar_indices_from_config (grid%id , idum1 , idum2) - call model_to_grid_config_rec (grid%id , model_config_rec , config_flags) + ! call model_to_grid_config_rec (grid%id , model_config_rec , config_flags) grid%itimestep = 1 diff --git a/wrfv2_fire/var/da/da_main/da_wrfvar_io.f90 b/wrfv2_fire/var/da/da_main/da_wrfvar_io.f90 index b2241c4b..4e50f756 100644 --- a/wrfv2_fire/var/da/da_main/da_wrfvar_io.f90 +++ b/wrfv2_fire/var/da/da_main/da_wrfvar_io.f90 @@ -4,7 +4,7 @@ module da_wrfvar_io use module_date_time, only : geth_julgmt,current_date, start_date use module_domain, only : domain use module_io_domain, only : open_r_dataset,close_dataset, & - input_model_input, open_w_dataset,output_model_input + input_input, open_w_dataset,output_input use da_control, only : trace_use,ierr use da_reporting, only : da_error, message, da_message diff --git a/wrfv2_fire/var/da/da_main/da_wrfvar_top.f90 b/wrfv2_fire/var/da/da_main/da_wrfvar_top.f90 index a5d3ae35..6af386c2 100644 --- a/wrfv2_fire/var/da/da_main/da_wrfvar_top.f90 +++ b/wrfv2_fire/var/da/da_main/da_wrfvar_top.f90 @@ -43,7 +43,7 @@ module da_wrfvar_top use da_minimisation, only : da_get_innov_vector,da_minimise_cg, & da_minimise_lz, da_write_diagnostics use da_obs_io, only : da_write_filtered_obs, da_write_obs, da_final_write_obs , & - da_write_obs_etkf + da_write_obs_etkf, da_write_modified_filtered_obs !cys_change use da_par_util, only : da_system,da_copy_tile_dims,da_copy_dims use da_physics, only : da_uvprho_to_w_lin #if defined (CRTM) || defined (RTTOV) @@ -55,7 +55,7 @@ module da_wrfvar_top use da_reporting, only : message, da_warning, da_error, da_message use da_setup_structures, only : da_setup_obs_structures, & da_setup_background_errors,da_setup_flow_predictors, & - da_setup_cv + da_setup_cv, da_scale_background_errors use da_test, only : da_check use da_tools_serial, only : da_get_unit, da_free_unit use da_tracing, only : da_trace_entry, da_trace_exit, da_trace @@ -67,7 +67,6 @@ module da_wrfvar_top #ifdef CRTM use module_radiance, only : crtm_destroy use da_crtm, only : channelinfo, sensor_descriptor - use da_control, only : rtm_option, use_rad #endif use da_airep, only : da_oi_stats_airep @@ -83,7 +82,7 @@ module da_wrfvar_top use da_profiler, only : da_oi_stats_profiler use da_qscat, only : da_oi_stats_qscat use da_mtgirs, only : da_oi_stats_mtgirs - use da_radar, only : da_oi_stats_radar + use da_radar, only : da_oi_stats_radar, da_write_oa_radar_ascii use da_satem, only : da_oi_stats_satem use da_ships, only : da_oi_stats_ships use da_sound, only : da_oi_stats_sound, da_oi_stats_sonde_sfc diff --git a/wrfv2_fire/var/da/da_metar/da_check_max_iv_metar.inc b/wrfv2_fire/var/da/da_metar/da_check_max_iv_metar.inc index 095349c1..4eade561 100644 --- a/wrfv2_fire/var/da/da_metar/da_check_max_iv_metar.inc +++ b/wrfv2_fire/var/da/da_metar/da_check_max_iv_metar.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -22,10 +25,8 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) !--------------------------------------------------------------------------- do n=iv%info(metar)%n1,iv%info(metar)%n2 - if( iv%metar(n)%u%qc == fails_error_max .and. it > 1 )iv%metar(n)%u%qc =0 - if( iv%metar(n)%u%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%metar(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(metar), n, iv%metar(n)%u, max_error_uv, failed) if( iv%info(metar)%proc_domain(1,n) ) then num_qcstat_conv(1,metar,1,1)= num_qcstat_conv(1,metar,1,1) + 1 @@ -35,12 +36,9 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) 'metar',ob_vars(1),iv%info(metar)%lat(1,n),iv%info(metar)%lon(1,n),0.01*ob%metar(n)%p end if end if - end if - if( iv%metar(n)%v%qc == fails_error_max .and. it > 1 )iv%metar(n)%v%qc =0 - if( iv%metar(n)%v%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%metar(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(metar), n, iv%metar(n)%v, max_error_uv, failed) if( iv%info(metar)%proc_domain(1,n) ) then num_qcstat_conv(1,metar,2,1)= num_qcstat_conv(1,metar,2,1) + 1 @@ -50,12 +48,9 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) 'metar',ob_vars(2),iv%info(metar)%lat(1,n),iv%info(metar)%lon(1,n),0.01*ob%metar(n)%p end if end if - end if - if( iv%metar(n)%t%qc == fails_error_max .and. it > 1 )iv%metar(n)%t%qc =0 - if( iv%metar(n)%t%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%metar(n)%t%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(metar), n, iv%metar(n)%t, max_error_t , failed) if( iv%info(metar)%proc_domain(1,n) ) then num_qcstat_conv(1,metar,3,1)= num_qcstat_conv(1,metar,3,1) + 1 @@ -65,12 +60,9 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) 'metar',ob_vars(3),iv%info(metar)%lat(1,n),iv%info(metar)%lon(1,n),0.01*ob%metar(n)%p end if end if - end if - if( iv%metar(n)%p%qc == fails_error_max .and. it > 1 )iv%metar(n)%p%qc =0 - if( iv%metar(n)%p%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%metar(n)%p%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(metar), n, iv%metar(n)%p, max_error_p , failed) if( iv%info(metar)%proc_domain(1,n) ) then num_qcstat_conv(1,metar,5,1)= num_qcstat_conv(1,metar,5,1) + 1 @@ -80,19 +72,16 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) 'metar',ob_vars(5),iv%info(metar)%lat(1,n),iv%info(metar)%lon(1,n),0.01*ob%metar(n)%p end if end if - end if - if( iv%metar(n)%q%qc == fails_error_max .and. it > 1 )iv%metar(n)%q%qc =0 - if( iv%metar(n)%q%qc >= obs_qc_pointer ) then failed=.false. - if( iv%metar(n)%t%qc == fails_error_max .or. iv%metar(n)%p%qc == fails_error_max) then - failed=.true. - iv%metar(n)%q%qc = fails_error_max - iv%metar(n)%q%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it, iv%info(metar), n, iv%metar(n)%q, max_error_q , failed) - endif + if( iv%metar(n)%q%qc >= obs_qc_pointer ) then + if( iv%metar(n)%t%qc == fails_error_max .or. iv%metar(n)%p%qc == fails_error_max) then + failed=.true. + iv%metar(n)%q%qc = fails_error_max + iv%metar(n)%q%inv = 0.0 + else + call da_max_error_qc (it, iv%info(metar), n, iv%metar(n)%q, max_error_q , failed) + endif if( iv%info(metar)%proc_domain(1,n) ) then num_qcstat_conv(1,metar,4,1)= num_qcstat_conv(1,metar,4,1) + 1 if(failed) then @@ -101,11 +90,9 @@ subroutine da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) 'metar',ob_vars(4),iv%info(metar)%lat(1,n),iv%info(metar)%lon(1,n),0.01*ob%metar(n)%p end if end if - end if + end if end do if (trace_use_dull) call da_trace_exit("da_check_max_iv_metar") end subroutine da_check_max_iv_metar - - diff --git a/wrfv2_fire/var/da/da_metar/da_get_innov_vector_metar.inc b/wrfv2_fire/var/da/da_metar/da_get_innov_vector_metar.inc index 3139252c..b15a51e0 100644 --- a/wrfv2_fire/var/da/da_metar/da_get_innov_vector_metar.inc +++ b/wrfv2_fire/var/da/da_metar/da_get_innov_vector_metar.inc @@ -41,6 +41,16 @@ subroutine da_get_innov_vector_metar(it,num_qcstat_conv, grid, ob, iv) allocate (model_p (1,iv%info(metar)%n1:iv%info(metar)%n2)) allocate (model_hsm(1,iv%info(metar)%n1:iv%info(metar)%n2)) + if ( it > 1 ) then + do n=iv%info(metar)%n1,iv%info(metar)%n2 + if (iv%metar(n)%u%qc == fails_error_max) iv%metar(n)%u%qc = 0 + if (iv%metar(n)%v%qc == fails_error_max) iv%metar(n)%v%qc = 0 + if (iv%metar(n)%t%qc == fails_error_max) iv%metar(n)%t%qc = 0 + if (iv%metar(n)%p%qc == fails_error_max) iv%metar(n)%p%qc = 0 + if (iv%metar(n)%q%qc == fails_error_max) iv%metar(n)%q%qc = 0 + end do + end if + if (sfc_assi_options == sfc_assi_options_1) then do n=iv%info(metar)%n1,iv%info(metar)%n2 @@ -73,16 +83,6 @@ subroutine da_get_innov_vector_metar(it,num_qcstat_conv, grid, ob, iv) if (iv % metar(n) % h < v_h(kts)) then iv%info(metar)%zk(:,n) = 1.0+1.0e-6 call da_obs_sfc_correction(iv%info(metar), iv%metar(n), n, grid%xb) - - ! To keep the original "ob" with no change for multiple - ! outer-loops use: - - ! ob%metar(n)%p = iv%metar(n)%p%inv - ! ob%metar(n)%t = iv%metar(n)%t%inv - ! ob%metar(n)%q = iv%metar(n)%q%inv - ! ob%metar(n)%u = iv%metar(n)%u%inv - ! ob%metar(n)%v = iv%metar(n)%v%inv - else call da_to_zk(iv % metar(n) % h, v_h, v_interp_h, iv%info(metar)%zk(1,n)) end if @@ -133,8 +133,8 @@ subroutine da_get_innov_vector_metar(it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_3d (grid%xb%q, iv%info(metar),model_q) call da_interp_lin_3d (grid%xb%p, iv%info(metar),model_p) - else if (sfc_assi_options == 2) then - ! 1.2.1 Surface assmiilation approach 2 + else if (sfc_assi_options == sfc_assi_options_2) then + ! 1.2.1 Surface assimilation approach 2 !(10-m u, v, 2-m t, q, and sfc_p) call da_interp_lin_2d (grid%xb%u10, iv%info(metar), 1, model_u) @@ -145,6 +145,13 @@ subroutine da_get_innov_vector_metar(it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_2d (grid%xb%terr, iv%info(metar), 1, model_hsm) do n=iv%info(metar)%n1,iv%info(metar)%n2 + + iv%metar(n)%p%inv = ob%metar(n)%p + iv%metar(n)%t%inv = ob%metar(n)%t + iv%metar(n)%q%inv = ob%metar(n)%q + iv%metar(n)%u%inv = ob%metar(n)%u + iv%metar(n)%v%inv = ob%metar(n)%v + if (iv%metar(n)%p%qc >= 0) then ! model surface p, t, q, h at observed site: @@ -215,7 +222,8 @@ subroutine da_get_innov_vector_metar(it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !----------------------------------------------------------------------- - call da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_metar(iv,ob, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_minimisation/da_calculate_gradj.inc b/wrfv2_fire/var/da/da_minimisation/da_calculate_gradj.inc index a5fc46fa..5bfa70f4 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_calculate_gradj.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_calculate_gradj.inc @@ -40,7 +40,7 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size real :: gnorm_jb, gnorm_jo, gnorm_j, gnorm_je, gnorm_js, gnorm_jp ! Variables for VarBC background constraint - real , allocatable, dimension(:) :: xhat_jp ! Jp control variable. + real :: xhat_jp(cv_size_jp) ! Jp control variable. integer :: jp_start, jp_end ! Start/end indices of Jp. integer :: inst, ichan, npred, ipred, id real :: bgerr @@ -88,36 +88,54 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size !------------------------------------------------------------------------- ! [2.0] calculate grad_v (jb): !------------------------------------------------------------------------- - if (cv_size_jb > 0) grad_jb(1:cv_size_jb) = jb_factor * xhat(1:cv_size_jb) + if (cv_size_jb > 0) then + if (it < 0) then + grad_jb(1:cv_size_jb) = jb_factor * (xhat(1:cv_size_jb)+cv(1:cv_size_jb)) + else + grad_jb(1:cv_size_jb) = jb_factor * (xhat(1:cv_size_jb)) + end if + endif !------------------------------------------------------------------------- ! [3.0] calculate grad_v (je): !------------------------------------------------------------------------- - if (cv_size_je > 0) grad_je(je_start:je_end) = je_factor * xhat(je_start:je_end) + if (cv_size_je > 0) then + if (it < 0) then + grad_je(je_start:je_end) = je_factor * (xhat(je_start:je_end)+cv(je_start:je_end)) + else + grad_je(je_start:je_end) = je_factor * (xhat(je_start:je_end)) + end if + end if !------------------------------------------------------------------------- ! [4.0] calculate grad_v (jp): !------------------------------------------------------------------------- +#if defined(RTTOV) || defined(CRTM) if (use_varbc) then - allocate(xhat_jp(cv_size_jp)) xhat_jp(1:cv_size_jp) = 0.0 do inst = 1, iv % num_inst do ichan = 1, iv%instid(inst)%nchan + if (satinfo(inst)%iuse(ichan) <= 0) cycle npred = iv%instid(inst)%varbc(ichan)%npred if (npred <= 0) cycle !! VarBC channels only do ipred = 1, npred id = iv%instid(inst)%varbc(ichan)%index(ipred) bgerr = iv%instid(inst)%varbc(ichan)%bgerr(ipred) if (bgerr > 0.0) & - xhat_jp(id-jp_start+1) = (1/sqrt(bgerr)) * & - SUM(xhat(id) * iv%instid(inst)%varbc(ichan)%vtox(ipred,1:npred)) + xhat_jp(id-jp_start+1) = (1/bgerr) * & + SUM( (cv(id)+xhat(id)) * & + iv%instid(inst)%varbc(ichan)%vtox(ipred,1:npred)) end do end do end do - grad_jp(jp_start:jp_end) = xhat_jp(1:cv_size_jp) + if (it < 0) then + grad_jp(jp_start:jp_end) = xhat_jp(1:cv_size_jp) + cv(jp_start:jp_end) + else + grad_jp(jp_start:jp_end) = xhat_jp(1:cv_size_jp) + end if - deallocate(xhat_jp) end if +#endif !------------------------------------------------------------------------- ! [5.0] calculate grad_v (js): @@ -127,18 +145,18 @@ subroutine da_calculate_gradj(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel ! Skin Temperature !----------------- -! if (use_satcv(1)) & -! grad_js(iv%instid(inst)%cv_index(n)%ts) = xhat(iv%instid(inst)%cv_index(n)%ts) + if (use_satcv(1)) & + grad_js(iv%instid(inst)%cv_index(n)%ts) = xhat(iv%instid(inst)%cv_index(n)%ts) + cv(iv%instid(inst)%cv_index(n)%ts) ! Cloud cover(s) !--------------- if (use_satcv(2)) then - grad_js(iv%instid(inst)%cv_index(n)%cc) = xhat(iv%instid(inst)%cv_index(n)%cc) + grad_js(iv%instid(inst)%cv_index(n)%cc) = xhat(iv%instid(inst)%cv_index(n)%cc) + cv(iv%instid(inst)%cv_index(n)%cc) WHERE (xhat(iv%instid(inst)%cv_index(n)%cc) < 0.0 .or. & xhat(iv%instid(inst)%cv_index(n)%cc) > 1.0 ) & grad_js(iv%instid(inst)%cv_index(n)%cc) = grad_js(iv%instid(inst)%cv_index(n)%cc) + & - 10.0 * xhat(iv%instid(inst)%cv_index(n)%cc) + 10.0 * (xhat(iv%instid(inst)%cv_index(n)%cc)+cv(iv%instid(inst)%cv_index(n)%cc)) end if end do end do diff --git a/wrfv2_fire/var/da/da_minimisation/da_calculate_j.inc b/wrfv2_fire/var/da/da_minimisation/da_calculate_j.inc index adfd772d..4c966712 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_calculate_j.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_calculate_j.inc @@ -29,16 +29,13 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, integer :: je_start, je_end ! Start/end indices of Je. real :: jo_partial ! jo for this processor type (y_type) :: jo_grad_y ! Grad_y(jo) - real :: cv_jb(1:cv_size_jb) ! Jb control variable. - real :: xhat_jb(1:cv_size_jb) ! Jb control variable. - real :: cv_je(1:cv_size_je) ! Je control variable. - real :: xhat_je(1:cv_size_je) ! Je control variable. - real, allocatable, dimension(:) :: cv_xhat_jb, cv_xhat_je + real :: cv_xhat_jb(cv_size_jb), cv_xhat_je(cv_size_je) + integer :: ndynopt, is, ie, js, je, ks, ke real :: dtemp1x ! Variables for VarBC background constraint - real , allocatable, dimension(:) :: cv_xhat_jp ! Jp control variable. + real :: cv_xhat_jp(cv_size_jp), xhat_jp(cv_size_jp) ! Jp control variable. integer :: jp_start, jp_end ! Start/end indices of Jp. integer :: inst, ichan, npred, ipred, id real :: bgerr, gnorm_jp @@ -49,13 +46,11 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, if (trace_use) call da_trace_entry("da_calculate_j") - allocate(cv_xhat_jb(cv_size_jb)) - allocate(cv_xhat_je(cv_size_je)) - allocate(cv_xhat_jp(cv_size_jp)) - - je_start = cv_size_jb + 1 - je_end = cv_size_jb + cv_size_je + je_end = cv_size_jb + cv_size_je + + jp_start = cv_size_jb + cv_size_je + 1 + jp_end = cv_size_jb + cv_size_je + cv_size_jp call da_allocate_y(iv, jo_grad_y) @@ -125,10 +120,7 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, ! [2.0] calculate jb: !------------------------------------------------------------------------- - cv_jb(1:cv_size_jb) = cv (1:cv_size_jb) - xhat_jb(1:cv_size_jb) = xhat (1:cv_size_jb) - - cv_xhat_jb(1:cv_size_jb) = cv_jb(1:cv_size_jb) + xhat_jb(1:cv_size_jb) + cv_xhat_jb(1:cv_size_jb) = cv(1:cv_size_jb) + xhat(1:cv_size_jb) j % jb = 0.5 * da_dot_cv(cv_size_jb, cv_size_domain_jb, & cv_xhat_jb, cv_xhat_jb, grid, & @@ -142,9 +134,8 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, j % je = 0.0 if (be % ne > 0) then - cv_je(1:cv_size_je) = cv(je_start:je_end) - xhat_je(1:cv_size_je) = xhat(je_start:je_end) - cv_xhat_je(1:cv_size_je) = cv_je(1:cv_size_je) + xhat_je(1:cv_size_je) + cv_xhat_je(1:cv_size_je) = cv(je_start:je_end) + xhat(je_start:je_end) + j % je = 0.5 * da_dot_cv(cv_size_je, cv_size_domain_je, & cv_xhat_je, cv_xhat_je, grid, & (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%alpha%mz /)) @@ -155,12 +146,11 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, ! [4.0] calculate jp: !------------------------------------------------------------------------- j % jp = 0.0 +#if defined(RTTOV) || defined(CRTM) if (use_varbc) then - jp_start = cv_size_jb + cv_size_je + 1 - jp_end = cv_size_jb + cv_size_je + cv_size_jp - cv_xhat_jp(1:cv_size_jp) = 0.0 do inst = 1, iv % num_inst do ichan = 1, iv%instid(inst)%nchan + if (satinfo(inst)%iuse(ichan) <= 0) cycle npred = iv%instid(inst)%varbc(ichan)%npred if (npred <= 0) cycle !! VarBC channels only do ipred = 1, npred @@ -175,6 +165,7 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, end do j % jp = 0.5 * da_dot(cv_size_jp, cv_xhat_jp, cv_xhat_jp) end if +#endif !------------------------------------------------------------------------- ! [5.0] calculate js: @@ -268,12 +259,7 @@ subroutine da_calculate_j(it, iter, cv_size, cv_size_jb, cv_size_je, cv_size_jp, it, EPS(it), iter, j % total, j % jb, j % jo % total, j % jc, j % je, j % jp, j%js end if - deallocate(cv_xhat_jb) - deallocate(cv_xhat_je) - deallocate(cv_xhat_jp) - if (trace_use) call da_trace_exit("da_calculate_j") end subroutine da_calculate_j - diff --git a/wrfv2_fire/var/da/da_minimisation/da_calculate_residual.inc b/wrfv2_fire/var/da/da_minimisation/da_calculate_residual.inc index 4f5a8ec4..bc426aa6 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_calculate_residual.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_calculate_residual.inc @@ -6,7 +6,7 @@ subroutine da_calculate_residual(iv, y, re) implicit none - type (iv_type), intent(in) :: iv ! Innovation vector (O-B). + type (iv_type), intent(inout) :: iv ! Innovation vector (O-B). type (y_type), intent(in) :: y ! y = H (xa) type (y_type), intent(inout) :: re ! Residual (O-A). diff --git a/wrfv2_fire/var/da/da_minimisation/da_get_innov_vector.inc b/wrfv2_fire/var/da/da_minimisation/da_get_innov_vector.inc index efe36438..cff21368 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_get_innov_vector.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_get_innov_vector.inc @@ -84,14 +84,16 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) call da_get_innov_vector_metar (it, num_qcstat_conv,grid, ob, iv) if (iv%info(ships)%nlocal > 0) & call da_get_innov_vector_ships (it, num_qcstat_conv,grid, ob, iv) + if ( (use_gpspwObs .and. iv%info(gpspw)%nlocal > 0) .or. & (pseudo_var(1:3) == 'tpw' .and. iv%info(pseudo)%nlocal > 0) ) then call da_get_innov_vector_gpspw (it, num_qcstat_conv,grid, ob, iv) else if ( (use_gpsztdObs .and. iv%info(gpspw)%nlocal > 0) .or. & (pseudo_var(1:3) == 'ztd' .and. iv%info(pseudo)%nlocal > 0) ) then call da_get_innov_vector_gpsztd ( it, num_qcstat_conv, grid, ob, iv ) - end if - if (iv%info(gpsref)%nlocal > 0) & + endif + if ( (iv%info(gpsref)%nlocal > 0 ) .or. & + (pseudo_var(1:3) == 'ref' .and. iv%info(pseudo)%nlocal > 0) ) & call da_get_innov_vector_gpsref (it, num_qcstat_conv, grid, ob, iv) if (iv%info(ssmi_tb)%nlocal > 0) & call da_get_innov_vector_ssmi_tb (it, grid, ob, iv) @@ -140,7 +142,6 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) call da_system("touch wrf_stop_now") #endif call wrf_message("*** WRF-Var multi-increment stage 1 completed successfully ***") - if (trace_use) call da_trace_exit("da_get_innov_vector") call wrfu_finalize call wrf_shutdown @@ -178,7 +179,7 @@ subroutine da_get_innov_vector (it, num_qcstat_conv, ob, iv, grid, config_flags) !----------------------------------------------- if (write_iv_rad_ascii) then write(unit=stdout,fmt='(A)') 'Writing radiance iv ascii' - call da_write_iv_rad_ascii(ob,iv) + call da_write_iv_rad_ascii(it,ob,iv) end if #endif diff --git a/wrfv2_fire/var/da/da_minimisation/da_get_var_diagnostics.inc b/wrfv2_fire/var/da/da_minimisation/da_get_var_diagnostics.inc index 6d6d0557..0ec5555b 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_get_var_diagnostics.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_get_var_diagnostics.inc @@ -211,14 +211,17 @@ subroutine da_get_var_diagnostics( iv, j) if (num_stats_tot > 0) & write(unit=stdout,fmt='(a,f15.5)') ' Final J / total num_obs = ', j % total / & real(num_stats_tot) - write(unit=stdout,fmt='(a,f15.5)') ' Jb factor used(1) = ', var_scaling1 - write(unit=stdout,fmt='(a,f15.5)') ' Jb factor used(2) = ', var_scaling2 - write(unit=stdout,fmt='(a,f15.5)') ' Jb factor used(3) = ', var_scaling3 - write(unit=stdout,fmt='(a,f15.5)') ' Jb factor used(4) = ', var_scaling4 - write(unit=stdout,fmt='(a,f15.5)') ' Jb factor used(5) = ', var_scaling5 - write(unit=stdout,fmt='(a,f15.5)') ' Jb factor used = ', jb_factor - write(unit=stdout,fmt='(a,f15.5)') ' Je factor used = ', je_factor - write(unit=stdout,fmt='(a,f15.5)') ' VarBC factor used = ', varbc_factor + if (cv_options /= 3) then + write(unit=stdout,fmt='(a,(5f15.5))') ' Jb factor used(1) = ', var_scaling1 + write(unit=stdout,fmt='(a,(5f15.5))') ' Jb factor used(2) = ', var_scaling2 + write(unit=stdout,fmt='(a,(5f15.5))') ' Jb factor used(3) = ', var_scaling3 + write(unit=stdout,fmt='(a,(5f15.5))') ' Jb factor used(4) = ', var_scaling4 + write(unit=stdout,fmt='(a,(5f15.5))') ' Jb factor used(5) = ', var_scaling5 + endif + + write(unit=stdout,fmt='(a, f15.5)') ' Jb factor used = ', jb_factor + write(unit=stdout,fmt='(a, f15.5)') ' Je factor used = ', je_factor + write(unit=stdout,fmt='(a, f15.5)') ' VarBC factor used = ', varbc_factor write(unit=stdout,fmt=*) ' ' if (use_rad) then diff --git a/wrfv2_fire/var/da/da_minimisation/da_minimisation.f90 b/wrfv2_fire/var/da/da_minimisation/da_minimisation.f90 index 5e59c64e..3f6799cc 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_minimisation.f90 +++ b/wrfv2_fire/var/da/da_minimisation/da_minimisation.f90 @@ -34,7 +34,7 @@ module da_minimisation write_filtered_rad,omb_set_rand,use_rad,var_scaling2,var_scaling1, & var_scaling4,var_scaling5,var_scaling3, jo_unit, & print_detail_grad,omb_set_rand,grad_unit,cost_unit, & - cv_size_domain_je,cv_size_domain_jb, num_pseudo, & + cv_size_domain_je,cv_size_domain_jb, num_pseudo, cv_options, & sound, mtgirs, sonde_sfc, synop, profiler, gpsref, gpspw, polaramv, geoamv, ships, metar, & satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep,tamdar, tamdar_sfc, & bogus, buoy, qscat,pseudo, radiance, monitor_on, max_ext_its, use_crtm_kmatrix, & @@ -42,7 +42,7 @@ module da_minimisation num_procs, myproc, use_gpspwobs, use_gpsztdobs, pseudo_var, num_pseudo, & num_ob_indexes, num_ob_vars, npres_print, pptop, ppbot, qcstat_conv_unit, & orthonorm_gradient, its, ite, jts, jte, kte, ids, ide, jds, jde, & - use_satcv, sensitivity_option + use_satcv, sensitivity_option, print_detail_outerloop use da_define_structures, only : iv_type, y_type, j_type, be_type, & xbx_type, jo_type, da_allocate_y,da_zero_x,da_zero_y,da_deallocate_y, & da_zero_vp_type @@ -95,7 +95,7 @@ module da_minimisation #if defined(RTTOV) || defined(CRTM) use da_radiance, only : da_calculate_grady_rad, da_write_filtered_rad, & - da_get_innov_vector_radiance + da_get_innov_vector_radiance, satinfo use da_radiance1, only : da_ao_stats_rad,da_oi_stats_rad, & da_write_iv_rad_ascii,da_residual_rad,da_jo_and_grady_rad #endif diff --git a/wrfv2_fire/var/da/da_minimisation/da_minimise_cg.inc b/wrfv2_fire/var/da/da_minimisation/da_minimise_cg.inc index dc747c55..43bda9c4 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_minimise_cg.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_minimise_cg.inc @@ -25,7 +25,7 @@ subroutine da_minimise_cg(grid, config_flags, & type (be_type), intent(in) :: be ! background error structure. type (iv_type), intent(inout) :: iv ! ob. increment vector. real, intent(inout) :: j_grad_norm_target ! Target norm. - real, intent(out) :: xhat(1:cv_size) ! control variable (local). + real, intent(inout) :: xhat(1:cv_size) ! control variable (local). real, intent(inout) :: cv(1:cv_size) ! control variable (local). type (y_type), intent(inout) :: re ! residual (o-a) structure. type (y_type), intent(inout) :: y ! y = H(x_inc) structure. @@ -38,7 +38,7 @@ subroutine da_minimise_cg(grid, config_flags, & integer :: iter integer :: je_start, je_end ! Start/end indices of Je. integer :: cv_size_jb ! end indices of Jb. - integer :: mz(6) + integer :: mz(7) real :: fhat(1:cv_size) ! cv copy. real :: ghat(1:cv_size) ! cv copy. real :: ghat0(1:cv_size) ! cv copy. @@ -68,7 +68,7 @@ subroutine da_minimise_cg(grid, config_flags, & !------------------------------------------------------------------------- ! [1.0] Initialization: !------------------------------------------------------------------------- - mz = (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%alpha%mz /) + mz = (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%alpha%mz, be % ne /) sz = (/ be%cv%size1, be%cv%size2, be%cv%size3, be%cv%size4, be%cv%size5 /) call da_calculate_j(it, 0, cv_size, be % cv % size_jb, be % cv % size_je, & @@ -107,7 +107,8 @@ subroutine da_minimise_cg(grid, config_flags, & if (j_cost%total == 0.0) return - if (it == 1) j_grad_norm_target = sqrt (rrmold) + !if (it == 1) j_grad_norm_target = sqrt (rrmold) + j_grad_norm_target = sqrt (rrmold) if (orthonorm_gradient) then allocate(qhat(1:cv_size, 0:ntmax)) @@ -174,7 +175,7 @@ subroutine da_minimise_cg(grid, config_flags, & be % cv % size_jp, xbx, be, iv, xhat, cv, & re, y, j_cost, grid, config_flags) call da_calculate_gradj(-it, iter, cv_size, be%cv%size_jb, be%cv%size_je, be%cv%size_jp, & - xbx, be, iv, xhat, cv, re, y, fhat, grid, config_flags ) + xbx, be, iv, xhat, cv, re, y, fhat, grid, config_flags ) write(unit=stdout,fmt=12)iter, j_cost%total, rrmnew_norm, step elseif (calculate_cg_cost_fn) then j_total = j_cost%total + 0.5 * da_dot_cv(cv_size,cv_size_domain,ghat0,xhat,grid,mz,use_varbc) diff --git a/wrfv2_fire/var/da/da_minimisation/da_write_diagnostics.inc b/wrfv2_fire/var/da/da_minimisation/da_write_diagnostics.inc index 284e99e7..79074294 100644 --- a/wrfv2_fire/var/da/da_minimisation/da_write_diagnostics.inc +++ b/wrfv2_fire/var/da/da_minimisation/da_write_diagnostics.inc @@ -15,8 +15,16 @@ subroutine da_write_diagnostics(it, grid,num_qcstat_conv, ob, iv, re, y, j) type (y_type), intent(in) :: y ! y = H(x_inc) structure. type (j_type), intent(inout) :: j ! Cost function. + character(len=13) filename + if (trace_use) call da_trace_entry("da_write_diagnostics") + if (rootproc .and. print_detail_outerloop) then + write(filename,'(a,i2.2)') "statistics_",it + call da_get_unit (stats_unit) + open(unit=stats_unit,file=filename,status="replace") + endif + iv%nstats(:) = 0 !--------------------------------------------------------------------------- @@ -130,6 +138,11 @@ if (.not. anal_type_verify) then call da_print_qcstat(it, iv, num_qcstat_conv) end if + if (rootproc .and. print_detail_outerloop) then + close(stats_unit) + call da_free_unit (stats_unit) + end if + if (trace_use) call da_trace_exit("da_write_diagnostics") end subroutine da_write_diagnostics diff --git a/wrfv2_fire/var/da/da_monitor/da_rad_diags.f90 b/wrfv2_fire/var/da/da_monitor/da_rad_diags.f90 index 58442229..8154783d 100644 --- a/wrfv2_fire/var/da/da_monitor/da_rad_diags.f90 +++ b/wrfv2_fire/var/da/da_monitor/da_rad_diags.f90 @@ -33,7 +33,7 @@ program da_rad_diags integer :: nproc, nlev, ilev, ich integer :: cycle_period, nlev_rtm, nlev_mdl character(len=20), dimension(maxnum) :: instid - character(len=3) :: file_prefix + character(len=6) :: file_prefix character(len=10) :: start_date, end_date ! ! netcdf variables diff --git a/wrfv2_fire/var/da/da_mtgirs/da_check_max_iv_mtgirs.inc b/wrfv2_fire/var/da/da_mtgirs/da_check_max_iv_mtgirs.inc index 2b9744c0..dbce3434 100644 --- a/wrfv2_fire/var/da/da_mtgirs/da_check_max_iv_mtgirs.inc +++ b/wrfv2_fire/var/da/da_mtgirs/da_check_max_iv_mtgirs.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_mtgirs(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -22,64 +25,53 @@ subroutine da_check_max_iv_mtgirs(iv, it, num_qcstat_conv) do n = iv%info(mtgirs)%n1,iv%info(mtgirs)%n2 do k = 1, iv%info(mtgirs)%levels(n) call da_get_print_lvl(iv%mtgirs(n)%p(k),ipr) - if( iv%mtgirs(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%mtgirs(n)%u(k)%qc =0 - if( iv%mtgirs(n)%u(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%mtgirs(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(mtgirs), n, iv%mtgirs(n)%u(k), max_error_uv,failed) if( iv%info(mtgirs)%proc_domain(k,n) ) then - num_qcstat_conv(1,mtgirs,1,ipr) = num_qcstat_conv(1,mtgirs,1,ipr) + 1 + num_qcstat_conv(1,mtgirs,1,ipr) = num_qcstat_conv(1,mtgirs,1,ipr) + 1 if(failed) then num_qcstat_conv(2,mtgirs,1,ipr) = num_qcstat_conv(2,mtgirs,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'mtgirs',ob_vars(1),iv%info(mtgirs)%lat(k,n),iv%info(mtgirs)%lon(k,n),0.01*iv%mtgirs(n)%p(k) end if end if - end if - if( iv%mtgirs(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%mtgirs(n)%v(k)%qc =0 - if( iv%mtgirs(n)%v(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%mtgirs(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(mtgirs), n, iv%mtgirs(n)%v(k), max_error_uv,failed) if( iv%info(mtgirs)%proc_domain(k,n) ) then - num_qcstat_conv(1,mtgirs,2,ipr) = num_qcstat_conv(1,mtgirs,2,ipr) + 1 + num_qcstat_conv(1,mtgirs,2,ipr) = num_qcstat_conv(1,mtgirs,2,ipr) + 1 if(failed) then num_qcstat_conv(2,mtgirs,2,ipr) = num_qcstat_conv(2,mtgirs,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'mtgirs',ob_vars(2),iv%info(mtgirs)%lat(k,n),iv%info(mtgirs)%lon(k,n),0.01*iv%mtgirs(n)%p(k) end if end if - end if - if( iv%mtgirs(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%mtgirs(n)%t(k)%qc =0 - if( iv%mtgirs(n)%t(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%mtgirs(n)%t(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(mtgirs), n, iv%mtgirs(n)%t(k), max_error_t ,failed) if( iv%info(mtgirs)%proc_domain(k,n) ) then - num_qcstat_conv(1,mtgirs,3,ipr) = num_qcstat_conv(1,mtgirs,3,ipr) + 1 + num_qcstat_conv(1,mtgirs,3,ipr) = num_qcstat_conv(1,mtgirs,3,ipr) + 1 if(failed) then num_qcstat_conv(2,mtgirs,3,ipr) = num_qcstat_conv(2,mtgirs,3,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'mtgirs',ob_vars(3),iv%info(mtgirs)%lat(k,n),iv%info(mtgirs)%lon(k,n),0.01*iv%mtgirs(n)%p(k) end if end if - end if - if( iv%mtgirs(n)%q(k)%qc == fails_error_max .and. it > 1 )iv%mtgirs(n)%q(k)%qc =0 - if( iv%mtgirs(n)%q(k)%qc >= obs_qc_pointer ) then failed=.false. - if( iv%mtgirs(n)%t(k)%qc == fails_error_max ) then - failed=.true. - iv%mtgirs(n)%q(k)%qc = fails_error_max - iv%mtgirs(n)%q(k)%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it,iv%info(mtgirs), n, iv%mtgirs(n)%q(k), max_error_q ,failed) - endif + if( iv%mtgirs(n)%q(k)%qc >= obs_qc_pointer ) then + if( iv%mtgirs(n)%t(k)%qc == fails_error_max ) then + failed=.true. + iv%mtgirs(n)%q(k)%qc = fails_error_max + iv%mtgirs(n)%q(k)%inv = 0.0 + else + call da_max_error_qc (it,iv%info(mtgirs), n, iv%mtgirs(n)%q(k), max_error_q ,failed) + endif if( iv%info(mtgirs)%proc_domain(k,n) ) then - num_qcstat_conv(1,mtgirs,4,ipr) = num_qcstat_conv(1,mtgirs,4,ipr) + 1 + num_qcstat_conv(1,mtgirs,4,ipr) = num_qcstat_conv(1,mtgirs,4,ipr) + 1 if(failed) then num_qcstat_conv(2,mtgirs,4,ipr) = num_qcstat_conv(2,mtgirs,4,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& @@ -94,5 +86,3 @@ subroutine da_check_max_iv_mtgirs(iv, it, num_qcstat_conv) if (trace_use_dull) call da_trace_exit("da_check_max_iv_mtgirs") end subroutine da_check_max_iv_mtgirs - - diff --git a/wrfv2_fire/var/da/da_mtgirs/da_get_innov_vector_mtgirs.inc b/wrfv2_fire/var/da/da_mtgirs/da_get_innov_vector_mtgirs.inc index a97eba1d..145ffe65 100644 --- a/wrfv2_fire/var/da/da_mtgirs/da_get_innov_vector_mtgirs.inc +++ b/wrfv2_fire/var/da/da_mtgirs/da_get_innov_vector_mtgirs.inc @@ -43,6 +43,17 @@ subroutine da_get_innov_vector_mtgirs (it, num_qcstat_conv, grid, ob, iv) model_t(:,:) = 0.0 model_q(:,:) = 0.0 + if ( it > 1 ) then + do n=iv%info(mtgirs)%n1, iv%info(mtgirs)%n2 + do k=1, iv%info(mtgirs)%levels(n) + if (iv%mtgirs(n)%u(k)%qc == fails_error_max) iv%mtgirs(n)%u(k)%qc = 0 + if (iv%mtgirs(n)%v(k)%qc == fails_error_max) iv%mtgirs(n)%v(k)%qc = 0 + if (iv%mtgirs(n)%t(k)%qc == fails_error_max) iv%mtgirs(n)%t(k)%qc = 0 + if (iv%mtgirs(n)%q(k)%qc == fails_error_max) iv%mtgirs(n)%q(k)%qc = 0 + end do + end do + end if + do n=iv%info(mtgirs)%n1, iv%info(mtgirs)%n2 if (iv%info(mtgirs)%levels(n) < 1) cycle @@ -149,7 +160,8 @@ subroutine da_get_innov_vector_mtgirs (it, num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !---------------------------------------------------------------------- - call da_check_max_iv_mtgirs (iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_mtgirs (iv, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_obs/da_count_filtered_obs.inc b/wrfv2_fire/var/da/da_obs/da_count_filtered_obs.inc index 4bbebc49..41cf206c 100644 --- a/wrfv2_fire/var/da/da_obs/da_count_filtered_obs.inc +++ b/wrfv2_fire/var/da/da_obs/da_count_filtered_obs.inc @@ -315,8 +315,13 @@ subroutine da_count_filtered_obs (ptop, map, ds, phic, xlonc, truelat1, truelat2 ! write end of header record - write (unit = filtered_obs_unit, fmt = '(A)') & - "#------------------------------------------------------------------------------#" + if (write_mod_filtered_obs) then !cys_change + write (unit = filtered_obs_unit, fmt = '(A)') & + "MODIFIED FILTERED OBS #--------------------------------------------------------#" + else + write (unit = filtered_obs_unit, fmt = '(A)') & + "FILTERED OBS #-----------------------------------------------------------------#" + end if if (trace_use) call da_trace_exit("da_count_filtered_obs") diff --git a/wrfv2_fire/var/da/da_obs/da_fill_obs_structures.inc b/wrfv2_fire/var/da/da_obs/da_fill_obs_structures.inc index 7202f6e8..9c74f272 100644 --- a/wrfv2_fire/var/da/da_obs/da_fill_obs_structures.inc +++ b/wrfv2_fire/var/da/da_obs/da_fill_obs_structures.inc @@ -1,4 +1,4 @@ -subroutine da_fill_obs_structures(iv, ob) +subroutine da_fill_obs_structures(iv, ob, uvq_direct) !---------------------------------------------------------------------------- ! Purpose: Allocates observation structure and fills it from iv. @@ -8,6 +8,7 @@ subroutine da_fill_obs_structures(iv, ob) type (iv_type), intent(inout) :: iv ! Obs and header structure. type (y_type), intent(out) :: ob ! (Smaller) observation structure. + logical, optional :: uvq_direct !flag for having direct u,v,q obs integer :: n, k ! Loop counters. real :: rh_error ! RH obs. error. @@ -135,6 +136,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%synop(n)%q%error ! q error is rh at this stage! ! if((ob % synop(n) % p > iv%ptop) .AND. & @@ -151,6 +153,7 @@ subroutine da_fill_obs_structures(iv, ob) if (iv%synop(n)% q % error == missing_r) iv%synop(n)% q % qc = missing_data ! end if + end if !cys_add end do end if @@ -166,6 +169,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%metar(n)%q%error ! q error is rh at this stage! call da_get_q_error(iv % metar(n) % p % inv, & ob % metar(n) % t, & @@ -175,6 +179,7 @@ subroutine da_fill_obs_structures(iv, ob) iv % metar(n) % q % error = q_error if (iv%metar(n)% q % error == missing_r) & iv%metar(n)% q % qc = missing_data + end if !cys_add end do end if @@ -190,6 +195,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%ships(n)%q%error ! q error is rh at this stage! call da_get_q_error(iv % ships(n) % p % inv, & ob % ships(n) % t, & @@ -199,6 +205,7 @@ subroutine da_fill_obs_structures(iv, ob) iv % ships(n) % q % error = q_error if(iv%ships(n)% q % error == missing_r) iv%ships(n)% q % qc = missing_data + end if !cys_add end do end if @@ -259,6 +266,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%sound(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % sound(n) % p(k), & ob % sound(n) % t(k), & @@ -269,6 +277,7 @@ subroutine da_fill_obs_structures(iv, ob) iv % sound(n) % q(k) % error = q_error if (iv%sound(n)% q(k) % error == missing_r) & iv%sound(n)% q(k) % qc = missing_data + end if !cys_add end do ob % sonde_sfc(n) % u = iv % sonde_sfc(n) % u % inv ob % sonde_sfc(n) % v = iv % sonde_sfc(n) % v % inv @@ -278,6 +287,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%sonde_sfc(n)%q%error ! q error is rh at this stage! call da_get_q_error(iv % sonde_sfc(n) % p % inv, & ob % sonde_sfc(n) % t, & @@ -286,6 +296,7 @@ subroutine da_fill_obs_structures(iv, ob) rh_error, iv % sonde_sfc(n) % q % error) if (iv%sonde_sfc(n)% q % error == missing_r) & iv%sonde_sfc(n)% q % qc = missing_data + end if !cys_add end do end if @@ -402,6 +413,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%buoy(n)%q%error ! q error is rh at this stage! call da_get_q_error(iv % buoy(n) % p % inv, & ob % buoy(n) % t, & @@ -411,6 +423,7 @@ subroutine da_fill_obs_structures(iv, ob) iv % buoy(n) % q % error = q_error if(iv%buoy (n)% q % error == missing_r) iv%buoy (n)% q % qc = missing_data + end if !cys_add end do end if @@ -469,6 +482,7 @@ subroutine da_fill_obs_structures(iv, ob) ! Calculate q error from rh error: + if (.not. present(uvq_direct) .or. (present(uvq_direct) .and. (.not. uvq_direct))) then !cys_add rh_error = iv%airsr(n)%q(k)%error ! q error is rh at this stage! call da_get_q_error(iv % airsr(n) % p(k), & ob % airsr(n) % t(k), & @@ -479,6 +493,7 @@ subroutine da_fill_obs_structures(iv, ob) iv % airsr(n) % q(k) % error = q_error if (iv%airsr(n)% q(k) % error == missing_r) & iv%airsr(n)% q(k) % qc = missing_data + end if !cys_add end do end do end if diff --git a/wrfv2_fire/var/da/da_obs/da_obs.f90 b/wrfv2_fire/var/da/da_obs/da_obs.f90 index 94fdbc7a..c7f248f6 100644 --- a/wrfv2_fire/var/da/da_obs/da_obs.f90 +++ b/wrfv2_fire/var/da/da_obs/da_obs.f90 @@ -21,7 +21,8 @@ module da_obs ob_format,ob_format_ascii,filename_len, trace_use_dull, & sound, mtgirs, synop, profiler, gpsref, gpspw, polaramv, geoamv, ships, metar, & satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, sonde_sfc, & - bogus, buoy, qscat, tamdar, pseudo, num_ob_indexes, its,ite,jds,jts,jte,ids + bogus, buoy, qscat, tamdar, pseudo, num_ob_indexes, its,ite,jds,jts,jte,ids, & + write_mod_filtered_obs !cys_add ! use_crtm_kmatrix,use_crtm_kmatrix_fast #ifdef CRTM use da_crtm, only : da_transform_xtoy_crtm, da_transform_xtoy_crtm_adj diff --git a/wrfv2_fire/var/da/da_obs/da_obs_proc_station.inc b/wrfv2_fire/var/da/da_obs/da_obs_proc_station.inc index 377484a6..32497486 100644 --- a/wrfv2_fire/var/da/da_obs/da_obs_proc_station.inc +++ b/wrfv2_fire/var/da/da_obs/da_obs_proc_station.inc @@ -1,4 +1,4 @@ -subroutine da_obs_proc_station(obs,fm) +subroutine da_obs_proc_station(obs,fm,uvq_direct) !----------------------------------------------------------------------- ! Purpose: Processing obs data read in at a station: @@ -12,6 +12,7 @@ subroutine da_obs_proc_station(obs,fm) type (multi_level_type), intent(inout) :: obs + logical,optional :: uvq_direct real :: po, to, rho, es, qs, qvo integer :: i,fm @@ -35,7 +36,7 @@ subroutine da_obs_proc_station(obs,fm) obs%each(i)%rh%qc = missing end if - if(fm.ne.161)then + if(.not. (present(uvq_direct) .and. uvq_direct) .and. fm.ne.161) then !cys_change po = obs % each(i) % p % inv to = obs % each(i) % t % inv rho = obs % each(i) % rh % inv diff --git a/wrfv2_fire/var/da/da_obs/da_use_obs_errfac.inc b/wrfv2_fire/var/da/da_obs/da_use_obs_errfac.inc index d00271c2..614bafc1 100644 --- a/wrfv2_fire/var/da/da_obs/da_use_obs_errfac.inc +++ b/wrfv2_fire/var/da/da_obs/da_use_obs_errfac.inc @@ -109,6 +109,19 @@ subroutine da_use_obs_errfac(iv) end do end if +! [2.5.1] Transfer gpsref obs: + + call da_read_errfac('gpsre', iv % gpsref_ef_ref, d1, d2, d3, d4) + + if (iv%info(gpsref)%nlocal > 0) then + do n = 1, iv%info(gpsref)%nlocal + do k = 1, iv%info(gpsref)%levels(n) + iv % gpsref(n) % ref(k) % error = iv % gpsref(n) % ref(k) % error * & + iv % gpsref_ef_ref + enddo + end do + end if + ! [2.6] Transfer sonde obs: diff --git a/wrfv2_fire/var/da/da_obs_io/da_obs_io.f90 b/wrfv2_fire/var/da/da_obs_io/da_obs_io.f90 index 1d6797a7..79fbec56 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_obs_io.f90 +++ b/wrfv2_fire/var/da/da_obs_io/da_obs_io.f90 @@ -22,11 +22,12 @@ module da_obs_io obs_names, num_ob_indexes, fm_index, ids,ide, ite, jte, & sound, mtgirs,synop, pilot, satem, geoamv, polaramv, airep, gpspw, gpsref, & tamdar, tamdar_sfc, metar, ships, ssmi_rv, ssmi_tb, ssmt1, ssmt2, qscat, profiler, buoy, bogus, pseudo, & - radar, radiance, airsr, sonde_sfc, trace_use_dull, num_fgat_time, time_slots, myproc + radar, radiance, airsr, sonde_sfc, trace_use_dull, num_fgat_time, time_slots, myproc, & + qmarker_retain, anal_type_verify use da_define_structures, only : iv_type, multi_level_type, & radar_multi_level_type, y_type, field_type, each_level_type, & - radar_each_level_type + radar_each_level_type, info_type, model_loc_type,gpsref_type use da_grid_definitions, only : da_ffdduv use da_obs, only : da_count_filtered_obs,da_check_missing,da_obs_proc_station use da_par_util1, only : da_proc_sum_int @@ -42,7 +43,7 @@ module da_obs_io use module_radiance, only : deg2rad use gsi_thinning, only : map2grids, map2grids_conv, cleangrids_conv, thinning_grid_conv use da_obs, only : da_set_obs_missing - use da_bufr, only : openbf, closbf, datelen, ufbint, readns + use da_bufr, only : openbf, closbf, datelen, ufbint, readns, ireadns, ufbseq #ifdef DM_PARALLEL use da_control, only : root ! use mpi, only : mpi_min @@ -71,9 +72,10 @@ contains #include "da_search_obs.inc" #include "da_write_obs_etkf.inc" #include "da_write_filtered_obs.inc" +#include "da_write_modified_filtered_obs.inc" #include "da_write_y.inc" #include "da_read_obs_bufr.inc" -#include "da_scan_obs_bufr.inc" +#include "da_read_obs_bufrgpsro.inc" #include "da_final_write_obs.inc" #include "da_final_write_y.inc" #include "da_read_y_unit.inc" @@ -81,5 +83,6 @@ contains #include "da_read_omb_tmp.inc" #include "da_write_noise_to_ob.inc" #include "da_final_write_filtered_obs.inc" +#include "da_final_write_modified_filtered_obs.inc" end module da_obs_io diff --git a/wrfv2_fire/var/da/da_obs_io/da_read_iv_for_multi_inc.inc b/wrfv2_fire/var/da/da_obs_io/da_read_iv_for_multi_inc.inc index 6aef052a..3f4c93df 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_read_iv_for_multi_inc.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_read_iv_for_multi_inc.inc @@ -640,6 +640,37 @@ subroutine da_read_iv_for_multi_inc(file_index, iv) close (unit_in) end if + + ! [22] radar obs: + + if (iv%info(radar)%plocal(iv%time)-iv%info(radar)%plocal(iv%time-1) > 0) then + + open(unit=unit_in,file=trim(filename)//'.radar',form='formatted',status='old',iostat=ios) + if (ios /= 0) Then + call da_error(__FILE__,__LINE__, & + (/"Cannot open file"//filename/)) + end if + + read(unit_in,'(a20,i8)', end = 999, err = 1000) ob_type_string,num_obs + if ( trim(adjustl(ob_type_string)) .ne. 'radar' ) & + call da_error(__FILE__,__LINE__, & + (/"Cannot find radar marker. "/)) + gn = 0 + do n = iv%info(radar)%plocal(iv%time-1) + 1, & + iv%info(radar)%plocal(iv%time) + call da_search_obs (ob_type_string, unit_in, num_obs, n, iv, found_flag) + if (found_flag .eqv. .false.) & + call da_error(__FILE__,__LINE__, & + (/"Cannot find radar obs. "/)) + gn = gn + 1 + end do + if (gn /= iv%info(radar)%plocal(iv%time)-iv%info(radar)%plocal(iv%time-1)) & + call da_error(__FILE__,__LINE__, & + (/"Unequal obs. found "/)) + close (unit_in) + end if + + 999 continue close (unit_in) call da_free_unit(unit_in) diff --git a/wrfv2_fire/var/da/da_obs_io/da_read_obs_ascii.inc b/wrfv2_fire/var/da/da_obs_io/da_read_obs_ascii.inc index b05acc2e..05f75b45 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_read_obs_ascii.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_read_obs_ascii.inc @@ -1,4 +1,4 @@ -subroutine da_read_obs_ascii (iv, filename) +subroutine da_read_obs_ascii (iv, filename, uvq_direct) !--------------------------------------------------------------------------- ! Purpose: Read a GTS observation file @@ -49,6 +49,7 @@ subroutine da_read_obs_ascii (iv, filename) logical :: outside logical :: outside_all + logical :: uvq_direct ![cys_add] integer :: surface_level real :: height_error, u_comp, v_comp integer :: nlocal(num_ob_indexes) @@ -126,7 +127,14 @@ subroutine da_read_obs_ascii (iv, filename) ! skip line ! ---------- - read (iunit, fmt = '(a)') fmt_name + ![cys_change] + ! read (iunit, fmt = '(a)') fmt_name + read (iunit, fmt = '(a)') info_string + if (info_string(1:21) == 'MODIFIED FILTERED OBS') then + uvq_direct=.true. + else + uvq_direct=.false. + endif ! loop over records ! ----------------- @@ -224,6 +232,16 @@ subroutine da_read_obs_ascii (iv, filename) platform%each(i)%td%inv, platform%each(i)%td%qc, platform%each(i)%td%error, & platform%each(i)%rh%inv, platform%each(i)%rh%qc, platform%each(i)%rh%error +! cys_add + if (uvq_direct) then + platform%each (i)%u = platform%each (i)%speed + if (platform%each(i)%rh%inv .gt. missing_r) & + platform%each(i)%rh%inv=platform%each(i)%rh%inv / 1e3 !convert back to kg/kg + if (platform%each(i)%rh%error .gt. 0.0) & + platform%each(i)%rh%error=platform%each(i)%rh%error / 1e3 !convert back to kg/kg + end if +! cys_add + if (print_detail_obs) then write(unit=stdout, fmt = '(a, i6)') 'i=', i ! because now the field_type included: inv, qc, error, sens, and imp (YRG, 02/23/2009): @@ -248,6 +266,7 @@ subroutine da_read_obs_ascii (iv, filename) ! To convert the wind speed and direction to ! the model wind components: u, v + if (.not. uvq_direct) then !cys_add if (platform%each (i)%speed%qc /= missing_data .and. & platform%each (i)%v%qc /= missing_data) then call da_ffdduv (platform%each (i)%speed%inv, platform%each (i)%v%inv, & @@ -264,6 +283,7 @@ subroutine da_read_obs_ascii (iv, filename) platform%each (i)%u%qc = missing_data platform%each (i)%v%qc = missing_data end if + end if !cys_add end do ! Check if outside of the time range: @@ -346,7 +366,7 @@ subroutine da_read_obs_ascii (iv, filename) end if end if - if (fm /= 86) call da_obs_proc_station(platform,fm) + if (fm /= 86) call da_obs_proc_station(platform,fm,uvq_direct) !cys_change nlevels = platform%info%levels ! Loop over duplicating obs for global diff --git a/wrfv2_fire/var/da/da_obs_io/da_read_obs_bufr.inc b/wrfv2_fire/var/da/da_obs_io/da_read_obs_bufr.inc index d5be583f..5c7ed9a0 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_read_obs_bufr.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_read_obs_bufr.inc @@ -1,81 +1,162 @@ -subroutine da_read_obs_bufr (iv, filename) +subroutine da_read_obs_bufr (iv) !--------------------------------------------------------------------------- ! Purpose: Read BUFR observation file for input to wrfvar !--------------------------------------------------------------------------- - + ! METHOD: use F90 sequantial data structure to avoid read file twice + ! so that da_scan_obs_bufr is not necessary any more. + ! 1. read file radiance data in sequential data structure + ! 2. do gross QC check + ! 3. assign sequential data structure to innovation structure + ! and deallocate sequential data structure + ! + ! HISTORY: 2009/10/13 - F90 sequantial structure Peng Xiu + ! + !---------------------------------------------------------------------------- + + use da_define_structures, only: da_allocate_observations + implicit none type (iv_type), intent(inout) :: iv - character(len=*), optional, intent(in) :: filename - + + #ifdef BUFR - - real, parameter :: r8bfms = 9.0D08 ! BUFR missing value threshold + character(len=10) :: filename + real, parameter :: r8bfms = 9.0D08 ! BUFR missing value threshold logical :: match, end_of_file character(len=8) :: subst2, csid, csid2 - integer :: idate2, nlevels2, lv1, lv2 - real :: hdr2(7), hdr_save(7), r8sid, r8sid2 - real :: pob1, pob2 - real :: temp(8,255) - real :: obs2(8,255), qms2(8,255) - real :: oes2(8,255), pco2(8,255) - real :: pmo2(2,1), pmo_save(2,1) + integer :: idate2, nlevels2, lv1, lv2 + real :: hdr2(7), hdr_save(7), r8sid, r8sid2 + real :: pob1, pob2 + real :: temp(8,255) + real :: obs2(8,255), qms2(8,255),obs_save(8,255) + real :: oes2(8,255), pco2(8,255) + real :: pmo2(2,1), pmo_save(2,1) equivalence (r8sid, csid), (r8sid2, csid2) ! for thinning - real :: tdiff ! DHR - real :: dlat_earth,dlon_earth,crit - integer :: itt,itx + real :: tdiff ! DHR + real :: dlat_earth,dlon_earth,crit + integer :: itt,itx,iout logical :: iuse - + type (multi_level_type) :: platform logical :: outside, outside_all, outside_time - integer :: nlocal(num_ob_indexes), ilocal(num_ob_indexes) - integer :: ntotal(num_ob_indexes) - - character(len=40) :: obstr,hdstr,qmstr,oestr, pcstr - character(len=8) :: subset - character(len=14) :: cdate, dmn, obs_date - real :: hdr(7) - real :: pmo(2,1) - real :: obs(8,255),qms(8,255),oes(8,255),pco(8,255) - real :: obs_time,woe,toe,qoe,poe,pob - integer :: iyear, imonth, iday, ihour, imin - - integer :: iost, ndup, n, i, j, k, surface_level, num_report, i1, i2 - integer :: iret, idate, kx, old_nlevels,nlevels, t29 - integer :: cat,zqm,pqm,qqm,tqm,wqm,pwq,pmq - integer :: tpc, wpc - integer :: iunit, fm , obs_index - - integer, parameter :: qflag=4 ! Flag for retaining data - - real, allocatable :: in(:), out(:) - logical :: found - - logical :: use_errtable - integer :: junit, itype, ivar - real :: oetab(300,33,6) ! 300 ob types, 33 levels (rows), 6 variables (columns) - real :: err_uv, err_t, err_p, err_q, err_pw, coef - integer :: num_outside_all, num_outside_time, num_thinned + integer :: ilocal(num_ob_indexes) + integer :: ntotal(num_ob_indexes) + integer :: nlocal(num_ob_indexes) + integer :: tp(num_ob_indexes) + character(len=40) :: obstr,hdstr,qmstr,oestr, pcstr + character(len=8) :: subset + character(len=14) :: cdate, dmn, obs_date,platform_name + real :: hdr(7) + real :: pmo(2,1) + real :: obs(8,255),qms(8,255),oes(8,255),pco(8,255) + real :: obs_time,woe,toe,qoe,poe,pob,pwe + integer :: iyear, imonth, iday, ihour, imin + + integer :: iost, ndup, n, i, j, k, kk,surface_level, num_report, i1, i2 + integer :: iret, idate, kx, old_nlevels,nlevels, t29,ifgat,ii + integer :: cat,zqm,pqm,qqm,tqm,wqm,pwq,pmq + integer :: tpc, wpc,iret2 + integer :: iunit, fm , obs_index + + integer :: qflag ! Flag for retaining data + + real, allocatable :: in(:), out(:) + integer :: num_bufr(7) + logical :: found + + logical :: use_errtable + integer :: junit, itype, ivar + real :: oetab(300,33,6) ! 300 ob types, 33 levels (rows), 6 variables (columns) + real :: err_uv, err_t, err_p, err_q, err_pw, coef + integer :: ibufr + integer :: num_outside_all, num_outside_time, num_thinned,num_p,numbufr + + type datalink_BUFR !for PREPBUFR data reading + type (multi_level_type) :: platform_BUFR + integer :: fm_BUFR + integer :: t29_BUFR + integer :: ifgat_BUFR + integer :: nlevels_BUFR + integer :: kx_BUFR + real :: pco_BUFR(8,255) + type(datalink_BUFR), pointer :: next + end type datalink_BUFR + + type(datalink_BUFR),pointer :: head,plink + if (trace_use) call da_trace_entry("da_read_obs_bufr") +! 0.0 Initialize variables +!-------------------------------------------------------------- ilocal(:) = 0 - nlocal(:) = 0 ntotal(:) = 0 - + nlocal(:) = 0 + err_uv = 10.0 ! m/s err_t = 5.0 ! degree err_p = 200 ! Pa err_q = 10 ! RH percent err_pw = 0.2 ! cm - ! open file - ! --------- + ! quality marker 0: Keep (always assimilate) + ! 1: Good + ! 2: Neutral or not checked + ! 3: Suspect + if ( anal_type_verify ) then + qflag = min(qmarker_retain,2) + else + qflag = qmarker_retain + end if + write(unit=message(1),fmt='(a,i1,a)') & + "PREPBUFR ob with quality marker <= ", qflag, " will be retained." + call da_message(message(1:1)) + + num_report = 0 + num_outside_all = 0 + num_outside_time = 0 + num_thinned = 0 + num_p = 0 + tp(:) = 0 + + +! 1.0 Open file +!---------------------------------------------------------------- +! +!check if input file exist +num_bufr(:)=0 +numbufr=0 +if (num_fgat_time>1) then + call da_get_unit(iunit) + do i=1,7 + write(filename,fmt='(A,I1,A)') 'ob0',i,'.bufr' + open(unit = iunit, FILE = trim(filename),iostat = iost, form = 'unformatted', STATUS = 'OLD') + if (iost == 0) then + numbufr=numbufr+1 + num_bufr(numbufr)=i + end if + end do + else + numbufr=1 + end if + + if (numbufr==0) numbufr=1 + +bufrfile: do ibufr=1,numbufr + if (num_fgat_time==1) then + filename='ob.bufr' + else + if ((numbufr ==1) .and. (num_bufr(ibufr) == 0)) then + filename='ob.bufr' + else + write(filename,fmt='(A,I1,A)') 'ob0',num_bufr(ibufr),'.bufr' + end if + end if +! call da_get_unit(iunit) - if (present(filename)) then - call closbf(iunit) open(unit = iunit, FILE = trim(filename), & iostat = iost, form = 'unformatted', STATUS = 'OLD') if (iost /= 0) then @@ -83,11 +164,8 @@ subroutine da_read_obs_bufr (iv, filename) "Error",iost," opening PREPBUFR obs file "//trim(filename) call da_warning(__FILE__,__LINE__,message(1:1)) call da_free_unit(iunit) - if (trace_use) call da_trace_exit("da_read_obs_bufr") - return + cycle bufrfile end if - end if - ! open observation error table if provided. call da_get_unit(junit) open (unit=junit, file='obs_errtable', form='formatted', status='old', & @@ -118,7 +196,6 @@ subroutine da_read_obs_bufr (iv, filename) oestr='POE QOE TOE NUL WOE NUL PWE NUL' ! observation error pcstr='PPC QPC TPC ZPC WPC NUL PWP NUL' ! program code - ! read bufr observation file call openbf(iunit,'IN',iunit) call datelen(10) @@ -134,16 +211,23 @@ subroutine da_read_obs_bufr (iv, filename) end if !rewind(iunit) - num_report = 0 - num_outside_all = 0 - num_outside_time = 0 - num_thinned = 0 + write(unit=message(1),fmt='(a,i10)') 'BUFR file date is: ', idate + call da_message(message(1:1)) + +! 2.0 read data +! scan reports first +!-------------------------------------------------------------- + if (ibufr ==1) then + allocate(head) + nullify(head%next) + plink => head + end if + match = .false. end_of_file = .false. outside_all = .false. outside_time = .false. - reports: do while ( .not. end_of_file ) if ( match .or. outside_all .or. outside_time ) then @@ -159,7 +243,7 @@ subroutine da_read_obs_bufr (iv, filename) num_report = num_report+1 - call ufbint(iunit,hdr,7,1,iret,hdstr) + call ufbint(iunit,hdr,7,1,iret2,hdstr) call ufbint(iunit,pmo,2,1,nlevels,'PMO PMQ') call ufbint(iunit,qms,8,255,nlevels,qmstr) call ufbint(iunit,oes,8,255,nlevels,oestr) @@ -195,7 +279,7 @@ subroutine da_read_obs_bufr (iv, filename) if (outside_all) then num_outside_all = num_outside_all + 1 if ( print_detail_obs ) then - write(unit=stdout,fmt='(a,1x,a,2(1x,f8.3),a)') & + write(unit=stderr,fmt='(a,1x,a,2(1x,f8.3),a)') & platform%info%name(1:8),platform%info%id(1:5), & platform%info%lat, platform%info%lon, ' -> outside_domain' end if @@ -218,7 +302,7 @@ subroutine da_read_obs_bufr (iv, filename) outside_time = .true. num_outside_time = num_outside_time + 1 if ( print_detail_obs ) then - write(unit=stdout,fmt='(a,1x,a,1x,a,a)') & + write(unit=stderr,fmt='(a,1x,a,1x,a,a)') & platform%info%name(1:8),platform%info%id(1:5), & trim(obs_date), ' -> outside_time' end if @@ -226,7 +310,14 @@ subroutine da_read_obs_bufr (iv, filename) else outside_time = .false. end if - + +!-------- determine FGAT index ifgat + + do ifgat=1,num_fgat_time + if (obs_time >= time_slots(ifgat-1) .and. & + obs_time < time_slots(ifgat)) exit + end do + write(unit=platform%info%date_char, fmt='(i4,a,i2.2,a,i2.2,a,i2.2,a,i2.2,a,i2.2)') & iyear, '-', imonth, '-', iday, '_', ihour, ':', imin, ':', 0 @@ -265,7 +356,7 @@ subroutine da_read_obs_bufr (iv, filename) end_of_file = .true. else match_check: do - call ufbint(iunit,hdr2,7,1,iret,hdstr) + call ufbint(iunit,hdr2,7,1,iret2,hdstr) ! check if this subset and the previous one are matching mass and wind match = .true. if ( subset /= subst2 ) then @@ -412,8 +503,8 @@ subroutine da_read_obs_bufr (iv, filename) ! 61: Satellite soundings/retrievals/radiances ! 66: SSM/I rain rate product ! 72: NEXTRAD VAD winds - if ( t29 == 61 .or. t29 == 66 .or. t29 == 72 ) cycle reports - + if ( t29 == 61 .or. t29 == 66 .or. t29 == 72 ) cycle reports + platform % info % levels = nlevels platform % loc % slp %inv = missing_r @@ -422,7 +513,22 @@ subroutine da_read_obs_bufr (iv, filename) platform % loc % pw %inv = missing_r platform % loc % pw %qc = missing_data platform % loc % pw %error = err_pw + pmq=nint(pmo(2,1)) + if (pmq <= qflag .and. pmq >= 0) then + platform % loc % slp % inv =pmo(1,1)*100.0 + platform % loc % slp % qc =pmq + platform % loc % slp % error = err_p ! hardwired + end if + pwq=nint(qms(7,1)) + pwe = min(err_pw, oes(7,1)) + if (pwq <= qflag .and. pwq >= 0) then + platform % loc % pw % inv = obs(7,1) * 0.1 ! convert to cm + platform % loc % pw % qc = pwq + platform % loc % pw % error = pwe ! hardwired + end if + !$OMP PARALLEL DO & + !$OMP PRIVATE (i) do i=1,max_ob_levels platform % each (i) % height = missing_r platform % each (i) % height_qc = missing_data @@ -447,7 +553,10 @@ subroutine da_read_obs_bufr (iv, filename) platform % each (i) % q % qc = missing_data platform % each (i) % q % error = err_q end do + !$OMP END PARALLEL DO + !!$OMP PARALLEL DO & + !!$OMP PRIVATE (k, tpc, wpc, pqm, qqm, tqm, wqm, zqm, cat, toe, poe, qoe, woe) do k = 1, platform % info % levels tpc = nint(pco(3,k)) @@ -473,32 +582,20 @@ subroutine da_read_obs_bufr (iv, filename) tqm=nint(qms(3,k)) zqm=nint(qms(4,k)) wqm=nint(qms(5,k)) - pwq=nint(qms(7,k)) - pmq=nint(pmo(2,1)) cat=nint(obs(8,k)) - if (pmq < qflag .and. pmq >= 0) then - platform % loc % slp % inv =pmo(1,1)*100.0 - platform % loc % slp % qc =pmq - platform % loc % slp % error = err_p ! hardwired - end if - - if (pwq < qflag .and. pwq >= 0) then - platform % loc % pw % inv = obs(7,k) * 0.1 ! convert to cm - platform % loc % pw % qc = pwq - platform % loc % pw % error = err_pw ! hardwired - end if - + toe = min(err_t, oes(3,k)) + woe = min(err_uv, oes(5,k)) + qoe = min(err_q, oes(2,k)*10.0) ! convert to % from PREPBUFR percent divided by 10 + poe = min(err_p, oes(1,k)*100.0) ! convert to Pa - if (tqm < qflag .and. tqm >= 0) then - toe = min(err_t, oes(3,k)) + if (tqm <= qflag .and. tqm >= 0) then platform % each (k) % t % inv =obs(3,k) platform % each (k) % t % qc =tqm platform % each (k) % t % error =toe end if - if (wqm < qflag .and. wqm >= 0) then - woe = min(err_uv, oes(5,k)) + if (wqm <= qflag .and. wqm >= 0) then platform % each (k) % u % inv =obs(5,k) platform % each (k) % v % inv =obs(6,k) platform % each (k) % u % qc =wqm @@ -524,61 +621,83 @@ subroutine da_read_obs_bufr (iv, filename) end if end if - if (qqm=0 .and. obs(2,k)>0.0 .and. obs(2,k)=0 .and. obs(2,k)>0.0 .and. obs(2,k)= 300.0 ) then ! do not use mositure above 300 hPa + platform % each (k) % q % qc =qqm + end if + platform % each (k) % q % error = qoe end if - if (zqm < qflag .and. zqm >= 0)then + if (zqm <= qflag .and. zqm >= 0)then platform % each (k) % height = obs(4,k) platform % each (k) % height_qc =zqm end if - if (pqm < qflag .and. pqm >= 0)then - poe = min(err_p, oes(1,k)*100.0) + if (pqm <= qflag .and. pqm >= 0)then platform % each (k) % p % inv =obs(1,k)*100.0 ! convert to Pa platform % each (k) % p % qc =pqm platform % each (k) % p % error =poe end if end do - - if ( .not. use_errtable ) then - ! assign u,v,t,q obs errors for synop and metar - if ( t29 == 512 .or. t29 == 511 .or. t29 == 514 ) then - if ( wqm == 8 .or. wqm == 9 .or. wqm == 15) then - platform%each(1)%u%qc = 88 - platform%each(1)%v%qc = 88 + !!$OMP END PARALLEL DO + + ! assign u,v,t,q obs errors for synop and metar + if ( t29 == 512 .or. t29 == 511 .or. t29 == 514 ) then + qqm=nint(qms(2,1)) + tqm=nint(qms(3,1)) + wqm=nint(qms(5,1)) + toe = min(err_t, oes(3,1)) + woe = min(err_uv, oes(5,1)) + qoe = min(err_q, oes(2,1)*10.0) ! convert to % from PREPBUFR percent divided by 10 + if ( wqm == 8 .or. wqm == 9 .or. wqm == 15) then + platform%each(1)%u%qc = 88 + platform%each(1)%v%qc = 88 + if ( use_errtable ) then + platform%each(1)%u%error = woe + platform%each(1)%v%error = woe + else platform%each(1)%u%error = 1.1 platform%each(1)%v%error = 1.1 - ! Convert earth wind to model wind. - call da_earth_2_model_wind(obs(5,1), obs(6,1), & - platform%each(1)%u%inv, platform%each(1)%v%inv, & - platform%info%lon) - if ( platform%each(1)%u%inv == 0.0 .and. platform%each(1)%v%inv == 0.0 ) then - platform%each(1)%u%inv = missing_r - platform%each(1)%v%inv = missing_r - platform%each(1)%u%qc = missing_data - platform%each(1)%v%qc = missing_data - end if end if - if ( tqm == 8 .or. tqm == 9 .or. tqm == 15 ) then - platform%each(1)%t%inv = obs(3,1) - platform%each(1)%t%qc = 88 + ! Convert earth wind to model wind. + call da_earth_2_model_wind(obs(5,1), obs(6,1), & + platform%each(1)%u%inv, platform%each(1)%v%inv, & + platform%info%lon) + if ( platform%each(1)%u%inv == 0.0 .and. platform%each(1)%v%inv == 0.0 ) then + platform%each(1)%u%inv = missing_r + platform%each(1)%v%inv = missing_r + platform%each(1)%u%qc = missing_data + platform%each(1)%v%qc = missing_data + end if + end if + if ( tqm == 8 .or. tqm == 9 .or. tqm == 15 ) then + platform%each(1)%t%inv = obs(3,1) + platform%each(1)%t%qc = 88 + if ( use_errtable ) then + platform%each(1)%t%error = toe + else platform%each(1)%t%error = 2.0 end if - if ( qqm == 8 .or. qqm == 9 .or. qqm == 15 ) then - platform%each(1)%q%inv = obs(2,1) - platform%each(1)%q%qc = 88 + end if + if ( qqm == 8 .or. qqm == 9 .or. qqm == 15 ) then + platform%each(1)%q%inv = obs(2,1) + platform%each(1)%q%qc = 88 + if ( use_errtable ) then + platform%each(1)%q%error = qoe ! RH percent + else platform%each(1)%q%error = 10 ! RH percent end if end if - ! assign tpw obs errors for gpspw - if ( t29 == 74 ) then - if ( pwq == 8 .or. pwq == 9 .or. pwq == 15) then - platform%loc%pw%inv = obs(7,1) * 0.1 ! convert to cm - platform%loc%pw%qc = 88 + end if + ! assign tpw obs errors for gpspw + if ( t29 == 74 ) then + if ( pwq == 8 .or. pwq == 9 .or. pwq == 15) then + platform%loc%pw%inv = obs(7,1) * 0.1 ! convert to cm + platform%loc%pw%qc = 88 + if ( use_errtable ) then + platform%loc%pw%error = pwe + else platform%loc%pw%error = 0.2 ! hardwired to 0.2 cm end if end if @@ -618,7 +737,25 @@ subroutine da_read_obs_bufr (iv, filename) cycle reports end if end if - ! for thinning + + if (num_fgat_time > 1 ) then !for 4dvar + + !--------------- + plink%platform_BUFR=platform + plink%ifgat_BUFR=ifgat + plink%fm_BUFR=0 + plink%nlevels_BUFR=nlevels + plink%kx_BUFR=kx + plink%t29_BUFR=t29 + plink%pco_BUFR=pco + + num_p=num_p+1 + allocate(plink%next) + plink => plink%next + nullify(plink%next) + + else !3dvar + tdiff = abs(platform%info%dhr-0.1) dlat_earth = platform%info%lat dlon_earth = platform%info%lon @@ -626,545 +763,1251 @@ subroutine da_read_obs_bufr (iv, filename) if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 dlat_earth = dlat_earth * deg2rad dlon_earth = dlon_earth * deg2rad - - !--------------------------------------------------------------------------- - ! This is basically converting rh to q i - ! Method : - ! if rh, temp and pr all available computes Qs otherwise sets Qs= missing - ! if rh > 100 sets q = qs otherwise q = rh*Qs/100.0 - ! Note: Currently da_obs_proc_station is active only for ob_format_ascii - ! call da_obs_proc_station(platform) - !--------------------------------------------------------------------------- - - ! Loop over duplicating obs for global ndup = 1 if (global .and. & (platform%loc%i < ids .or. platform%loc%i >= ide)) ndup= 2 + if (test_transforms) ndup = 1 ! It is possible that logic for counting obs is incorrect for the ! global case with >1 MPI tasks due to obs duplication, halo, etc. ! TBH: 20050913 - if (.not.outside) then - if (print_detail_obs .and. ndup > 1) then - write(unit=stdout, fmt = '(A12,1X,A19,1X,A40,1X,I6,3(F12.3,11X),6X,A5)') & - platform%info%platform, & - platform%info%date_char, & - platform%info%name, & - platform%info%levels, & - platform%info%lat, & - platform%info%lon, & - platform%info%elv, & - platform%info%id - - write(unit=stdout, fmt = '(a,2i5,4e20.10)') & - ' duplicating obs since loc% i,j,dx,dxm,dy & dym ', & - platform%loc%i, platform%loc%j, & - platform%loc%dx, platform%loc%dxm, & - platform%loc%dy, platform%loc%dym - end if - end if dup_loop: do n = 1, ndup select case(t29) case (11, 12, 13, 22, 23, 31) select case (kx) case (120, 122, 132, 220, 222, 232) ; ! Sound if (.not.use_soundobs) cycle reports - if( n==1 ) ntotal(sound) = ntotal(sound) + 1 - if( n==1 ) ntotal(sonde_sfc) = ntotal(sonde_sfc) + 1 - if (outside) then - cycle reports - end if - + if (n==1) iv%info(sound)%ntotal = iv%info(sound)%ntotal + 1 + if (n==1) iv%info(sonde_sfc)%ntotal = iv%info(sonde_sfc)%ntotal + 1 + + if (outside) cycle reports if ( thin_conv ) then crit = tdiff - call map2grids_conv(sound,dlat_earth,dlon_earth,crit,nlocal(sound),itx,1,itt,ilocal(sound),iuse) - call map2grids_conv(sonde_sfc,dlat_earth,dlon_earth,crit,nlocal(sonde_sfc),itx,1,itt,ilocal(sonde_sfc),iuse) + call map2grids_conv(sound,dlat_earth,dlon_earth,crit,iv%info(sound)%nlocal,itx,1,itt,iout,iuse) + call map2grids_conv(sonde_sfc,dlat_earth,dlon_earth,crit,iv%info(sonde_sfc)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then num_thinned = num_thinned + 1 cycle reports end if else - nlocal(sound) = nlocal(sound) + 1 - nlocal(sonde_sfc) = nlocal(sound) - ilocal(sound) = nlocal(sound) - ilocal(sonde_sfc) = ilocal(sound) + iv%info(sound)%nlocal = iv%info(sound)%nlocal + 1 + iv%info(sonde_sfc)%nlocal = iv%info(sound)%nlocal end if - - platform % info % platform ='FM-35 TEMP ' - if (nlocal(sound) > iv%info(sound)%nlocal) cycle reports fm = 35 - old_nlevels = nlevels - - ! Search to see if we have surface obs. - - surface_level = 0 - - do i = 1, nlevels - ! if (elevation and height are the same, it is surface) - if (abs(platform%info%elv - & - platform%each(i)%height) < 0.1) then - surface_level = i - - ! Save surface pressure. - iv%sonde_sfc(ilocal(sonde_sfc))%h = platform%each(i)%height - iv%sonde_sfc(ilocal(sonde_sfc))%u = platform%each(i)%u - iv%sonde_sfc(ilocal(sonde_sfc))%v = platform%each(i)%v - iv%sonde_sfc(ilocal(sonde_sfc))%t = platform%each(i)%t - iv%sonde_sfc(ilocal(sonde_sfc))%q = platform%each(i)%q - iv%sonde_sfc(ilocal(sonde_sfc))%p = platform%each(i)%p - exit - end if - end do - - ! processing the sound_sfc data: - - if (surface_level > 0) then - nlevels = nlevels - 1 - else - iv%sonde_sfc(ilocal(sonde_sfc))%h = missing_r - iv%sonde_sfc(ilocal(sonde_sfc))%u%inv = missing_r - iv%sonde_sfc(ilocal(sonde_sfc))%u%qc = missing_data - iv%sonde_sfc(ilocal(sonde_sfc))%u%error = abs(missing_r) - iv%sonde_sfc(ilocal(sonde_sfc))%v = iv%sonde_sfc(ilocal(sonde_sfc))%u - iv%sonde_sfc(ilocal(sonde_sfc))%t = iv%sonde_sfc(ilocal(sonde_sfc))%u - iv%sonde_sfc(ilocal(sonde_sfc))%p = iv%sonde_sfc(ilocal(sonde_sfc))%u - iv%sonde_sfc(ilocal(sonde_sfc))%q = iv%sonde_sfc(ilocal(sonde_sfc))%u - end if - - if (nlevels > 0) then - - if ( ilocal(sound) == nlocal(sound) ) then - allocate (iv%sound(ilocal(sound))%h(1:iv%info(sound)%max_lev)) - allocate (iv%sound(ilocal(sound))%p(1:iv%info(sound)%max_lev)) - allocate (iv%sound(ilocal(sound))%u(1:iv%info(sound)%max_lev)) - allocate (iv%sound(ilocal(sound))%v(1:iv%info(sound)%max_lev)) - allocate (iv%sound(ilocal(sound))%t(1:iv%info(sound)%max_lev)) - allocate (iv%sound(ilocal(sound))%q(1:iv%info(sound)%max_lev)) - end if - - j = 0 - do i = 1, old_nlevels - if (i == surface_level) cycle - j=j+1 - iv%sound(ilocal(sound))%h(j) = platform%each(i)%height - iv%sound(ilocal(sound))%p(j) = platform%each(i)%p%inv - iv%sound(ilocal(sound))%u(j) = platform%each(i)%u - iv%sound(ilocal(sound))%v(j) = platform%each(i)%v - iv%sound(ilocal(sound))%t(j) = platform%each(i)%t - iv%sound(ilocal(sound))%q(j) = platform%each(i)%q - end do - end if - - case (221) ; ! Pilot + + case (221) ; ! Pilot if (.not.use_pilotobs) cycle reports - if( n==1 ) ntotal(pilot) = ntotal(pilot) + 1 - if (outside) then - cycle reports - end if - + if (n==1) iv%info(pilot)%ntotal = iv%info(pilot)%ntotal + 1 + if (outside) cycle reports if ( thin_conv ) then crit = tdiff - call map2grids_conv(pilot,dlat_earth,dlon_earth,crit,nlocal(pilot),itx,1,itt,ilocal(pilot),iuse) + call map2grids_conv(pilot,dlat_earth,dlon_earth,crit,iv%info(pilot)%nlocal,itx,1,itt,iout,iuse) if ( .not. iuse ) then num_thinned = num_thinned + 1 cycle reports end if else - nlocal(pilot) = nlocal(pilot) + 1 - ilocal(pilot) = nlocal(pilot) + iv%info(pilot)%nlocal = iv%info(pilot)%nlocal + 1 end if - - platform % info % platform ='FM-32 PILOT ' - if (nlocal(pilot) > iv%info(pilot)%nlocal) cycle reports fm = 32 - - if ( ilocal(pilot) == nlocal(pilot) ) then - allocate (iv%pilot(ilocal(pilot))%h(1:iv%info(pilot)%max_lev)) - allocate (iv%pilot(ilocal(pilot))%p(1:iv%info(pilot)%max_lev)) - allocate (iv%pilot(ilocal(pilot))%u(1:iv%info(pilot)%max_lev)) - allocate (iv%pilot(ilocal(pilot))%v(1:iv%info(pilot)%max_lev)) - end if - - do i = 1, nlevels - iv%pilot(ilocal(pilot))%h(i) = platform%each(i)%height - iv%pilot(ilocal(pilot))%p(i) = platform%each(i)%p%inv - iv%pilot(ilocal(pilot))%u(i) = platform%each(i)%u - iv%pilot(ilocal(pilot))%v(i) = platform%each(i)%v - end do + case default exit dup_loop end select case (41) ! case (130:131, 133, 230:231, 233) ; ! Airep - if (.not.use_airepobs) cycle reports - if( n==1 ) ntotal(airep) = ntotal(airep) + 1 - if (outside) then - cycle reports - end if - - if ( thin_conv ) then - crit = tdiff - call map2grids_conv(airep,dlat_earth,dlon_earth,crit,nlocal(airep),itx,1,itt,ilocal(airep),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + if (.not.use_airepobs) cycle reports + if (n==1) iv%info(airep)%ntotal = iv%info(airep)%ntotal + 1 + if (outside) cycle reports + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(airep,dlat_earth,dlon_earth,crit,iv%info(airep)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(airep)%nlocal = iv%info(airep)%nlocal + 1 end if - else - nlocal(airep) = nlocal(airep) + 1 - ilocal(airep) = nlocal(airep) - end if - - platform % info % platform ='FM-97 AIREP ' - if (nlocal(airep) > iv%info(airep)%nlocal) cycle reports - fm = 42 - - if ( ilocal(airep) == nlocal(airep) ) then - allocate (iv%airep(ilocal(airep))%h(1:iv%info(airep)%max_lev)) - allocate (iv%airep(ilocal(airep))%p(1:iv%info(airep)%max_lev)) - allocate (iv%airep(ilocal(airep))%u(1:iv%info(airep)%max_lev)) - allocate (iv%airep(ilocal(airep))%v(1:iv%info(airep)%max_lev)) - allocate (iv%airep(ilocal(airep))%t(1:iv%info(airep)%max_lev)) - end if - - do i = 1, nlevels - iv % airep (ilocal(airep)) % h(i) = platform % each(i) % height - iv % airep (ilocal(airep)) % p(i) = platform % each(i) % p % inv - iv % airep (ilocal(airep)) % u(i) = platform % each(i) % u - iv % airep (ilocal(airep)) % v(i) = platform % each(i) % v - iv % airep (ilocal(airep)) % t(i) = platform % each(i) % t - end do - + fm = 42 + case (522, 523); ! Ships - if (.not.use_shipsobs) cycle reports - if( n==1 ) ntotal(ships) = ntotal(ships) + 1 - if (outside) then - cycle reports - end if - - if ( thin_conv ) then - crit = tdiff - call map2grids_conv(ships,dlat_earth,dlon_earth,crit,nlocal(ships),itx,1,itt,ilocal(ships),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + if (.not.use_shipsobs) cycle reports + if (n==1) iv%info(ships)%ntotal = iv%info(ships)%ntotal + 1 + if (outside) cycle reports + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(ships,dlat_earth,dlon_earth,crit,iv%info(ships)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(ships)%nlocal = iv%info(ships)%nlocal + 1 end if - else - nlocal(ships) = nlocal(ships) + 1 - ilocal(ships) = nlocal(ships) - end if - - platform % info % platform ='FM-13 SHIP ' - if (nlocal(ships) > iv%info(ships)%nlocal) cycle reports - fm = 13 - iv % ships (ilocal(ships)) % h = platform % each(1) % height - iv % ships (ilocal(ships)) % u = platform % each(1) % u - iv % ships (ilocal(ships)) % v = platform % each(1) % v - iv % ships (ilocal(ships)) % t = platform % each(1) % t - iv % ships (ilocal(ships)) % p = platform % each(1) % p - iv % ships (ilocal(ships)) % q = platform % each(1) % q - + fm = 13 + case (531, 532, 561, 562) ; ! Buoy - if (.not.use_buoyobs) cycle reports - if( n==1 ) ntotal(buoy) = ntotal(buoy) + 1 - if (outside) then - cycle reports - end if - - if ( thin_conv ) then - crit = tdiff - call map2grids_conv(buoy,dlat_earth,dlon_earth,crit,nlocal(buoy),itx,1,itt,ilocal(buoy),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + if (.not.use_buoyobs) cycle reports + if (n==1) iv%info(buoy)%ntotal = iv%info(buoy)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(buoy,dlat_earth,dlon_earth,crit,iv%info(buoy)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(buoy)%nlocal = iv%info(buoy)%nlocal + 1 end if - else - nlocal(buoy) = nlocal(buoy) + 1 - ilocal(buoy) = nlocal(buoy) - end if - - platform % info % platform ='FM-18 BUOY ' - if (nlocal(buoy) > iv%info(buoy)%nlocal) cycle reports - fm = 18 - - iv%buoy(ilocal(buoy))%h = platform%each(1)%height - iv%buoy(ilocal(buoy))%u = platform%each(1)%u - iv%buoy(ilocal(buoy))%v = platform%each(1)%v - iv%buoy(ilocal(buoy))%t = platform%each(1)%t - if ( kx == 282 ) then ! ATLAS BUOY, reported Pstn and Pmslp are both - ! missing. Pstn is set to 1013hPa in PREPBUFR - iv%buoy(ilocal(buoy))%p%inv = missing_r - iv%buoy(ilocal(buoy))%p%qc = missing_data - iv%buoy(ilocal(buoy))%p%error = err_p - else - iv%buoy(ilocal(buoy))%p = platform%each(1)%p - end if - iv%buoy(ilocal(buoy))%q = platform%each(1)%q - + fm = 18 + case (511, 514) - if (.not.use_synopobs) cycle reports ! case (181, 281) ; ! Synop - - if( n==1 ) ntotal(synop) = ntotal(synop) + 1 - if (outside) then - cycle reports - end if - - if ( thin_conv ) then - crit = tdiff - call map2grids_conv(synop,dlat_earth,dlon_earth,crit,nlocal(synop),itx,1,itt,ilocal(synop),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + if (.not.use_synopobs) cycle reports + + if (n==1) iv%info(synop)%ntotal = iv%info(synop)%ntotal + 1 + if (outside) cycle reports + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(synop,dlat_earth,dlon_earth,crit,iv%info(synop)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(synop)%nlocal = iv%info(synop)%nlocal + 1 end if - else - nlocal(synop) = nlocal(synop) + 1 - ilocal(synop) = nlocal(synop) - end if - - platform % info % platform ='FM-12 SYNOP ' - if (nlocal(synop) > iv%info(synop)%nlocal) cycle reports - fm = 12 - iv % synop (ilocal(synop)) % h = platform % each(1) % height - iv % synop (ilocal(synop)) % u = platform % each(1) % u - iv % synop (ilocal(synop)) % v = platform % each(1) % v - iv % synop (ilocal(synop)) % t = platform % each(1) % t - iv % synop (ilocal(synop)) % p = platform % each(1) % p - iv % synop (ilocal(synop)) % q = platform % each(1) % q - - if (iv % synop(ilocal(synop)) % h < platform % info % elv) then - iv % synop(ilocal(synop)) % h = platform % info % elv - end if - + fm = 12 + case (512) - if (.not.use_metarobs) cycle reports ! case (187, 287) ; ! Metar - if( n==1 ) ntotal(metar) = ntotal(metar) + 1 - if (outside) then - cycle reports - end if - - if ( thin_conv ) then - crit = tdiff - call map2grids_conv(metar,dlat_earth,dlon_earth,crit,nlocal(metar),itx,1,itt,ilocal(metar),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + if (.not.use_metarobs) cycle reports + + if (n==1) iv%info(metar)%ntotal = iv%info(metar)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(metar,dlat_earth,dlon_earth,crit,iv%info(metar)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(metar)%nlocal = iv%info(metar)%nlocal + 1 end if + fm = 15 + + case (63) + ! case (242:246, 252:253, 255) ; ! Geo. CMVs + if (.not.use_geoamvobs) cycle reports + + if (n==1) iv%info(geoamv)%ntotal = iv%info(geoamv)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(geoamv,dlat_earth,dlon_earth,crit,iv%info(geoamv)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(geoamv)%nlocal = iv%info(geoamv)%nlocal + 1 + end if + fm = 88 + + case (582, 583) ! QuikSCAT 582 and WindSat 583 + if (.not.use_qscatobs) cycle reports + + if (n==1) iv%info(qscat)%ntotal = iv%info(qscat)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(qscat,dlat_earth,dlon_earth,crit,iv%info(qscat)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(qscat)%nlocal = iv%info(qscat)%nlocal + 1 + end if + fm = 281 + + case (74) ! GPS PW + if (.not.use_gpspwobs) cycle reports + + if (n==1) iv%info(gpspw)%ntotal = iv%info(gpspw)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(gpspw,dlat_earth,dlon_earth,crit,iv%info(gpspw)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(gpspw)%nlocal = iv%info(gpspw)%nlocal + 1 + end if + fm = 111 + + case (71, 73, 75, 76, 77) ! Profiler + if (.not.use_profilerobs) cycle reports + + if (n==1) iv%info(profiler)%ntotal = iv%info(profiler)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(profiler,dlat_earth,dlon_earth,crit,iv%info(profiler)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(profiler)%nlocal = iv%info(profiler)%nlocal + 1 + end if + fm = 132 + + case (571, 65) + if (.not. use_ssmiretrievalobs) cycle reports + + if (n==1) iv%info(ssmi_rv)%ntotal = iv%info(ssmi_rv)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(ssmi_rv,dlat_earth,dlon_earth,crit,iv%info(ssmi_rv)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(ssmi_rv)%nlocal = iv%info(ssmi_rv)%nlocal + 1 + end if + fm = 125 ! ssmi wind speed & tpw + + case default + select case (kx) + case (111 , 210) ; ! Tropical Cyclone Bogus + ! Note Tropical cyclone Bougus is given type 135 in Obs-ascii + if (.not.use_bogusobs) cycle reports + + if (n==1) iv%info(bogus)%ntotal = iv%info(bogus)%ntotal + 1 + if (outside) cycle reports + + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(bogus,dlat_earth,dlon_earth,crit,iv%info(bogus)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + cycle reports + end if + else + iv%info(bogus)%nlocal = iv%info(bogus)%nlocal + 1 + end if + fm = 135 + + case default + if ( print_detail_obs ) then + write(unit=message(1), fmt='(a, 2i12)') & + 'unsaved obs found with kx & t29= ',kx,t29 + call da_warning(__FILE__,__LINE__,message(1:1)) + end if + exit dup_loop + end select + end select + + obs_index=fm_index(fm) + iv%info(obs_index)%max_lev = max(iv%info(obs_index)%max_lev, nlevels) + + plink%fm_BUFR=fm + plink%platform_BUFR=platform + plink%ifgat_BUFR=ifgat + plink%nlevels_BUFR=nlevels + plink%kx_BUFR=kx + plink%t29_BUFR=t29 + plink%pco_BUFR=pco + + num_p=num_p+1 + allocate(plink%next) + plink => plink%next + nullify(plink%next) + + end do dup_loop + end if !3dvar and 4dvar + end do reports + +call closbf(iunit) +close(iunit) +call da_free_unit(iunit) +if ( use_errtable ) then + close(junit) + call da_free_unit(junit) +end if + +end do bufrfile + +! 3.0 Thinning based on FGAT +! Only for 4dvar +!-------------------------------------------------------------- + + if (num_fgat_time > 1 ) then + + do kk=1,num_fgat_time + if ( thin_conv ) then + do n = 1, num_ob_indexes + call cleangrids_conv(n) + end do + end if + + plink => head + reports2: do ii=1,num_p + + kx=plink%kx_BUFR + t29=plink%t29_BUFR + + if (plink%ifgat_BUFR /= kk) then !sort iv + plink => plink%next + cycle reports2 + else + ! for thinning + tdiff = abs(plink%platform_BUFR%info%dhr-0.1) + dlat_earth = plink%platform_BUFR%info%lat + dlon_earth = plink%platform_BUFR%info%lon + if (dlon_earth < 0.0) dlon_earth = dlon_earth + 360.0 + if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 + dlat_earth = dlat_earth * deg2rad + dlon_earth = dlon_earth * deg2rad + call da_llxy (plink%platform_BUFR%info, plink%platform_BUFR%loc,outside, outside_all) + + ! Loop over duplicating obs for global + ndup = 1 + if (global .and. & + (plink%platform_BUFR%loc%i < ids .or. plink%platform_BUFR%loc%i >= ide)) ndup= 2 + if (test_transforms) ndup = 1 + + ! It is possible that logic for counting obs is incorrect for the + ! global case with >1 MPI tasks due to obs duplication, halo, etc. + ! TBH: 20050913 + dup_loop2: do n = 1, ndup + select case(t29) + case (11, 12, 13, 22, 23, 31) + select case (kx) + case (120, 122, 132, 220, 222, 232) ; ! Sound + if (.not.use_soundobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(sound)%ntotal = iv%info(sound)%ntotal + 1 + if (n==1) iv%info(sonde_sfc)%ntotal = iv%info(sonde_sfc)%ntotal + 1 + + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(sound,dlat_earth,dlon_earth,crit,iv%info(sound)%nlocal,itx,1,itt,iout,iuse) + call map2grids_conv(sonde_sfc,dlat_earth,dlon_earth,crit,iv%info(sonde_sfc)%nlocal,itx,1,itt,iout,iuse) + + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(sound)%nlocal = iv%info(sound)%nlocal + 1 + iv%info(sonde_sfc)%nlocal = iv%info(sound)%nlocal + end if + fm = 35 + + case (221) ; ! Pilot + if (.not.use_pilotobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(pilot)%ntotal = iv%info(pilot)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(pilot,dlat_earth,dlon_earth,crit,iv%info(pilot)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(pilot)%nlocal = iv%info(pilot)%nlocal + 1 + end if + fm = 32 + + case default + exit dup_loop2 + end select + + case (41) + ! case (130:131, 133, 230:231, 233) ; ! Airep + if (.not.use_airepobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(airep)%ntotal = iv%info(airep)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(airep,dlat_earth,dlon_earth,crit,iv%info(airep)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(airep)%nlocal = iv%info(airep)%nlocal + 1 + end if + fm = 42 + + case (522, 523); ! Ships + if (.not.use_shipsobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(ships)%ntotal = iv%info(ships)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(ships,dlat_earth,dlon_earth,crit,iv%info(ships)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(ships)%nlocal = iv%info(ships)%nlocal + 1 + end if + fm = 13 + + case (531, 532, 561, 562) ; ! Buoy + if (.not.use_buoyobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(buoy)%ntotal = iv%info(buoy)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(buoy,dlat_earth,dlon_earth,crit,iv%info(buoy)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(buoy)%nlocal = iv%info(buoy)%nlocal + 1 + end if + fm = 18 + + case (511, 514) + ! case (181, 281) ; ! Synop + if (.not.use_synopobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(synop)%ntotal = iv%info(synop)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(synop,dlat_earth,dlon_earth,crit,iv%info(synop)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(synop)%nlocal = iv%info(synop)%nlocal + 1 + end if + fm = 12 + + case (512) + ! case (187, 287) ; ! Metar + if (.not.use_metarobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(metar)%ntotal = iv%info(metar)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(metar,dlat_earth,dlon_earth,crit,iv%info(metar)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(metar)%nlocal = iv%info(metar)%nlocal + 1 + end if + fm = 15 + + case (63) + ! case (242:246, 252:253, 255) ; ! Geo. CMVs + if (.not.use_geoamvobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(geoamv)%ntotal = iv%info(geoamv)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(geoamv,dlat_earth,dlon_earth,crit,iv%info(geoamv)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(geoamv)%nlocal = iv%info(geoamv)%nlocal + 1 + end if + fm = 88 + + case (582, 583) ! QuikSCAT 582 and WindSat 583 + if (.not.use_qscatobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(qscat)%ntotal = iv%info(qscat)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(qscat,dlat_earth,dlon_earth,crit,iv%info(qscat)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(qscat)%nlocal = iv%info(qscat)%nlocal + 1 + end if + fm = 281 + + case (74) ! GPS PW + if (.not.use_gpspwobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(gpspw)%ntotal = iv%info(gpspw)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(gpspw,dlat_earth,dlon_earth,crit,iv%info(gpspw)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(gpspw)%nlocal = iv%info(gpspw)%nlocal + 1 + end if + fm = 111 + + case (71, 73, 75, 76, 77) ! Profiler + if (.not.use_profilerobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(profiler)%ntotal = iv%info(profiler)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(profiler,dlat_earth,dlon_earth,crit,iv%info(profiler)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(profiler)%nlocal = iv%info(profiler)%nlocal + 1 + end if + fm = 132 + + case (571, 65) + if (.not. use_ssmiretrievalobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(ssmi_rv)%ntotal = iv%info(ssmi_rv)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(ssmi_rv,dlat_earth,dlon_earth,crit,iv%info(ssmi_rv)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(ssmi_rv)%nlocal = iv%info(ssmi_rv)%nlocal + 1 + end if + fm = 125 ! ssmi wind speed & tpw + + case default + select case (kx) + case (111 , 210) ; ! Tropical Cyclone Bogus + ! Note Tropical cyclone Bougus is given type 135 in Obs-ascii + if (.not.use_bogusobs) then + plink => plink%next + cycle reports2 + end if + if (n==1) iv%info(bogus)%ntotal = iv%info(bogus)%ntotal + 1 + if (outside) then + plink => plink%next + cycle reports2 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(bogus,dlat_earth,dlon_earth,crit,iv%info(bogus)%nlocal,itx,1,itt,iout,iuse) + if ( .not. iuse ) then + num_thinned = num_thinned + 1 + plink => plink%next + cycle reports2 + end if + else + iv%info(bogus)%nlocal = iv%info(bogus)%nlocal + 1 + end if + fm = 135 + + case default + if ( print_detail_obs ) then + write(unit=message(1), fmt='(a, 2i12)') & + 'unsaved obs found with kx & t29= ',kx,t29 + call da_warning(__FILE__,__LINE__,message(1:1)) + end if + exit dup_loop2 + end select + end select + + obs_index=fm_index(fm) + iv%info(obs_index)%max_lev = max(iv%info(obs_index)%max_lev, plink%nlevels_BUFR) + + plink%fm_BUFR=fm + if (ii/= num_p) plink => plink%next + end do dup_loop2 + end if !sort iv + + end do reports2 + +end do !kk + +end if + +! 4.0 Allocate iv +! +!-------------------------------------------------------------- + + iv%info(synop)%max_lev = 1 + iv%info(metar)%max_lev = 1 + iv%info(ships)%max_lev = 1 + iv%info(buoy)%max_lev = 1 + iv%info(sonde_sfc)%max_lev = 1 + + call da_allocate_observations (iv) + +! 5.0 Transfer p structure into iv structure +! Also sort iv structure to FGAT time bins +!-------------------------------------------------------------- + do kk=1,num_fgat_time + + if ( thin_conv ) then + do n = 1, num_ob_indexes + call cleangrids_conv(n) + end do + end if + + plink => head + + reports3: do ii=1,num_p + + if (plink%ifgat_BUFR /= kk) then !sort iv + plink => plink%next + cycle reports3 + else + ! for thinning + tdiff = abs(plink%platform_BUFR%info%dhr-0.1) + dlat_earth = plink%platform_BUFR%info%lat + dlon_earth = plink%platform_BUFR%info%lon + if (dlon_earth < 0.0) dlon_earth = dlon_earth + 360.0 + if (dlon_earth >= 360.0) dlon_earth = dlon_earth - 360.0 + dlat_earth = dlat_earth * deg2rad + dlon_earth = dlon_earth * deg2rad + call da_llxy (plink%platform_BUFR%info, plink%platform_BUFR%loc,outside, outside_all) + ndup = 1 + if (global .and. & + (plink%platform_BUFR%loc%i < ids .or. plink%platform_BUFR%loc%i >= ide)) ndup= 2 + if (test_transforms) ndup = 1 + dup_loop3: do n = 1, ndup + + select case(plink%t29_BUFR) + case (11, 12, 13, 22, 23, 31) + select case (plink%kx_BUFR) + case (120, 122, 132, 220, 222, 232) ; ! Sound + if (.not.use_soundobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(sound) = ntotal(sound) + 1 + if (n==1) ntotal(sonde_sfc) = ntotal(sonde_sfc) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(sound,dlat_earth,dlon_earth,crit,nlocal(sound),itx,1,itt,ilocal(sound),iuse) + call map2grids_conv(sonde_sfc,dlat_earth,dlon_earth,crit,nlocal(sonde_sfc),itx,1,itt,ilocal(sonde_sfc),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if + else + nlocal(sound) = nlocal(sound) + 1 + nlocal(sonde_sfc) = nlocal(sound) + ilocal(sound) = nlocal(sound) + ilocal(sonde_sfc) = ilocal(sound) + end if + + platform_name ='FM-35 TEMP ' + + old_nlevels = plink%nlevels_BUFR + + ! Search to see if we have surface obs. + + surface_level = 0 + + do i = 1, plink%nlevels_BUFR + ! if (elevation and height are the same, it is surface) + if (abs(plink%platform_BUFR%info%elv - & + plink%platform_BUFR%each(i)%height) < 0.1) then + surface_level = i + + ! Save surface pressure. + iv%sonde_sfc(ilocal(sonde_sfc))%h = plink%platform_BUFR%each(i)%height + iv%sonde_sfc(ilocal(sonde_sfc))%u = plink%platform_BUFR%each(i)%u + iv%sonde_sfc(ilocal(sonde_sfc))%v = plink%platform_BUFR%each(i)%v + iv%sonde_sfc(ilocal(sonde_sfc))%t = plink%platform_BUFR%each(i)%t + iv%sonde_sfc(ilocal(sonde_sfc))%q = plink%platform_BUFR%each(i)%q + iv%sonde_sfc(ilocal(sonde_sfc))%p = plink%platform_BUFR%each(i)%p + + exit + end if + end do + + ! processing the sound_sfc data: + + if (surface_level > 0) then + plink%nlevels_BUFR = plink%nlevels_BUFR - 1 + else !missing surface data + iv%sonde_sfc(ilocal(sonde_sfc))%h = missing_r + iv%sonde_sfc(ilocal(sonde_sfc))%u%inv = missing_r + iv%sonde_sfc(ilocal(sonde_sfc))%u%qc = missing_data + iv%sonde_sfc(ilocal(sonde_sfc))%u%error = abs(missing_r) + iv%sonde_sfc(ilocal(sonde_sfc))%v = iv%sonde_sfc(ilocal(sonde_sfc))%u + iv%sonde_sfc(ilocal(sonde_sfc))%t = iv%sonde_sfc(ilocal(sonde_sfc))%u + iv%sonde_sfc(ilocal(sonde_sfc))%p = iv%sonde_sfc(ilocal(sonde_sfc))%u + iv%sonde_sfc(ilocal(sonde_sfc))%q = iv%sonde_sfc(ilocal(sonde_sfc))%u + + end if + + if (plink%nlevels_BUFR > 0) then + + if ( ilocal(sound) == nlocal(sound) ) then + allocate (iv%sound(ilocal(sound))%h(1:iv%info(sound)%max_lev)) + allocate (iv%sound(ilocal(sound))%p(1:iv%info(sound)%max_lev)) + allocate (iv%sound(ilocal(sound))%u(1:iv%info(sound)%max_lev)) + allocate (iv%sound(ilocal(sound))%v(1:iv%info(sound)%max_lev)) + allocate (iv%sound(ilocal(sound))%t(1:iv%info(sound)%max_lev)) + allocate (iv%sound(ilocal(sound))%q(1:iv%info(sound)%max_lev)) + endif + + j = 0 + do i = 1, old_nlevels + if (i == surface_level) cycle + j=j+1 + iv%sound(ilocal(sound))%h(j) = plink%platform_BUFR%each(i)%height + iv%sound(ilocal(sound))%p(j) = plink%platform_BUFR%each(i)%p%inv + iv%sound(ilocal(sound))%u(j) = plink%platform_BUFR%each(i)%u + iv%sound(ilocal(sound))%v(j) = plink%platform_BUFR%each(i)%v + iv%sound(ilocal(sound))%t(j) = plink%platform_BUFR%each(i)%t + iv%sound(ilocal(sound))%q(j) = plink%platform_BUFR%each(i)%q + + end do + end if + + case (221) ; ! Pilot + if (.not.use_pilotobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(pilot) = ntotal(pilot) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(pilot,dlat_earth,dlon_earth,crit,nlocal(pilot),itx,1,itt,ilocal(pilot),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if + else + nlocal(pilot) = nlocal(pilot) + 1 + ilocal(pilot) = nlocal(pilot) + end if + platform_name='FM-32 PILOT ' + + if ( ilocal(pilot) == nlocal(pilot) ) then + allocate (iv%pilot(ilocal(pilot))%h(1:iv%info(pilot)%max_lev)) + allocate (iv%pilot(ilocal(pilot))%p(1:iv%info(pilot)%max_lev)) + allocate (iv%pilot(ilocal(pilot))%u(1:iv%info(pilot)%max_lev)) + allocate (iv%pilot(ilocal(pilot))%v(1:iv%info(pilot)%max_lev)) + endif + + do i = 1, plink%nlevels_BUFR + iv%pilot(ilocal(pilot))%h(i) = plink%platform_BUFR%each(i)%height + iv%pilot(ilocal(pilot))%p(i) = plink%platform_BUFR%each(i)%p%inv + iv%pilot(ilocal(pilot))%u(i) = plink%platform_BUFR%each(i)%u + iv%pilot(ilocal(pilot))%v(i) = plink%platform_BUFR%each(i)%v + + end do + case default + exit dup_loop3 + end select + case (41) + if (.not.use_airepobs) then + plink => plink%next + cycle reports3 + end if + + if (n==1) ntotal(airep) = ntotal(airep) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(airep,dlat_earth,dlon_earth,crit,nlocal(airep),itx,1,itt,ilocal(airep),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if else - nlocal(metar) = nlocal(metar) + 1 - ilocal(metar) = nlocal(metar) + nlocal(airep) = nlocal(airep) + 1 + ilocal(airep) = nlocal(airep) + end if + platform_name ='FM-97 AIREP ' + if ( ilocal(airep) == nlocal(airep) ) then + allocate (iv%airep(ilocal(airep))%h(1:iv%info(airep)%max_lev)) + allocate (iv%airep(ilocal(airep))%p(1:iv%info(airep)%max_lev)) + allocate (iv%airep(ilocal(airep))%u(1:iv%info(airep)%max_lev)) + allocate (iv%airep(ilocal(airep))%v(1:iv%info(airep)%max_lev)) + allocate (iv%airep(ilocal(airep))%t(1:iv%info(airep)%max_lev)) + end if + do i = 1, plink%nlevels_BUFR + iv % airep (ilocal(airep)) % h(i) = plink%platform_BUFR % each(i) % height + iv % airep (ilocal(airep)) % p(i) = plink%platform_BUFR % each(i) % p % inv + iv % airep (ilocal(airep)) % u(i) = plink%platform_BUFR % each(i) % u + iv % airep (ilocal(airep)) % v(i) = plink%platform_BUFR % each(i) % v + iv % airep (ilocal(airep)) % t(i) = plink%platform_BUFR % each(i) % t + + end do - platform % info % platform ='FM-15 METAR ' - if (nlocal(metar) > iv%info(metar)%nlocal) cycle reports - fm = 15 - iv % metar (ilocal(metar)) % h = platform % each(1) % height - iv % metar (ilocal(metar)) % u = platform % each(1) % u - iv % metar (ilocal(metar)) % v = platform % each(1) % v - iv % metar (ilocal(metar)) % t = platform % each(1) % t - iv % metar (ilocal(metar)) % p = platform % each(1) % p - iv % metar (ilocal(metar)) % q = platform % each(1) % q + case (522,523); ! Ships + if (.not.use_shipsobs) then + plink => plink%next + cycle reports3 + end if - case (63) - if (.not.use_geoamvobs) cycle reports - ! case (242:246, 252:253, 255) ; ! Geo. CMVs - if( n==1 ) ntotal(geoamv) = ntotal(geoamv) + 1 - if (outside) then - cycle reports + if (n==1) ntotal(ships) = ntotal(ships) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(ships,dlat_earth,dlon_earth,crit,nlocal(ships),itx,1,itt,ilocal(ships),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if + else + nlocal(ships) = nlocal(ships) + 1 + ilocal(ships) = nlocal(ships) end if + platform_name ='FM-13 SHIP ' + + iv % ships (ilocal(ships)) % h = plink%platform_BUFR % each(1) % height + iv % ships (ilocal(ships)) % u = plink%platform_BUFR % each(1) % u + iv % ships (ilocal(ships)) % v = plink%platform_BUFR % each(1) % v + iv % ships (ilocal(ships)) % t = plink%platform_BUFR % each(1) % t + iv % ships (ilocal(ships)) % p = plink%platform_BUFR % each(1) % p + iv % ships (ilocal(ships)) % q = plink%platform_BUFR % each(1) % q + + case (531, 532, 561, 562) ; ! Buoy + if (.not.use_buoyobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(buoy) = ntotal(buoy) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if if ( thin_conv ) then crit = tdiff - call map2grids_conv(geoamv,dlat_earth,dlon_earth,crit,nlocal(geoamv),itx,1,itt,ilocal(geoamv),iuse) + call map2grids_conv(buoy,dlat_earth,dlon_earth,crit,nlocal(buoy),itx,1,itt,ilocal(buoy),iuse) if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + plink => plink%next + cycle reports3 + end if + else + nlocal(buoy) = nlocal(buoy) + 1 + ilocal(buoy) = nlocal(buoy) + end if + platform_name ='FM-18 BUOY ' + + iv%buoy(ilocal(buoy))%h = plink%platform_BUFR%each(1)%height + iv%buoy(ilocal(buoy))%u = plink%platform_BUFR%each(1)%u + iv%buoy(ilocal(buoy))%v = plink%platform_BUFR%each(1)%v + iv%buoy(ilocal(buoy))%t = plink%platform_BUFR%each(1)%t + + + if ( plink%kx_BUFR == 282 ) then ! ATLAS BUOY, reported Pstn and Pmslp are both + ! missing. Pstn is set to 1013hPa in PREPBUFR + iv%buoy(ilocal(buoy))%p%inv = missing_r + iv%buoy(ilocal(buoy))%p%qc = missing_data + iv%buoy(ilocal(buoy))%p%error = err_p + else + iv%buoy(ilocal(buoy))%p = plink%platform_BUFR%each(1)%p + end if + iv%buoy(ilocal(buoy))%q = plink%platform_BUFR%each(1)%q + + case (511, 514) + if (.not.use_synopobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(synop) = ntotal(synop) + 1 + if (outside) then + plink => plink%next + cycle reports3 end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(synop,dlat_earth,dlon_earth,crit,nlocal(synop),itx,1,itt,ilocal(synop),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if else - nlocal(geoamv) = nlocal(geoamv) + 1 - ilocal(geoamv) = nlocal(geoamv) + nlocal(synop) = nlocal(synop) + 1 + ilocal(synop) = nlocal(synop) + end if + platform_name ='FM-12 SYNOP ' + + iv % synop (ilocal(synop)) % h = plink%platform_BUFR % each(1) % height + iv % synop (ilocal(synop)) % u = plink%platform_BUFR % each(1) % u + iv % synop (ilocal(synop)) % v = plink%platform_BUFR % each(1) % v + iv % synop (ilocal(synop)) % t = plink%platform_BUFR % each(1) % t + iv % synop (ilocal(synop)) % p = plink%platform_BUFR % each(1) % p + iv % synop (ilocal(synop)) % q = plink%platform_BUFR % each(1) % q + + if (iv % synop(ilocal(synop)) % h < plink%platform_BUFR % info % elv) then + iv % synop(ilocal(synop)) % h = plink%platform_BUFR % info % elv end if - platform % info % platform ='FM-88 SATOB ' - if (nlocal(geoamv) > iv%info(geoamv)%nlocal) cycle reports - fm = 88 + case (512) + if (.not.use_metarobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(metar) = ntotal(metar) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(metar,dlat_earth,dlon_earth,crit,nlocal(metar),itx,1,itt,ilocal(metar),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if + + else + nlocal(metar) = nlocal(metar) + 1 + ilocal(metar) = nlocal(metar) + end if + + platform_name='FM-15 METAR ' + + iv % metar (ilocal(metar)) % h = plink%platform_BUFR % each(1) % height + iv % metar (ilocal(metar)) % u = plink%platform_BUFR % each(1) % u + iv % metar (ilocal(metar)) % v = plink%platform_BUFR % each(1) % v + iv % metar (ilocal(metar)) % t = plink%platform_BUFR % each(1) % t + iv % metar (ilocal(metar)) % p = plink%platform_BUFR % each(1) % p + iv % metar (ilocal(metar)) % q = plink%platform_BUFR % each(1) % q + + case (63) + if (.not.use_geoamvobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(geoamv) = ntotal(geoamv) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then + crit = tdiff + call map2grids_conv(geoamv,dlat_earth,dlon_earth,crit,nlocal(geoamv),itx,1,itt,ilocal(geoamv),iuse) + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if + else + nlocal(geoamv) = nlocal(geoamv) + 1 + ilocal(geoamv) = nlocal(geoamv) + end if + + platform_name ='FM-88 SATOB ' if ( ilocal(geoamv) == nlocal(geoamv) ) then allocate (iv%geoamv(ilocal(geoamv))%p(1:iv%info(geoamv)%max_lev)) allocate (iv%geoamv(ilocal(geoamv))%u(1:iv%info(geoamv)%max_lev)) allocate (iv%geoamv(ilocal(geoamv))%v(1:iv%info(geoamv)%max_lev)) + end if - do i = 1, nlevels - iv % geoamv (ilocal(geoamv)) % p(i) = platform % each(i) % p % inv - iv % geoamv (ilocal(geoamv)) % u(i) = platform % each(i) % u - iv % geoamv (ilocal(geoamv)) % v(i) = platform % each(i) % v + do i = 1, plink%nlevels_BUFR + iv % geoamv (ilocal(geoamv)) % p(i) = plink%platform_BUFR % each(i) % p % inv + iv % geoamv (ilocal(geoamv)) % u(i) = plink%platform_BUFR % each(i) % u + iv % geoamv (ilocal(geoamv)) % v(i) = plink%platform_BUFR % each(i) % v + end do - case (582, 583) - if (.not.use_qscatobs) cycle reports - if( n==1 ) ntotal(qscat) = ntotal(qscat) + 1 + case (582, 583) + if (.not.use_qscatobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(qscat) = ntotal(qscat) + 1 if (outside) then - cycle reports - end if - + plink => plink%next + cycle reports3 + end if if ( thin_conv ) then crit = tdiff call map2grids_conv(qscat,dlat_earth,dlon_earth,crit,nlocal(qscat),itx,1,itt,ilocal(qscat),iuse) if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports - end if + plink => plink%next + cycle reports3 + end if else nlocal(qscat) = nlocal(qscat) + 1 ilocal(qscat) = nlocal(qscat) end if - - platform % info % platform ='FM-281 Quiks' - if (nlocal(qscat) > iv%info(qscat)%nlocal) cycle reports - fm = 281 - + + platform_name ='FM-281 Quiks' + ! prepbufr uses pressure not height, so hardwire height to ! 0 (sea-level) iv%qscat(ilocal(qscat))%h = 0.0 - iv%qscat(ilocal(qscat))%u = platform%each(1)%u - iv%qscat(ilocal(qscat))%v = platform%each(1)%v - iv%qscat(ilocal(qscat))%u%error = max(platform%each(1)%u%error,1.0) - iv%qscat(ilocal(qscat))%v%error = max(platform%each(1)%v%error,1.0) + iv%qscat(ilocal(qscat))%u = plink%platform_BUFR%each(1)%u + iv%qscat(ilocal(qscat))%v = plink%platform_BUFR%each(1)%v + iv%qscat(ilocal(qscat))%u%error = max(plink%platform_BUFR%each(1)%u%error,1.0) + iv%qscat(ilocal(qscat))%v%error = max(plink%platform_BUFR%each(1)%v%error,1.0) + case (74) ! GPS PW - if (.not.use_gpspwobs) cycle reports - if( n==1 ) ntotal(gpspw) = ntotal(gpspw) + 1 - if (outside) then - cycle reports - end if - + if (.not.use_gpspwobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(gpspw) = ntotal(gpspw) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if if ( thin_conv ) then crit = tdiff call map2grids_conv(gpspw,dlat_earth,dlon_earth,crit,nlocal(gpspw),itx,1,itt,ilocal(gpspw),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports - end if + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if else nlocal(gpspw) = nlocal(gpspw) + 1 ilocal(gpspw) = nlocal(gpspw) end if + platform_name ='FM-111 GPSPW' + + iv%gpspw(ilocal(gpspw))%tpw = plink%platform_BUFR%loc%pw + - platform % info % platform ='FM-111 GPSPW' - if (nlocal(gpspw) > iv%info(gpspw)%nlocal) cycle reports - fm = 111 - - iv%gpspw(ilocal(gpspw))%tpw = platform%loc%pw - - case (71, 73, 75, 76, 77) - ! case (223, 224 ) ; ! Profiler & VADWND - NEXRAD winds - if (.not.use_profilerobs) cycle reports - if( n==1 ) ntotal(profiler) = ntotal(profiler) + 1 - if (outside) then - cycle reports - end if - - if ( thin_conv ) then + case (71, 73, 75, 76, 77) + if (.not.use_profilerobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(profiler) = ntotal(profiler) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then crit = tdiff call map2grids_conv(profiler,dlat_earth,dlon_earth,crit,nlocal(profiler),itx,1,itt,ilocal(profiler),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports - end if + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if else nlocal(profiler) = nlocal(profiler) + 1 ilocal(profiler) = nlocal(profiler) end if - - platform % info % platform ='FM-132 PRFLR' - if (nlocal(profiler) > iv%info(profiler)%nlocal) cycle reports - fm = 132 - + + platform_name ='FM-132 PRFLR' if ( ilocal(profiler) == nlocal(profiler) ) then allocate (iv%profiler(ilocal(profiler))%h(1:iv%info(profiler)%max_lev)) allocate (iv%profiler(ilocal(profiler))%p(1:iv%info(profiler)%max_lev)) allocate (iv%profiler(ilocal(profiler))%u(1:iv%info(profiler)%max_lev)) allocate (iv%profiler(ilocal(profiler))%v(1:iv%info(profiler)%max_lev)) - end if - - do i = 1, nlevels - iv%profiler(ilocal(profiler))%h(i) = platform%each(i)%height - iv%profiler(ilocal(profiler))%p(i) = platform%each(i)%p%inv - iv%profiler(ilocal(profiler))%u(i) = platform%each(i)%u - iv%profiler(ilocal(profiler))%v(i) = platform%each(i)%v + end if + + do i = 1, plink%nlevels_BUFR + iv%profiler(ilocal(profiler))%h(i) = plink%platform_BUFR%each(i)%height + iv%profiler(ilocal(profiler))%p(i) = plink%platform_BUFR%each(i)%p%inv + iv%profiler(ilocal(profiler))%u(i) = plink%platform_BUFR%each(i)%u + iv%profiler(ilocal(profiler))%v(i) = plink%platform_BUFR%each(i)%v + end do - case (571, 65) ! SSM/I wind speed & TPW - if (.not. use_ssmiretrievalobs) cycle reports - if( n==1 ) ntotal(ssmi_rv) = ntotal(ssmi_rv) + 1 - if (outside) then - cycle reports - end if - + case (571, 65) ! SSM/I wind speed & TPW + if (.not. use_ssmiretrievalobs) then + plink => plink%next + cycle reports3 + end if + if (n==1) ntotal(ssmi_rv) = ntotal(ssmi_rv) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if if ( thin_conv ) then crit = tdiff call map2grids_conv(ssmi_rv,dlat_earth,dlon_earth,crit,nlocal(ssmi_rv),itx,1,itt,ilocal(ssmi_rv),iuse) - if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports - end if + if ( .not. iuse ) then + plink => plink%next + cycle reports3 + end if else nlocal(ssmi_rv) = nlocal(ssmi_rv) + 1 ilocal(ssmi_rv) = nlocal(ssmi_rv) end if - - if (nlocal(ssmi_rv) > iv%info(ssmi_rv)%nlocal) cycle reports - platform % info % platform ='FM-125 SSMI ' - fm = 125 - - select case (kx) + + platform_name ='FM-125 SSMI ' + + select case (plink%kx_BUFR) case ( 283) ! wind speed - do i = 1, nlevels + do i = 1, plink%nlevels_BUFR + wpc = nint(plink%pco_BUFR(5,i)) ! if wpc == 1, UOB is set to zero, VOB is speed - iv%ssmi_rv(ilocal(ssmi_rv))%speed = platform%each(i)%v + iv%ssmi_rv(ilocal(ssmi_rv))%speed = plink%platform_BUFR%each(i)%v if ( wpc == 10 ) then iv%ssmi_rv(ilocal(ssmi_rv))%speed%inv = sqrt ( & - platform%each(i)%u%inv * platform%each(i)%u%inv + & - platform%each(i)%v%inv * platform%each(i)%v%inv ) + plink%platform_BUFR%each(i)%u%inv * plink%platform_BUFR%each(i)%u%inv + & + plink%platform_BUFR%each(i)%v%inv * plink%platform_BUFR%each(i)%v%inv ) end if - iv%ssmi_rv(ilocal(ssmi_rv))%tpw = platform%loc%pw + iv%ssmi_rv(ilocal(ssmi_rv))%tpw = plink%platform_BUFR%loc%pw + end do case ( 152 ) ! tpw - do i = 1, nlevels - iv%ssmi_rv(ilocal(ssmi_rv))%speed = platform%each(i)%u - iv%ssmi_rv(ilocal(ssmi_rv))%tpw = platform%loc%pw + do i = 1, plink%nlevels_BUFR + iv%ssmi_rv(ilocal(ssmi_rv))%speed = plink%platform_BUFR%each(i)%u + iv%ssmi_rv(ilocal(ssmi_rv))%tpw = plink%platform_BUFR%loc%pw + end do - case default - exit dup_loop + case default + exit dup_loop3 + end select - case default - select case (kx) - case (111 , 210) ; ! Tropical Cyclone Bogus - if (.not.use_bogusobs) cycle reports - ! Note Tropical cyclone Bougus is given type 135 in Obs-ascii - if( n==1 ) ntotal(bogus) = ntotal(bogus) + 1 - if (outside) then - cycle reports + case default + select case (plink%kx_BUFR) + case (111 , 210) + if (.not.use_bogusobs) then + plink => plink%next + cycle reports3 end if - - if ( thin_conv ) then + if (n==1) ntotal(bogus) = ntotal(bogus) + 1 + if (outside) then + plink => plink%next + cycle reports3 + end if + if ( thin_conv ) then crit = tdiff call map2grids_conv(bogus,dlat_earth,dlon_earth,crit,nlocal(bogus),itx,1,itt,ilocal(bogus),iuse) if ( .not. iuse ) then - num_thinned = num_thinned + 1 - cycle reports + plink => plink%next + cycle reports3 end if else nlocal(bogus) = nlocal(bogus) + 1 ilocal(bogus) = nlocal(bogus) end if - - platform % info % platform ='FM-135 TCBOG' - fm = 135 - + + platform_name ='FM-135 TCBOG' if ( ilocal(bogus) == nlocal(bogus) ) then allocate (iv%bogus(ilocal(bogus))%h(1:iv%info(bogus)%max_lev)) allocate (iv%bogus(ilocal(bogus))%p(1:iv%info(bogus)%max_lev)) @@ -1172,105 +2015,102 @@ subroutine da_read_obs_bufr (iv, filename) allocate (iv%bogus(ilocal(bogus))%v(1:iv%info(bogus)%max_lev)) allocate (iv%bogus(ilocal(bogus))%t(1:iv%info(bogus)%max_lev)) allocate (iv%bogus(ilocal(bogus))%q(1:iv%info(bogus)%max_lev)) - end if - - do i = 1, nlevels - iv%bogus(ilocal(bogus))%h(i) = platform%each(i)%height - iv%bogus(ilocal(bogus))%p(i) = platform%each(i)%p%inv - iv%bogus(ilocal(bogus))%u(i) = platform%each(i)%u - iv%bogus(ilocal(bogus))%v(i) = platform%each(i)%v - iv%bogus(ilocal(bogus))%t(i) = platform%each(i)%t - iv%bogus(ilocal(bogus))%q(i) = platform%each(i)%q + end if + + do i = 1, plink%nlevels_BUFR + iv%bogus(ilocal(bogus))%h(i) = plink%platform_BUFR%each(i)%height + iv%bogus(ilocal(bogus))%p(i) = plink%platform_BUFR%each(i)%p%inv + iv%bogus(ilocal(bogus))%u(i) = plink%platform_BUFR%each(i)%u + iv%bogus(ilocal(bogus))%v(i) = plink%platform_BUFR%each(i)%v + iv%bogus(ilocal(bogus))%t(i) = plink%platform_BUFR%each(i)%t + iv%bogus(ilocal(bogus))%q(i) = plink%platform_BUFR%each(i)%q + end do - iv%bogus(ilocal(bogus))%slp = platform%loc%slp - - case default - exit dup_loop - end select + iv%bogus(ilocal(bogus))%slp = plink%platform_BUFR%loc%slp + case default + exit dup_loop3 + end select end select - obs_index = fm_index(fm) - iv%info(obs_index)%name(ilocal(obs_index)) = platform%info%name - iv%info(obs_index)%platform(ilocal(obs_index)) = platform%info%platform - iv%info(obs_index)%id(ilocal(obs_index)) = platform%info%id - iv%info(obs_index)%date_char(ilocal(obs_index)) = platform%info%date_char + obs_index = fm_index(plink%fm_BUFR) + iv%info(obs_index)%name(ilocal(obs_index)) = plink%platform_BUFR%info%name + iv%info(obs_index)%platform(ilocal(obs_index)) = platform_name + iv%info(obs_index)%id(ilocal(obs_index)) = plink%platform_BUFR%info%id + iv%info(obs_index)%date_char(ilocal(obs_index)) = plink%platform_BUFR%info%date_char ! nlevels adjusted for some obs types so use that - iv%info(obs_index)%levels(ilocal(obs_index)) = nlevels - iv%info(obs_index)%lat(:,ilocal(obs_index)) = platform%info%lat - iv%info(obs_index)%lon(:,ilocal(obs_index)) = platform%info%lon - iv%info(obs_index)%elv(ilocal(obs_index)) = platform%info%elv - iv%info(obs_index)%pstar(ilocal(obs_index)) = platform%info%pstar - - iv%info(obs_index)%slp(ilocal(obs_index)) = platform%loc%slp - iv%info(obs_index)%pw(ilocal(obs_index)) = platform%loc%pw - iv%info(obs_index)%x(:,ilocal(obs_index)) = platform%loc%x - iv%info(obs_index)%y(:,ilocal(obs_index)) = platform%loc%y - iv%info(obs_index)%i(:,ilocal(obs_index)) = platform%loc%i - iv%info(obs_index)%j(:,ilocal(obs_index)) = platform%loc%j - iv%info(obs_index)%dx(:,ilocal(obs_index)) = platform%loc%dx - iv%info(obs_index)%dxm(:,ilocal(obs_index)) = platform%loc%dxm - iv%info(obs_index)%dy(:,ilocal(obs_index)) = platform%loc%dy - iv%info(obs_index)%dym(:,ilocal(obs_index)) = platform%loc%dym - iv%info(obs_index)%proc_domain(:,ilocal(obs_index)) = platform%loc%proc_domain - - iv%info(obs_index)%obs_global_index(ilocal(obs_index)) = ntotal(obs_index) + iv%info(obs_index)%levels(ilocal(obs_index)) = plink%nlevels_BUFR + iv%info(obs_index)%lat(:,ilocal(obs_index)) = plink%platform_BUFR%info%lat + iv%info(obs_index)%lon(:,ilocal(obs_index)) = plink%platform_BUFR%info%lon + iv%info(obs_index)%elv(ilocal(obs_index)) = plink%platform_BUFR%info%elv + iv%info(obs_index)%pstar(ilocal(obs_index)) = plink%platform_BUFR%info%pstar + + iv%info(obs_index)%slp(ilocal(obs_index)) = plink%platform_BUFR%loc%slp + iv%info(obs_index)%pw(ilocal(obs_index)) = plink%platform_BUFR%loc%pw + iv%info(obs_index)%x(:,ilocal(obs_index)) = plink%platform_BUFR%loc%x + iv%info(obs_index)%y(:,ilocal(obs_index)) = plink%platform_BUFR%loc%y + iv%info(obs_index)%i(:,ilocal(obs_index)) = plink%platform_BUFR%loc%i + iv%info(obs_index)%j(:,ilocal(obs_index)) = plink%platform_BUFR%loc%j + iv%info(obs_index)%dx(:,ilocal(obs_index)) = plink%platform_BUFR%loc%dx + iv%info(obs_index)%dxm(:,ilocal(obs_index)) = plink%platform_BUFR%loc%dxm + iv%info(obs_index)%dy(:,ilocal(obs_index)) = plink%platform_BUFR%loc%dy + iv%info(obs_index)%dym(:,ilocal(obs_index)) = plink%platform_BUFR%loc%dym + iv%info(obs_index)%proc_domain(:,ilocal(obs_index)) = plink%platform_BUFR%loc%proc_domain + + iv%info(obs_index)%obs_global_index(ilocal(obs_index)) = iv%info(obs_index)%ntotal ! special case for sonde_sfc, duplicate sound info if (obs_index == sound) then - iv%info(sonde_sfc)%name(ilocal(sonde_sfc)) = platform%info%name - iv%info(sonde_sfc)%platform(ilocal(sonde_sfc)) = platform%info%platform - iv%info(sonde_sfc)%id(ilocal(sonde_sfc)) = platform%info%id - iv%info(sonde_sfc)%date_char(ilocal(sonde_sfc)) = platform%info%date_char + iv%info(sonde_sfc)%name(ilocal(sonde_sfc)) = plink%platform_BUFR%info%name + iv%info(sonde_sfc)%platform(ilocal(sonde_sfc)) = platform_name + iv%info(sonde_sfc)%id(ilocal(sonde_sfc)) = plink%platform_BUFR%info%id + iv%info(sonde_sfc)%date_char(ilocal(sonde_sfc)) = plink%platform_BUFR%info%date_char iv%info(sonde_sfc)%levels(ilocal(sonde_sfc)) = 1 - iv%info(sonde_sfc)%lat(:,ilocal(sonde_sfc)) = platform%info%lat - iv%info(sonde_sfc)%lon(:,ilocal(sonde_sfc)) = platform%info%lon - iv%info(sonde_sfc)%elv(ilocal(sonde_sfc)) = platform%info%elv - iv%info(sonde_sfc)%pstar(ilocal(sonde_sfc)) = platform%info%pstar - - iv%info(sonde_sfc)%slp(ilocal(sonde_sfc)) = platform%loc%slp - iv%info(sonde_sfc)%pw(ilocal(sonde_sfc)) = platform%loc%pw - iv%info(sonde_sfc)%x(:,ilocal(sonde_sfc)) = platform%loc%x - iv%info(sonde_sfc)%y(:,ilocal(sonde_sfc)) = platform%loc%y - iv%info(sonde_sfc)%i(:,ilocal(sonde_sfc)) = platform%loc%i - iv%info(sonde_sfc)%j(:,ilocal(sonde_sfc)) = platform%loc%j - iv%info(sonde_sfc)%dx(:,ilocal(sonde_sfc)) = platform%loc%dx - iv%info(sonde_sfc)%dxm(:,ilocal(sonde_sfc)) = platform%loc%dxm - iv%info(sonde_sfc)%dy(:,ilocal(sonde_sfc)) = platform%loc%dy - iv%info(sonde_sfc)%dym(:,ilocal(sonde_sfc)) = platform%loc%dym - iv%info(sonde_sfc)%proc_domain(:,ilocal(sonde_sfc)) = platform%loc%proc_domain - - iv%info(sonde_sfc)%obs_global_index(ilocal(sonde_sfc)) = ntotal(sonde_sfc) - end if + iv%info(sonde_sfc)%lat(:,ilocal(sonde_sfc)) = plink%platform_BUFR%info%lat + iv%info(sonde_sfc)%lon(:,ilocal(sonde_sfc)) = plink%platform_BUFR%info%lon + iv%info(sonde_sfc)%elv(ilocal(sonde_sfc)) = plink%platform_BUFR%info%elv + iv%info(sonde_sfc)%pstar(ilocal(sonde_sfc)) = plink%platform_BUFR%info%pstar + + iv%info(sonde_sfc)%slp(ilocal(sonde_sfc)) = plink%platform_BUFR%loc%slp + iv%info(sonde_sfc)%pw(ilocal(sonde_sfc)) = plink%platform_BUFR%loc%pw + iv%info(sonde_sfc)%x(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%x + iv%info(sonde_sfc)%y(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%y + iv%info(sonde_sfc)%i(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%i + iv%info(sonde_sfc)%j(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%j + iv%info(sonde_sfc)%dx(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%dx + iv%info(sonde_sfc)%dxm(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%dxm + iv%info(sonde_sfc)%dy(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%dy + iv%info(sonde_sfc)%dym(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%dym + iv%info(sonde_sfc)%proc_domain(:,ilocal(sonde_sfc)) = plink%platform_BUFR%loc%proc_domain + + iv%info(sonde_sfc)%obs_global_index(ilocal(sonde_sfc)) =iv%info(sonde_sfc)%ntotal - if (global .and. n < 2) then - if (test_transforms) exit dup_loop - if (platform%loc % i >= ide) then - platform%loc%i = platform%loc % i - ide - else if (platform%loc % i < ids) then - platform%loc%i = platform%loc % i + ide - end if - platform%loc%proc_domain = .not. platform%loc%proc_domain end if - end do dup_loop - end do reports - - write(unit=message(1),fmt='(A,4(1x,i7))') & - 'da_read_obs_bufr: num_report, num_outside_all, num_outside_time, num_thinned: ', & - num_report, num_outside_all, num_outside_time, num_thinned - call da_message(message(1:1)) - - do n = 1, num_ob_indexes - if ( nlocal(n) /= iv%info(n)%nlocal ) then - call da_error(__FILE__,__LINE__,(/"numbers mismatch between scanning and reading PREPBUFR file"/)) - end if - end do + + if (ii/= num_p) plink => plink%next + end do dup_loop3 + end if !sort iv + end do reports3 + + if (num_fgat_time >1 ) then + do n = 1, num_ob_indexes + iv%info(n)%ptotal(kk)=ntotal(n) + iv%info(n)%plocal(kk)=nlocal(n) + end do + else + do n = 1, num_ob_indexes + ntotal(n)=iv%info(n)%ntotal + nlocal(n)=iv%info(n)%nlocal + iv%info(n)%ptotal(1)=iv%info(n)%ntotal + iv%info(n)%plocal(1)=iv%info(n)%nlocal + end do + end if ! thinning check if ( thin_conv ) then do n = 1, num_ob_indexes - if ( ntotal(n)>0 ) then + if ( ntotal(n)>0 ) then #ifdef DM_PARALLEL ! Get minimum crit and associated processor index. @@ -1292,8 +2132,8 @@ subroutine da_read_obs_bufr (iv, filename) deallocate( in ) deallocate( out ) #endif - - do j = 1, nlocal(n) + + do j = (1+tp(n)), nlocal(n) found = .false. do i = 1, thinning_grid_conv(n)%itxmax if ( thinning_grid_conv(n)%ibest_obs(i) == j .and. & @@ -1306,24 +2146,34 @@ subroutine da_read_obs_bufr (iv, filename) iv%info(n)%thinned(:,j) = .true. end if end do + + tp(n)=nlocal(n) + end if + end do + end if ! thin_conv + end do !kk cycle + +if ( thin_conv ) then + do n = 1, num_ob_indexes + if ( ntotal(n)>0 ) then if ( nlocal(n) > 0 ) then if ( ANY(iv%info(n)%thinned(:,:)) ) then call da_set_obs_missing(iv,n) ! assign missing values to those thinned=true data end if end if + end if + end do +end if - end if - end do - end if ! thin_conv +write(unit=message(1),fmt='(A,4(1x,i7))') & + 'da_read_obs_bufr: num_report, num_outside_all, num_outside_time, num_thinned: ', & + num_report, num_outside_all, num_outside_time, num_thinned + call da_message(message(1:1)) - call closbf(iunit) - close(iunit) - call da_free_unit(iunit) - if ( use_errtable ) then - close(junit) - call da_free_unit(junit) - end if + +deallocate(plink) +deallocate(head) if (trace_use) call da_trace_exit("da_read_obs_bufr") #else @@ -1331,3 +2181,6 @@ subroutine da_read_obs_bufr (iv, filename) #endif end subroutine da_read_obs_bufr + + + diff --git a/wrfv2_fire/var/da/da_obs_io/da_search_obs.inc b/wrfv2_fire/var/da/da_obs_io/da_search_obs.inc index ba4305dc..67f2027f 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_search_obs.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_search_obs.inc @@ -294,7 +294,30 @@ subroutine da_search_obs (ob_type_string, unit_in, num_obs, nth, iv, found_flag) iv%info(gpspw)%lon(1,nth) == lon ) then read(unit_in,'(E22.13,i8,3E22.13)')& - iv%gpspw(nth)%tpw + iv%gpspw(nth)%tpw + found_flag = .true. + rewind (unit_in) + read(unit_in,*) + return + else + read(unit_in,*) + endif + enddo + found_flag = .false. + + CASE ('radar') + + do n = 1, num_obs + read(unit_in,'(2i8,2E22.13)') n_dummy, levels, lat, lon + + if ( iv%info(radar)%lat(1,nth) == lat .and. & + iv%info(radar)%lon(1,nth) == lon ) then + + do k = 1, levels + read(unit_in,'(E22.13,i8,3E22.13)')& + iv%radar(nth)%rv(k) + enddo + found_flag = .true. rewind (unit_in) read(unit_in,*) @@ -330,6 +353,7 @@ subroutine da_search_obs (ob_type_string, unit_in, num_obs, nth, iv, found_flag) do n = 1, num_obs read(unit_in,'(2i8,a5,2E22.13)') n_dummy, levels, stn_id, lat, lon + if ( iv%info(airep)%id(nth) == stn_id .and. & iv%info(airep)%lat(1,nth) == lat .and. & iv%info(airep)%lon(1,nth) == lon ) then @@ -342,6 +366,7 @@ subroutine da_search_obs (ob_type_string, unit_in, num_obs, nth, iv, found_flag) iv%airep(nth)%v(k), &! O-B v iv%airep(nth)%t(k) enddo + found_flag = .true. rewind (unit_in) read(unit_in,*) diff --git a/wrfv2_fire/var/da/da_obs_io/da_write_filtered_obs.inc b/wrfv2_fire/var/da/da_obs_io/da_write_filtered_obs.inc index dd37e2c4..10b5652f 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_write_filtered_obs.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_write_filtered_obs.inc @@ -1,4 +1,4 @@ -subroutine da_write_filtered_obs(grid, ob, iv, & +subroutine da_write_filtered_obs(it, grid, ob, iv, & coarse_ix, coarse_jy, start_x, start_y) !------------------------------------------------------------------------ @@ -39,6 +39,7 @@ subroutine da_write_filtered_obs(grid, ob, iv, & implicit none + integer, intent(in) :: it type (domain), intent(in) :: grid type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(inout) :: iv ! O-B structure. @@ -1105,7 +1106,7 @@ subroutine da_write_filtered_obs(grid, ob, iv, & iv%profiler(n)%p(k),zero,pr_error, & speed,speed_qc ,speed_error, & dir ,dir_qc ,dir_error, & - iv%info(profiler)%elv(n), zero, elv_error, & + iv%profiler(n)%h(k), zero, elv_error, & missing_r, missing_data, xmiss, & missing_r, missing_data, xmiss, & missing_r, missing_data, xmiss @@ -1581,8 +1582,9 @@ subroutine da_write_filtered_obs(grid, ob, iv, & #endif if (rootproc) then call da_get_unit(filtered_obs_unit) + write(unit=filename, fmt='(a,i2.2)') 'filtered_obs_', it open (unit=filtered_obs_unit, & - file= 'filtered_obs' ,form='formatted', status='replace', iostat=iost) + file= filename ,form='formatted', status='replace', iostat=iost) if (iost /= 0) & call da_error(__FILE__,__LINE__, (/"Cannot open filtered_obs "/)) call da_count_filtered_obs(& diff --git a/wrfv2_fire/var/da/da_obs_io/da_write_iv_for_multi_inc.inc b/wrfv2_fire/var/da/da_obs_io/da_write_iv_for_multi_inc.inc index 3865e91b..8ce4f21f 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_write_iv_for_multi_inc.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_write_iv_for_multi_inc.inc @@ -253,8 +253,8 @@ subroutine da_write_iv_for_multi_inc(file_index, iv) n, iv%info(gpspw)%id(n), & ! Station iv%info(gpspw)%lat(1,n), & ! Latitude iv%info(gpspw)%lon(1,n) ! Longitude - write(ounit,'(E22.13,i8,E22.13)')& - iv%gpspw(n)%tpw + write(ounit,'(E22.13,i8,3E22.13)')& + iv%gpspw(n)%tpw end do close (ounit) end if @@ -636,6 +636,39 @@ subroutine da_write_iv_for_multi_inc(file_index, iv) close (ounit) end if + ! [22] radar obs: + + if (iv%info(radar)%plocal(iv%time) - iv%info(radar)%plocal(iv%time-1) > 0) then + + open (unit=ounit,file=trim(filename)//'.radar',form='formatted',status='replace', & + iostat=ios) + if (ios /= 0) then + call da_error(__FILE__,__LINE__, & + (/"Cannot open conventional observation omb file"//filename/)) + end if + + write(ounit,'(a20,i8)')'radar', iv%info(radar)%plocal(iv%time) - & + iv%info(radar)%plocal(iv%time-1) + do n = iv%info(radar)%plocal(iv%time-1) + 1, & + iv%info(radar)%plocal(iv%time) + write(ounit,'(2i8,2E22.13)')& + n, iv%info(radar)%levels(n), & + iv%info(radar)%lat(1,n), & ! Latitude + iv%info(radar)%lon(1,n) ! Longitude + do k = 1 , iv%info(radar)%levels(n) + write(ounit,'(E22.13,i8,3E22.13)')& + iv%radar(n)%rv(k) ! radar_rv + + enddo + end do + close (ounit) + end if + + + + !------------------------------------------------------------------------------- + + call da_free_unit(ounit) if (trace_use) call da_trace_exit("da_write_iv_for_multi_inc") diff --git a/wrfv2_fire/var/da/da_obs_io/da_write_noise_to_ob.inc b/wrfv2_fire/var/da/da_obs_io/da_write_noise_to_ob.inc index f1e529f3..c89f2b62 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_write_noise_to_ob.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_write_noise_to_ob.inc @@ -26,7 +26,8 @@ subroutine da_write_noise_to_ob (iv) if (rootproc) then call da_get_unit (rand_unit) open(unit=rand_unit,file='rand_obs_error',form='formatted', & - iostat=ierr,status='new') + iostat=ierr,status='unknown') +! iostat=ierr,status='new') if (ierr /= 0) & call da_error(__FILE__,__LINE__, (/"Cannot open file rand_obs_error"/)) end if diff --git a/wrfv2_fire/var/da/da_obs_io/da_write_obs.inc b/wrfv2_fire/var/da/da_obs_io/da_write_obs.inc index e6fabf75..f3545a18 100644 --- a/wrfv2_fire/var/da/da_obs_io/da_write_obs.inc +++ b/wrfv2_fire/var/da/da_obs_io/da_write_obs.inc @@ -212,7 +212,7 @@ subroutine da_write_obs(it,ob, iv, re) num_obs, 1, iv%info(gpspw)%id(n), & ! Station iv%info(gpspw)%lat(1,n), & ! Latitude iv%info(gpspw)%lon(1,n), & ! Longitude - missing_r, & + iv%info(gpspw)%elv(n) , & ob%gpspw(n)%tpw, & iv%gpspw(n)%tpw%inv, iv%gpspw(n)%tpw%qc, iv%gpspw(n)%tpw%error, & re%gpspw(n)%tpw @@ -659,7 +659,7 @@ subroutine da_write_obs(it,ob, iv, re) end do if (num_obs > 0) then write(ounit,'(a20,i8)')'gpsref', num_obs - num_obs = 0 + num_obs = 0 do n = 1, iv%info(gpsref)%nlocal if (iv%info(gpsref)%proc_domain(1,n)) then num_obs = num_obs + 1 @@ -676,8 +676,8 @@ subroutine da_write_obs(it,ob, iv, re) end do end if end do - end if - + end if + close (ounit) call da_free_unit(ounit) diff --git a/wrfv2_fire/var/da/da_par_util/da_copy_tile_dims.inc b/wrfv2_fire/var/da/da_par_util/da_copy_tile_dims.inc index 49fdad0f..6e778d27 100644 --- a/wrfv2_fire/var/da/da_par_util/da_copy_tile_dims.inc +++ b/wrfv2_fire/var/da/da_par_util/da_copy_tile_dims.inc @@ -14,29 +14,29 @@ subroutine da_copy_tile_dims(grid) ! De-reference tile indices stored in the grid data structure. - do ij = 1 , grid%num_tiles - its = grid%i_start(ij) - ite = grid%i_end(ij) - jts = grid%j_start(ij) - jte = grid%j_end(ij) - kts = grid%xp%kds - kte = grid%xp%kde - - grid%xp%its = its - grid%xp%ite = ite - grid%xp%jts = jts - grid%xp%jte = jte - grid%xp%kts = kts - grid%xp%kte = kte - - if (grid%xp%ite > grid%xp%ide) grid%xp%ite = grid%xp%ide - if (grid%xp%jte > grid%xp%jde) grid%xp%jte = grid%xp%jde - if (grid%xp%kte > grid%xp%kde) grid%xp%kte = grid%xp%kde - - if (ite > grid%xp%ide) ite = grid%xp%ide - if (jte > grid%xp%jde) jte = grid%xp%jde - if (kte > grid%xp%kde) kte = grid%xp%kde + its = MINVAL( grid%i_start(1:grid%num_tiles) ) + ite = MAXVAL( grid%i_end(1:grid%num_tiles) ) + jts = MINVAL( grid%j_start(1:grid%num_tiles) ) + jte = MAXVAL( grid%j_end(1:grid%num_tiles) ) + kts = grid%xp%kds + kte = grid%xp%kde + + grid%xp%its = its + grid%xp%ite = ite + grid%xp%jts = jts + grid%xp%jte = jte + grid%xp%kts = kts + grid%xp%kte = kte + + if (grid%xp%ite > grid%xp%ide) grid%xp%ite = grid%xp%ide + if (grid%xp%jte > grid%xp%jde) grid%xp%jte = grid%xp%jde + if (grid%xp%kte > grid%xp%kde) grid%xp%kte = grid%xp%kde + + if (ite > grid%xp%ide) ite = grid%xp%ide + if (jte > grid%xp%jde) jte = grid%xp%jde + if (kte > grid%xp%kde) kte = grid%xp%kde + do ij = 1 , grid%num_tiles if (print_detail_parallel) then write(unit=stdout, fmt='(/)') write(unit=stdout, fmt='(A,i3,A,5x,3(i3,A,i3,5x))') 'Tile ',ij, & diff --git a/wrfv2_fire/var/da/da_par_util/da_cv_to_global.inc b/wrfv2_fire/var/da/da_par_util/da_cv_to_global.inc index b8981175..82ca3c5e 100644 --- a/wrfv2_fire/var/da/da_par_util/da_cv_to_global.inc +++ b/wrfv2_fire/var/da/da_par_util/da_cv_to_global.inc @@ -28,6 +28,8 @@ subroutine da_cv_to_global(cv_size, cv_size_global, x, grid, mzs, xg) ims, ime, jms, jme, kms, & ips, ipe, jps, jpe, kps + integer :: n + if (trace_use) call da_trace_entry("da_cv_to_global") ! @@ -46,7 +48,7 @@ subroutine da_cv_to_global(cv_size, cv_size_global, x, grid, mzs, xg) allocate(vv_x%v3(ims:ime,jms:jme,mzs(3))) allocate(vv_x%v4(ims:ime,jms:jme,mzs(4))) allocate(vv_x%v5(ims:ime,jms:jme,mzs(5))) - allocate(vv_x%alpha(ims:ime,jms:jme,mzs(6))) + allocate(vv_x%alpha(ims:ime,jms:jme,kms:kme,mzs(7))) call da_cv_to_vv (cv_size, x, mzs, vv_x) @@ -57,7 +59,7 @@ subroutine da_cv_to_global(cv_size, cv_size_global, x, grid, mzs, xg) allocate(vv_xg%v3(ids:ide,jds:jde,mzs(3))) allocate(vv_xg%v4(ids:ide,jds:jde,mzs(4))) allocate(vv_xg%v5(ids:ide,jds:jde,mzs(5))) - allocate(vv_xg%alpha(ids:ide,jds:jde,mzs(6))) + allocate(vv_xg%alpha(ids:ide,jds:jde,kds:kde,mzs(7))) else ! Allocate dummy array for non-monitor process to keep Fortran ! CICO happy... @@ -66,7 +68,7 @@ subroutine da_cv_to_global(cv_size, cv_size_global, x, grid, mzs, xg) allocate(vv_xg%v3(1,1,1)) allocate(vv_xg%v4(1,1,1)) allocate(vv_xg%v5(1,1,1)) - allocate(vv_xg%alpha(1,1,1)) + allocate(vv_xg%alpha(1,1,1,1)) end if ! TOdo: encapsulate this crap! @@ -78,10 +80,15 @@ subroutine da_cv_to_global(cv_size, cv_size_global, x, grid, mzs, xg) call da_patch_to_global(grid, vv_x%v3, vv_xg%v3, mzs(3)) call da_patch_to_global(grid, vv_x%v4, vv_xg%v4, mzs(4)) call da_patch_to_global(grid, vv_x%v5, vv_xg%v5, mzs(5)) - call da_patch_to_global(grid, vv_x%alpha, vv_xg%alpha, mzs(6)) + + if ( mzs(7) > 0 ) then + do n = 1, mzs(7) ! Ensemble size + call da_patch_to_global(grid, vv_x%alpha(:,:,:,n), vv_xg%alpha(:,:,:,n), mzs(6)) + end do + end if ! deallocate vv_x - deallocate (vv_x%v1, vv_x%v2, vv_x%v3, vv_x%v4, vv_x%v5) + deallocate (vv_x%v1, vv_x%v2, vv_x%v3, vv_x%v4, vv_x%v5, vv_x%alpha) if (rootproc) then ! finally, collapse data back into a globally-sized cv-array diff --git a/wrfv2_fire/var/da/da_par_util/da_cv_to_vv.inc b/wrfv2_fire/var/da/da_par_util/da_cv_to_vv.inc index 9af1cd1a..d9676e29 100644 --- a/wrfv2_fire/var/da/da_par_util/da_cv_to_vv.inc +++ b/wrfv2_fire/var/da/da_par_util/da_cv_to_vv.inc @@ -15,8 +15,10 @@ subroutine da_cv_to_vv (cv_size, rcv, mzs, vv) integer :: js,je ! Local grid range in x coordinate. integer :: ix,jy ! Local grid horizontal dimensions. integer :: mz ! Max vertical coordinate for v1 through v5 arrays. + integer :: ne ! Ensemble size. integer :: cv_s,cv_e ! Starting and ending indices into CV array. integer :: ijm ! Size of interior of v1 through v5 arrays. + integer :: ijmn ! Size of interior of alpha cv arrays. if (trace_use) call da_trace_entry("da_cv_to_vv") @@ -82,11 +84,12 @@ subroutine da_cv_to_vv (cv_size, rcv, mzs, vv) !-------------------------------------------------------------------------- mz = mzs(6) - if (mz > 0) then - ijm = ix * jy * mz + ne = mzs(7) + if ( ne > 0 ) then + ijmn = ix * jy * mz * ne cv_s = cv_e + 1 - cv_e = cv_s + ijm - 1 - vv % alpha(is:ie,js:je,1:mz) = RESHAPE(rcv(cv_s:cv_e),(/ix, jy, mz/)) + cv_e = cv_s + ijmn - 1 + vv % alpha(is:ie,js:je,1:mz,1:ne) = RESHAPE(rcv(cv_s:cv_e),(/ix, jy, mz, ne/)) end if if (trace_use) call da_trace_exit("da_cv_to_vv") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_x2y.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_x2y.inc index ac3bad20..823bd840 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_x2y.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_x2y.inc @@ -3,14 +3,25 @@ subroutine da_transpose_x2y (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use_dull) call da_trace_entry("da_transpose_x2y") #ifdef DM_PARALLEL #include "XPOSE_V1_x2y.inc" #else - grid%xp % v1y(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v1x(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v1y(i,j,k) = grid%xp % v1x(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use_dull) call da_trace_exit("da_transpose_x2y") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_x2y_v2.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_x2y_v2.inc index 34d7031f..95b05431 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_x2y_v2.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_x2y_v2.inc @@ -3,14 +3,25 @@ subroutine da_transpose_x2y_v2 (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use) call da_trace_entry("da_transpose_x2y_v2") #ifdef DM_PARALLEL #include "XPOSE_V2_x2y.inc" #else - grid%xp % v2y(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v2x(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v2y(i,j,k) = grid%xp % v2x(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use) call da_trace_exit("da_transpose_x2y_v2") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_x2z.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_x2z.inc index c74e6a06..dde7f582 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_x2z.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_x2z.inc @@ -3,14 +3,25 @@ subroutine da_transpose_x2z (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use_dull) call da_trace_entry("da_transpose_x2z") #ifdef DM_PARALLEL #include "XPOSE_V1_x2z.inc" #else - grid%xp % v1z(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v1x(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v1z(i,j,k) = grid%xp % v1x(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use_dull) call da_trace_exit("da_transpose_x2z") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_y2x.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_y2x.inc index 0ad0fdd5..2b5453d2 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_y2x.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_y2x.inc @@ -3,14 +3,25 @@ subroutine da_transpose_y2x (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use_dull) call da_trace_entry("da_transpose_y2x") #ifdef DM_PARALLEL #include "XPOSE_V1_y2x.inc" #else - grid%xp % v1x(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v1y(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v1x(i,j,k) = grid%xp % v1y(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use_dull) call da_trace_exit("da_transpose_y2x") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_y2x_v2.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_y2x_v2.inc index 76a4da0c..93b7ea26 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_y2x_v2.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_y2x_v2.inc @@ -3,14 +3,25 @@ subroutine da_transpose_y2x_v2 (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use) call da_trace_entry("da_transpose_y2x_v2") #ifdef DM_PARALLEL #include "XPOSE_V2_y2x.inc" #else - grid%xp % v2x(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v2y(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v2x(i,j,k) = grid%xp % v2y(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use) call da_trace_exit("da_transpose_y2x_v2") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_y2z.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_y2z.inc index e0833703..adca28e5 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_y2z.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_y2z.inc @@ -3,14 +3,25 @@ subroutine da_transpose_y2z (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use_dull) call da_trace_entry("da_transpose_y2z") #ifdef DM_PARALLEL #include "XPOSE_V1_y2z.inc" #else - grid%xp % v1z(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v1y(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v1z(i,j,k) = grid%xp % v1y(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use_dull) call da_trace_exit("da_transpose_y2z") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_z2x.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_z2x.inc index cc902a8d..5790a7ca 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_z2x.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_z2x.inc @@ -7,14 +7,25 @@ subroutine da_transpose_z2x (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use_dull) call da_trace_entry("da_transpose_z2x") #ifdef DM_PARALLEL #include "XPOSE_V1_z2x.inc" #else - grid%xp % v1x(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v1z(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v1x(i,j,k) = grid%xp % v1z(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use_dull) call da_trace_exit("da_transpose_z2x") diff --git a/wrfv2_fire/var/da/da_par_util/da_transpose_z2y.inc b/wrfv2_fire/var/da/da_par_util/da_transpose_z2y.inc index 42708642..571ba78a 100644 --- a/wrfv2_fire/var/da/da_par_util/da_transpose_z2y.inc +++ b/wrfv2_fire/var/da/da_par_util/da_transpose_z2y.inc @@ -3,14 +3,25 @@ subroutine da_transpose_z2y (grid) implicit none type(domain), intent(inout) :: grid + integer :: ij, i, j, k if (trace_use_dull) call da_trace_entry("da_transpose_z2y") #ifdef DM_PARALLEL #include "XPOSE_V1_z2y.inc" #else - grid%xp % v1y(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) = & - grid%xp % v1z(grid%xp%ids:grid%xp%ide,grid%xp%jds:grid%xp%jde,grid%xp%kds:grid%xp%kde) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = grid%xp%kds, grid%xp%kde + do j = grid%j_start(ij), grid%j_end(ij) + do i = grid%xp%ids, grid%xp%ide + grid%xp % v1y(i,j,k) = grid%xp % v1z(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO #endif if (trace_use_dull) call da_trace_exit("da_transpose_z2y") diff --git a/wrfv2_fire/var/da/da_par_util/da_vv_to_cv.inc b/wrfv2_fire/var/da/da_par_util/da_vv_to_cv.inc index 9be3bbfd..a128f5e7 100644 --- a/wrfv2_fire/var/da/da_par_util/da_vv_to_cv.inc +++ b/wrfv2_fire/var/da/da_par_util/da_vv_to_cv.inc @@ -16,11 +16,13 @@ subroutine da_vv_to_cv(vv, xp, mzs, cv_size, rcv) integer :: js,je ! Local grid range in x coordinate. integer :: ix,jy ! Local grid horizontal dimensions. integer :: mz ! Max vertical coordinate for v1 through v5 arrays. + integer :: ne ! Ensemble size. integer :: cv_s,cv_e ! Starting and ending indices into CV array. integer :: ijm ! Size of interior of v1 through v5 arrays. + integer :: ijmn ! Size of interior of alpha cv arrays. #ifdef NORESHAPE - integer :: i,j,k,ijk + integer :: i,j,k,ijk,m,n #endif if (trace_use) call da_trace_entry("da_vv_to_cv") @@ -139,21 +141,25 @@ subroutine da_vv_to_cv(vv, xp, mzs, cv_size, rcv) ! Store alpha: mz = mzs(6) - if (mz > 0) then - ijm = ix * jy * mz + ne = mzs(7) + + if ( ne > 0 ) then + ijmn = ix * jy * mz * ne cv_s = cv_e + 1 - cv_e = cv_s + ijm - 1 + cv_e = cv_s + ijmn - 1 #ifdef NORESHAPE - do k=1,mz - do j=js,je - do i=is,ie - ijk = ijk + 1 - rcv(ijk) = vv%alpha(i,j,k) + do n = 1, ne + do m = 1, mz + do j = js, je + do i = is, ie + ijk = ijk + 1 + rcv(ijk) = vv%alpha(i,j,m,n) + end do end do end do end do #else - rcv(cv_s:cv_e) = RESHAPE(vv % alpha(is:ie,js:je,1:mz), (/ijm/)) + rcv(cv_s:cv_e) = RESHAPE(vv % alpha(is:ie,js:je,1:mz,1:ne), (/ijmn/)) #endif end if diff --git a/wrfv2_fire/var/da/da_physics/da_check_rh.inc b/wrfv2_fire/var/da/da_physics/da_check_rh.inc index eb436ce2..8d70db91 100644 --- a/wrfv2_fire/var/da/da_physics/da_check_rh.inc +++ b/wrfv2_fire/var/da/da_physics/da_check_rh.inc @@ -14,7 +14,7 @@ subroutine da_check_rh(grid) real :: x_qs(kts:kte) real :: dz(kts:kte) - integer :: i, j, k + integer :: i, j, k, ij real :: tol_adjust_moist, tol_moist, oldrha, each_moist, es, weight real :: upper_modify_rh, lower_modify_rh @@ -30,8 +30,14 @@ subroutine da_check_rh(grid) call da_tpq_to_rh_lin (grid) end if + !$OMP PARALLEL DO SCHEDULE (DYNAMIC, 1) & + !$OMP PRIVATE ( i, j, k, tol_adjust_moist, tol_moist) & + !$OMP PRIVATE ( weight, oldrha, each_moist, imod, dz, x_qs, rhtol, es) +! do ij = 1 , grid%num_tiles + do i=its,ite - do j=jts,jte + !do j=grid%j_start(ij), grid%j_end(ij) + do j=jts, jte tol_adjust_moist = 0.0 tol_moist = 0.0 @@ -141,6 +147,9 @@ subroutine da_check_rh(grid) end do end do +! end do + !$OMP END PARALLEL DO + if (trace_use) call da_trace_exit("da_check_rh") end subroutine da_check_rh diff --git a/wrfv2_fire/var/da/da_physics/da_integrat_dz.inc b/wrfv2_fire/var/da/da_physics/da_integrat_dz.inc index 3a0239ee..c58c8b11 100644 --- a/wrfv2_fire/var/da/da_physics/da_integrat_dz.inc +++ b/wrfv2_fire/var/da/da_physics/da_integrat_dz.inc @@ -21,7 +21,7 @@ subroutine da_integrat_dz(grid) type (domain), intent(inout) :: grid - integer :: i, j, K + integer :: i, j, K, ij real :: pw @@ -29,6 +29,10 @@ subroutine da_integrat_dz(grid) ! weighted sum of vertical column + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij, i, j, pw) + do ij = 1, grid%num_tiles + do j=jts, jte do i=its, ite pw = 0.0 @@ -40,6 +44,9 @@ subroutine da_integrat_dz(grid) end do end do + end do + !$OMP END PARALLEL DO + if (trace_use) call da_trace_exit("da_integrat_dz") end subroutine da_integrat_dz diff --git a/wrfv2_fire/var/da/da_physics/da_transform_xtogpsref.inc b/wrfv2_fire/var/da/da_physics/da_transform_xtogpsref.inc index e70526b9..9fc5efb0 100644 --- a/wrfv2_fire/var/da/da_physics/da_transform_xtogpsref.inc +++ b/wrfv2_fire/var/da/da_physics/da_transform_xtogpsref.inc @@ -11,11 +11,15 @@ subroutine da_transform_xtogpsref(grid) type (domain), intent(inout) :: grid - integer :: i, j, k + integer :: i, j, k, ij real :: partone, parttwo, dividnd if (trace_use_dull) call da_trace_entry("da_transform_xtogpsref") + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k, partone, dividnd, parttwo) + do ij = 1 , grid%num_tiles + do k = kts, kte do j = jts, jte do i = its, ite @@ -38,6 +42,9 @@ subroutine da_transform_xtogpsref(grid) end do end do + end do + !$OMP END PARALLEL DO + if (trace_use_dull) call da_trace_exit("da_transform_xtogpsref") end subroutine da_transform_xtogpsref diff --git a/wrfv2_fire/var/da/da_physics/da_trh_to_td.inc b/wrfv2_fire/var/da/da_physics/da_trh_to_td.inc index f6883bde..a86a732d 100644 --- a/wrfv2_fire/var/da/da_physics/da_trh_to_td.inc +++ b/wrfv2_fire/var/da/da_physics/da_trh_to_td.inc @@ -1,4 +1,4 @@ -subroutine da_trh_to_td (rh, t, td) +subroutine da_trh_to_td (grid) !--------------------------------------------------------------------- ! @@ -45,40 +45,42 @@ subroutine da_trh_to_td (rh, t, td) implicit none - real, dimension(ims:ime,jms:jme,kms:kme), & - intent(inout) :: rh ! relative humidity. - real, dimension(ims:ime,jms:jme,kms:kme), & - intent(in) :: t ! temperature. - real, dimension(ims:ime,jms:jme,kms:kme), & - intent(out) :: td ! dew point in k. + type (domain), intent(inout) :: grid - integer :: i, j, k + integer :: i, j, k, ij real :: invdifftd, invtd if (trace_use_dull) call da_trace_entry("da_trh_to_td") - do j=jts,jte - do k=kts,kte + !$OMP PARALLEL DO & + !$OMP PRIVATE( ij, i, j, k, invdifftd, invtd ) + do ij = 1 , grid%num_tiles + + do k=kts,kte + do j=grid%j_start(ij), grid%j_end(ij) do i=its,ite - if (rh(i,j,k) < 10.0) then - rh(i,j,k) = 10.0 - else if (rh(i,j,k) > 105.0) then - rh(i,j,k) = 105.0 + if (grid%xb%rh(i,j,k) < 10.0) then + grid%xb%rh(i,j,k) = 10.0 + else if (grid%xb%rh(i,j,k) > 105.0) then + grid%xb%rh(i,j,k) = 105.0 end if - invdifftd = log (rh(i,j,k)/100.0) / l_over_rv + invdifftd = log (grid%xb%rh(i,j,k)/100.0) / l_over_rv - invtd = 1/t(i,j,k) - invdifftd + invtd = 1/grid%xb%t(i,j,k) - invdifftd - td(i,j,k) = 1.0 / invtd + grid%xb%td(i,j,k) = 1.0 / invtd - if (td(i,j,k) > t(i,j,k)) & - td(i,j,k) = t(i,j,k) + if (grid%xb%td(i,j,k) > grid%xb%t(i,j,k)) & + grid%xb%td(i,j,k) = grid%xb%t(i,j,k) end do end do end do + end do + !$OMP END PARALLEL DO + if (trace_use_dull) call da_trace_exit("da_trh_to_td") end subroutine da_trh_to_td diff --git a/wrfv2_fire/var/da/da_physics/da_wrf_tpq_2_slp.inc b/wrfv2_fire/var/da/da_physics/da_wrf_tpq_2_slp.inc index 0df932a3..e14c18fc 100644 --- a/wrfv2_fire/var/da/da_physics/da_wrf_tpq_2_slp.inc +++ b/wrfv2_fire/var/da/da_physics/da_wrf_tpq_2_slp.inc @@ -18,7 +18,7 @@ subroutine da_wrf_tpq_2_slp (grid) type (domain), intent(inout) :: grid - integer :: I, J, K, KLO, KHI + integer :: I, J, K, KLO, KHI, ij real :: PL, T0, TS, XTERM, & TLO, THI, TL @@ -37,7 +37,11 @@ subroutine da_wrf_tpq_2_slp (grid) ! compute pressure at pconst mb above surface (pl) - j_loop: do j=jts, jte + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij, i, j, k, PL, klo, khi, tlo, thi, tl, ts, t0) + do ij = 1, grid%num_tiles + + j_loop: do j=grid%j_start(ij), grid%j_end(ij) i_loop: do i=its, ite if (grid%xb%terr(i,j) <= 0.0) then grid%xb%slp(i,j) = grid%xb%psfc(i,j) @@ -92,6 +96,9 @@ subroutine da_wrf_tpq_2_slp (grid) end do i_loop end do j_loop + end do + !$OMP END PARALLEL DO + if (trace_use_dull) call da_trace_exit("da_wrf_tpq_2_slp") end subroutine da_wrf_tpq_2_slp diff --git a/wrfv2_fire/var/da/da_pilot/da_check_max_iv_pilot.inc b/wrfv2_fire/var/da/da_pilot/da_check_max_iv_pilot.inc index 0e049234..797495c4 100644 --- a/wrfv2_fire/var/da/da_pilot/da_check_max_iv_pilot.inc +++ b/wrfv2_fire/var/da/da_pilot/da_check_max_iv_pilot.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_pilot(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -23,35 +26,29 @@ subroutine da_check_max_iv_pilot(iv, it, num_qcstat_conv) do k = 1, iv%info(pilot)%levels(n) call da_get_print_lvl(iv%pilot(n)%p(k),ipr) - if( iv%pilot(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%pilot(n)%u(k)%qc =0 - if( iv%pilot(n)%u(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%pilot(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(pilot), n, iv%pilot(n)%u(k), max_error_uv,failed) if( iv%info(pilot)%proc_domain(k,n) ) then - num_qcstat_conv(1,pilot,1,ipr) = num_qcstat_conv(1,pilot,1,ipr) + 1 + num_qcstat_conv(1,pilot,1,ipr) = num_qcstat_conv(1,pilot,1,ipr) + 1 if(failed) then num_qcstat_conv(2,pilot,1,ipr) = num_qcstat_conv(2,pilot,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'pilot',ob_vars(1),iv%info(pilot)%lat(k,n),iv%info(pilot)%lon(k,n),0.01*iv%pilot(n)%p(k) end if end if - end if - if( iv%pilot(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%pilot(n)%v(k)%qc =0 - if( iv%pilot(n)%v(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%pilot(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(pilot), n, iv%pilot(n)%v(k), max_error_uv,failed) if( iv%info(pilot)%proc_domain(k,n) ) then - num_qcstat_conv(1,pilot,2,ipr) = num_qcstat_conv(1,pilot,2,ipr) + 1 + num_qcstat_conv(1,pilot,2,ipr) = num_qcstat_conv(1,pilot,2,ipr) + 1 if(failed)then num_qcstat_conv(2,pilot,2,ipr) = num_qcstat_conv(2,pilot,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'pilot',ob_vars(2),iv%info(pilot)%lat(k,n),iv%info(pilot)%lon(k,n),0.01*iv%pilot(n)%p(k) end if end if - end if end do end do diff --git a/wrfv2_fire/var/da/da_pilot/da_get_innov_vector_pilot.inc b/wrfv2_fire/var/da/da_pilot/da_get_innov_vector_pilot.inc index 20bb967b..49843430 100644 --- a/wrfv2_fire/var/da/da_pilot/da_get_innov_vector_pilot.inc +++ b/wrfv2_fire/var/da/da_pilot/da_get_innov_vector_pilot.inc @@ -34,6 +34,15 @@ subroutine da_get_innov_vector_pilot( it,num_qcstat_conv, grid, ob, iv) model_u(:,:) = 0.0 model_v(:,:) = 0.0 + if ( it > 1 ) then + do n=iv%info(pilot)%n1,iv%info(pilot)%n2 + do k=1, iv%info(pilot)%levels(n) + if (iv%pilot(n)%u(k)%qc == fails_error_max) iv%pilot(n)%u(k)%qc = 0 + if (iv%pilot(n)%v(k)%qc == fails_error_max) iv%pilot(n)%v(k)%qc = 0 + end do + end do + end if + do n=iv%info(pilot)%n1,iv%info(pilot)%n2 ! [1.3] Get horizontal interpolation weights: @@ -101,7 +110,8 @@ subroutine da_get_innov_vector_pilot( it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_pilot(iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_pilot(iv, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_polaramv/da_check_max_iv_polaramv.inc b/wrfv2_fire/var/da/da_polaramv/da_check_max_iv_polaramv.inc index 4613084e..ad18c8bf 100644 --- a/wrfv2_fire/var/da/da_polaramv/da_check_max_iv_polaramv.inc +++ b/wrfv2_fire/var/da/da_polaramv/da_check_max_iv_polaramv.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_polaramv(iv,it,num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -21,11 +24,9 @@ subroutine da_check_max_iv_polaramv(iv,it,num_qcstat_conv) do n = iv%info(polaramv)%n1,iv%info(polaramv)%n2 do k = 1, iv%info(polaramv)%levels(n) - if( iv%polaramv(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%polaramv(n)%u(k)%qc =0 call da_get_print_lvl(iv%polaramv(n)%p(k),ipr) - if( iv%polaramv(n)%u(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%polaramv(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(polaramv), n, iv%polaramv(n)%u(k), max_error_uv,failed) if( iv%info(polaramv)%proc_domain(k,n) ) then num_qcstat_conv(1,polaramv,1,ipr) = num_qcstat_conv(1,polaramv,1,ipr) + 1 @@ -35,12 +36,9 @@ subroutine da_check_max_iv_polaramv(iv,it,num_qcstat_conv) 'polaramv',ob_vars(1),iv%info(polaramv)%lat(k,n),iv%info(polaramv)%lon(k,n),0.01*iv%polaramv(n)%p(k) end if end if - end if - if( iv%polaramv(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%polaramv(n)%v(k)%qc =0 - if( iv%polaramv(n)%v(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%polaramv(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(polaramv), n, iv%polaramv(n)%v(k), max_error_uv,failed) if( iv%info(polaramv)%proc_domain(k,n) ) then num_qcstat_conv(1,polaramv,2,ipr) = num_qcstat_conv(1,polaramv,2,ipr) + 1 @@ -50,7 +48,6 @@ subroutine da_check_max_iv_polaramv(iv,it,num_qcstat_conv) 'polaramv',ob_vars(2),iv%info(polaramv)%lat(k,n),iv%info(polaramv)%lon(k,n),0.01*iv%polaramv(n)%p(k) end if end if - end if end do end do diff --git a/wrfv2_fire/var/da/da_polaramv/da_get_innov_vector_polaramv.inc b/wrfv2_fire/var/da/da_polaramv/da_get_innov_vector_polaramv.inc index 34c776e6..bc2a0da9 100644 --- a/wrfv2_fire/var/da/da_polaramv/da_get_innov_vector_polaramv.inc +++ b/wrfv2_fire/var/da/da_polaramv/da_get_innov_vector_polaramv.inc @@ -34,6 +34,15 @@ subroutine da_get_innov_vector_polaramv( it, num_qcstat_conv, grid, ob, iv) model_u(:,:) = 0.0 model_v(:,:) = 0.0 + if( it > 1 ) then + do n=iv%info(polaramv)%n1, iv%info(polaramv)%n2 + do k=1, iv%info(polaramv)%levels(n) + if (iv%polaramv(n)%u(k)%qc == fails_error_max) iv%polaramv(n)%u(k)%qc = 0 + if (iv%polaramv(n)%v(k)%qc == fails_error_max) iv%polaramv(n)%v(k)%qc = 0 + end do + end do + end if + do n=iv%info(polaramv)%n1, iv%info(polaramv)%n2 if (iv%info(polaramv)%levels(n) < 1) cycle @@ -113,7 +122,8 @@ subroutine da_get_innov_vector_polaramv( it, num_qcstat_conv, grid, ob, iv) ! Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_polaramv(iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_polaramv(iv, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_profiler/da_check_max_iv_profiler.inc b/wrfv2_fire/var/da/da_profiler/da_check_max_iv_profiler.inc index efe81688..325cdf68 100644 --- a/wrfv2_fire/var/da/da_profiler/da_check_max_iv_profiler.inc +++ b/wrfv2_fire/var/da/da_profiler/da_check_max_iv_profiler.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_profiler(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -24,35 +27,29 @@ subroutine da_check_max_iv_profiler(iv, it, num_qcstat_conv) call da_get_print_lvl(iv%profiler(n)%p(k),ipr) - if( iv%profiler(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%profiler(n)%u(k)%qc =0 - if( iv%profiler(n)%u(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%profiler(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(profiler), n, iv%profiler(n)%u(k), max_error_uv, failed) if( iv%info(profiler)%proc_domain(k,n) ) then - num_qcstat_conv(1,profiler,1,ipr) = num_qcstat_conv(1,profiler,1,ipr) + 1 + num_qcstat_conv(1,profiler,1,ipr) = num_qcstat_conv(1,profiler,1,ipr) + 1 if(failed)then num_qcstat_conv(2,profiler,1,ipr) = num_qcstat_conv(2,profiler,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'profiler',ob_vars(1),iv%info(profiler)%lat(k,n),iv%info(profiler)%lon(k,n),0.01*iv%profiler(n)%p(k) end if end if - end if - if( iv%profiler(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%profiler(n)%v(k)%qc =0 - if( iv%profiler(n)%v(k)%qc >= obs_qc_pointer ) then - failed=.false. - if( check_max_iv) & + failed=.false. + if( iv%profiler(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(profiler), n, iv%profiler(n)%v(k), max_error_uv, failed) if( iv%info(profiler)%proc_domain(k,n) ) then - num_qcstat_conv(1,profiler,2,ipr) = num_qcstat_conv(1,profiler,2,ipr) + 1 + num_qcstat_conv(1,profiler,2,ipr) = num_qcstat_conv(1,profiler,2,ipr) + 1 if(failed)then num_qcstat_conv(2,profiler,2,ipr) = num_qcstat_conv(2,profiler,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'profiler',ob_vars(2),iv%info(profiler)%lat(k,n),iv%info(profiler)%lon(k,n),0.01*iv%profiler(n)%p(k) end if end if - end if end do end do diff --git a/wrfv2_fire/var/da/da_profiler/da_get_innov_vector_profiler.inc b/wrfv2_fire/var/da/da_profiler/da_get_innov_vector_profiler.inc index 0854436d..999d3b8b 100644 --- a/wrfv2_fire/var/da/da_profiler/da_get_innov_vector_profiler.inc +++ b/wrfv2_fire/var/da/da_profiler/da_get_innov_vector_profiler.inc @@ -38,6 +38,15 @@ subroutine da_get_innov_vector_profiler( it,num_qcstat_conv, grid, ob, iv) model_u(:,:) = 0.0 model_v(:,:) = 0.0 + if ( it > 1 ) then + do n=iv%info(profiler)%n1,iv%info(profiler)%n2 + do k = 1, iv%info(profiler)%levels(n) + if (iv%profiler(n)%u(k)%qc == fails_error_max) iv%profiler(n)%u(k)%qc = 0 + if (iv%profiler(n)%v(k)%qc == fails_error_max) iv%profiler(n)%v(k)%qc = 0 + end do + end do + end if + do n=iv%info(profiler)%n1,iv%info(profiler)%n2 ! [1.3] Get horizontal interpolation weights: @@ -110,7 +119,8 @@ subroutine da_get_innov_vector_profiler( it,num_qcstat_conv, grid, ob, iv) end do - call da_check_max_iv_profiler(iv, it,num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_profiler(iv, it,num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_pseudo/da_ao_stats_pseudo.inc b/wrfv2_fire/var/da/da_pseudo/da_ao_stats_pseudo.inc index cbd14b64..1572603d 100644 --- a/wrfv2_fire/var/da/da_pseudo/da_ao_stats_pseudo.inc +++ b/wrfv2_fire/var/da/da_pseudo/da_ao_stats_pseudo.inc @@ -98,6 +98,7 @@ subroutine da_ao_stats_pseudo (stats_unit, iv, re) call da_proc_sum_int (nt) call da_proc_sum_int (np) call da_proc_sum_int (nq) + iv%nstats(pseudo) = nu + nv + nt + np + nq call da_proc_stats_combine(stats%average%u, stats%rms_err%u, & stats%minimum%u%value, stats%maximum%u%value, & diff --git a/wrfv2_fire/var/da/da_pseudo/da_get_innov_vector_pseudo.inc b/wrfv2_fire/var/da/da_pseudo/da_get_innov_vector_pseudo.inc index d21091b3..d7503d95 100644 --- a/wrfv2_fire/var/da/da_pseudo/da_get_innov_vector_pseudo.inc +++ b/wrfv2_fire/var/da/da_pseudo/da_get_innov_vector_pseudo.inc @@ -45,17 +45,38 @@ subroutine da_get_innov_vector_pseudo(grid, ob, iv) ! [3.0] Calculate observation O = B +(O-B): !--------------------------------------------------------------- - if (pseudo_var(1:1) == 'u' .or. pseudo_var(1:1) == 'U') then - ob % pseudo(n) % u = model_u(1,n) + iv % pseudo(n) % u % inv - else if (pseudo_var(1:1) == 'v' .or. pseudo_var(1:1) == 'V') then - ob % pseudo(n) % v = model_v(1,n) + iv % pseudo(n) % v % inv - else if (pseudo_var(1:1) == 't' .or. pseudo_var(1:1) == 'T') then - ob % pseudo(n) % t = model_t(1,n) + iv % pseudo(n) % t % inv - else if (pseudo_var(1:1) == 'p' .or. pseudo_var(1:1) == 'P') then - ob % pseudo(n) % p = model_p(1,n) + iv % pseudo(n) % p % inv - else if (pseudo_var(1:1) == 'q' .or. pseudo_var(1:1) == 'Q') then - ob % pseudo(n) % q = model_q(1,n) + iv % pseudo(n) % q % inv - end if + select case(pseudo_var(1:1)) + case ('u', 'U') + if (ob % pseudo(n) % u > missing_r) then + iv % pseudo(n) % u % inv = ob%pseudo(n)%u - model_u(1,n) + else + ob % pseudo(n) % u = model_u(1,n) + iv % pseudo(n) % u % inv + endif + case ('v', 'V') + if (ob % pseudo(n) % v > missing_r) then + iv % pseudo(n) % v % inv = ob%pseudo(n)%v - model_v(1,n) + else + ob % pseudo(n) % v = model_v(1,n) + iv % pseudo(n) % v % inv + endif + case ('t', 'T') + if (ob % pseudo(n) % t > missing_r) then + iv % pseudo(n) % t % inv = ob%pseudo(n)%t - model_t(1,n) + else + ob % pseudo(n) % t = model_t(1,n) + iv % pseudo(n) % t % inv + endif + case ('p', 'P') + if (ob % pseudo(n) % p > missing_r) then + iv % pseudo(n) % p % inv = ob%pseudo(n)%p - model_p(1,n) + else + ob % pseudo(n) % p = model_p(1,n) + iv % pseudo(n) % p % inv + endif + case ('q', 'Q') + if (ob % pseudo(n) % q > missing_r) then + iv % pseudo(n) % q % inv = ob%pseudo(n)%q - model_q(1,n) + else + ob % pseudo(n) % q = model_q(1,n) + iv % pseudo(n) % q % inv + endif + end select end do deallocate (model_u) diff --git a/wrfv2_fire/var/da/da_qscat/da_check_max_iv_qscat.inc b/wrfv2_fire/var/da/da_qscat/da_check_max_iv_qscat.inc index 2e58f368..28ea027f 100644 --- a/wrfv2_fire/var/da/da_qscat/da_check_max_iv_qscat.inc +++ b/wrfv2_fire/var/da/da_qscat/da_check_max_iv_qscat.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_qscat(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -20,10 +23,8 @@ subroutine da_check_max_iv_qscat(iv, it, num_qcstat_conv) !--------------------------------------------------------------------------- do n=iv%info(qscat)%n1,iv%info(qscat)%n2 - if( iv%qscat(n)%u%qc == fails_error_max .and. it > 1 )iv%qscat(n)%u%qc =0 - if( iv%qscat(n)%u%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%qscat(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(qscat), n, iv%qscat(n)%u, max_error_uv, failed) if( iv%info(qscat)%proc_domain(1,n) ) then num_qcstat_conv(1,qscat,1,1) = num_qcstat_conv(1,qscat,1,1) + 1 @@ -33,11 +34,9 @@ subroutine da_check_max_iv_qscat(iv, it, num_qcstat_conv) 'qscat',ob_vars(1),iv%info(qscat)%lat(1,n),iv%info(qscat)%lon(1,n),'1013.25' end if end if - end if - if( iv%qscat(n)%v%qc == fails_error_max .and. it > 1 )iv%qscat(n)%v%qc =0 - if( iv%qscat(n)%v%qc >= obs_qc_pointer ) then + failed=.false. - if( check_max_iv) & + if( iv%qscat(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc(it, iv%info(qscat), n, iv%qscat(n)%v, max_error_uv, failed) if( iv%info(qscat)%proc_domain(1,n) ) then num_qcstat_conv(1,qscat,2,1) = num_qcstat_conv(1,qscat,2,1) + 1 @@ -47,7 +46,6 @@ subroutine da_check_max_iv_qscat(iv, it, num_qcstat_conv) 'qscat',ob_vars(2),iv%info(qscat)%lat(1,n),iv%info(qscat)%lon(1,n),'1013.25' end if end if - end if end do if (trace_use_dull) call da_trace_exit("da_check_max_iv_qscat") diff --git a/wrfv2_fire/var/da/da_qscat/da_get_innov_vector_qscat.inc b/wrfv2_fire/var/da/da_qscat/da_get_innov_vector_qscat.inc index 23b6bb22..33acf757 100644 --- a/wrfv2_fire/var/da/da_qscat/da_get_innov_vector_qscat.inc +++ b/wrfv2_fire/var/da/da_qscat/da_get_innov_vector_qscat.inc @@ -29,6 +29,13 @@ subroutine da_get_innov_vector_qscat (it,num_qcstat_conv, grid, ob, iv) allocate (model_u(iv%info(qscat)%max_lev,iv%info(qscat)%n1:iv%info(qscat)%n2)) allocate (model_v(iv%info(qscat)%max_lev,iv%info(qscat)%n1:iv%info(qscat)%n2)) + if ( it > 1 ) then + do n=iv%info(qscat)%n1,iv%info(qscat)%n2 + if (iv%qscat(n)%u%qc == fails_error_max) iv%qscat(n)%u%qc = 0 + if (iv%qscat(n)%v%qc == fails_error_max) iv%qscat(n)%v%qc = 0 + end do + end if + do n=iv%info(qscat)%n1,iv%info(qscat)%n2 ! [1.1] Get horizontal interpolation weights: @@ -96,10 +103,11 @@ subroutine da_get_innov_vector_qscat (it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_qscat(iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_qscat(iv, it, num_qcstat_conv) - deallocate (model_u) - deallocate (model_v) + deallocate (model_u) + deallocate (model_v) if (trace_use_dull) call da_trace_exit("da_get_innov_vector_qscat") diff --git a/wrfv2_fire/var/da/da_radar/da_get_innov_vector_radar.inc b/wrfv2_fire/var/da/da_radar/da_get_innov_vector_radar.inc index 895e99e1..4b7ff182 100644 --- a/wrfv2_fire/var/da/da_radar/da_get_innov_vector_radar.inc +++ b/wrfv2_fire/var/da/da_radar/da_get_innov_vector_radar.inc @@ -58,6 +58,15 @@ subroutine da_get_innov_vector_radar (it, grid, ob, iv) model_rf(:,:) = 0 model_ps(:) = 0 + if ( it > 1 ) then + do n=iv%info(radar)%n1,iv%info(radar)%n2 + do k=1,iv%info(radar)%levels(n) + if (iv%radar(n)%rv(k)%qc == fails_error_max) iv%radar(n)%rv(k)%qc = 0 + if (iv%radar(n)%rf(k)%qc == fails_error_max) iv%radar(n)%rf(k)%qc = 0 + end do + end do + end if + do n=iv%info(radar)%n1,iv%info(radar)%n2 if (iv%info(radar)%levels(n) < 1) cycle diff --git a/wrfv2_fire/var/da/da_radar/da_radar.f90 b/wrfv2_fire/var/da/da_radar/da_radar.f90 index eab33b7d..5f4efc04 100644 --- a/wrfv2_fire/var/da/da_radar/da_radar.f90 +++ b/wrfv2_fire/var/da/da_radar/da_radar.f90 @@ -11,7 +11,8 @@ module da_radar use_radar_rv, use_radar_rf,below_model_surface,mkz,above_model_lid,& fg_format,fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional,fg_format_wrf_arw_global,& fg_format_kma_global,max_error_rv,max_error_rf, & - far_below_model_surface,kms,kme,kts,kte, trace_use_dull + far_below_model_surface,kms,kme,kts,kte, trace_use_dull,filename_len,& + myproc use da_define_structures, only : maxmin_type, iv_type, y_type, jo_type, & bad_data_type, x_type, number_type, bad_data_type, & infa_type, field_type @@ -21,6 +22,8 @@ module da_radar use da_statistics, only : da_stats_calculate use da_tools, only : da_residual, map_info, da_llxy_wrf, da_llxy_default, da_convert_zk use da_tracing, only : da_trace_entry, da_trace_exit + use da_reporting, only : da_error + use da_tools_serial, only : da_get_unit, da_free_unit ! The "stats_radar_type" is ONLY used locally in da_radar: @@ -58,6 +61,7 @@ contains #include "da_radial_velocity_adj.inc" #include "da_calculate_grady_radar.inc" #include "da_max_error_qc_radar.inc" +#include "da_write_oa_radar_ascii.inc" end module da_radar diff --git a/wrfv2_fire/var/da/da_radiance/da_allocate_rad_iv.inc b/wrfv2_fire/var/da/da_radiance/da_allocate_rad_iv.inc index e8416eff..6761e56a 100644 --- a/wrfv2_fire/var/da/da_radiance/da_allocate_rad_iv.inc +++ b/wrfv2_fire/var/da/da_radiance/da_allocate_rad_iv.inc @@ -98,6 +98,7 @@ subroutine da_allocate_rad_iv (i, nchan, iv) allocate(iv%instid(i)%snow_coverage(iv%instid(i)%num_rad)) if (use_crtm_kmatrix) then allocate(iv%instid(i)%ts_jacobian(nchan,iv%instid(i)%num_rad)) + allocate(iv%instid(i)%ps_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%windspeed_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%emiss_jacobian(nchan,iv%instid(i)%num_rad)) allocate(iv%instid(i)%gamma_jacobian(nchan,iv%instid(i)%num_rad)) diff --git a/wrfv2_fire/var/da/da_radiance/da_cloud_sim_airs.inc b/wrfv2_fire/var/da/da_radiance/da_cloud_sim_airs.inc index b97ae3c6..a729aaeb 100644 --- a/wrfv2_fire/var/da/da_radiance/da_cloud_sim_airs.inc +++ b/wrfv2_fire/var/da/da_radiance/da_cloud_sim_airs.inc @@ -92,6 +92,6 @@ double precision :: zx(KDIM), zgx(KDIM, KDIM), zx_eof(KDIM) WHERE (ZX<0.0) PG = PG + alpha*ZX !write(*,'(a,2f10.2,50f6.1)') 'ACD_PX',PF,sqrt(sum(pg**2)),sum(px(1:kdim-1))*100.,PX*100. -write(*,'(a,2f10.5,f10.2,50f7.2)') '888888 ',PF,sqrt(sum(pg**2)),sum(zx(1:kdim-1))*100.,ZX*100. +!write(*,'(a,2f10.5,f10.2,50f7.2)') '888888 ',PF,sqrt(sum(pg**2)),sum(zx(1:kdim-1))*100.,ZX*100. end subroutine da_cloud_sim_airs diff --git a/wrfv2_fire/var/da/da_radiance/da_crtm.f90 b/wrfv2_fire/var/da/da_radiance/da_crtm.f90 index baf6aaf1..625b67ec 100644 --- a/wrfv2_fire/var/da/da_radiance/da_crtm.f90 +++ b/wrfv2_fire/var/da/da_radiance/da_crtm.f90 @@ -46,7 +46,7 @@ module da_crtm use da_tools, only: da_get_time_slots, da_eof_decomposition use da_tracing, only : da_trace_entry, da_trace_exit - TYPE (CRTM_ChannelInfo_type), allocatable, save :: ChannelInfo(:) + TYPE (CRTM_ChannelInfo_type), allocatable, save :: ChannelInfo(:) contains diff --git a/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_crtm.inc b/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_crtm.inc index b84b2d1f..bf9ab465 100644 --- a/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_crtm.inc +++ b/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_crtm.inc @@ -319,7 +319,7 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) Atmosphere(1)%Pressure(kte-k+1) = 0.01 * p(1) ! convert Pa to hPa Atmosphere(1)%Temperature(kte-k+1) = t(1) - Atmosphere(1)%Absorber(kte-k+1,1) = 1000.0 * a(1) ! in g/kg + Atmosphere(1)%Absorber(kte-k+1,1) = 1000.0 * a(1)/(1.0-a(1)) ! in g/kg mixing ratio ! NOTE: WRF high-level q values seems too big, replaced by constants if (p(1)*0.01 < 75.0) Atmosphere(1)%Absorber(kte-k+1,1) = 0.001 @@ -611,6 +611,12 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) !---------------------------------------------------------------- ! full level pressures iv%instid(inst)%pf(0,n) = Atmosphere(1)%level_pressure(0) + if (use_crtm_kmatrix) then + ! PS Jacobian + do l=1,nchanl + iv%instid(inst)%ps_jacobian(l,n) = Atmosphere_k(l,1)%level_pressure(Atmosphere(1)%n_layers) + end do + end if do k=1,Atmosphere(1)%n_layers iv%instid(inst)%pm(k,n) = Atmosphere(1)%pressure(k) iv%instid(inst)%pf(k,n) = Atmosphere(1)%level_pressure(k) @@ -624,8 +630,10 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) iv%instid(inst)%q_jacobian(l,k,n) = Atmosphere_k(l,1)%absorber(k,1) end do end if + end do - if (crtm_cloud) then + if (crtm_cloud) then + do k=1,Atmosphere(1)%n_layers iv%instid(inst)%qcw(k,n) = Atmosphere(1)%cloud(1)%water_content(k) iv%instid(inst)%qci(k,n) = Atmosphere(1)%cloud(2)%water_content(k) iv%instid(inst)%qrn(k,n) = Atmosphere(1)%cloud(3)%water_content(k) @@ -669,8 +677,8 @@ subroutine da_get_innov_vector_crtm ( it, grid, ob, iv ) Atmosphere_k(l,1)%cloud(6)%effective_radius(k) end do end if - end if - end do + end do + end if !---------------------------------------------- ! [4.0] store surface information to innovation structure diff --git a/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_radiance.inc b/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_radiance.inc index 69049481..e9b69979 100644 --- a/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_radiance.inc +++ b/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_radiance.inc @@ -63,13 +63,13 @@ subroutine da_get_innov_vector_radiance (it, grid, ob, iv) ! [3.0] Perform QC check !------------------------------------------------------------------------ if (qc_rad) then - call da_qc_rad(ob, iv) + call da_qc_rad(it, ob, iv) end if !------------------------------------------------------------------------ ! [4.0] Compute preconditioning for Variational bias correction !------------------------------------------------------------------------ - if (use_varbc) call da_varbc_precond(iv) + if (use_varbc .and. it == 1) call da_varbc_precond(iv) !------------------------------------------------------------------------ ! [5.0] Prepare (QCed) bias statistics files diff --git a/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_rttov.inc b/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_rttov.inc index b9707ee4..afabf4b8 100644 --- a/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_rttov.inc +++ b/wrfv2_fire/var/da/da_radiance/da_get_innov_vector_rttov.inc @@ -288,6 +288,8 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) iv%instid(inst)%v10) end if + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n, temp, temp2, temp3 ) do n=n1,n2 con_vars(n) % nlevels = nlevels allocate (con_vars(n) % t(nlevels)) @@ -328,6 +330,7 @@ real,allocatable :: temp(:), temp2(:), temp3(:,:) deallocate(temp,temp2,temp3) end do + !$OMP END PARALLEL DO if (iv%instid(inst)%nchannels > nchan) then iv%instid(inst)%emiss(nchan+1:iv%instid(inst)%nchannels,n1:n2) = 0.0 diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_airs.inc b/wrfv2_fire/var/da/da_radiance/da_qc_airs.inc index f22a0087..983115b0 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_airs.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_airs.inc @@ -1,4 +1,4 @@ -subroutine da_qc_airs (i, nchan, ob, iv) +subroutine da_qc_airs (it, i, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for AQUA/EOS-2-AIRS data. @@ -6,6 +6,7 @@ subroutine da_qc_airs (i, nchan, ob, iv) implicit none + integer, intent(in) :: it ! outer loop count integer, intent(in) :: i ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. @@ -335,9 +336,9 @@ subroutine da_qc_airs (i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(a,i2.2)') 'qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - filename = 'qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_amsua.inc b/wrfv2_fire/var/da/da_radiance/da_qc_amsua.inc index 28cfecf2..bdc321e8 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_amsua.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_amsua.inc @@ -1,4 +1,4 @@ -subroutine da_qc_amsua (i, nchan, ob, iv) +subroutine da_qc_amsua (it, i, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for amsua data. @@ -6,6 +6,7 @@ subroutine da_qc_amsua (i, nchan, ob, iv) implicit none + integer, intent(in) :: it ! outer loop count integer, intent(in) :: i ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. @@ -193,9 +194,9 @@ subroutine da_qc_amsua (i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(a,i2.2)') 'qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - filename = 'qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_amsub.inc b/wrfv2_fire/var/da/da_radiance/da_qc_amsub.inc index 0f2b22b0..6173607d 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_amsub.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_amsub.inc @@ -1,4 +1,4 @@ -subroutine da_qc_amsub (i, nchan, ob, iv) +subroutine da_qc_amsub (it, i, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for amsub data. @@ -6,6 +6,7 @@ subroutine da_qc_amsub (i, nchan, ob, iv) implicit none + integer, intent(in) :: it ! outer loop count integer, intent(in) :: i ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. @@ -181,9 +182,9 @@ subroutine da_qc_amsub (i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(a,i2.2)') 'qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - filename = 'qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) open(fgat_rad_unit,file=trim(filename),form='formatted',iostat=ios) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_crtm.inc b/wrfv2_fire/var/da/da_radiance/da_qc_crtm.inc index 120c1c7a..5874d15a 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_crtm.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_crtm.inc @@ -1,4 +1,4 @@ -subroutine da_qc_crtm (ob, iv) +subroutine da_qc_crtm (it, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for radiance data. @@ -8,6 +8,7 @@ subroutine da_qc_crtm (ob, iv) implicit none + integer , intent(in) :: it type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(inout) :: iv ! O-B structure. @@ -18,6 +19,9 @@ subroutine da_qc_crtm (ob, iv) #ifdef CRTM do i = 1, iv%num_inst + + !if (iv%instid(i)%info%n2 < iv%instid(i)%info%n1) cycle + nchan = iv%instid(i)%nchan amsua = trim(rttov_inst_name(rtminit_sensor(i))) == 'amsua' @@ -30,23 +34,23 @@ subroutine da_qc_crtm (ob, iv) mhs = trim(rttov_inst_name(rtminit_sensor(i))) == 'mhs' if (hirs) then - call da_qc_hirs(i,nchan,ob,iv) + call da_qc_hirs(it, i,nchan,ob,iv) else if (airs) then - call da_qc_airs(i,nchan,ob,iv) + call da_qc_airs(it, i,nchan,ob,iv) else if ( hsb ) then - ! call da_qc_hsb(i,nchan,ob,iv) + ! call da_qc_hsb(it, i,nchan,ob,iv) call da_warning(__FILE__,__LINE__,(/'QC Not implemented for HSB'/)) else if (amsua) then - call da_qc_amsua(i,nchan,ob,iv) + call da_qc_amsua(it,i,nchan,ob,iv) else if ( amsub ) then - call da_qc_amsub(i,nchan,ob,iv) + call da_qc_amsub(it,i,nchan,ob,iv) else if (msu) then - ! call da_qc_msu(i,nchan, ob,iv) + ! call da_qc_msu(it, i,nchan, ob,iv) call da_warning(__FILE__,__LINE__,(/'QC Not implemented for MSU'/)) else if (ssmis) then - call da_qc_ssmis(i,nchan,ob,iv) + call da_qc_ssmis(it, i,nchan,ob,iv) else if (mhs) then - call da_qc_mhs(i,nchan,ob,iv) + call da_qc_mhs(it,i,nchan,ob,iv) else write(unit=message(1),fmt='(A,A)') & "Unrecognized instrument",trim(rttov_inst_name(rtminit_sensor(i))) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_hirs.inc b/wrfv2_fire/var/da/da_radiance/da_qc_hirs.inc index 55b8d43c..aaa23db0 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_hirs.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_hirs.inc @@ -1,4 +1,4 @@ -subroutine da_qc_hirs (i, nchan, ob, iv) +subroutine da_qc_hirs (it, i, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for HIRS data. @@ -6,6 +6,7 @@ subroutine da_qc_hirs (i, nchan, ob, iv) implicit none + integer, intent(in) :: it ! outer loop count integer, intent(in) :: i ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. @@ -163,9 +164,9 @@ subroutine da_qc_hirs (i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(a,i2.2)') 'qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - filename = 'qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_mhs.inc b/wrfv2_fire/var/da/da_radiance/da_qc_mhs.inc index b98ccbc5..9ae243c7 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_mhs.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_mhs.inc @@ -1,4 +1,4 @@ -subroutine da_qc_mhs (i, nchan, ob, iv) +subroutine da_qc_mhs (it, i, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for mhs data. @@ -6,6 +6,7 @@ subroutine da_qc_mhs (i, nchan, ob, iv) implicit none + integer, intent(in) :: it ! outer loop count integer, intent(in) :: i ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. @@ -173,9 +174,9 @@ subroutine da_qc_mhs (i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(a,i2.2)') 'qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - filename = 'qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it, '_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) open(fgat_rad_unit,file=trim(filename),form='formatted',iostat=ios) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_rad.inc b/wrfv2_fire/var/da/da_radiance/da_qc_rad.inc index 338f682e..da5ddfcd 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_rad.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_rad.inc @@ -1,4 +1,4 @@ -subroutine da_qc_rad (ob, iv) +subroutine da_qc_rad (it, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for radiance data. @@ -8,6 +8,7 @@ subroutine da_qc_rad (ob, iv) implicit none + integer , intent(in) :: it ! outer loop count type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(inout) :: iv ! O-B structure. @@ -42,6 +43,9 @@ subroutine da_qc_rad (ob, iv) if ( .not. allocated(spare_count) ) allocate (spare_count(num_procs)) do i = 1, iv%num_inst + + !if (iv%instid(i)%info%n2 < iv%instid(i)%info%n1) cycle + nchan = iv%instid(i)%nchan amsua = trim(rttov_inst_name(rtminit_sensor(i))) == 'amsua' @@ -55,23 +59,23 @@ subroutine da_qc_rad (ob, iv) if (hirs) then ! 1.0 QC for HIRS - call da_qc_hirs(i,nchan,ob,iv) + call da_qc_hirs(it, i,nchan,ob,iv) else if (airs) then - call da_qc_airs(i,nchan,ob,iv) + call da_qc_airs(it, i,nchan,ob,iv) else if ( hsb ) then - ! call da_qc_hsb(i,nchan,ob,iv) + ! call da_qc_hsb(it, i,nchan,ob,iv) call da_warning(__FILE__,__LINE__,(/'QC Not implemented for HSB'/)) else if (amsua) then - call da_qc_amsua(i,nchan,ob,iv) + call da_qc_amsua(it,i,nchan,ob,iv) else if ( amsub ) then - call da_qc_amsub(i,nchan,ob,iv) + call da_qc_amsub(it,i,nchan,ob,iv) else if (msu) then - ! call da_qc_msu(i,nchan, ob,iv) + ! call da_qc_msu(it, i,nchan, ob,iv) call da_warning(__FILE__,__LINE__,(/'QC Not implemented for MSU'/)) else if (ssmis) then - call da_qc_ssmis(i,nchan,ob,iv) + call da_qc_ssmis(it, i,nchan,ob,iv) else if (mhs) then - call da_qc_mhs(i,nchan,ob,iv) + call da_qc_mhs(it,i,nchan,ob,iv) else write(unit=message(1),fmt='(A,A)') & "Unrecognized instrument",trim(rttov_inst_name(rtminit_sensor(i))) diff --git a/wrfv2_fire/var/da/da_radiance/da_qc_ssmis.inc b/wrfv2_fire/var/da/da_radiance/da_qc_ssmis.inc index aed468bc..88a21aae 100644 --- a/wrfv2_fire/var/da/da_radiance/da_qc_ssmis.inc +++ b/wrfv2_fire/var/da/da_radiance/da_qc_ssmis.inc @@ -1,4 +1,4 @@ -subroutine da_qc_ssmis (i, nchan, ob, iv) +subroutine da_qc_ssmis (it,i, nchan, ob, iv) !--------------------------------------------------------------------------- ! Purpose: perform quality control for ssmis data. @@ -6,6 +6,7 @@ subroutine da_qc_ssmis (i, nchan, ob, iv) implicit none + integer, intent(in) :: it ! outer loop count integer, intent(in) :: i ! sensor index. integer, intent(in) :: nchan ! number of channel type (y_type), intent(in) :: ob ! Observation structure. @@ -195,9 +196,9 @@ subroutine da_qc_ssmis (i, nchan, ob, iv) if (rootproc) then if (num_fgat_time > 1) then - write(filename,'(a,i2.2)') 'qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time + write(filename,'(i2.2,a,i2.2)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string)//'_',iv%time else - filename = 'qcstat_'//trim(iv%instid(i)%rttovid_string) + write(filename,'(i2.2,a)') it,'_qcstat_'//trim(iv%instid(i)%rttovid_string) end if call da_get_unit(fgat_rad_unit) diff --git a/wrfv2_fire/var/da/da_radiance/da_read_obs_bufrairs.inc b/wrfv2_fire/var/da/da_radiance/da_read_obs_bufrairs.inc index acf5526d..c823700c 100644 --- a/wrfv2_fire/var/da/da_radiance/da_read_obs_bufrairs.inc +++ b/wrfv2_fire/var/da/da_radiance/da_read_obs_bufrairs.inc @@ -82,7 +82,7 @@ subroutine da_read_obs_bufrairs(obstype,iv,infile) real(r_double) :: acqf ! Channel quality flags for ATOVS real(r_double) :: tmbrst ! Brightness temperature end type airschan_list - real(r_double), dimension(1:N_AIRSCHAN_LIST) :: airschan_list_array + real(r_double), dimension(1:N_AIRSCHAN_LIST,1:N_MAXCHAN) :: airschan_list_array ! BUFR talble file sequencial number character(len=512) :: table_file @@ -326,11 +326,12 @@ subroutine da_read_obs_bufrairs(obstype,iv,infile) else call ufbseq(lnbufr,airschan_list_array,N_AIRSCHAN_LIST,N_MAXCHAN,iret,channame) end if - airschan = airschan_list( airschan_list_array(1), & - airschan_list_array(2), & - airschan_list_array(3), & - airschan_list_array(4) ) - + do l = 1 , N_MAXCHAN + airschan(l) = airschan_list( airschan_list_array(1,l), & + airschan_list_array(2,l), & + airschan_list_array(3,l), & + airschan_list_array(4,l) ) + end do if (iret /= nchanr) then write(unit=message(1),fmt=*) & diff --git a/wrfv2_fire/var/da/da_radiance/da_setup_radiance_structures.inc b/wrfv2_fire/var/da/da_radiance/da_setup_radiance_structures.inc index 0c88205d..aad50014 100644 --- a/wrfv2_fire/var/da/da_radiance/da_setup_radiance_structures.inc +++ b/wrfv2_fire/var/da/da_radiance/da_setup_radiance_structures.inc @@ -43,10 +43,10 @@ subroutine da_setup_radiance_structures( grid, ob, iv ) rlon_min = r999 rlon_max = -r999 - istart=grid%i_start(1) - iend =grid%i_end (1) - jstart=grid%j_start(1) - jend =grid%j_end (1) + istart=MINVAL( grid%i_start(1:grid%num_tiles) ) + iend =MAXVAL( grid%i_end (1:grid%num_tiles) ) + jstart=MINVAL( grid%j_start(1:grid%num_tiles) ) + jend =MAXVAL( grid%j_end (1:grid%num_tiles) ) do i = istart, iend do j = jstart, jend diff --git a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm.inc b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm.inc index 3903317a..438319d3 100644 --- a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm.inc +++ b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm.inc @@ -25,12 +25,12 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) integer, parameter :: AIRS_Max_Channels = 281 #ifdef CRTM - integer :: k ! Index dimension. + integer :: k, l ! Index dimension. integer :: inst, num_rad, nchanl, n, icld integer :: ipred, npred, gammapred, id real, allocatable :: temperature(:,:) - real, allocatable :: absorber(:,:) + real, allocatable :: absorber(:,:), xb_q(:,:) real, allocatable :: psfc(:) !! for crtm_cloud real, allocatable :: qcw(:,:),qci(:,:),qrn(:,:),qsn(:,:),qgr(:,:) @@ -38,10 +38,10 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) ! CRTM local variables and types integer :: wmo_sensor_id, Error_Status, Allocate_Status type( CRTM_RTSolution_type ), ALLOCATABLE :: RTSolution(:,:),RTSolution_TL(:,:) - type( CRTM_Atmosphere_type ) :: Atmosphere(1), Atmosphere_TL(1) - type( CRTM_Surface_type ) :: Surface(1), Surface_TL(1) - type( CRTM_GeometryInfo_type ) :: GeometryInfo(1) - type( CRTM_Options_type ) :: Options(1) + type( CRTM_Atmosphere_type ), allocatable :: Atmosphere(:), Atmosphere_TL(:) + type( CRTM_Surface_type ), allocatable :: Surface(:), Surface_TL(:) + type( CRTM_GeometryInfo_type ), allocatable :: GeometryInfo(:) + type( CRTM_Options_type ), allocatable :: Options(:) integer :: ts_index integer :: nclouds, ncv @@ -106,44 +106,77 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) if (trace_use) call da_trace_entry("da_transform_xtoy_crtm") + sensor_loop : do inst = 1, iv%num_inst ! loop for sensor + + num_rad = iv%instid(inst)%info%n2 - iv%instid(inst)%info%n1 + 1 + if ( num_rad < 1 ) cycle + + allocate (Atmosphere (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + Atmosphere_TL(iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting Atmosphere"/)) + end if + allocate (Surface (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + Surface_TL (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting Surface"/)) + end if + allocate (GeometryInfo (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting GeometryInfo"/)) + end if + allocate (Options (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting Options"/)) + end if + !---------------------------------------------------------------------------- ! CRTM allocation ! ! Atmosphere structure - Atmosphere(1)%n_Layers=(kte-kts)+1 ! number of vertical levels - Atmosphere(1)%n_Absorbers=2 - Atmosphere(1)%n_Clouds=0 - Atmosphere(1)%n_Aerosols=0 - if (crtm_cloud) Atmosphere(1)%n_Clouds=6 - - Error_Status = CRTM_Allocate_Atmosphere( Atmosphere(1)%n_Layers, & - Atmosphere(1)%n_Absorbers, & - Atmosphere(1)%n_Clouds, & - Atmosphere(1)%n_Aerosols, & - Atmosphere) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in allocatting CRTM Atmosphere Structure"/)) - end if - - Atmosphere(1)%Absorber_ID(1)=H2O_ID - Atmosphere(1)%Absorber_ID(2)=O3_ID - Atmosphere(1)%Climatology=crtm_atmosphere - - if (crtm_cloud) then - Atmosphere(1)%Cloud(1)%Type=WATER_CLOUD - Atmosphere(1)%Cloud(2)%Type=ICE_CLOUD - Atmosphere(1)%Cloud(3)%Type=RAIN_CLOUD - Atmosphere(1)%Cloud(4)%Type=SNOW_CLOUD - Atmosphere(1)%Cloud(5)%Type=GRAUPEL_CLOUD - Atmosphere(1)%Cloud(6)%Type=HAIL_CLOUD - end if -!------------------------------------------------------------------------------- + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel - do inst = 1, iv%num_inst ! loop for sensor - num_rad = iv%instid(inst)%info%n2 - iv%instid(inst)%info%n1 + 1 - if ( num_rad < 1 ) cycle + Atmosphere(n)%n_Layers=(kte-kts)+1 ! number of vertical levels + Atmosphere(n)%n_Absorbers=2 + Atmosphere(n)%n_Clouds=0 + Atmosphere(n)%n_Aerosols=0 + if (crtm_cloud) Atmosphere(n)%n_Clouds=6 + + Error_Status = CRTM_Allocate_Atmosphere( Atmosphere(n)%n_Layers, & + Atmosphere(n)%n_Absorbers, & + Atmosphere(n)%n_Clouds, & + Atmosphere(n)%n_Aerosols, & + Atmosphere(n)) + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting CRTM Atmosphere Structure"/)) + end if + + Atmosphere(n)%Absorber_ID(1)=H2O_ID + Atmosphere(n)%Absorber_ID(2)=O3_ID + Atmosphere(n)%Climatology=crtm_atmosphere + + if (crtm_cloud) then + Atmosphere(n)%Cloud(1)%Type=WATER_CLOUD + Atmosphere(n)%Cloud(2)%Type=ICE_CLOUD + Atmosphere(n)%Cloud(3)%Type=RAIN_CLOUD + Atmosphere(n)%Cloud(4)%Type=SNOW_CLOUD + Atmosphere(n)%Cloud(5)%Type=GRAUPEL_CLOUD + Atmosphere(n)%Cloud(6)%Type=HAIL_CLOUD + end if + + end do + +!------------------------------------------------------------------------------- ! CRTM channel information structure ! Error_Status = CRTM_Set_ChannelInfo(Sensor_Descriptor(inst),ChannelInfo) @@ -154,12 +187,12 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) nchanl = ChannelInfo(inst)%n_channels ! Allocate forward model solution RTSolution array to number of channels - allocate( RTSolution( ChannelInfo(inst)%n_Channels, 1 ), & - RTSolution_TL( ChannelInfo(inst)%n_Channels, 1 ), & - STAT = Allocate_Status ) + allocate( RTSolution( ChannelInfo(inst)%n_Channels, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2 ), & + RTSolution_TL( ChannelInfo(inst)%n_Channels, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2 ), & + STAT = Allocate_Status ) if ( Allocate_Status /= 0 ) then call da_error(__FILE__,__LINE__, & - (/"Error in allocatting RTSolution"/)) + (/"Error in allocatting RTSolution"/)) END IF ! CRTM Surface Structure @@ -179,29 +212,35 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) wmo_sensor_id=INVALID_WMO_SENSOR_ID end if - Error_Status = CRTM_Allocate_Surface( nchanl, & ! Input - Surface) ! Output - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in allocatting CRTM Surface Structure"/)) - end if + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + + Error_Status = CRTM_Allocate_Surface( nchanl, & ! Input + Surface(n) ) ! Output + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting CRTM Surface Structure"/)) + end if ! CRTM Options structure - Options(1)%n_channels = nchanl - if ( use_antcorr(inst) ) Options(1)%Antenna_Correction = 1 ! SET = 1 in CRTM_Parameters.f90 - Error_Status = CRTM_Allocate_Options( nchanl, & ! Input - Options) ! InOut - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in allocatting CRTM Options Structure"/)) - endif + Options(n)%n_channels = nchanl + if ( use_antcorr(inst) ) Options(n)%Antenna_Correction = 1 ! SET = 1 in CRTM_Parameters.f90 + Error_Status = CRTM_Allocate_Options( nchanl, & ! Input + Options(n) ) ! InOut + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting CRTM Options Structure"/)) + endif + + end do allocate (temperature(Atmosphere(1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (absorber(Atmosphere(1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) + allocate (xb_q(Atmosphere(1)%n_layers, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (psfc(iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) temperature(:,:) = 0.0 absorber(:,:) = 0.0 + xb_q(:,:) = 0.0 psfc(:) = 0.0 if (crtm_cloud) then @@ -225,7 +264,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) call da_interp_lin_2d_partial (grid%xa%q(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & absorber(kte-k+1,:)) - if (crtm_cloud) then + if (crtm_cloud) then call da_interp_lin_2d_partial (grid%xa%qcw(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & qcw(kte-k+1,:)) @@ -237,7 +276,8 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) qsn(kte-k+1,:)) call da_interp_lin_2d_partial (grid%xa%qgr(:,:,k), iv%instid(inst)%info, k, iv%instid(inst)%info%n1, iv%instid(inst)%info%n2, & qgr(kte-k+1,:)) - end if + + end if end do @@ -256,8 +296,8 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) do ipred = 1, npred if (iv%instid(inst)%varbc(k)%ipred(ipred) /= gammapred) cycle id = iv%instid(inst)%varbc(k)%index(ipred) - RTSolution(k,1)%Gamma = iv%instid(inst)%varbc(k)%param(ipred) - RTSolution_TL(k,1)%Gamma = SUM(cv(id) * iv%instid(inst)%varbc(k)%vtox(ipred,1:npred)) + RTSolution(k,:)%Gamma = iv%instid(inst)%varbc(k)%param(ipred) + RTSolution_TL(k,:)%Gamma = SUM(cv(id) * iv%instid(inst)%varbc(k)%vtox(ipred,1:npred)) end do end do end if @@ -268,27 +308,30 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) ! [1.1] Get horizontal interpolation weights: ! [1.3] Extract base state Atmosphere variables - Atmosphere(1)%level_pressure(0) = iv%instid(inst)%pf(0,n) - do k=1,Atmosphere(1)%n_layers - Atmosphere(1)%pressure(k) = iv%instid(inst)%pm(k,n) - Atmosphere(1)%level_pressure(k) = iv%instid(inst)%pf(k,n) - Atmosphere(1)%temperature(k) = iv%instid(inst)%tm(k,n) - Atmosphere(1)%absorber(k,1) = iv%instid(inst)%qm(k,n) - if (crtm_cloud) then - Atmosphere(1)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) - Atmosphere(1)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) - Atmosphere(1)%cloud(3)%water_content(k)=iv%instid(inst)%qrn(k,n) - Atmosphere(1)%cloud(4)%water_content(k)=iv%instid(inst)%qsn(k,n) - Atmosphere(1)%cloud(5)%water_content(k)=iv%instid(inst)%qgr(k,n) - Atmosphere(1)%cloud(6)%water_content(k)=iv%instid(inst)%qhl(k,n) - Atmosphere(1)%cloud(1)%effective_radius(k)=iv%instid(inst)%rcw(k,n) - Atmosphere(1)%cloud(2)%effective_radius(k)=iv%instid(inst)%rci(k,n) - Atmosphere(1)%cloud(3)%effective_radius(k)=iv%instid(inst)%rrn(k,n) - Atmosphere(1)%cloud(4)%effective_radius(k)=iv%instid(inst)%rsn(k,n) - Atmosphere(1)%cloud(5)%effective_radius(k)=iv%instid(inst)%rgr(k,n) - Atmosphere(1)%cloud(6)%effective_radius(k)=iv%instid(inst)%rhl(k,n) - end if + Atmosphere(n)%level_pressure(0) = iv%instid(inst)%pf(0,n) + do k=1,Atmosphere(n)%n_layers + Atmosphere(n)%pressure(k) = iv%instid(inst)%pm(k,n) + Atmosphere(n)%level_pressure(k) = iv%instid(inst)%pf(k,n) + Atmosphere(n)%temperature(k) = iv%instid(inst)%tm(k,n) + Atmosphere(n)%absorber(k,1) = iv%instid(inst)%qm(k,n) + xb_q(k,n) = 0.001*iv%instid(inst)%qm(k,n)/(1.0+iv%instid(inst)%qm(k,n)) ! specific humidity + end do + if (crtm_cloud) then + do k=1,Atmosphere(n)%n_layers + Atmosphere(n)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) + Atmosphere(n)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) + Atmosphere(n)%cloud(3)%water_content(k)=iv%instid(inst)%qrn(k,n) + Atmosphere(n)%cloud(4)%water_content(k)=iv%instid(inst)%qsn(k,n) + Atmosphere(n)%cloud(5)%water_content(k)=iv%instid(inst)%qgr(k,n) + Atmosphere(n)%cloud(6)%water_content(k)=iv%instid(inst)%qhl(k,n) + Atmosphere(n)%cloud(1)%effective_radius(k)=iv%instid(inst)%rcw(k,n) + Atmosphere(n)%cloud(2)%effective_radius(k)=iv%instid(inst)%rci(k,n) + Atmosphere(n)%cloud(3)%effective_radius(k)=iv%instid(inst)%rrn(k,n) + Atmosphere(n)%cloud(4)%effective_radius(k)=iv%instid(inst)%rsn(k,n) + Atmosphere(n)%cloud(5)%effective_radius(k)=iv%instid(inst)%rgr(k,n) + Atmosphere(n)%cloud(6)%effective_radius(k)=iv%instid(inst)%rhl(k,n) end do + end if ! [1.4] User-supplied emissivity !Options%emissivity_switch = 1 @@ -296,172 +339,197 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) ! iv%instid(inst)%emiss(1:Options%n_channels,n) ! [1.4] CRTM Surface parameter data - Surface(1)%Land_Coverage=iv%instid(inst)%land_coverage(n) - Surface(1)%Water_Coverage=iv%instid(inst)%water_coverage(n) - Surface(1)%Snow_Coverage=iv%instid(inst)%snow_coverage(n) - Surface(1)%Ice_Coverage=iv%instid(inst)%ice_coverage(n) - - if (Surface(1)%Land_Coverage > 0.0) then - Surface(1)%Land_Type=GRASS_SOIL ! land type (User guide appendix 3) - Surface(1)%Land_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Soil_Moisture_Content=iv%instid(inst)%smois(n) !0.05 ! volumetric water content (g/cm**3) - !Surface(1)%Canopy_Water_Content=0.05 ! gravimetric water content - Surface(1)%Vegetation_Fraction=iv%instid(inst)%vegtyp(n) - Surface(1)%Soil_Temperature=iv%instid(inst)%tslb(n) - end if - if (Surface(1)%Water_Coverage > 0.0) then - !Surface(1)%Water_Type=SEA_WATER ! (Currently NOT used) - Surface(1)%Water_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Wind_Speed=sqrt((iv%instid(inst)%u10(n))**2+ & - (iv%instid(inst)%v10(n))**2) ! m/sec - !surface(1)%Wind_Direction=0.0 ! NOT used - Surface(1)%Salinity=33. ! ppmv - end if - if (Surface(1)%Snow_Coverage > 0.0) then - Surface(1)%Snow_Type=NEW_SNOW ! User guide appendix 3 - Surface(1)%Snow_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Snow_Depth=iv%instid(inst)%snowh(n) ! mm - !Surface(1)%Snow_Density=0.2 ! g/cm**3 - !Surface(1)%Snow_Grain_Size=2.0 ! mm - end if - if (Surface(1)%Ice_Coverage > 0.0) then - !Surface(1)%Ice_Type=FRESH_ICE ! NO Table offered, single egrid%xample is FRESH_ICE - Surface(1)%Ice_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Ice_Thickness=10.0 ! mm - !Surface(1)%Ice_Density=0.9 ! g/cm**3 - !Surface(1)%Ice_Roughness=0.0 ! NO Table offered, single egrid%xample is ZERO - end if - Surface(1)%SensorData%n_channels = nchanl + Surface(n)%Land_Coverage=iv%instid(inst)%land_coverage(n) + Surface(n)%Water_Coverage=iv%instid(inst)%water_coverage(n) + Surface(n)%Snow_Coverage=iv%instid(inst)%snow_coverage(n) + Surface(n)%Ice_Coverage=iv%instid(inst)%ice_coverage(n) + + if (Surface(n)%Land_Coverage > 0.0) then + Surface(n)%Land_Type=GRASS_SOIL ! land type (User guide appendix 3) + Surface(n)%Land_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Soil_Moisture_Content=iv%instid(inst)%smois(n) !0.05 ! volumetric water content (g/cm**3) + !Surface(n)%Canopy_Water_Content=0.05 ! gravimetric water content + Surface(n)%Vegetation_Fraction=iv%instid(inst)%vegfra(n) + Surface(n)%Soil_Temperature=iv%instid(inst)%tslb(n) + end if + if (Surface(n)%Water_Coverage > 0.0) then + !Surface(n)%Water_Type=SEA_WATER ! (Currently NOT used) + Surface(n)%Water_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Wind_Speed=sqrt((iv%instid(inst)%u10(n))**2+ & + (iv%instid(inst)%v10(n))**2) ! m/sec + !surface(n)%Wind_Direction=0.0 ! NOT used + Surface(n)%Salinity=33. ! ppmv + end if + if (Surface(n)%Snow_Coverage > 0.0) then + Surface(n)%Snow_Type=NEW_SNOW ! User guide appendix 3 + Surface(n)%Snow_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Snow_Depth=iv%instid(inst)%snowh(n) ! mm + !Surface(n)%Snow_Density=0.2 ! g/cm**3 + !Surface(n)%Snow_Grain_Size=2.0 ! mm + end if + if (Surface(n)%Ice_Coverage > 0.0) then + !Surface(n)%Ice_Type=FRESH_ICE ! NO Table offered, single egrid%xample is FRESH_ICE + Surface(n)%Ice_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Ice_Thickness=10.0 ! mm + !Surface(n)%Ice_Density=0.9 ! g/cm**3 + !Surface(n)%Ice_Roughness=0.0 ! NO Table offered, single egrid%xample is ZERO + end if + Surface(n)%SensorData%n_channels = nchanl #ifdef CRTM_1_1 - Surface(1)%SensorData%Sensor_Id = wmo_sensor_id ! CRTM_1.1 + Surface(n)%SensorData%Sensor_Id = wmo_sensor_id ! CRTM_1.1 #else - Surface(1)%SensorData%Select_WMO_Sensor_Id = wmo_sensor_id ! CRTM_1.2 + Surface(n)%SensorData%Select_WMO_Sensor_Id = wmo_sensor_id ! CRTM_1.2 #endif - Surface(1)%SensorData%Tb(1:nchanl) = iv%instid(inst)%tb_inv(1:nchanl,n) + & - iv%instid(inst)%tb_xb(1:nchanl,n) + Surface(n)%SensorData%Tb(1:nchanl) = iv%instid(inst)%tb_inv(1:nchanl,n) + & + iv%instid(inst)%tb_xb(1:nchanl,n) ! -- Copy the TL atmosphere structure - Error_Status = CRTM_Assign_Atmosphere( Atmosphere, Atmosphere_TL ) + Error_Status = CRTM_Assign_Atmosphere( Atmosphere(n), Atmosphere_TL(n) ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error copying Atmosphere_TL structure"/)) - END IF + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error copying Atmosphere_TL structure"/)) + END IF ! -- Copy the TL surface structure - Error_Status = CRTM_Assign_Surface( Surface, Surface_TL ) + Error_Status = CRTM_Assign_Surface( Surface(n), Surface_TL(n) ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error copying Surface_TL structure"/)) - END IF + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error copying Surface_TL structure"/)) + END IF ! -- Zero the TL outputs ! Important: adjoint variables must be initialized - call CRTM_Zero_Atmosphere( Atmosphere_TL ) - call CRTM_Zero_Surface( Surface_TL ) - - do k = kts, kte - if ( iv%instid(inst)%pm(k,n) < 75.0 ) absorber(k,n) = 0.0 - end do - Atmosphere_TL(1)%Absorber(kts+1:kte,1) = 1000.0 * absorber(kts+1:kte,n) ! in g/kg Zero Jacobian for top level(s) - Atmosphere_TL(1)%Temperature(kts+1:kte) = temperature(kts+1:kte,n) ! Zero Jacobian for top level - Atmosphere_TL(1)%Level_Pressure(Atmosphere_TL(1)%n_Layers) = 0.01 * psfc(n) - - if (crtm_cloud) then - Atmosphere_TL(1)%Cloud(1)%Water_Content(kts:kte) = qcw(kts:kte,n) - Atmosphere_TL(1)%Cloud(2)%Water_Content(kts:kte) = qci(kts:kte,n) - Atmosphere_TL(1)%Cloud(3)%Water_Content(kts:kte) = qrn(kts:kte,n) - Atmosphere_TL(1)%Cloud(4)%Water_Content(kts:kte) = qsn(kts:kte,n) - Atmosphere_TL(1)%Cloud(5)%Water_Content(kts:kte) = qgr(kts:kte,n) - Atmosphere_TL(1)%Cloud(6)%Water_Content(kts:kte) = 0. + call CRTM_Zero_Atmosphere( Atmosphere_TL(n) ) + call CRTM_Zero_Surface( Surface_TL(n) ) + + do k = kts, kte + if ( iv%instid(inst)%pm(k,n) < 75.0 ) absorber(k,n) = 0.0 + end do + Atmosphere_TL(n)%Absorber(kts+1:kte,1) = 1000.0 / (1.0-xb_q(kts+1:kte,n))**2 & + * absorber(kts+1:kte,n) + ! in g/kg Zero Jacobian for top level(s) + Atmosphere_TL(n)%Temperature(kts+1:kte) = temperature(kts+1:kte,n) ! Zero Jacobian for top level + Atmosphere_TL(n)%Level_Pressure(Atmosphere_TL(n)%n_Layers) = 0.01 * psfc(n) + + if (crtm_cloud) then + Atmosphere_TL(n)%Cloud(1)%Water_Content(kts:kte) = qcw(kts:kte,n) + Atmosphere_TL(n)%Cloud(2)%Water_Content(kts:kte) = qci(kts:kte,n) + Atmosphere_TL(n)%Cloud(3)%Water_Content(kts:kte) = qrn(kts:kte,n) + Atmosphere_TL(n)%Cloud(4)%Water_Content(kts:kte) = qsn(kts:kte,n) + Atmosphere_TL(n)%Cloud(5)%Water_Content(kts:kte) = qgr(kts:kte,n) + Atmosphere_TL(n)%Cloud(6)%Water_Content(kts:kte) = 0. ! convert cloud content unit from kg/kg to kg/m^2 - do k=kts,kte - do icld=1,Atmosphere(1)%n_Clouds + do k=kts,kte + do icld=1,Atmosphere(n)%n_Clouds - Atmosphere_TL(1)%Cloud(icld)%Water_Content(k)= Atmosphere_TL(1)%Cloud(icld)%Water_Content(k)* & - (Atmosphere(1)%Level_Pressure(k)- Atmosphere(1)%Level_Pressure(k-1))*100./gravity + Atmosphere_TL(n)%Cloud(icld)%Water_Content(k)= Atmosphere_TL(n)%Cloud(icld)%Water_Content(k)* & + (Atmosphere(n)%Level_Pressure(k)- Atmosphere(n)%Level_Pressure(k-1))*100./gravity - enddo - enddo - end if + enddo + enddo + end if ! Skin Temperature !----------------- - if (use_satcv(1)) then - ts_index = iv%instid(inst)%cv_index(n)%ts - if (Surface(1)%Land_Coverage > 0.0) Surface_TL(1)%Land_Temperature = cv(ts_index) - if (Surface(1)%Water_Coverage > 0.0) Surface_TL(1)%Water_Temperature = cv(ts_index) - if (Surface(1)%Snow_Coverage > 0.0) Surface_TL(1)%Snow_Temperature = cv(ts_index) - if (Surface(1)%Ice_Coverage > 0.0) Surface_TL(1)%Ice_Temperature = cv(ts_index) - end if + if (use_satcv(1)) then + ts_index = iv%instid(inst)%cv_index(n)%ts + if (Surface(n)%Land_Coverage > 0.0) Surface_TL(n)%Land_Temperature = cv(ts_index) + if (Surface(n)%Water_Coverage > 0.0) Surface_TL(n)%Water_Temperature = cv(ts_index) + if (Surface(n)%Snow_Coverage > 0.0) Surface_TL(n)%Snow_Temperature = cv(ts_index) + if (Surface(n)%Ice_Coverage > 0.0) Surface_TL(n)%Ice_Temperature = cv(ts_index) + end if ! Cloud cover(s) !--------------- - if (use_satcv(2)) then - nclouds = iv%instid(inst)%cv_index(n)%nclouds - ncv = iv%instid(inst)%cv_index(n)%ncv - allocate (rad_ovc (nclouds)) - allocate (cc_tl (nclouds)) + if (use_satcv(2)) then + nclouds = iv%instid(inst)%cv_index(n)%nclouds + ncv = iv%instid(inst)%cv_index(n)%ncv + allocate (rad_ovc (nclouds)) + allocate (cc_tl (nclouds)) - cc_tl(:) = cv(iv%instid(inst)%cv_index(n)%cc(:)) + cc_tl(:) = cv(iv%instid(inst)%cv_index(n)%cc(:)) ! !--------------------------------------------------------------- ! ! Change of variable (preconditioning) ! !--------------------------------------------------------------- -! do icld = 1, nclouds -! cc_tl(icld) = SUM( cv(iv%instid(inst)%cv_index(n)%cc) * & -! iv%instid(inst)%cv_index(n)%vtox(icld,1:ncv) ) -! end do +! do icld = 1, nclouds +! cc_tl(icld) = SUM( cv(iv%instid(inst)%cv_index(n)%cc) * & +! iv%instid(inst)%cv_index(n)%vtox(icld,1:ncv) ) +! end do - do k = 1, nchanl - if (ALL(iv%instid(inst)%ichan(k) /= Bands(:,1))) cycle ! Only Channels in Band 1 - rad_clr = iv%instid(inst)%rad_xb(k,n) - rad_ovc(:) = iv%instid(inst)%rad_ovc(k,kte-nclouds+1:kte,n) - rad_cld = SUM(cc_tl*rad_ovc) + (1.0 - SUM(cc_tl))*rad_clr - rad_tl = SUM(cc_tl*(rad_ovc-rad_clr)) - call CRTM_Planck_Temperature_TL(inst,k,rad_clr,rad_tl,tb_tl) - y%instid(inst)%tb(k,n) = y%instid(inst)%tb(k,n) + tb_tl - end do - - deallocate(cc_tl, rad_ovc) - else - y%instid(inst)%tb(:,n) = 0.0 - end if + do k = 1, nchanl + if (ALL(iv%instid(inst)%ichan(k) /= Bands(:,1))) cycle ! Only Channels in Band 1 + rad_clr = iv%instid(inst)%rad_xb(k,n) + rad_ovc(:) = iv%instid(inst)%rad_ovc(k,kte-nclouds+1:kte,n) + rad_cld = SUM(cc_tl*rad_ovc) + (1.0 - SUM(cc_tl))*rad_clr + rad_tl = SUM(cc_tl*(rad_ovc-rad_clr)) + call CRTM_Planck_Temperature_TL(inst,k,rad_clr,rad_tl,tb_tl) + y%instid(inst)%tb(k,n) = y%instid(inst)%tb(k,n) + tb_tl + end do + + deallocate(cc_tl, rad_ovc) + else + y%instid(inst)%tb(:,n) = 0.0 + end if ! [1.5] CRTM GeometryInfo Structure - GeometryInfo(1)%Sensor_Zenith_Angle=iv%instid(inst)%satzen(n) - GeometryInfo(1)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) - GeometryInfo(1)%iFOV=iv%instid(inst)%scanpos(n) - ! GeometryInfo(1)%Satellite_Height=830.0 - ! GeometryInfo(1)%Sensor_Scan_Angle= - ! GeometryInfo(1)%Sensor_Zenith_Angle= - ! GeometryInfo(1)%Sensor_Scan_Angle= - ! GeometryInfo(1)%Source_Zenith_Angle= + GeometryInfo(n)%Sensor_Zenith_Angle=iv%instid(inst)%satzen(n) + GeometryInfo(n)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) + GeometryInfo(n)%iFOV=iv%instid(inst)%scanpos(n) + ! GeometryInfo(n)%Satellite_Height=830.0 + ! GeometryInfo(n)%Sensor_Scan_Angle= + ! GeometryInfo(n)%Sensor_Zenith_Angle= + ! GeometryInfo(n)%Sensor_Scan_Angle= + ! GeometryInfo(n)%Source_Zenith_Angle= + + end do + ! [1.6] Call CRTM_TL model - call da_crtm_tl (1, nchanl, 1, Atmosphere, & - Surface, & - Atmosphere_TL,& - Surface_TL, & - GeometryInfo, & - ChannelInfo(inst:inst), & - RTSolution, & - RTSolution_TL,& - Options) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n ) + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + if (.not. use_crtm_kmatrix) then + call da_crtm_tl (1, nchanl, 1, Atmosphere(n), & + Surface(n), & + Atmosphere_TL(n),& + Surface_TL(n), & + GeometryInfo(n), & + ChannelInfo(inst:inst), & + RTSolution(:,n), & + RTSolution_TL(:,n),& + Options(n)) + else + RTSolution_TL(:,n)%brightness_temperature = 0. + do l = 1, ChannelInfo(inst)%n_Channels + do k = kts , kte + RTSolution_TL(l,n)%brightness_temperature = RTSolution_TL(l,n)%brightness_temperature + & + iv%instid(inst)%t_jacobian(l,k,n) * Atmosphere_TL(n)%Temperature(k) + & + iv%instid(inst)%q_jacobian(l,k,n) * Atmosphere_TL(n)%absorber(k,1) + end do + RTSolution_TL(l,n)%brightness_temperature = RTSolution_TL(l,n)%brightness_temperature + & + iv%instid(inst)%ps_jacobian(l,n) * Atmosphere_TL(n)%Level_Pressure(Atmosphere_TL(n)%n_Layers) + end do + endif + end do + !$OMP END PARALLEL DO !------------------------------------------------------------------- ! [1.7] assign Hdx : !------------------------------------------------------------------- - y%instid(inst)%tb(:,n) = y%instid(inst)%tb(:,n) + RTSolution_TL(:,1)%brightness_temperature + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + + y%instid(inst)%tb(:,n) = y%instid(inst)%tb(:,n) + RTSolution_TL(:,n)%brightness_temperature - Error_Status = CRTM_Destroy_Atmosphere( Atmosphere_TL ) + Error_Status = CRTM_Destroy_Atmosphere( Atmosphere_TL(n) ) if ( Error_Status /= 0 ) then call da_error(__FILE__,__LINE__, & (/"Error in deallocatting CRTM Atmosphere_TL Structure"/)) end if - Error_Status = CRTM_Destroy_Surface(Surface_TL) + Error_Status = CRTM_Destroy_Surface(Surface_TL(n)) if ( Error_Status /= 0 ) then call da_error(__FILE__,__LINE__, & (/"Error in deallocatting CRTM Surface_TL Structure"/)) @@ -471,6 +539,7 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) deallocate (temperature) deallocate (absorber) + deallocate (xb_q) deallocate (psfc) if (crtm_cloud) then @@ -481,38 +550,63 @@ subroutine da_transform_xtoy_crtm (cv_size, cv, grid, iv, y ) deallocate (qgr) end if - + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel !------------------------------------------------------------------- ! [2.0] Deallocating CRTM structures - !------------------------------------------------------------------- - deallocate( RTSolution, RTSolution_TL, STAT = Allocate_Status ) - if ( Allocate_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting RTSolution"/)) - END IF - - Error_Status = CRTM_Destroy_Options(Options) + ! ------------------------------------------------------------------- + Error_Status = CRTM_Destroy_Options(Options(n)) if ( Error_Status /= 0 ) then call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting CRTM Options Structure"/)) + (/"Error in deallocatting CRTM Options Structure"/)) end if - Error_Status = CRTM_Destroy_Surface(Surface) + Error_Status = CRTM_Destroy_Surface(Surface(n)) if ( Error_Status /= 0 ) then call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting CRTM Surface Structure"/)) + (/"Error in deallocatting CRTM Surface Structure"/)) end if - - end do ! end loop for sensor - !------------------------------------------------------------------- ! [3.0] Deallocating CRTM Atmosphere structures !------------------------------------------------------------------- - Error_Status = CRTM_Destroy_Atmosphere( Atmosphere ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting CRTM Atmosphere Structure"/)) - end if + Error_Status = CRTM_Destroy_Atmosphere( Atmosphere(n) ) + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting CRTM Atmosphere Structure"/)) + end if + + end do + + deallocate( RTSolution, RTSolution_TL, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting RTSolution"/)) + END IF + + deallocate( Atmosphere, Atmosphere_TL, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting Atmosphere"/)) + END IF + + deallocate( Surface, Surface_TL, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting Surface"/)) + END IF + + deallocate( Options, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting Options"/)) + END IF + + deallocate( GeometryInfo, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting GeometryInfo"/)) + END IF + + end do sensor_loop ! end loop for sensor if (trace_use) call da_trace_exit("da_transform_xtoy_crtm") #else diff --git a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc index 6d10b3a7..1f2d78d6 100644 --- a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc +++ b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_crtm_adj.inc @@ -26,7 +26,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) #ifdef CRTM - integer :: icld, jcld + integer :: icld, jcld, i integer :: k ! Index dimension. integer :: num_rad ! Number of radiance obs integer :: inst, nchanl, n @@ -35,6 +35,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) real, allocatable :: q_ad(:,:) real, allocatable :: t_ad(:,:) real, allocatable :: p_ad(:) + real, allocatable :: xb_q(:,:) !! for crtm_cloud real, allocatable :: qcw(:,:) @@ -51,10 +52,10 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) ! CRTM local varaibles and types integer :: wmo_sensor_id, Error_Status, Allocate_Status type (CRTM_RTSolution_type ), allocatable :: RTSolution(:,:),RTSolution_AD(:,:) - type (CRTM_Atmosphere_type ) :: Atmosphere(1), Atmosphere_AD(1) - type (CRTM_Surface_type ) :: Surface(1), Surface_AD(1) - type (CRTM_GeometryInfo_type ) :: GeometryInfo(1) - type (CRTM_Options_type ) :: Options(1) + type (CRTM_Atmosphere_type ), allocatable :: Atmosphere(:), Atmosphere_AD(:) + type (CRTM_Surface_type ), allocatable :: Surface(:), Surface_AD(:) + type (CRTM_GeometryInfo_type ), allocatable :: GeometryInfo(:) + type (CRTM_Options_type ) , allocatable :: Options(:) integer :: ts_index integer :: nclouds, ncv @@ -122,46 +123,79 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) cv_local(:) = 0.0 + sensors_loop: do inst = 1, iv%num_inst ! loop for sensor + + num_rad = iv%instid(inst)%info%n2 - iv%instid(inst)%info%n1 + 1 + if ( num_rad < 1 ) cycle + + allocate (Atmosphere (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + Atmosphere_AD(iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting Atmosphere"/)) + end if + allocate (Surface (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + Surface_AD (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting Surface"/)) + end if + allocate (GeometryInfo (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting GeometryInfo"/)) + end if + allocate (Options (iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & + STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting Options"/)) + end if + !---------------------------------------------------------------------------- ! CRTM allocation ! ! Atmosphere structure - Atmosphere(1)%n_Layers=(kte-kts)+1 ! number of vertical levels - Atmosphere(1)%n_Absorbers=2 - Atmosphere(1)%n_Clouds=0 - Atmosphere(1)%n_Aerosols=0 - if (crtm_cloud) Atmosphere(1)%n_Clouds=6 - - Error_Status = CRTM_Allocate_Atmosphere( Atmosphere(1)%n_Layers, & - Atmosphere(1)%n_Absorbers, & - Atmosphere(1)%n_Clouds, & - Atmosphere(1)%n_Aerosols, & - Atmosphere) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in allocatting CRTM Atmosphere Structure"/)) - end if - Atmosphere(1)%Absorber_ID(1)=H2O_ID - Atmosphere(1)%Absorber_ID(2)=O3_ID - Atmosphere(1)%Climatology=crtm_atmosphere - - if (crtm_cloud) then - Atmosphere(1)%Cloud(1)%Type=WATER_CLOUD - Atmosphere(1)%Cloud(2)%Type=ICE_CLOUD - Atmosphere(1)%Cloud(3)%Type=RAIN_CLOUD - Atmosphere(1)%Cloud(4)%Type=SNOW_CLOUD - Atmosphere(1)%Cloud(5)%Type=GRAUPEL_CLOUD - Atmosphere(1)%Cloud(6)%Type=HAIL_CLOUD - end if +! + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + Atmosphere(n)%n_Layers=(kte-kts)+1 ! number of vertical levels + Atmosphere(n)%n_Absorbers=2 + Atmosphere(n)%n_Clouds=0 + Atmosphere(n)%n_Aerosols=0 + if (crtm_cloud) Atmosphere(n)%n_Clouds=6 + + Error_Status = CRTM_Allocate_Atmosphere( Atmosphere(n)%n_Layers, & + Atmosphere(n)%n_Absorbers, & + Atmosphere(n)%n_Clouds, & + Atmosphere(n)%n_Aerosols, & + Atmosphere(n)) + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting CRTM Atmosphere Structure"/)) + end if + Atmosphere(n)%Absorber_ID(1)=H2O_ID + Atmosphere(n)%Absorber_ID(2)=O3_ID + Atmosphere(n)%Climatology=crtm_atmosphere + + if (crtm_cloud) then + Atmosphere(n)%Cloud(1)%Type=WATER_CLOUD + Atmosphere(n)%Cloud(2)%Type=ICE_CLOUD + Atmosphere(n)%Cloud(3)%Type=RAIN_CLOUD + Atmosphere(n)%Cloud(4)%Type=SNOW_CLOUD + Atmosphere(n)%Cloud(5)%Type=GRAUPEL_CLOUD + Atmosphere(n)%Cloud(6)%Type=HAIL_CLOUD + end if + end do !------------------------------------------------------------------------------- - do inst = 1, iv%num_inst ! loop for sensor - num_rad = iv%instid(inst)%info%n2 - iv%instid(inst)%info%n1 + 1 - if ( num_rad < 1 ) cycle allocate (q_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (t_ad(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) allocate (p_ad(iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) + allocate (xb_q(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) if (crtm_cloud) then allocate (qcw(kts:kte,iv%instid(inst)%info%n1:iv%instid(inst)%info%n2)) @@ -174,6 +208,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) q_ad = 0.0 t_ad = 0.0 p_ad = 0.0 + xb_q = 0.0 ! info => iv%instid(inst)%info @@ -186,12 +221,12 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) nchanl = ChannelInfo(inst)%n_channels ! Allocate forward model solution RTSolution array to number of channels - allocate( RTSolution( ChannelInfo(inst)%n_Channels, 1 ) , & - RTSolution_AD( ChannelInfo(inst)%n_Channels, 1 ), & + allocate( RTSolution( ChannelInfo(inst)%n_Channels, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2 ) , & + RTSolution_AD( ChannelInfo(inst)%n_Channels, iv%instid(inst)%info%n1:iv%instid(inst)%info%n2), & STAT = Allocate_Status ) if ( Allocate_Status /= 0 ) then call da_error(__FILE__,__LINE__, & - (/"Error in allocatting RTSolution"/)) + (/"Error in allocatting RTSolution"/)) END IF ! CRTM Surface Structure @@ -211,173 +246,207 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) wmo_sensor_id=INVALID_WMO_SENSOR_ID end if - Error_Status = CRTM_Allocate_Surface( nchanl, & ! Input - Surface) ! Output - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in allocatting CRTM Surface Structure"/)) - end if + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + + Error_Status = CRTM_Allocate_Surface( nchanl, & ! Input + Surface(n)) ! Output + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting CRTM Surface Structure"/)) + end if - ! CRTM Options structure - Options(1)%n_channels = nchanl - if ( use_antcorr(inst) ) Options(1)%Antenna_Correction = 1 ! SET = 1 in CRTM_Parameters.f90 - Error_Status = CRTM_Allocate_Options( nchanl, & ! Input - Options) ! Output - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in allocatting CRTM Options Structure"/)) - endif - - ! Gamma correction from VarBC - !---------------------------- + ! CRTM Options structure + Options(n)%n_channels = nchanl + if ( use_antcorr(inst) ) Options(n)%Antenna_Correction = 1 ! SET = 1 in CRTM_Parameters.f90 + Error_Status = CRTM_Allocate_Options( nchanl, & ! Input + Options(n)) ! Output + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in allocatting CRTM Options Structure"/)) + endif + + ! Gamma correction from VarBC + !---------------------------- #ifdef CRTM_MODIF - if (use_varbc) then - gammapred = iv%instid(inst)%varbc_info%gammapred - do k = 1, nchanl - npred = iv%instid(inst)%varbc(k)%npred - if (npred <= 0) cycle ! VarBC channels only - if (iv%instid(inst)%varbc_info%npredmax < gammapred) cycle ! Gamma channels only - if (iv%instid(inst)%varbc(k)%pred_use(gammapred) < 0) cycle ! Gamma channels only - do ipred = 1, npred - if (iv%instid(inst)%varbc(k)%ipred(ipred) /= gammapred) cycle - RTSolution(k,1)%Gamma = iv%instid(inst)%varbc(k)%param(ipred) + if (use_varbc) then + gammapred = iv%instid(inst)%varbc_info%gammapred + do k = 1, nchanl + npred = iv%instid(inst)%varbc(k)%npred + if (npred <= 0) cycle ! VarBC channels only + if (iv%instid(inst)%varbc_info%npredmax < gammapred) cycle ! Gamma channels only + if (iv%instid(inst)%varbc(k)%pred_use(gammapred) < 0) cycle ! Gamma channels only + do ipred = 1, npred + if (iv%instid(inst)%varbc(k)%ipred(ipred) /= gammapred) cycle + RTSolution(k,n)%Gamma = iv%instid(inst)%varbc(k)%param(ipred) + end do end do - end do - end if - RTSolution_AD(:,1)%Gamma = 0.0 + end if + RTSolution_AD(:,n)%Gamma = 0.0 #endif + end do do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel - ! [1.0] Extract base state Atmosphere variables - Atmosphere(1)%level_pressure(0) = iv%instid(inst)%pf(0,n) - do k=1,Atmosphere(1)%n_layers - Atmosphere(1)%pressure(k) = iv%instid(inst)%pm(k,n) - Atmosphere(1)%level_pressure(k) = iv%instid(inst)%pf(k,n) - Atmosphere(1)%temperature(k) = iv%instid(inst)%tm(k,n) - Atmosphere(1)%absorber(k,1) = iv%instid(inst)%qm(k,n) - if (crtm_cloud) then - Atmosphere(1)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) - Atmosphere(1)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) - Atmosphere(1)%cloud(3)%water_content(k)=iv%instid(inst)%qrn(k,n) - Atmosphere(1)%cloud(4)%water_content(k)=iv%instid(inst)%qsn(k,n) - Atmosphere(1)%cloud(5)%water_content(k)=iv%instid(inst)%qgr(k,n) - Atmosphere(1)%cloud(6)%water_content(k)=iv%instid(inst)%qhl(k,n) - Atmosphere(1)%cloud(1)%effective_radius(k)=iv%instid(inst)%rcw(k,n) - Atmosphere(1)%cloud(2)%effective_radius(k)=iv%instid(inst)%rci(k,n) - Atmosphere(1)%cloud(3)%effective_radius(k)=iv%instid(inst)%rrn(k,n) - Atmosphere(1)%cloud(4)%effective_radius(k)=iv%instid(inst)%rsn(k,n) - Atmosphere(1)%cloud(5)%effective_radius(k)=iv%instid(inst)%rgr(k,n) - Atmosphere(1)%cloud(6)%effective_radius(k)=iv%instid(inst)%rhl(k,n) - end if - end do + ! [1.0] Extract base state Atmosphere variables + Atmosphere(n)%level_pressure(0) = iv%instid(inst)%pf(0,n) + do k=1,Atmosphere(n)%n_layers + Atmosphere(n)%pressure(k) = iv%instid(inst)%pm(k,n) + Atmosphere(n)%level_pressure(k) = iv%instid(inst)%pf(k,n) + Atmosphere(n)%temperature(k) = iv%instid(inst)%tm(k,n) + Atmosphere(n)%absorber(k,1) = iv%instid(inst)%qm(k,n) + xb_q(k,n) = 0.001*iv%instid(inst)%qm(k,n)/(1.0+iv%instid(inst)%qm(k,n)) ! specific humidity + end do + + if (crtm_cloud) then + do k=1,Atmosphere(n)%n_layers + Atmosphere(n)%cloud(1)%water_content(k)=iv%instid(inst)%qcw(k,n) + Atmosphere(n)%cloud(2)%water_content(k)=iv%instid(inst)%qci(k,n) + Atmosphere(n)%cloud(3)%water_content(k)=iv%instid(inst)%qrn(k,n) + Atmosphere(n)%cloud(4)%water_content(k)=iv%instid(inst)%qsn(k,n) + Atmosphere(n)%cloud(5)%water_content(k)=iv%instid(inst)%qgr(k,n) + Atmosphere(n)%cloud(6)%water_content(k)=iv%instid(inst)%qhl(k,n) + Atmosphere(n)%cloud(1)%effective_radius(k)=iv%instid(inst)%rcw(k,n) + Atmosphere(n)%cloud(2)%effective_radius(k)=iv%instid(inst)%rci(k,n) + Atmosphere(n)%cloud(3)%effective_radius(k)=iv%instid(inst)%rrn(k,n) + Atmosphere(n)%cloud(4)%effective_radius(k)=iv%instid(inst)%rsn(k,n) + Atmosphere(n)%cloud(5)%effective_radius(k)=iv%instid(inst)%rgr(k,n) + Atmosphere(n)%cloud(6)%effective_radius(k)=iv%instid(inst)%rhl(k,n) + end do + end if - ! [1.1] User-supplied emissivity - ! Options%emissivity_switch = 1 - ! Options%emissivity(1:Options%n_channels) = & - ! iv%instid(inst)%emiss(1:Options%n_channels,n) - - ! [1.1] CRTM Surface parameter data - Surface(1)%Land_Coverage=iv%instid(inst)%land_coverage(n) - Surface(1)%Water_Coverage=iv%instid(inst)%water_coverage(n) - Surface(1)%Snow_Coverage=iv%instid(inst)%snow_coverage(n) - Surface(1)%Ice_Coverage=iv%instid(inst)%ice_coverage(n) - - if (Surface(1)%Land_Coverage > 0.0) then - Surface(1)%Land_Type=GRASS_SOIL ! land type (User guide appendix 3) - Surface(1)%Land_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Soil_Moisture_Content=iv%instid(inst)%smois(n) !0.05 ! volumetric water content (g/cm**3) - !Surface(1)%Canopy_Water_Content=0.05 ! gravimetric water content - Surface(1)%Vegetation_Fraction=iv%instid(inst)%vegtyp(n) - Surface(1)%Soil_Temperature=iv%instid(inst)%tslb(n) - end if - if (Surface(1)%Water_Coverage > 0.0) then - !Surface(1)%Water_Type=SEA_WATER ! (Currently NOT used) - Surface(1)%Water_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Wind_Speed=sqrt((iv%instid(inst)%u10(n))**2+ & + ! [1.1] User-supplied emissivity + ! Options%emissivity_switch = 1 + ! Options%emissivity(1:Options%n_channels) = & + ! iv%instid(inst)%emiss(1:Options%n_channels,n) + + ! [1.1] CRTM Surface parameter data + Surface(n)%Land_Coverage=iv%instid(inst)%land_coverage(n) + Surface(n)%Water_Coverage=iv%instid(inst)%water_coverage(n) + Surface(n)%Snow_Coverage=iv%instid(inst)%snow_coverage(n) + Surface(n)%Ice_Coverage=iv%instid(inst)%ice_coverage(n) + + if (Surface(n)%Land_Coverage > 0.0) then + Surface(n)%Land_Type=GRASS_SOIL ! land type (User guide appendix 3) + Surface(n)%Land_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Soil_Moisture_Content=iv%instid(inst)%smois(n) !0.05 ! volumetric water content (g/cm**3) + !Surface(n)%Canopy_Water_Content=0.05 ! gravimetric water content + Surface(n)%Vegetation_Fraction=iv%instid(inst)%vegfra(n) + Surface(n)%Soil_Temperature=iv%instid(inst)%tslb(n) + end if + if (Surface(n)%Water_Coverage > 0.0) then + !Surface(n)%Water_Type=SEA_WATER ! (Currently NOT used) + Surface(n)%Water_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Wind_Speed=sqrt((iv%instid(inst)%u10(n))**2+ & (iv%instid(inst)%v10(n))**2) ! m/sec - !surface(1)%Wind_Direction=0.0 ! NOT used - Surface(1)%Salinity=33.0 ! ppmv - end if - if (Surface(1)%Snow_Coverage > 0.0) then - Surface(1)%Snow_Type=NEW_SNOW ! User guide appendix 3 - Surface(1)%Snow_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Snow_Depth=iv%instid(inst)%snowh(n) ! mm - !Surface(1)%Snow_Density=0.2 ! g/cm**3 - !Surface(1)%Snow_Grain_Size=2.0 ! mm - end if - if (Surface(1)%Ice_Coverage > 0.0) then - !Surface(1)%Ice_Type=FRESH_ICE ! NO Table offered, single example is FRESH_ICE - Surface(1)%Ice_Temperature=iv%instid(inst)%ts(n) ! K - Surface(1)%Ice_Thickness=10.0 ! mm - !Surface(1)%Ice_Density=0.9 ! g/cm**3 - !Surface(1)%Ice_Roughness=0.0 ! NO Table offered, single example is ZERO - end if - Surface(1)%SensorData%n_channels = nchanl + !surface(n)%Wind_Direction=0.0 ! NOT used + Surface(n)%Salinity=33.0 ! ppmv + end if + if (Surface(n)%Snow_Coverage > 0.0) then + Surface(n)%Snow_Type=NEW_SNOW ! User guide appendix 3 + Surface(n)%Snow_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Snow_Depth=iv%instid(inst)%snowh(n) ! mm + !Surface(n)%Snow_Density=0.2 ! g/cm**3 + !Surface(n)%Snow_Grain_Size=2.0 ! mm + end if + if (Surface(n)%Ice_Coverage > 0.0) then + !Surface(n)%Ice_Type=FRESH_ICE ! NO Table offered, single example is FRESH_ICE + Surface(n)%Ice_Temperature=iv%instid(inst)%ts(n) ! K + Surface(n)%Ice_Thickness=10.0 ! mm + !Surface(n)%Ice_Density=0.9 ! g/cm**3 + !Surface(n)%Ice_Roughness=0.0 ! NO Table offered, single example is ZERO + end if + Surface(n)%SensorData%n_channels = nchanl #ifdef CRTM_1_1 - Surface(1)%SensorData%Sensor_Id = wmo_sensor_id ! CRTM_1.1 + Surface(n)%SensorData%Sensor_Id = wmo_sensor_id ! CRTM_1.1 #else - Surface(1)%SensorData%Select_WMO_Sensor_Id = wmo_sensor_id ! CRTM_1.2 + Surface(n)%SensorData%Select_WMO_Sensor_Id = wmo_sensor_id ! CRTM_1.2 #endif - Surface(1)%SensorData%Tb(1:nchanl) = iv%instid(inst)%tb_inv(1:nchanl,n) + & - iv%instid(inst)%tb_xb(1:nchanl,n) + Surface(n)%SensorData%Tb(1:nchanl) = iv%instid(inst)%tb_inv(1:nchanl,n) + & + iv%instid(inst)%tb_xb(1:nchanl,n) - ! -- Copy the adjoint atmosphere structure - Error_Status = CRTM_Assign_Atmosphere( Atmosphere, Atmosphere_AD ) + ! -- Copy the adjoint atmosphere structure + Error_Status = CRTM_Assign_Atmosphere( Atmosphere(n), Atmosphere_AD(n) ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error copying Atmosphere_AD structure"/)) - END IF + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error copying Atmosphere_AD structure"/)) + END IF - ! -- Copy the adjoint surface structure - Error_Status = CRTM_Assign_Surface( Surface, Surface_AD ) + ! -- Copy the adjoint surface structure + Error_Status = CRTM_Assign_Surface( Surface(n), Surface_AD(n) ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error copying Surface_AD structure"/)) - END IF + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error copying Surface_AD structure"/)) + END IF - ! -- Zero the Adjoint outputs - ! Important: adjoint variables must be initialized - call CRTM_Zero_Atmosphere( Atmosphere_AD ) - call CRTM_Zero_Surface( Surface_AD ) - - ! [1.2] CRTM GeometryInfo Structure - GeometryInfo(1)%Sensor_Zenith_Angle=iv%instid(inst)%satzen(n) - GeometryInfo(1)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) - GeometryInfo(1)%iFOV=iv%instid(inst)%scanpos(n) - ! GeometryInfo(1)%Satellite_Height=830.0 - ! GeometryInfo(1)%Sensor_Scan_Angle= - ! GeometryInfo(1)%Sensor_Zenith_Angle= - ! GeometryInfo(1)%Sensor_Scan_Angle= - ! GeometryInfo(1)%Source_Zenith_Angle= + ! -- Zero the Adjoint outputs + ! Important: adjoint variables must be initialized + call CRTM_Zero_Atmosphere( Atmosphere_AD(n) ) + call CRTM_Zero_Surface( Surface_AD(n) ) + + ! [1.2] CRTM GeometryInfo Structure + GeometryInfo(n)%Sensor_Zenith_Angle=iv%instid(inst)%satzen(n) + GeometryInfo(n)%Source_Zenith_Angle=iv%instid(inst)%solzen(n) + GeometryInfo(n)%iFOV=iv%instid(inst)%scanpos(n) + ! GeometryInfo(n)%Satellite_Height=830.0 + ! GeometryInfo(n)%Sensor_Scan_Angle= + ! GeometryInfo(n)%Sensor_Zenith_Angle= + ! GeometryInfo(n)%Sensor_Scan_Angle= + ! GeometryInfo(n)%Source_Zenith_Angle= - ! [1.3] assign tb = R^-1 Re : + ! [1.3] assign tb = R^-1 Re : + + do i = 1, ChannelInfo(inst)%n_Channels + RTSolution_AD(i,n)%brightness_temperature = jo_grad_y%instid(inst)%tb(i,n) + RTSolution_AD(i,n)%radiance = 0.0 ! must assign zero, since each call of AD model will return non-zero value + end do - RTSolution_AD(:,1)%brightness_temperature = jo_grad_y%instid(inst)%tb(:,n) - RTSolution_AD(:,1)%radiance = 0.0 ! must assign zero, since each call of AD model will return non-zero value + end do ! [1.4] Call CRTM_AD model + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n ) + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + if (.not. use_crtm_kmatrix) then + call da_crtm_ad (1, nchanl, 1, Atmosphere(n), & + Surface(n), & + RTSolution_AD(:,n),& + GeometryInfo(n), & + ChannelInfo(inst:inst), & + Atmosphere_AD(n),& + Surface_AD(n), & + RTSolution(:,n), & + Options(n)) + else + do i = 1, ChannelInfo(inst)%n_Channels + Atmosphere_AD(n)%Level_Pressure(Atmosphere(n)%n_layers) = & + Atmosphere_AD(n)%Level_Pressure(Atmosphere(n)%n_layers) + & + iv%instid(inst)%ps_jacobian(i,n) * RTSolution_AD(i,n)%brightness_temperature + end do - call da_crtm_ad (1, nchanl, 1, Atmosphere, & - Surface, & - RTSolution_AD,& - GeometryInfo, & - ChannelInfo(inst:inst), & - Atmosphere_AD,& - Surface_AD, & - RTSolution, & - Options) + do k = kts , kte + do i = 1, ChannelInfo(inst)%n_Channels + Atmosphere_AD(n)%Temperature(k) = Atmosphere_AD(n)%Temperature(k) + & + iv%instid(inst)%t_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature + Atmosphere_AD(n)%absorber(k,1) = Atmosphere_AD(n)%absorber(k,1) + & + iv%instid(inst)%q_jacobian(i,k,n) * RTSolution_AD(i,n)%brightness_temperature + end do + end do + endif + end do + !$OMP END PARALLEL DO + + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel ! Skin Temperature !----------------- if (use_satcv(1)) then ts_index = iv%instid(inst)%cv_index(n)%ts - if (Surface(1)%Land_Coverage > 0.0) cv(ts_index) = Surface_AD(1)%Land_Temperature - if (Surface(1)%Water_Coverage > 0.0) cv(ts_index) = Surface_AD(1)%Water_Temperature - if (Surface(1)%Snow_Coverage > 0.0) cv(ts_index) = Surface_AD(1)%Snow_Temperature - if (Surface(1)%Ice_Coverage > 0.0) cv(ts_index) = Surface_AD(1)%Ice_Temperature + if (Surface(n)%Land_Coverage > 0.0) cv(ts_index) = Surface_AD(n)%Land_Temperature + if (Surface(n)%Water_Coverage > 0.0) cv(ts_index) = Surface_AD(n)%Water_Temperature + if (Surface(n)%Snow_Coverage > 0.0) cv(ts_index) = Surface_AD(n)%Snow_Temperature + if (Surface(n)%Ice_Coverage > 0.0) cv(ts_index) = Surface_AD(n)%Ice_Temperature end if ! Cloud cover(s) @@ -390,12 +459,16 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) do k = 1, nchanl if (ALL(iv%instid(inst)%ichan(k) /= Bands(:,1))) cycle ! Only Channels in Band 1 rad_clr = iv%instid(inst)%rad_xb(k,n) - rad_ovc(:) = iv%instid(inst)%rad_ovc(k,kte-nclouds+1:kte,n) + do icld = kte-nclouds+1, kte + rad_ovc(icld) = iv%instid(inst)%rad_ovc(k,icld,n) + end do rad_ad = 0.0 tb_ad = jo_grad_y%instid(inst)%tb(k,n) call CRTM_Planck_Temperature_AD(inst,k,rad_clr,tb_ad,rad_ad) - cc_ad = rad_ad * (rad_ovc(:)-rad_clr) + do icld = 1, nclouds + cc_ad(icld) = rad_ad * (rad_ovc(icld)-rad_clr) + end do ! !--------------------------------------------------------------- ! ! Change of variable (preconditioning) ! !--------------------------------------------------------------- @@ -404,7 +477,9 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) ! iv%instid(inst)%cv_index(n)%vtox(icld,:) ) ! end do - cv(iv%instid(inst)%cv_index(n)%cc) = cv(iv%instid(inst)%cv_index(n)%cc) + cc_ad + do icld = 1, ncv + cv(iv%instid(inst)%cv_index(n)%cc(icld)) = cv(iv%instid(inst)%cv_index(n)%cc(icld)) + cc_ad(icld) + end do end do deallocate(rad_ovc, cc_ad) end if @@ -413,47 +488,49 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) if (crtm_cloud) then do k=kts,kte - do icld=1,Atmosphere(1)%n_Clouds - Atmosphere_AD(1)%Cloud(icld)%Water_Content(k) = & - Atmosphere_AD(1)%Cloud(icld)%Water_Content(k) * & - (Atmosphere(1)%Level_Pressure(k)- Atmosphere(1)%Level_Pressure(k-1)) / gravity + do icld=1,Atmosphere(n)%n_Clouds + Atmosphere_AD(n)%Cloud(icld)%Water_Content(k) = & + Atmosphere_AD(n)%Cloud(icld)%Water_Content(k) * & + (Atmosphere(n)%Level_Pressure(k)- Atmosphere(n)%Level_Pressure(k-1)) / gravity enddo enddo end if ! [1.6] Adjoint of Interpolate horizontally from ob to grid: + if (crtm_cloud) then do k=kts,kte ! from bottom to top - - if (crtm_cloud) then - qcw(k,n)=Atmosphere_AD(1)%Cloud(1)%Water_Content(kte-k+1) - qci(k,n)=Atmosphere_AD(1)%Cloud(2)%Water_Content(kte-k+1) - qrn(k,n)=Atmosphere_AD(1)%Cloud(3)%Water_Content(kte-k+1) - qsn(k,n)=Atmosphere_AD(1)%Cloud(4)%Water_Content(kte-k+1) - qgr(k,n)=Atmosphere_AD(1)%Cloud(5)%Water_Content(kte-k+1) - end if - - if (atmosphere(1)%pressure(kte-k+1) >= 75.0) & ! Zero Jacobian for top level(s) - q_ad(k,n) = Atmosphere_AD(1)%Absorber(kte-k+1,1) * 1000.0 ! in g/kg - if (k < kte) & ! Zero Jacobian for top level - t_ad(k,n)=Atmosphere_AD(1)%Temperature(kte-k+1) + qcw(k,n)=Atmosphere_AD(n)%Cloud(1)%Water_Content(kte-k+1) + qci(k,n)=Atmosphere_AD(n)%Cloud(2)%Water_Content(kte-k+1) + qrn(k,n)=Atmosphere_AD(n)%Cloud(3)%Water_Content(kte-k+1) + qsn(k,n)=Atmosphere_AD(n)%Cloud(4)%Water_Content(kte-k+1) + qgr(k,n)=Atmosphere_AD(n)%Cloud(5)%Water_Content(kte-k+1) end do + end if + + do k=kts,kte ! from bottom to top + if (atmosphere(n)%pressure(kte-k+1) >= 75.0) & ! Zero Jacobian for top level(s) + q_ad(k,n) = Atmosphere_AD(n)%Absorber(kte-k+1,1) * 1000.0 / & + (1.0-xb_q(kte-k+1,n))**2 ! in g/kg + if (k < kte) & ! Zero Jacobian for top level + t_ad(k,n)=Atmosphere_AD(n)%Temperature(kte-k+1) + end do - p_ad(n) = Atmosphere_AD(1)%Level_Pressure(atmosphere(1)%n_layers) * 0.01 ! in hPa + p_ad(n) = Atmosphere_AD(n)%Level_Pressure(atmosphere(n)%n_layers) * 0.01 ! in hPa - Error_Status = CRTM_Destroy_Atmosphere( Atmosphere_AD ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting CRTM Atmosphere_AD Structure"/)) - end if + Error_Status = CRTM_Destroy_Atmosphere( Atmosphere_AD(n) ) + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting CRTM Atmosphere_AD Structure"/)) + end if - Error_Status = CRTM_Destroy_Surface(Surface_AD) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting CRTM Surface_AD Structure"/)) - end if + Error_Status = CRTM_Destroy_Surface(Surface_AD(n)) + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting CRTM Surface_AD Structure"/)) + end if - end do ! end loop for pixels + end do ! end loop for pixels ! [1.7] Gamma correction to VarBC #ifdef CRTM_MODIF @@ -467,7 +544,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) if (iv%instid(inst)%varbc(k)%ipred(ipred) /= gammapred) cycle id = iv%instid(inst)%varbc(k)%index(ipred) cv_local(id) = cv_local(id) + & - SUM(RTSolution_AD(k,1)%Gamma * iv%instid(inst)%varbc(k)%vtox(ipred,1:npred)) + SUM(RTSolution_AD(k,n)%Gamma * iv%instid(inst)%varbc(k)%vtox(ipred,1:npred)) end do end do end if @@ -492,6 +569,7 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) deallocate (q_ad) deallocate (t_ad) deallocate (p_ad) + deallocate (xb_q) if (crtm_cloud) then deallocate (qcw) @@ -510,27 +588,57 @@ subroutine da_transform_xtoy_crtm_adj ( cv_size, cv, iv, jo_grad_y, jo_grad_x ) (/"Error in deallocatting RTSolution"/)) END IF - Error_Status = CRTM_Destroy_Options(Options) + do n = iv%instid(inst)%info%n1, iv%instid(inst)%info%n2 ! loop for pixel + + Error_Status = CRTM_Destroy_Options(Options(n)) if ( Error_Status /= 0 ) then call da_error(__FILE__,__LINE__, & (/"Error in deallocatting CRTM Options Structure"/)) end if - Error_Status = CRTM_Destroy_Surface(Surface) + Error_Status = CRTM_Destroy_Surface(Surface(n)) if ( Error_Status /= 0 ) then call da_error(__FILE__,__LINE__, & (/"Error in deallocatting CRTM Surface Structure"/)) end if - end do ! end loop for sensor !------------------------------------------------------------------- ! [3.0] Deallocating CRTM Atmosphere structures !------------------------------------------------------------------- - Error_Status = CRTM_Destroy_Atmosphere( Atmosphere ) - if ( Error_Status /= 0 ) then - call da_error(__FILE__,__LINE__, & - (/"Error in deallocatting CRTM Atmosphere Structure"/)) - end if + Error_Status = CRTM_Destroy_Atmosphere( Atmosphere(n) ) + if ( Error_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting CRTM Atmosphere Structure"/)) + end if + + end do + + deallocate( Atmosphere, Atmosphere_AD, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting Atmosphere"/)) + END IF + + deallocate( Surface, Surface_AD, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting Surface"/)) + END IF + + deallocate( Options, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting Options"/)) + END IF + + deallocate( GeometryInfo, STAT = Allocate_Status ) + if ( Allocate_Status /= 0 ) then + call da_error(__FILE__,__LINE__, & + (/"Error in deallocatting GeometryInfo"/)) + END IF + + end do sensors_loop ! end loop for sensor + if (trace_use) call da_trace_exit("da_transform_xtoy_crtm_adj") #else diff --git a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov.inc b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov.inc index 540f47b7..754e7c38 100644 --- a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov.inc +++ b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov.inc @@ -349,11 +349,14 @@ subroutine da_transform_xtoy_rttov (grid, iv, y ) call da_rttov_tl (i, nchan, d_num_rad, d_con_vars, & d_aux_vars, d_con_vars_tl, d_aux_vars_tl, d_tb) else + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n ) do n=1,d_num_rad call da_rttov_tl (i, nchan, 1, d_con_vars(n:n), & d_aux_vars(n:n), d_con_vars_tl(n:n), d_aux_vars_tl(n:n), & d_tb(:,n:n)) end do + !$OMP END PARALLEL DO end if end if diff --git a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov_adj.inc b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov_adj.inc index 10ddc939..1b16fea3 100644 --- a/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov_adj.inc +++ b/wrfv2_fire/var/da/da_radiance/da_transform_xtoy_rttov_adj.inc @@ -262,10 +262,13 @@ subroutine da_transform_xtoy_rttov_adj ( iv, jo_grad_y, jo_grad_x ) call da_rttov_ad (i, nchan, d_num_rad, d_con_vars, & d_aux_vars, d_con_vars_ad, d_tb) else - do n=1,d_num_rad - call da_rttov_ad (i, nchan, 1, d_con_vars(n:n), & - d_aux_vars(n:n), d_con_vars_ad(n:n), d_tb(:,n:n)) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( n ) + do n=1,d_num_rad + call da_rttov_ad (i, nchan, 1, d_con_vars(n:n), & + d_aux_vars(n:n), d_con_vars_ad(n:n), d_tb(:,n:n)) end do + !$OMP END PARALLEL DO end if end if diff --git a/wrfv2_fire/var/da/da_radiance/da_write_iv_rad_ascii.inc b/wrfv2_fire/var/da/da_radiance/da_write_iv_rad_ascii.inc index f4afd9d1..949527f6 100644 --- a/wrfv2_fire/var/da/da_radiance/da_write_iv_rad_ascii.inc +++ b/wrfv2_fire/var/da/da_radiance/da_write_iv_rad_ascii.inc @@ -1,4 +1,4 @@ -subroutine da_write_iv_rad_ascii (ob, iv ) +subroutine da_write_iv_rad_ascii (it, ob, iv ) !--------------------------------------------------------------------------- ! Purpose: write out innovation vector structure for radiance data. @@ -6,6 +6,7 @@ subroutine da_write_iv_rad_ascii (ob, iv ) implicit none + integer , intent(in) :: it ! outer loop count type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(in) :: iv ! O-B structure. @@ -33,7 +34,7 @@ subroutine da_write_iv_rad_ascii (ob, iv ) end do if (ndomain < 1) cycle - write(unit=filename, fmt='(a,i4.4)') 'inv_'//trim(iv%instid(i)%rttovid_string)//'.', myproc + write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_inv_'//trim(iv%instid(i)%rttovid_string)//'.', myproc call da_get_unit(innov_rad_unit) open(unit=innov_rad_unit,file=trim(filename),form='formatted',iostat=ios) diff --git a/wrfv2_fire/var/da/da_radiance/da_write_oa_rad_ascii.inc b/wrfv2_fire/var/da/da_radiance/da_write_oa_rad_ascii.inc index 77922c8c..26e84f8c 100644 --- a/wrfv2_fire/var/da/da_radiance/da_write_oa_rad_ascii.inc +++ b/wrfv2_fire/var/da/da_radiance/da_write_oa_rad_ascii.inc @@ -1,4 +1,4 @@ -subroutine da_write_oa_rad_ascii ( ob, iv, re ) +subroutine da_write_oa_rad_ascii (it, ob, iv, re ) !--------------------------------------------------------------------------- ! Purpose: write out OMB and OMA vector structure for radiance data. @@ -6,6 +6,7 @@ subroutine da_write_oa_rad_ascii ( ob, iv, re ) implicit none + integer , intent(in) :: it ! outer loop count type (y_type), intent(in) :: ob ! Observation structure. type (iv_type), intent(in) :: iv ! O-B structure. type (y_type), intent(in) :: re ! O-A structure. @@ -34,7 +35,7 @@ subroutine da_write_oa_rad_ascii ( ob, iv, re ) end do if (ndomain < 1) cycle - write(unit=filename, fmt='(a,i4.4)') 'oma_'//trim(iv%instid(i)%rttovid_string)//'.', myproc + write(unit=filename, fmt='(i2.2,a,i4.4)') it,'_oma_'//trim(iv%instid(i)%rttovid_string)//'.', myproc call da_get_unit(oma_rad_unit) open(unit=oma_rad_unit,file=trim(filename),form='formatted',iostat=ios) diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf.inc b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf.inc index 50d88369..459cd257 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf.inc +++ b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf.inc @@ -54,20 +54,24 @@ SUBROUTINE da_apply_rf( be, vp, grid ) in=grid%xp%ipex-grid%xp%ipsx jn=grid%xp%jpex-grid%xp%jpsx - call smoothx(in,jn,& - grid%xp % v1x(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,1),& - be%slipx(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex),& - be%ndeg,be%be,be%nta,be%swidth,be%table) + if ( LBOUND(grid%xp%v1x,3) == 1 ) then + call smoothx(in,jn,& + grid%xp%v1x(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,1),& + be%slipx(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex),& + be%ndeg,be%be,be%nta,be%swidth,be%table) + endif call da_transpose_x2y ( grid ) in=grid%xp%ipey-grid%xp%ipsy jn=grid%xp%jpey-grid%xp%jpsy - call smoothy(in,jn, & - grid%xp % v1y(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,1),& - be%sljpy(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey),& - be%ndeg,be%be,be%nta,be%swidth,be%table) + if ( LBOUND(grid%xp%v1y,3) == 1 ) then + call smoothy(in,jn, & + grid%xp%v1y(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,1),& + be%sljpy(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey),& + be%ndeg,be%be,be%nta,be%swidth,be%table) + endif call da_transpose_y2z ( grid ) diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v.inc b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v.inc index 5fc98faa..84bc521c 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v.inc +++ b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v.inc @@ -37,12 +37,15 @@ SUBROUTINE da_apply_rf_1v( be, vp, grid, nv ) in=grid%xp%ipex-grid%xp%ipsx jn=grid%xp%jpex-grid%xp%jpsx + !$OMP PARALLEL DO & + !$OMP PRIVATE ( k ) do k=grid%xp%kpsx,grid%xp%kpex call smoothx(in,jn, & grid%xp% v1x(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,k),& be%slix(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,k,nv), & be%ndeg,be%be,be%nta,be%swidth,be%table) enddo + !$OMP END PARALLEL DO call da_transpose_x2y ( grid ) @@ -50,12 +53,15 @@ SUBROUTINE da_apply_rf_1v( be, vp, grid, nv ) in=grid%xp%ipey-grid%xp%ipsy jn=grid%xp%jpey-grid%xp%jpsy + !$OMP PARALLEL DO & + !$OMP PRIVATE ( k ) do k=grid%xp%kpsy,grid%xp%kpey call smoothy(in,jn, & grid%xp%v1y(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,k),& be%sljy(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,k,nv), & be%ndeg,be%be,be%nta,be%swidth,be%table) enddo + !$OMP END PARALLEL DO call da_transpose_y2z ( grid ) diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v_adj.inc b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v_adj.inc index d720f35c..1d277fef 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v_adj.inc +++ b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_1v_adj.inc @@ -24,24 +24,30 @@ SUBROUTINE da_apply_rf_1v_adj( be, vp, grid, nv ) in=grid%xp%ipey-grid%xp%ipsy jn=grid%xp%jpey-grid%xp%jpsy + !$OMP PARALLEL DO & + !$OMP PRIVATE ( k ) do k=grid%xp%kpsy,grid%xp%kpey call smoothy(in,jn,& grid%xp % v1y(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,k),& be%sljy(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,k,nv), & be%ndeg,be%be,be%nta,be%swidth,be%table) enddo + !$OMP END PARALLEL DO call da_transpose_y2x ( grid ) in=grid%xp%ipex-grid%xp%ipsx jn=grid%xp%jpex-grid%xp%jpsx + !$OMP PARALLEL DO & + !$OMP PRIVATE ( k ) do k=grid%xp%kpsx,grid%xp%kpex call smoothx(in,jn, & grid%xp % v1x(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,k),& be%slix(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,k,nv), & be%ndeg,be%be,be%nta,be%swidth,be%table) enddo + !$OMP END PARALLEL DO call da_transpose_x2z ( grid ) diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_adj.inc b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_adj.inc index 3cdf4ab9..a8696f55 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_adj.inc +++ b/wrfv2_fire/var/da/da_recursive_filter/da_apply_rf_adj.inc @@ -50,21 +50,25 @@ SUBROUTINE da_apply_rf_adj( be, vp , grid ) in=grid%xp%ipey-grid%xp%ipsy jn=grid%xp%jpey-grid%xp%jpsy - - call smoothy(in,jn, & - grid%xp % v1y(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,1),& - be%sljpy(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey),& - be%ndeg,be%be,be%nta,be%swidth,be%table) + + if ( LBOUND(grid%xp%v1y,3) == 1 ) then + call smoothy(in,jn, & + grid%xp%v1y(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey,1),& + be%sljpy(grid%xp%ipsy:grid%xp%ipey,grid%xp%jpsy:grid%xp%jpey),& + be%ndeg,be%be,be%nta,be%swidth,be%table) + endif call da_transpose_y2x ( grid ) in=grid%xp%ipex-grid%xp%ipsx jn=grid%xp%jpex-grid%xp%jpsx - call smoothx(in,jn,& - grid%xp % v1x(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,1),& - be%slipx(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex),& - be%ndeg,be%be,be%nta,be%swidth,be%table) + if ( LBOUND(grid%xp%v1x,3) == 1 ) then + call smoothx(in,jn,& + grid%xp%v1x(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex,1),& + be%slipx(grid%xp%ipsx:grid%xp%ipex,grid%xp%jpsx:grid%xp%jpex),& + be%ndeg,be%be,be%nta,be%swidth,be%table) + endif call da_transpose_x2z ( grid ) diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_rfz_cv3.f90 b/wrfv2_fire/var/da/da_recursive_filter/da_rfz_cv3.f90 index 6099b38e..ea26f72b 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_rfz_cv3.f90 +++ b/wrfv2_fire/var/da/da_recursive_filter/da_rfz_cv3.f90 @@ -20,6 +20,8 @@ contains jtsm=jts-1 ta=float(nta)/swidth + !$OMP PARALLEL DO & + !$OMP PRIVATE (j, jj, i, ii, k, kk, im, al, p2, p3, GA, DE) do j=1,n2 jj=j+jtsm do i=1,n1 @@ -44,6 +46,7 @@ contains enddo enddo enddo + !$OMP END PARALLEL DO RETURN END SUBROUTINE da_rfz diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf.inc b/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf.inc index c038cf51..ad8a777b 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf.inc +++ b/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf.inc @@ -19,9 +19,10 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field) real, intent(inout) :: field(ims:ime,jms:jme,kms:kme) ! Field to be transformed. integer :: rf_passes_over_two ! rf_passes / 2 - integer :: i, j, m, n, pass ! Loop counters. + integer :: i, j, m, n, pass, ij ! Loop counters. real :: p_x(ims:ime,jms:jme)! sqrt(Grid box area). real :: val_j(grid%xp%jtsy:grid%xp%jtey) + real :: val_i(grid%xp%itsx:grid%xp%itex) !---------------------------------------------------------------------- ! [1.0]: Initialise: @@ -31,16 +32,45 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field) rf_passes_over_two = rf_passes / 2 - ! [1.1] Define inner product (square root of grid box area): - p_x(its:ite,jts:jte) = sqrt(grid%xb%grid_box_area(its:ite,jts:jte)) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j ) + do ij = 1 , grid%num_tiles + ! [1.1] Define inner product (square root of grid box area): + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + p_x(i,j) = sqrt(grid%xb%grid_box_area(i,j)) + end do + end do + end do + !$OMP END PARALLEL DO - grid%xp%v1z(:,:,:) = 0.0 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, m, i, j ) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xp%v1z(i,j,m) = 0.0 + end do + end do + end do + end do + !$OMP END PARALLEL DO - ! [1.2] Transform to nondimensional v_hat space: + ! [1.2] Transform to nondimensional v_hat space: - do m = 1, mz - grid%xp%v1z(its:ite,jts:jte,m) = field(its:ite,jts:jte,m) / p_x(its:ite,jts:jte) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, m, i, j ) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xp%v1z(i,j,m) = field(i,j,m) / p_x(i,j) + end do + end do + end do end do + !$OMP END PARALLEL DO !------------------------------------------------------------------------- ! [2.0]: Perform 1D recursive filter in x-direction: @@ -54,13 +84,22 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field) ! [2.2] Apply 1D filter in x direction: n = grid%xp%itex - grid%xp%itsx + 1 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( m, j, pass, val_i, i ) do m = grid%xp%ktsx, min(grid%xp%ktex,mz) do j = grid%xp%jtsx, grid%xp%jtex + do i = grid%xp%itsx, grid%xp%itex + val_i(i) = grid%xp%v1x(i,j,m) + end do do pass = 1, rf_passes_over_two - call da_recursive_filter_1d(pass, rf_alpha(m), grid%xp%v1x(grid%xp%itsx:grid%xp%itex,j,m), n) + call da_recursive_filter_1d(pass, rf_alpha(m), val_i, n) + end do + do i = grid%xp%itsx, grid%xp%itex + grid%xp%v1x(i,j,m) = val_i(i) end do end do end do + !$OMP END PARALLEL DO !------------------------------------------------------------------------- ! [3.0]: Perform 1D recursive filter in y-direction: @@ -74,15 +113,22 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field) ! [3.2] Apply 1D filter in y direction: n = grid%xp%jtey - grid%xp%jtsy + 1 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( m, i, pass, val_j, j ) do m = grid%xp%ktsy, min(grid%xp%ktey,mz) do i = grid%xp%itsy, grid%xp%itey - val_j(grid%xp%jtsy:grid%xp%jtey) = grid%xp%v1y(i,grid%xp%jtsy:grid%xp%jtey,m) + do j = grid%xp%jtsy, grid%xp%jtey + val_j(j) = grid%xp%v1y(i,j,m) + end do do pass = 1, rf_passes_over_two call da_recursive_filter_1d(pass, rf_alpha(m), val_j, n) end do - grid%xp%v1y(i,grid%xp%jtsy:grid%xp%jtey,m) = val_j(grid%xp%jtsy:grid%xp%jtey) + do j = grid%xp%jtsy, grid%xp%jtey + grid%xp%v1y(i,j,m) = val_j(j) + end do end do end do + !$OMP END PARALLEL DO !------------------------------------------------------------------------- ! [4.0]: Perform 1D recursive filter in y-direction: @@ -95,9 +141,19 @@ subroutine da_transform_through_rf(grid,mz, rf_alpha, val,field) ! [4.2] Transform filtered field to dimensional space: - do m = 1, mz - field(its:ite,jts:jte,m) = grid%xp%v1z(its:ite,jts:jte,m) * p_x(its:ite,jts:jte) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, m, i, j ) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + ! do j = jts, jte + do i = its, ite + field(i,j,m) = grid%xp%v1z(i,j,m) * p_x(i,j) + end do + end do + end do end do + !$OMP END PARALLEL DO ! [4.3] Optionally scale by background error: diff --git a/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf_adj.inc b/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf_adj.inc index 13f997d5..6d590020 100644 --- a/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf_adj.inc +++ b/wrfv2_fire/var/da/da_recursive_filter/da_transform_through_rf_adj.inc @@ -19,9 +19,10 @@ subroutine da_transform_through_rf_adj(grid, mz,rf_alpha, val, field) real, intent(inout) :: field(ims:ime,jms:jme,kms:kme) ! Field to be transformed. integer :: rf_passes_over_two ! rf_passes / 2 - integer :: i, j, m, n, pass ! Loop counters. + integer :: i, j, m, n, pass, ij ! Loop counters. real :: p_x(ims:ime,jms:jme) ! sqrt(Grid box area). real :: val_j(grid%xp%jtsy:grid%xp%jtey) + real :: val_i(grid%xp%itsx:grid%xp%itex) !------------------------------------------------------------------------- ! [1.0]: Initialise: @@ -32,7 +33,16 @@ subroutine da_transform_through_rf_adj(grid, mz,rf_alpha, val, field) rf_passes_over_two = rf_passes / 2 ! [1.1] Define inner product (square root of grid box area): - p_x(its:ite,jts:jte) = sqrt(grid%xb%grid_box_area(its:ite,jts:jte)) + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij, i, j) + do ij = 1 , grid%num_tiles + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + p_x(i,j) = sqrt(grid%xb%grid_box_area(i,j)) + end do + end do + end do + !$OMP END PARALLEL DO !------------------------------------------------------------------------- ! [4.0]: Perform 1D recursive filter in y-direction: @@ -54,10 +64,18 @@ subroutine da_transform_through_rf_adj(grid, mz,rf_alpha, val, field) ! [4.2] Transform filtered field to dimensional space: - do m = 1, mz - grid%xp%v1z(its:ite,jts:jte,m) = field(its:ite,jts:jte,m) * & - p_x(its:ite,jts:jte) + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij ,m, j, i) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xp%v1z(i,j,m) = field(i,j,m) * p_x(i,j) + end do + end do + end do end do + !$OMP END PARALLEL DO ! [4.1] Apply (i',j',k -> i',j,k') (grid%xp%v1z -> grid%xp%v1y) ! convert vertical column to y-stripe @@ -71,15 +89,22 @@ subroutine da_transform_through_rf_adj(grid, mz,rf_alpha, val, field) ! [3.2] Apply 1D filter in y direction: n=grid%xp%jtey-grid%xp%jtsy+1 + !$OMP PARALLEL DO & + !$OMP PRIVATE (m, i, val_j, pass, j) do m = grid%xp%ktsy, min(grid%xp%ktey, mz) do i = grid%xp%itsy, grid%xp%itey - val_j(grid%xp%jtsy:grid%xp%jtey) = grid%xp%v1y(i,grid%xp%jtsy:grid%xp%jtey,m) + do j = grid%xp%jtsy, grid%xp%jtey + val_j(j) = grid%xp%v1y(i,j,m) + end do do pass = rf_passes_over_two, 1, -1 call da_recursive_filter_1d_adj(pass, rf_alpha(m), val_j, n) end do - grid%xp%v1y(i,grid%xp%jtsy:grid%xp%jtey,m) = val_j(grid%xp%jtsy:grid%xp%jtey) + do j = grid%xp%jtsy, grid%xp%jtey + grid%xp%v1y(i,j,m) = val_j(j) + end do end do end do + !$OMP END PARALLEL DO ! [3.1] Apply (i',j,k' -> i,j',k') (grid%xp%v1y -> grid%xp%v1x) ! convert from y-stripe to x-stripe @@ -94,13 +119,22 @@ subroutine da_transform_through_rf_adj(grid, mz,rf_alpha, val, field) n = grid%xp%itex-grid%xp%itsx+1 + !$OMP PARALLEL DO & + !$OMP PRIVATE ( m, j, pass, i, val_i) do m = grid%xp%ktsx, min(grid%xp%ktex,mz) do j = grid%xp%jtsx, grid%xp%jtex + do i = grid%xp%itsx, grid%xp%itex + val_i(i) = grid%xp%v1x(i,j,m) + end do do pass = rf_passes_over_two, 1, -1 - call da_recursive_filter_1d_adj(pass, rf_alpha(m), grid%xp%v1x(grid%xp%itsx:grid%xp%itex,j,m), n) + call da_recursive_filter_1d_adj(pass, rf_alpha(m), val_i, n) + end do + do i = grid%xp%itsx, grid%xp%itex + grid%xp%v1x(i,j,m) = val_i(i) end do end do end do + !$OMP END PARALLEL DO ! [2.1] Apply (i,j',k' -> i',j',k) (grid%xp%v1x -> grid%xp%v1z) ! convert from x-stripe to vertical column @@ -113,9 +147,18 @@ subroutine da_transform_through_rf_adj(grid, mz,rf_alpha, val, field) ! [1.2] Transform to nondimensional v_hat space: - do m = 1, mz - field(its:ite,jts:jte,m) = grid%xp%v1z(its:ite,jts:jte,m) / p_x(its:ite,jts:jte) + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij ,m, i, j) + do ij = 1 , grid%num_tiles + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + field(i,j,m) = grid%xp%v1z(i,j,m) / p_x(i,j) + end do + end do + end do end do + !$OMP END PARALLEL DO if (trace_use_dull) call da_trace_exit("da_transform_through_rf_adj") diff --git a/wrfv2_fire/var/da/da_satem/da_check_max_iv_satem.inc b/wrfv2_fire/var/da/da_satem/da_check_max_iv_satem.inc index 31f60797..2c78b28b 100644 --- a/wrfv2_fire/var/da/da_satem/da_check_max_iv_satem.inc +++ b/wrfv2_fire/var/da/da_satem/da_check_max_iv_satem.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_satem(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -22,12 +25,9 @@ subroutine da_check_max_iv_satem(iv, it, num_qcstat_conv) do n = iv%info(satem)%n1,iv%info(satem)%n2 do k = 1, iv%info(satem)%levels(n) call da_get_print_lvl(iv%satem(n)%p(k),ipr) - - if ( iv%satem(n)%thickness(k)%qc == fails_error_max .and. it > 1 ) iv%satem(n)%thickness(k)%qc =0 - if ( iv%satem(n)%thickness(k)%qc >= obs_qc_pointer ) then + failed=.false. + if ( iv%satem(n)%thickness(k)%qc >= obs_qc_pointer ) & ! Thickness - failed=.false. - if( check_max_iv) & call da_max_error_qc(it, iv%info(satem), n, iv%satem(n)%thickness(k),& max_error_thickness, failed) if( iv%info(satem)%proc_domain(k,n) ) then @@ -38,7 +38,6 @@ subroutine da_check_max_iv_satem(iv, it, num_qcstat_conv) 'satem',ob_vars(9),iv%info(satem)%lat(k,n),iv%info(satem)%lon(k,n),0.01*iv%satem(n)%p(k) end if end if - end if end do end do diff --git a/wrfv2_fire/var/da/da_satem/da_get_innov_vector_satem.inc b/wrfv2_fire/var/da/da_satem/da_get_innov_vector_satem.inc index dedff16e..b6b312fd 100644 --- a/wrfv2_fire/var/da/da_satem/da_get_innov_vector_satem.inc +++ b/wrfv2_fire/var/da/da_satem/da_get_innov_vector_satem.inc @@ -35,6 +35,14 @@ subroutine da_get_innov_vector_satem(it, num_qcstat_conv,grid, ob, iv) if (trace_use_dull) call da_trace_entry("da_get_innov_vector_satem") + if ( it > 1 ) then + do n=iv%info(satem)%n1,iv%info(satem)%n2 + do k = 1, iv%info(satem)%levels(n) + if (iv%satem(n)%thickness(k)%qc == fails_error_max) iv%satem(n)%thickness(k)%qc = 0 + end do + end do + end if + do n=iv%info(satem)%n1,iv%info(satem)%n2 num_levs = iv%info(satem)%levels(n) @@ -106,7 +114,8 @@ subroutine da_get_innov_vector_satem(it, num_qcstat_conv,grid, ob, iv) ! [5.0] Perform optional maximum error check: !------------------------------------------------------------------------ - call da_check_max_iv_satem(iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_satem(iv, it, num_qcstat_conv) !------------------------------------------------------------------------ ! [6.0] Perform land/ocean check diff --git a/wrfv2_fire/var/da/da_setup_structures/da_rescale_background_errors.inc b/wrfv2_fire/var/da/da_setup_structures/da_rescale_background_errors.inc index 1df2e2fc..407779de 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_rescale_background_errors.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_rescale_background_errors.inc @@ -21,6 +21,9 @@ subroutine da_rescale_background_errors (var_scaling, len_scaling, & if (trace_use_dull) call da_trace_entry("da_rescale_background_errors") + write(unit=stdout,fmt='(3x,"Scaling: var, len, ds:",3e15.6 )') & + var_scaling, len_scaling, ds + !-------------------------------------------------------------------------- ! [1.0] Initialise: !-------------------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_global.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_global.inc index cc48186c..802bda91 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_global.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_global.inc @@ -131,22 +131,22 @@ subroutine da_setup_be_global (be) if (nrec == 1) then be % v1 % name = variable call da_get_bins_info(nj, nk, bin2d, evec_g, eval_g, & - evec_loc, eval_loc, max_vert_var1, var_scaling1, be%v1) + evec_loc, eval_loc, max_vert_var1, var_scaling1(1), be%v1) else if (nrec == 2) then be % v2 % name = variable call da_get_bins_info(nj, nk, bin2d, evec_g, eval_g, & - evec_loc, eval_loc, max_vert_var2, var_scaling2, be%v2) + evec_loc, eval_loc, max_vert_var2, var_scaling2(1), be%v2) else if (nrec == 3) then be % v3 % name = variable call da_get_bins_info(nj, nk, bin2d, evec_g, eval_g, & - evec_loc, eval_loc, max_vert_var3, var_scaling3, be%v3) + evec_loc, eval_loc, max_vert_var3, var_scaling3(1), be%v3) else if (nrec == 4) then be % v4 % name = variable call da_get_bins_info(nj, nk, bin2d, evec_g, eval_g, & - evec_loc, eval_loc, max_vert_var4, var_scaling4, be%v4) + evec_loc, eval_loc, max_vert_var4, var_scaling4(1), be%v4) end if deallocate (evec_g) @@ -186,7 +186,7 @@ subroutine da_setup_be_global (be) 'Horizontal truncation for ', be % v1 % name, ' = ', be % v1 % max_wave allocate (be % v1 % power(0:be % v1 % max_wave,1:nk)) be % v1 % power(0:be % v1 % max_wave,1:nk) = power2d(0:be % v1 % max_wave,1:nk) - be % v1 % power(0,1:nk) = len_scaling1 * be % v1 % power(0,1:nk) + be % v1 % power(0,1:nk) = len_scaling1(1) * be % v1 % power(0,1:nk) do k = 1, nk read (be_unit) variable @@ -205,7 +205,7 @@ subroutine da_setup_be_global (be) 'Horizontal truncation for ', be % v2 % name, ' = ', be % v2 % max_wave allocate (be % v2 % power(0:be % v2 % max_wave,1:nk)) be % v2 % power(0:be % v2 % max_wave,1:nk) = power2d(0:be % v2 % max_wave,1:nk) - be % v2 % power(0,1:nk) = len_scaling2 * be % v2 % power(0,1:nk) + be % v2 % power(0,1:nk) = len_scaling2(1) * be % v2 % power(0,1:nk) do k = 1, nk read (be_unit) variable @@ -224,7 +224,7 @@ subroutine da_setup_be_global (be) 'Horizontal truncation for ', be % v3 % name, ' = ', be % v3 % max_wave allocate (be % v3 % power(0:be % v3 % max_wave,1:nk)) be % v3 % power(0:be % v3 % max_wave,1:nk) = power2d(0:be % v3 % max_wave,1:nk) - be % v3 % power(0,1:nk) = len_scaling3 * be % v3 % power(0,1:nk) + be % v3 % power(0,1:nk) = len_scaling3(1) * be % v3 % power(0,1:nk) do k = 1, nk read (be_unit) variable @@ -243,7 +243,7 @@ subroutine da_setup_be_global (be) 'Horizontal truncation for ', be % v4 % name, ' = ', be % v4 % max_wave allocate (be % v4 % power(0:be % v4 % max_wave,1:nk)) be % v4 % power(0:be % v4 % max_wave,1:nk) = power2d(0:be % v4 % max_wave,1:nk) - be % v4 % power(0,1:nk) = len_scaling4 * be % v4 % power(0,1:nk) + be % v4 % power(0,1:nk) = len_scaling4(1) * be % v4 % power(0,1:nk) ! ps_u: read (be_unit) variable @@ -262,7 +262,7 @@ subroutine da_setup_be_global (be) 'Horizontal truncation for ', be % v5 % name, ' = ', be % v5 % max_wave allocate (be % v5 % power(0:be % v5 % max_wave,1)) be % v5 % power(0:be % v5 % max_wave,1) = power(0:be % v5 % max_wave) - be % v5 % power(0,1) = len_scaling5 * be%v5%power(0,1) + be % v5 % power(0,1) = len_scaling5(1) * be%v5%power(0,1) deallocate(power) diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_ncep_gfs.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_ncep_gfs.inc index 23eb569f..fd54716c 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_ncep_gfs.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_ncep_gfs.inc @@ -279,7 +279,9 @@ subroutine da_setup_be_ncep_gfs( grid, be ) ! 7.1 Calculate the interpolation coefficients: - do j= jds, jde + !$OMP PARALLEL DO & + !$OMP PRIVATE ( j, i, m, m1 ) + do j= jds, jde do i= ids, ide if (global_lat(i,j).ge.clat_avn(2*nlath)) then @@ -304,11 +306,16 @@ subroutine da_setup_be_ncep_gfs( grid, be ) end do end do + !$OMP END PARALLEL DO ! 7.2 interpolation of the covariance ! Psfc: - do j=jts,jte + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, j, i, m, m1 ) + do ij = 1, grid%num_tiles + + do j=grid%j_start(ij), grid%j_end(ij) do i=its,ite m=mlat(i,j) m1=m+1 @@ -316,9 +323,16 @@ subroutine da_setup_be_ncep_gfs( grid, be ) enddo enddo + enddo + !$OMP END PARALLEL DO + ! psi, chi, t, and rh: + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, j, i, k, m, m1 ) + do ij = 1, grid%num_tiles + do k=kts,kte - do j=jts,jte + do j=grid%j_start(ij), grid%j_end(ij) do i=its,ite m=mlat(i,j) m1=m+1 @@ -329,6 +343,9 @@ subroutine da_setup_be_ncep_gfs( grid, be ) end do end do end do + + end do + !$OMP END PARALLEL DO ! 7.3 interpolation of the horizontal scale lengths @@ -492,8 +509,11 @@ subroutine da_setup_be_ncep_gfs( grid, be ) ! 9.2 Re-scale the covariance for psi, chi, t, and rh: + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij, n, j, i, vv, k) + do ij = 1, grid%num_tiles do n=1,4 - do j=jts,jte + do j=grid%j_start(ij), grid%j_end(ij) do i=its,ite vv=0. @@ -515,6 +535,8 @@ subroutine da_setup_be_ncep_gfs( grid, be ) enddo enddo enddo + enddo + !$OMP END PARALLEL DO ! 9.3 Re-scale the covariance for Psfc: diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_nmm_regional.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_nmm_regional.inc index 69add7f3..ce2c8685 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_nmm_regional.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_nmm_regional.inc @@ -450,15 +450,15 @@ subroutine da_setup_be_nmm_regional(xb, be) ! 7.0 Apply empirical and recursive filter rescaling factor: ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - call da_rescale_background_errors(var_scaling1, len_scaling1, & + call da_rescale_background_errors(var_scaling1(1), len_scaling1(1), & xb % ds, be1_rf_lengthscale, be % v1) - call da_rescale_background_errors(var_scaling2, len_scaling2, & + call da_rescale_background_errors(var_scaling2(1), len_scaling2(1), & xb % ds, be2_rf_lengthscale, be % v2) - call da_rescale_background_errors(var_scaling3, len_scaling3, & + call da_rescale_background_errors(var_scaling3(1), len_scaling3(1), & xb % ds, be3_rf_lengthscale, be % v3) - call da_rescale_background_errors(var_scaling4, len_scaling4, & + call da_rescale_background_errors(var_scaling4(1), len_scaling4(1), & xb % ds, be4_rf_lengthscale, be % v4) - call da_rescale_background_errors(var_scaling5, len_scaling5, & + call da_rescale_background_errors(var_scaling5(1), len_scaling5(1), & xb % ds, be5_rf_lengthscale, be % v5) ! 8.0 deallocate input model state: diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_regional.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_regional.inc index 63a4bdc4..22f48d82 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_be_regional.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_be_regional.inc @@ -6,8 +6,8 @@ subroutine da_setup_be_regional(xb, be) implicit none - type (xb_type), intent(in) :: xb ! First guess structure. - type (be_type), intent(out) :: be ! Back. errors structure. + type (xb_type), intent(in) :: xb ! First guess structure. + type (be_type), intent(inout) :: be ! Back. errors structure. integer :: i, j, k, m ! Loop counters. integer, allocatable:: bin(:,:,:) ! Bin assigned to each 3D point @@ -29,6 +29,7 @@ subroutine da_setup_be_regional(xb, be) real, allocatable :: be3_eval_glo(:) ! Global Eigenvalues. real, allocatable :: be4_eval_glo(:) ! Global Eigenvalues. real, allocatable :: be5_eval_glo(:) ! Global Eigenvalues. + real, allocatable :: alpha_val(:) ! Global Eigenvalues. real, allocatable :: be1_evec_loc(:,:,:) ! Local Eigenvectors. real, allocatable :: be2_evec_loc(:,:,:) ! Local Eigenvectors. @@ -41,6 +42,7 @@ subroutine da_setup_be_regional(xb, be) real, allocatable :: be3_evec_glo(:,:) ! Global Eigenvectors. real, allocatable :: be4_evec_glo(:,:) ! Global Eigenvectors. real, allocatable :: be5_evec_glo(:,:) ! Global Eigenvectors. + real, allocatable :: alpha_evec(:,:) ! Global Eigenvectors. real, allocatable :: be1_rf_lengthscale(:) ! RF lengthscale. real, allocatable :: be2_rf_lengthscale(:) ! RF lengthscale. @@ -48,18 +50,19 @@ subroutine da_setup_be_regional(xb, be) real, allocatable :: be4_rf_lengthscale(:) ! RF lengthscale. real, allocatable :: be5_rf_lengthscale(:) real, allocatable :: alpha_rf_lengthscale(:) + real, allocatable :: alpha_rf_scale_factor(:) real, allocatable :: evec_loc(:,:,:) ! Latitudinally varying eigenvectors. real, allocatable :: eval_loc(:,:) ! Latitudinally varying eigenvalues. character*10 :: variable integer :: ni, nj, nk, nk_2d, b - integer :: ix, jy, kz + integer :: ix, jy, kz, mz real, allocatable :: regcoeff1(:) real, allocatable :: regcoeff2(:,:) real, allocatable :: regcoeff3(:,:,:) real :: avg,avg2,avg3 - integer :: be_unit, ier + integer :: be_unit, ier, be_rf_unit, be_print_unit, it if (trace_use) call da_trace_entry("da_setup_be_regional") @@ -88,6 +91,9 @@ subroutine da_setup_be_regional(xb, be) jy = xb % mjy kz = xb % mkz + be_rf_unit = unit_end + 1 + be_print_unit = unit_end + 2 + call da_get_unit(be_unit) open(unit=be_unit,file="be.dat", status="old",form="unformatted") @@ -462,19 +468,84 @@ subroutine da_setup_be_regional(xb, be) close(be_unit) call da_free_unit(be_unit) + ! 6.3 Keep the original be % v1, be % v2,...., and lengthscale in the first loop + ! for the rescaling in the later loops: + + it = 1 + + if (max_ext_its > 1) then + + print '(/5x,">>> Save the variances and scale-lengths in outer-loop",i2/)', it + write(be_rf_unit) kz, jy, ix, be % v1 % mz, be % v2 % mz, be% v3 % mz, & + be % v4 % mz, be % v5 % mz, xb % ds + write(be_rf_unit) be % v1 % val, be % v2 % val, be% v3 % val, & + be % v4 % val, be % v5 % val, & + be1_rf_lengthscale, be2_rf_lengthscale, be3_rf_lengthscale, & + be4_rf_lengthscale, be5_rf_lengthscale + + if (print_detail_be ) then + write(be_print_unit,'("it=",i2,2x,"kz=",i3,2x,"jy=",i4,2x,"ix=",i4,2x,"ds=",e12.5)') & + it, kz, jy, ix, xb % ds + write(be_print_unit,'("Original val and rf, and mz:",5i5)') & + be % v1 % mz, be % v2 % mz, be% v3 % mz, be % v4 % mz, be % v5 % mz + write(be_print_unit,'("mz=",i3,2x,"be%v1%val:"/(10e12.5))') be%v1%mz, be%v1%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v2%val:"/(10e12.5))') be%v2%mz, be%v2%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v3%val:"/(10e12.5))') be%v3%mz, be%v3%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v4%val:"/(10e12.5))') be%v4%mz, be%v4%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v5%val:"/(10e12.5))') be%v5%mz, be%v5%val(1,:) + write(be_print_unit,'(/"scale-length: kz=",i3)') kz + do i = 1,kz + if (i == 1) then + write(be_print_unit,'(i3,2x,5e15.5)') i,be1_rf_lengthscale(i), & + be2_rf_lengthscale(i), be3_rf_lengthscale(i), be4_rf_lengthscale(i), & + be5_rf_lengthscale(i) + else + write(be_print_unit,'(i3,2x,5e15.5)') i,be1_rf_lengthscale(i), & + be2_rf_lengthscale(i), be3_rf_lengthscale(i), be4_rf_lengthscale(i) + endif + enddo + + endif + + endif + ! 7.0 Apply empirical and recursive filter rescaling factor: ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - call da_rescale_background_errors(var_scaling1, len_scaling1, & + call da_rescale_background_errors(var_scaling1(1), len_scaling1(1), & xb % ds, be1_rf_lengthscale, be % v1) - call da_rescale_background_errors(var_scaling2, len_scaling2, & + call da_rescale_background_errors(var_scaling2(1), len_scaling2(1), & xb % ds, be2_rf_lengthscale, be % v2) - call da_rescale_background_errors(var_scaling3, len_scaling3, & + call da_rescale_background_errors(var_scaling3(1), len_scaling3(1), & xb % ds, be3_rf_lengthscale, be % v3) - call da_rescale_background_errors(var_scaling4, len_scaling4, & + call da_rescale_background_errors(var_scaling4(1), len_scaling4(1), & xb % ds, be4_rf_lengthscale, be % v4) - call da_rescale_background_errors(var_scaling5, len_scaling5, & + call da_rescale_background_errors(var_scaling5(1), len_scaling5(1), & xb % ds, be5_rf_lengthscale, be % v5) + if (print_detail_be ) then + + write(be_print_unit,'("it=",i2,2x,"kz=",i3,2x,"jy=",i4,2x,"ix=",i4,2x,"ds=",e12.5)') & + it, kz, jy, ix, xb % ds + write(be_print_unit,'("Loop it=",i2," val and rf, and mz:",5i5)') & + it, be % v1 % mz, be % v2 % mz, be% v3 % mz, be % v4 % mz, be % v5 % mz + write(be_print_unit,'("mz=",i3,2x,"be%v1%val:"/(10e12.5))') be%v1%mz, be%v1%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v2%val:"/(10e12.5))') be%v2%mz, be%v2%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v3%val:"/(10e12.5))') be%v3%mz, be%v3%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v4%val:"/(10e12.5))') be%v4%mz, be%v4%val(1,:) + write(be_print_unit,'("mz=",i3,2x,"be%v5%val:"/(10e12.5))') be%v5%mz, be%v5%val(1,:) + write(be_print_unit,'(/"scale-length: kz=",i3)') kz + do i = 1,kz + if (i == 1) then + write(be_print_unit,'(i3,2x,5e15.5)') i, be % v1 % rf_alpha(i), & + be % v2 % rf_alpha(i), be % v3 % rf_alpha(i), be % v4 % rf_alpha(i), & + be % v5 % rf_alpha(i) + else + write(be_print_unit,'(i3,2x,5e15.5)') i, be % v1 % rf_alpha(i), & + be % v2 % rf_alpha(i), be % v3 % rf_alpha(i), be % v4 % rf_alpha(i) + endif + enddo + + endif ! 8.0 deallocate input model state: ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -516,29 +587,51 @@ subroutine da_setup_be_regional(xb, be) deallocate (bin2d) if (be % ne > 0) then - be % alpha % mz = be % ne be % alpha % name = 'alpha' + allocate (alpha_val(1:kz)) ! Not using jy dimension yet. + allocate (alpha_evec(1:kz,1:kz)) ! Not using jy dimension yet. - allocate (be5_eval_loc (1:1,1:num_bins2d)) - allocate (be5_eval_glo(1:1)) - allocate (be5_evec_loc(1:1,1:1,1:num_bins2d)) - allocate (be5_evec_glo(1:1,1:1)) + if ( alpha_vertloc ) then ! Use vertical localization: + call da_get_unit(be_unit) + open(unit=be_unit,file='be.vertloc.dat', status='old', form='unformatted') + + read (be_unit)nk + read (be_unit)alpha_val(1:nk) + read (be_unit)alpha_evec(1:nk,1:nk) + close(be_unit) + + call da_get_vertical_truncation(max_vert_var_alpha, alpha_val, be % alpha) + else + be % alpha % mz = 1 ! No vertical localization. + alpha_val(1) = 1.0 + alpha_val(2:kz) = 0.0 + alpha_evec(:,:) = 1.0 + end if + mz = be % alpha % mz + +! Alpha eigenvalues and eigenvectors: + allocate (be % alpha % val(1:jy,1:mz)) ! Not using jy dimension but here for consistency. + allocate (be % alpha % evec(1:jy,1:kz,1:mz)) + do m = 1, mz + be % alpha % val(:,m) = sigma_alpha * alpha_val(m) + do k = 1, nk + be % alpha % evec(:,k,m) = alpha_evec(k,m) + end do + end do - ! Transfer the alpha standard deviation to be % alpha: - allocate (be % alpha % val(1:jy,1:be % ne)) - allocate (be % alpha % evec(1:jy,1:kz,1:be % ne)) - allocate (be % alpha % rf_alpha(1:be % ne)) +! Alpha RF lengthscales and variance scaling factors: + allocate (alpha_rf_lengthscale(1:mz)) + allocate (be % alpha % rf_alpha(1:mz)) + allocate (alpha_rf_scale_factor(1:mz)) - be % alpha % val(1:jy,1:be % ne) = sigma_alpha - be % alpha % evec(1:jy,1:kz,1:be % ne) = 1.0 - be % alpha % rf_alpha(1:be % ne) = 1.0 + alpha_rf_lengthscale(1:mz) = 1000.0 * alpha_corr_scale / xb % ds ! Convert km to grid spacings. - ! Include alpha lengthscale info: - allocate (alpha_rf_lengthscale(1:be % ne)) - alpha_rf_lengthscale(:) = 1000.0 * alpha_corr_scale ! Convert km to m. + call da_calculate_rf_factors( alpha_rf_lengthscale(:), be % alpha % rf_alpha(:), & + alpha_rf_scale_factor(:) ) + do m = 1, mz + be % alpha % val(:,m) = alpha_rf_scale_factor(m) * be % alpha % val(:,m) + end do - call da_rescale_background_errors(1.0, 1.0, & - xb % ds, alpha_rf_lengthscale, be % alpha) else be % alpha % mz = 0 end if diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_cv.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_cv.inc index 16ea2b47..d51da4e6 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_cv.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_cv.inc @@ -49,13 +49,13 @@ subroutine da_setup_cv(be) be % cv % size_je = 0 - if (ensdim_alpha > 0) then + if ( be % ne > 0) then if (global) then be % cv % size_alphac = (be % alpha % max_wave + 1) * & (be % alpha % max_wave + 2) / 2 be % cv % size_je = 2 * be % cv % size_alphac * be % alpha % mz else - be % cv % size_alphac = ij * be % alpha % mz + be % cv % size_alphac = ij * be % alpha % mz * be % ne be % cv % size_je = be % cv % size_alphac end if end if @@ -75,7 +75,7 @@ subroutine da_setup_cv(be) ij = iy * jx cv_size_domain_jb = ij * (be % v1 % mz + be % v2 % mz + be % v3 % mz + & be % v4 % mz + be % v5 % mz) - cv_size_domain_je = ij * be % alpha % mz + cv_size_domain_je = ij * be % alpha % mz * be % ne end if cv_size_domain = cv_size_domain_jb + cv_size_domain_je diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_firstguess.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_firstguess.inc index 81cf87f1..82b941f7 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_firstguess.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_firstguess.inc @@ -13,7 +13,7 @@ subroutine da_setup_firstguess(xbx, grid, config_flags) type(domain),intent(inout) :: grid type(grid_config_rec_type), intent(in) :: config_flags - integer :: is, ie, js, je + integer :: is, ie, js, je, ij, i, j real :: ddx , ddy if (trace_use) call da_trace_entry("da_setup_firstguess") @@ -67,9 +67,18 @@ subroutine da_setup_firstguess(xbx, grid, config_flags) if ((fg_format==fg_format_wrf_arw_regional) .or. & (fg_format==fg_format_wrf_arw_global ) ) then ! Calculate multiplicative constants for PsiChi_TO_UV - grid%xb%coefx(is:ie,js:je) = 0.5 * grid%xb%map_factor(is:ie,js:je)/grid%xb%ds - grid%xb%coefy(is:ie,js:je) = grid%xb%coefx(is:ie,js:je) - grid%xb%coefz(is:ie,js:je) = 0.5 / (grid%xb%map_factor(is:ie,js:je)*grid%xb%ds) + !$OMP PARALLEL DO & + !$OMP PRIVATE (ij, i, j) + do ij = 1, grid%num_tiles + do j = grid%j_start(ij), grid%j_end(ij) + do i = is, ie + grid%xb%coefx(i,j) = 0.5 * grid%xb%map_factor(i,j)/grid%xb%ds + grid%xb%coefy(i,j) = grid%xb%coefx(i,j) + grid%xb%coefz(i,j) = 0.5 / (grid%xb%map_factor(i,j)*grid%xb%ds) + end do + end do + end do + !$OMP END PARALLEL DO else if (fg_format == fg_format_wrf_nmm_regional) then grid%xb%coefx(is:ie,js:je) = 0.5/grid%mu0(is:ie,js:je) grid%xb%coefy(is:ie,js:je) = 0.5/grid%xb%ds diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_flow_predictors.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_flow_predictors.inc index 8a183a33..787e29e2 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_flow_predictors.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_flow_predictors.inc @@ -1,4 +1,5 @@ -subroutine da_setup_flow_predictors(ix, jy, kz, ne, ep) +subroutine da_setup_flow_predictors( ix, jy, kz, ne, ep, & + its, ite, jts, jte, kts, kte ) !------------------------------------------------------------------------------ ! Purpose: Setup structures for flow-dependent information and read it in. @@ -7,6 +8,8 @@ subroutine da_setup_flow_predictors(ix, jy, kz, ne, ep) implicit none integer, intent(in) :: ix, jy, kz ! EP grid dimensions. + integer, intent(in) :: its, jts, kts ! Tile start. + integer, intent(in) :: ite, jte, kte ! Tile end. integer, intent(in) :: ne ! Ensemble size. type (ep_type), intent(inout):: ep ! Flow-dependent info. @@ -75,14 +78,16 @@ subroutine da_setup_flow_predictors(ix, jy, kz, ne, ep) read(unit=ep_unit) temp3d(1:ix,1:jy,1:kz) close(unit=ep_unit) - ep % v1(1:ix,1:jy,1:kz,e) = ens_scaling_inv * temp3d(1:ix,1:jy,1:kz) + ep % v1(its:ite,jts:jte,kts:kte,e) = ens_scaling_inv * & + temp3d(its:ite,jts:jte,kts:kte) ! v2: filename = 'ep/'//trim(var(2))//'.e'//trim(ce) open(unit=ep_unit, file = filename, form = 'unformatted', status = 'old') read(unit=ep_unit) ni, nj, nk read(unit=ep_unit) temp3d(1:ix,1:jy,1:kz) - ep % v2(1:ix,1:jy,1:kz,e) = ens_scaling_inv * temp3d(1:ix,1:jy,1:kz) + ep % v2(its:ite,jts:jte,kts:kte,e) = ens_scaling_inv * & + temp3d(its:ite,jts:jte,kts:kte) close(unit=ep_unit) ! v3: @@ -90,7 +95,8 @@ subroutine da_setup_flow_predictors(ix, jy, kz, ne, ep) open(unit=ep_unit, file = filename, form = 'unformatted', status = 'old') read(unit=ep_unit) ni, nj, nk read(unit=ep_unit) temp3d(1:ix,1:jy,1:kz) - ep % v3(1:ix,1:jy,1:kz,e) = ens_scaling_inv * temp3d(1:ix,1:jy,1:kz) + ep % v3(its:ite,jts:jte,kts:kte,e) = ens_scaling_inv * & + temp3d(its:ite,jts:jte,kts:kte) close(unit=ep_unit) ! v4: @@ -98,7 +104,8 @@ subroutine da_setup_flow_predictors(ix, jy, kz, ne, ep) open(unit=ep_unit, file = filename, form = 'unformatted', status = 'old') read(unit=ep_unit) ni, nj, nk read(unit=ep_unit) temp3d(1:ix,1:jy,1:kz) - ep % v4(1:ix,1:jy,1:kz,e) = ens_scaling_inv * temp3d(1:ix,1:jy,1:kz) + ep % v4(its:ite,jts:jte,kts:kte,e) = ens_scaling_inv * & + temp3d(its:ite,jts:jte,kts:kte) close(unit=ep_unit) ! v5: @@ -106,11 +113,37 @@ subroutine da_setup_flow_predictors(ix, jy, kz, ne, ep) open(unit=ep_unit, file = filename, form = 'unformatted', status = 'old') read(unit=ep_unit) ni, nj, nkdum read(unit=ep_unit) temp2d(1:ix,1:jy) - ep % v5(1:ix,1:jy,1,e) = ens_scaling_inv * temp2d(1:ix,1:jy) + ep % v5(its:ite,jts:jte,1,e) = ens_scaling_inv * temp2d(its:ite,jts:jte) close(unit=ep_unit) end do +! Optional include hydrometeors: + + if( use_radarobs .and. use_radar_rf .or. use_rad .and. crtm_cloud & ! qt control variable + .and. alphacv_method == alphacv_method_xa .and. alpha_hydrometeors ) then ! xa space + + do e = 1, ne + write(unit=ce,fmt='(i3.3)')e + + filename = 'ep/'//'qcloud'//'.e'//trim(ce) + open(unit=ep_unit, file = filename, form = 'unformatted', status = 'old') + read(unit=ep_unit) ni, nj, nk + read(unit=ep_unit) temp3d(1:ix,1:jy,1:kz) + ep % v4(its:ite,jts:jte,kts:kte,e) = ep % v4(its:ite,jts:jte,kts:kte,e) + & + ens_scaling_inv * temp3d(its:ite,jts:jte,kts:kte) + close(unit=ep_unit) + + filename = 'ep/'//'qrain'//'.e'//trim(ce) + open(unit=ep_unit, file = filename, form = 'unformatted', status = 'old') + read(unit=ep_unit) ni, nj, nk + read(unit=ep_unit) temp3d(1:ix,1:jy,1:kz) + ep % v4(its:ite,jts:jte,kts:kte,e) = ep % v4(its:ite,jts:jte,kts:kte,e) + & + ens_scaling_inv * temp3d(its:ite,jts:jte,kts:kte) + close(unit=ep_unit) + end do + end if + call da_free_unit(ep_unit) if (trace_use) call da_trace_exit("da_setup_flow_predictors") diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc index d9558e39..91643268 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_ascii.inc @@ -13,6 +13,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) character(len=filename_len) :: filename integer :: n, i, j, k logical :: outside + logical :: uvq_direct=.false. !cys_add if (trace_use) call da_trace_entry("da_setup_obs_structures_ascii") @@ -112,7 +113,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) write(filename(1:10), fmt='(a, i2.2, a)') 'ob', n,'.ascii' ! Read gts observation file - call da_read_obs_ascii (iv, filename) + call da_read_obs_ascii (iv, filename, uvq_direct) !cys_change if (use_ssmiretrievalobs .or. use_ssmitbobs) then ! read ssmi observation file @@ -129,7 +130,7 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) else iv%time = 1 - call da_read_obs_ascii(iv, 'ob.ascii') + call da_read_obs_ascii(iv, 'ob.ascii', uvq_direct) !cys_change if (use_ssmiretrievalobs .or. use_ssmitbobs) then ! read ssmi observation file @@ -180,7 +181,13 @@ subroutine da_setup_obs_structures_ascii( ob, iv, grid ) ! [3.0] Calculate innovation vector (O-B) and create (smaller) ob structure: !-------------------------------------------------------------------------- - call da_fill_obs_structures(iv, ob) + ! cys_change + ! call da_fill_obs_structures(iv, ob) + if (uvq_direct) then + call da_fill_obs_structures(iv, ob, uvq_direct) + else + call da_fill_obs_structures(iv, ob) + endif iv%time = 1 diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_bufr.inc b/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_bufr.inc index 5b0b3d93..a2b319a0 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_bufr.inc +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_obs_structures_bufr.inc @@ -14,7 +14,7 @@ subroutine da_setup_obs_structures_bufr(grid, ob, iv) character(len=filename_len) :: filename integer :: n,i,j - + ! thinning variables integer :: istart,iend,jstart,jend real :: rlonlat(4) @@ -32,10 +32,10 @@ subroutine da_setup_obs_structures_bufr(grid, ob, iv) rlon_min = r999 rlon_max = -r999 - istart=grid%i_start(1) - iend =grid%i_end (1) - jstart=grid%j_start(1) - jend =grid%j_end (1) + istart=MINVAL( grid%i_start(1:grid%num_tiles) ) + iend =MAXVAL( grid%i_end (1:grid%num_tiles) ) + jstart=MINVAL( grid%j_start(1:grid%num_tiles) ) + jend =MAXVAL( grid%j_end (1:grid%num_tiles) ) do i = istart, iend do j = jstart, jend @@ -75,68 +75,16 @@ subroutine da_setup_obs_structures_bufr(grid, ob, iv) end if !-------------------------------------------------------------------------- - ! [1.0] Scan BUFR observation header and get idea of number of obs: + ! [1.0] Read data !-------------------------------------------------------------------------- - - if (num_fgat_time > 1) then - filename = ' ' - - do n=1, num_fgat_time - iv%time = n - - write(filename(1:10), fmt='(a, i2.2,a)') 'ob', n,'.bufr' - - ! scan prepbufr observation file - call da_scan_obs_bufr (iv, filename) - iv%info(:)%plocal(n) = iv%info(:)%nlocal - iv%info(:)%ptotal(n) = iv%info(:)%ntotal - end do - else + iv%time = 1 - filename="ob.bufr" - call da_scan_obs_bufr(iv, filename) - do i=1,num_ob_indexes - iv%info(i)%plocal(iv%time) = iv%info(i)%nlocal - iv%info(i)%ptotal(iv%time) = iv%info(i)%ntotal - end do - - ! scan main body of radar observation file - ! if (use_radarobs) & - ! call da_scan_bufr_radar(iv, 'radar.dat') - end if - - !------------------------------------------------------------------------- - ! Allocate the iv based on input number of obs: - !-------------------------------------------------------------------------- - - call da_allocate_observations (iv) - - if (num_fgat_time > 1) then - do n=1, num_fgat_time - iv%time = n - - write(filename(1:10), fmt='(a, i2.2)') 'ob.', n - - ! read prepbufr observation file - call da_read_obs_bufr (iv, filename) - - ! if (use_radarobs) then - ! ! read radar observation file - ! write(filename(1:10), fmt='(a, i2.2)') 'radarob.', n - ! call da_read_bufr_radar(iv, filename) - ! end if - end do - else - - iv%time = 1 - - filename="ob.bufr" - call da_read_obs_bufr(iv, filename) + call da_read_obs_bufr(iv) +! +!for gps - ! if (use_radarobs) then - ! ! read radar observation file - ! call da_read_bufr_radar(iv) - ! end if + if ( use_gpsrefobs ) then + call da_read_obs_bufrgpsro(iv, 'gpsro.bufr') end if if ( thin_conv ) then diff --git a/wrfv2_fire/var/da/da_setup_structures/da_setup_structures.f90 b/wrfv2_fire/var/da/da_setup_structures/da_setup_structures.f90 index 536b6b2e..3292bbfc 100644 --- a/wrfv2_fire/var/da/da_setup_structures/da_setup_structures.f90 +++ b/wrfv2_fire/var/da/da_setup_structures/da_setup_structures.f90 @@ -26,10 +26,10 @@ module da_setup_structures use_ssmt1obs,use_ssmt2obs, use_shipsobs, use_satemobs, use_synopobs, & use_radar_rv,use_profilerobs, use_obsgts, use_geoamvobs, use_buoyobs, & jb_factor, je_factor, alphacv_method,its,ite,jts,jte,cv_size_domain_jb, & - cv_size_domain_je, cv_size_domain,ensdim_alpha, & + cv_size_domain_je, cv_size_domain,ensdim_alpha, alpha_vertloc, alpha_hydrometeors, & lat_stats_option,alpha_std_dev,sigma_alpha,alpha_corr_scale,len_scaling1, & len_scaling2,len_scaling3,len_scaling4,len_scaling5,max_vert_var1, & - max_vert_var2,max_vert_var3,max_vert_var4,print_detail_be, & + max_vert_var2,max_vert_var3,max_vert_var4,max_vert_var_alpha,print_detail_be, & test_statistics, var_scaling1,var_scaling2,var_scaling3,var_scaling4, & var_scaling5,vert_corr,max_vert_var5,power_truncation,alpha_truncation, & print_detail_regression,gas_constant, use_airsretobs, & @@ -49,11 +49,12 @@ module da_setup_structures cv_options, cv_size, as1, as2, as3, as4, as5, & ids,ide,jds,jde,kds,kde, ims,ime,jms,jme,kms,kme, & its,ite,jts,jte,kts,kte, ips,ipe,jps,jpe,kps,kpe, root, comm, ierr, & - fmt_info, fmt_srfc, fmt_each + fmt_info, fmt_srfc, fmt_each, unit_end, max_ext_its use da_obs, only : da_fill_obs_structures, da_store_obs_grid_info, da_store_obs_grid_info_bufr - use da_obs_io, only : da_scan_obs_bufr,da_read_obs_bufr,da_read_obs_radar, & - da_scan_obs_radar,da_scan_obs_ascii,da_read_obs_ascii + use da_obs_io, only : da_read_obs_bufr,da_read_obs_radar, & + da_scan_obs_radar,da_scan_obs_ascii,da_read_obs_ascii, & + da_read_obs_bufrgpsro use da_par_util, only : da_patch_to_global #if defined(RTTOV) || defined(CRTM) use da_radiance, only : da_setup_radiance_structures @@ -92,6 +93,7 @@ contains #include "da_get_vertical_truncation.inc" #include "da_interpolate_regcoeff.inc" #include "da_rescale_background_errors.inc" +#include "da_scale_background_errors.inc" #include "da_setup_background_errors.inc" #include "da_setup_be_global.inc" #include "da_setup_be_ncep_gfs.inc" diff --git a/wrfv2_fire/var/da/da_ships/da_check_max_iv_ships.inc b/wrfv2_fire/var/da/da_ships/da_check_max_iv_ships.inc index fa0c94b6..ed5fea2e 100644 --- a/wrfv2_fire/var/da/da_ships/da_check_max_iv_ships.inc +++ b/wrfv2_fire/var/da/da_ships/da_check_max_iv_ships.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) !------------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !------------------------------------------------------------------------- implicit none @@ -23,10 +26,8 @@ subroutine da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) do n=iv%info(ships)%n1,iv%info(ships)%n2 - if( iv%ships(n)%u%qc == fails_error_max .and. it > 1) iv%ships(n)%u%qc =0 - if( iv%ships(n)%u%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%ships(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%u, max_error_uv, failed) if( iv%info(ships)%proc_domain(1,n) ) then num_qcstat_conv(1,ships,1,1)= num_qcstat_conv(1,ships,1,1) + 1 @@ -36,11 +37,9 @@ subroutine da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) 'ships',ob_vars(1),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p end if end if - end if - if( iv%ships(n)%v%qc == fails_error_max .and. it > 1) iv%ships(n)%v%qc =0 - if( iv%ships(n)%v%qc >= obs_qc_pointer ) then + failed=.false. - if( check_max_iv) & + if( iv%ships(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%v, max_error_uv, failed) if( iv%info(ships)%proc_domain(1,n) ) then num_qcstat_conv(1,ships,2,1)= num_qcstat_conv(1,ships,2,1) + 1 @@ -50,12 +49,9 @@ subroutine da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) 'ships',ob_vars(2),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p end if end if - end if - if( iv%ships(n)%t%qc == fails_error_max .and. it > 1) iv%ships(n)%t%qc =0 - if( iv%ships(n)%t%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%ships(n)%t%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%t, max_error_t , failed) if( iv%info(ships)%proc_domain(1,n) ) then num_qcstat_conv(1,ships,3,1)= num_qcstat_conv(1,ships,3,1) + 1 @@ -65,43 +61,38 @@ subroutine da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) 'ships',ob_vars(3),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p end if end if - end if - if( iv%ships(n)%q%qc == fails_error_max .and. it > 1) iv%ships(n)%q%qc =0 - if( iv%ships(n)%q%qc >= obs_qc_pointer ) then failed=.false. - if( iv%ships(n)%t%qc == fails_error_max .or. iv%ships(n)%p%qc == fails_error_max) then - failed=.true. - iv%ships(n)%q%qc = fails_error_max - iv%ships(n)%q%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%q, max_error_q , failed) - endif + if( iv%ships(n)%p%qc >= obs_qc_pointer ) & + call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%p, max_error_p , failed) if( iv%info(ships)%proc_domain(1,n) ) then - num_qcstat_conv(1,ships,4,1)= num_qcstat_conv(1,ships,4,1) + 1 + num_qcstat_conv(1,ships,5,1)= num_qcstat_conv(1,ships,5,1) + 1 if(failed) then - num_qcstat_conv(2,ships,4,1)= num_qcstat_conv(2,ships,4,1) + 1 + num_qcstat_conv(2,ships,5,1)= num_qcstat_conv(2,ships,5,1) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& - 'ships',ob_vars(4),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p + 'ships',ob_vars(5),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p end if end if - end if - if( iv%ships(n)%p%qc == fails_error_max .and. it > 1) iv%ships(n)%p%qc =0 - if( iv%ships(n)%p%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & - call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%p, max_error_p , failed) + if( iv%ships(n)%q%qc >= obs_qc_pointer ) then + if( iv%ships(n)%t%qc == fails_error_max .or. iv%ships(n)%p%qc == fails_error_max) then + failed=.true. + iv%ships(n)%q%qc = fails_error_max + iv%ships(n)%q%inv = 0.0 + else + call da_max_error_qc (it, iv%info(ships), n, iv%ships(n)%q, max_error_q , failed) + endif if( iv%info(ships)%proc_domain(1,n) ) then - num_qcstat_conv(1,ships,5,1)= num_qcstat_conv(1,ships,5,1) + 1 + num_qcstat_conv(1,ships,4,1)= num_qcstat_conv(1,ships,4,1) + 1 if(failed) then - num_qcstat_conv(2,ships,5,1)= num_qcstat_conv(2,ships,5,1) + 1 + num_qcstat_conv(2,ships,4,1)= num_qcstat_conv(2,ships,4,1) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& - 'ships',ob_vars(5),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p + 'ships',ob_vars(4),iv%info(ships)%lat(1,n),iv%info(ships)%lon(1,n),0.01*ob%ships(n)%p end if end if end if + end do if (trace_use_dull) call da_trace_exit("da_check_max_iv_ships") diff --git a/wrfv2_fire/var/da/da_ships/da_get_innov_vector_ships.inc b/wrfv2_fire/var/da/da_ships/da_get_innov_vector_ships.inc index ea3c1259..bf50ce6c 100644 --- a/wrfv2_fire/var/da/da_ships/da_get_innov_vector_ships.inc +++ b/wrfv2_fire/var/da/da_ships/da_get_innov_vector_ships.inc @@ -40,6 +40,15 @@ subroutine da_get_innov_vector_ships( it,num_qcstat_conv, grid, ob, iv) allocate (model_q(1,iv%info(ships)%n1:iv%info(ships)%n2)) allocate (model_hsm(1,iv%info(ships)%n1:iv%info(ships)%n2)) + if ( it > 1 ) then + do n=iv%info(ships)%n1,iv%info(ships)%n2 + if (iv%ships(n)%u%qc == fails_error_max) iv%ships(n)%u%qc = 0 + if (iv%ships(n)%v%qc == fails_error_max) iv%ships(n)%v%qc = 0 + if (iv%ships(n)%t%qc == fails_error_max) iv%ships(n)%t%qc = 0 + if (iv%ships(n)%p%qc == fails_error_max) iv%ships(n)%p%qc = 0 + if (iv%ships(n)%q%qc == fails_error_max) iv%ships(n)%q%qc = 0 + end do + end if if (sfc_assi_options == sfc_assi_options_1) then do n=iv%info(ships)%n1,iv%info(ships)%n2 @@ -73,16 +82,6 @@ subroutine da_get_innov_vector_ships( it,num_qcstat_conv, grid, ob, iv) if (iv % ships(n) % h < v_h(kts)) then iv%info(ships)%zk(:,n) = 1.0+1.0e-6 call da_obs_sfc_correction(iv%info(ships), iv%ships(n), n, grid%xb) - - ! To keep the original "ob" with no change for multiple - ! outer-loops use: - - ! ob%ships(n)%p = iv%ships(n)%p%inv - ! ob%ships(n)%t = iv%ships(n)%t%inv - ! ob%ships(n)%q = iv%ships(n)%q%inv - ! ob%ships(n)%u = iv%ships(n)%u%inv - ! ob%ships(n)%v = iv%ships(n)%v%inv - else call da_to_zk(iv % ships(n) % h, v_h, v_interp_h, iv%info(ships)%zk(1,n)) end if @@ -129,8 +128,8 @@ subroutine da_get_innov_vector_ships( it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_3d (grid%xb%q, iv%info(ships), model_q) call da_interp_lin_3d (grid%xb%p, iv%info(ships), model_p) - else if (sfc_assi_options == 2) then - ! Surface data assmiilation approca 2 + else if (sfc_assi_options == sfc_assi_options_2) then + ! Surface data assimilation approach 2 ! 1.2.1 Surface assmiilation approach 2(10-m u, v, 2-m t, q, and ! sfc_p) @@ -142,6 +141,12 @@ subroutine da_get_innov_vector_ships( it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_2d (grid%xb%psfc, iv%info(ships), 1, model_p) do n=iv%info(ships)%n1,iv%info(ships)%n2 + iv%ships(n)%p%inv = ob%ships(n)%p + iv%ships(n)%t%inv = ob%ships(n)%t + iv%ships(n)%q%inv = ob%ships(n)%q + iv%ships(n)%u%inv = ob%ships(n)%u + iv%ships(n)%v%inv = ob%ships(n)%v + if (iv%ships(n)%p%qc >= 0) then ! model surface p, t, q, h at observed site: @@ -210,7 +215,8 @@ subroutine da_get_innov_vector_ships( it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !--------------------------------------------------------------------- - call da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_ships(iv,ob, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_sound/da_check_max_iv_sonde_sfc.inc b/wrfv2_fire/var/da/da_sound/da_check_max_iv_sonde_sfc.inc index 2386b9a2..dab7b396 100644 --- a/wrfv2_fire/var/da/da_sound/da_check_max_iv_sonde_sfc.inc +++ b/wrfv2_fire/var/da/da_sound/da_check_max_iv_sonde_sfc.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -23,10 +26,8 @@ subroutine da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) !--------------------------------------------------------------------------- do n=iv%info(sonde_sfc)%n1,iv%info(sonde_sfc)%n2 - if( iv%sonde_sfc(n)%u%qc == fails_error_max .and. it > 1 )iv%sonde_sfc(n)%u%qc =0 - if( iv%sonde_sfc(n)%u%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sonde_sfc(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(sonde_sfc), n, iv%sonde_sfc(n)%u, max_error_uv, failed) if( iv%info(sonde_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,sonde_sfc,1,1)= num_qcstat_conv(1,sonde_sfc,1,1) + 1 @@ -36,12 +37,9 @@ subroutine da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) 'sonde_sfc',ob_vars(1),iv%info(sonde_sfc)%lat(1,n),iv%info(sonde_sfc)%lon(1,n),0.01*ob%sonde_sfc(n)%p end if end if - end if - if( iv%sonde_sfc(n)%v%qc == fails_error_max .and. it > 1 )iv%sonde_sfc(n)%v%qc =0 - if( iv%sonde_sfc(n)%v%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sonde_sfc(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(sonde_sfc), n, iv%sonde_sfc(n)%v, max_error_uv, failed) if( iv%info(sonde_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,sonde_sfc,2,1)= num_qcstat_conv(1,sonde_sfc,2,1) + 1 @@ -51,12 +49,9 @@ subroutine da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) 'sonde_sfc',ob_vars(2),iv%info(sonde_sfc)%lat(1,n),iv%info(sonde_sfc)%lon(1,n),0.01*ob%sonde_sfc(n)%p end if end if - end if - if( iv%sonde_sfc(n)%t%qc == fails_error_max .and. it > 1 )iv%sonde_sfc(n)%t%qc =0 - if( iv%sonde_sfc(n)%t%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sonde_sfc(n)%t%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(sonde_sfc), n, iv%sonde_sfc(n)%t, max_error_t , failed) if( iv%info(sonde_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,sonde_sfc,3,1)= num_qcstat_conv(1,sonde_sfc,3,1) + 1 @@ -66,12 +61,9 @@ subroutine da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) 'sonde_sfc',ob_vars(3),iv%info(sonde_sfc)%lat(1,n),iv%info(sonde_sfc)%lon(1,n),0.01*ob%sonde_sfc(n)%p end if end if - end if - if( iv%sonde_sfc(n)%p%qc == fails_error_max .and. it > 1 )iv%sonde_sfc(n)%p%qc =0 - if( iv%sonde_sfc(n)%p%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sonde_sfc(n)%p%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(sonde_sfc), n, iv%sonde_sfc(n)%p, max_error_p , failed) if( iv%info(sonde_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,sonde_sfc,5,1)= num_qcstat_conv(1,sonde_sfc,5,1) + 1 @@ -81,19 +73,16 @@ subroutine da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) 'sonde_sfc',ob_vars(5),iv%info(sonde_sfc)%lat(1,n),iv%info(sonde_sfc)%lon(1,n),0.01*ob%sonde_sfc(n)%p end if end if - end if - if( iv%sonde_sfc(n)%q%qc == fails_error_max .and. it > 1 )iv%sonde_sfc(n)%q%qc =0 - if( iv%sonde_sfc(n)%q%qc >= obs_qc_pointer ) then failed=.false. - if( iv%sonde_sfc(n)%t%qc == fails_error_max .or. iv%sonde_sfc(n)%p%qc == fails_error_max) then - failed=.true. - iv%sonde_sfc(n)%q%qc = fails_error_max - iv%sonde_sfc(n)%q%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it, iv%info(sonde_sfc), n, iv%sonde_sfc(n)%q, max_error_q , failed) - endif + if( iv%sonde_sfc(n)%q%qc >= obs_qc_pointer ) then + if( iv%sonde_sfc(n)%t%qc == fails_error_max .or. iv%sonde_sfc(n)%p%qc == fails_error_max) then + failed=.true. + iv%sonde_sfc(n)%q%qc = fails_error_max + iv%sonde_sfc(n)%q%inv = 0.0 + else + call da_max_error_qc (it, iv%info(sonde_sfc), n, iv%sonde_sfc(n)%q, max_error_q , failed) + endif if( iv%info(sonde_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,sonde_sfc,4,1)= num_qcstat_conv(1,sonde_sfc,4,1) + 1 if(failed) then diff --git a/wrfv2_fire/var/da/da_sound/da_check_max_iv_sound.inc b/wrfv2_fire/var/da/da_sound/da_check_max_iv_sound.inc index 1b60b6c8..40573330 100644 --- a/wrfv2_fire/var/da/da_sound/da_check_max_iv_sound.inc +++ b/wrfv2_fire/var/da/da_sound/da_check_max_iv_sound.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_sound(iv, it,num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -22,10 +25,8 @@ subroutine da_check_max_iv_sound(iv, it,num_qcstat_conv) do n = iv%info(sound)%n1,iv%info(sound)%n2 do k = 1, iv%info(sound)%levels(n) call da_get_print_lvl(iv%sound(n)%p(k),ipr) - if( iv%sound(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%sound(n)%u(k)%qc =0 - if( iv%sound(n)%u(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sound(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(sound), n, iv%sound(n)%u(k), max_error_uv,failed) if( iv%info(sound)%proc_domain(k,n) ) then num_qcstat_conv(1,sound,1,ipr) = num_qcstat_conv(1,sound,1,ipr) + 1 @@ -35,12 +36,9 @@ subroutine da_check_max_iv_sound(iv, it,num_qcstat_conv) 'sound',ob_vars(1),iv%info(sound)%lat(k,n),iv%info(sound)%lon(k,n),0.01*iv%sound(n)%p(k) end if end if - end if - if( iv%sound(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%sound(n)%v(k)%qc =0 - if( iv%sound(n)%v(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sound(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(sound), n, iv%sound(n)%v(k), max_error_uv,failed) if( iv%info(sound)%proc_domain(k,n) ) then num_qcstat_conv(1,sound,2,ipr) = num_qcstat_conv(1,sound,2,ipr) + 1 @@ -50,12 +48,9 @@ subroutine da_check_max_iv_sound(iv, it,num_qcstat_conv) 'sound',ob_vars(2),iv%info(sound)%lat(k,n),iv%info(sound)%lon(k,n),0.01*iv%sound(n)%p(k) end if end if - end if - if( iv%sound(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%sound(n)%t(k)%qc =0 - if( iv%sound(n)%t(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%sound(n)%t(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(sound), n, iv%sound(n)%t(k), max_error_t ,failed) if( iv%info(sound)%proc_domain(k,n) ) then num_qcstat_conv(1,sound,3,ipr) = num_qcstat_conv(1,sound,3,ipr) + 1 @@ -65,19 +60,16 @@ subroutine da_check_max_iv_sound(iv, it,num_qcstat_conv) 'sound',ob_vars(3),iv%info(sound)%lat(k,n),iv%info(sound)%lon(k,n),0.01*iv%sound(n)%p(k) end if end if - end if - if( iv%sound(n)%q(k)%qc == fails_error_max .and. it > 1 )iv%sound(n)%q(k)%qc =0 - if( iv%sound(n)%q(k)%qc >= obs_qc_pointer ) then failed=.false. - if( iv%sound(n)%t(k)%qc == fails_error_max ) then - failed=.true. - iv%sound(n)%q(k)%qc = fails_error_max - iv%sound(n)%q(k)%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it,iv%info(sound), n, iv%sound(n)%q(k), max_error_q ,failed) - endif + if( iv%sound(n)%q(k)%qc >= obs_qc_pointer ) then + if( iv%sound(n)%t(k)%qc == fails_error_max ) then + failed=.true. + iv%sound(n)%q(k)%qc = fails_error_max + iv%sound(n)%q(k)%inv = 0.0 + else + call da_max_error_qc (it,iv%info(sound), n, iv%sound(n)%q(k), max_error_q ,failed) + endif if( iv%info(sound)%proc_domain(k,n) ) then num_qcstat_conv(1,sound,4,ipr) = num_qcstat_conv(1,sound,4,ipr) + 1 if(failed) then diff --git a/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sonde_sfc.inc b/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sonde_sfc.inc index bdb14f10..02b93254 100644 --- a/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sonde_sfc.inc +++ b/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sonde_sfc.inc @@ -41,6 +41,16 @@ subroutine da_get_innov_vector_sonde_sfc( it, num_qcstat_conv,grid, ob, iv) allocate (model_q(1,iv%info(sonde_sfc)%n1:iv%info(sonde_sfc)%n2)) allocate (model_hsm(1,iv%info(sonde_sfc)%n1:iv%info(sonde_sfc)%n2)) + if ( it > 1 ) then + do n=iv%info(sonde_sfc)%n1,iv%info(sonde_sfc)%n2 + if (iv%sonde_sfc(n)%u%qc == fails_error_max) iv%sonde_sfc(n)%u%qc = 0 + if (iv%sonde_sfc(n)%v%qc == fails_error_max) iv%sonde_sfc(n)%v%qc = 0 + if (iv%sonde_sfc(n)%t%qc == fails_error_max) iv%sonde_sfc(n)%t%qc = 0 + if (iv%sonde_sfc(n)%p%qc == fails_error_max) iv%sonde_sfc(n)%p%qc = 0 + if (iv%sonde_sfc(n)%q%qc == fails_error_max) iv%sonde_sfc(n)%q%qc = 0 + end do + end if + if (sfc_assi_options == sfc_assi_options_1) then do n=iv%info(sonde_sfc)%n1,iv%info(sonde_sfc)%n2 ! [1.1] Get horizontal interpolation weights: @@ -73,15 +83,6 @@ subroutine da_get_innov_vector_sonde_sfc( it, num_qcstat_conv,grid, ob, iv) iv%info(sonde_sfc)%zk(:,n) = 1.0+1.0e-6 call da_obs_sfc_correction(iv%info(sonde_sfc), iv%sonde_sfc(n), n, grid%xb) - ! To keep the original "ob" with no change for multiple - ! outer-loops use: - - ! ob%sonde_sfc(n)%p = iv%sonde_sfc(n)%p%inv - ! ob%sonde_sfc(n)%t = iv%sonde_sfc(n)%t%inv - ! ob%sonde_sfc(n)%q = iv%sonde_sfc(n)%q%inv - ! ob%sonde_sfc(n)%u = iv%sonde_sfc(n)%u%inv - ! ob%sonde_sfc(n)%v = iv%sonde_sfc(n)%v%inv - else call da_to_zk(iv % sonde_sfc(n) % h, v_h, v_interp_h, iv%info(sonde_sfc)%zk(1,n)) end if @@ -127,8 +128,8 @@ subroutine da_get_innov_vector_sonde_sfc( it, num_qcstat_conv,grid, ob, iv) call da_interp_lin_3d (grid%xb%t, iv%info(sonde_sfc), model_t) call da_interp_lin_3d (grid%xb%q, iv%info(sonde_sfc), model_q) call da_interp_lin_3d (grid%xb%p, iv%info(sonde_sfc), model_p) - else if (sfc_assi_options == 2) then - ! 1.2.1 Surface assmiilation approach 2(10-m u, v, 2-m t, q, and sfc_p) + else if (sfc_assi_options == sfc_assi_options_2) then + ! 1.2.1 Surface assimilation approach 2(10-m u, v, 2-m t, q, and sfc_p) call da_interp_lin_2d (grid%xb%u10, iv%info(sonde_sfc), 1,model_u) call da_interp_lin_2d (grid%xb%v10, iv%info(sonde_sfc), 1,model_v) @@ -138,6 +139,12 @@ subroutine da_get_innov_vector_sonde_sfc( it, num_qcstat_conv,grid, ob, iv) do n=iv%info(sonde_sfc)%n1,iv%info(sonde_sfc)%n2 + iv%sonde_sfc(n)%p%inv = ob%sonde_sfc(n)%p + iv%sonde_sfc(n)%t%inv = ob%sonde_sfc(n)%t + iv%sonde_sfc(n)%q%inv = ob%sonde_sfc(n)%q + iv%sonde_sfc(n)%u%inv = ob%sonde_sfc(n)%u + iv%sonde_sfc(n)%v%inv = ob%sonde_sfc(n)%v + if (iv%sonde_sfc(n)%p%qc >= 0) then ! model surface p, t, q, h at observed site: @@ -204,7 +211,8 @@ subroutine da_get_innov_vector_sonde_sfc( it, num_qcstat_conv,grid, ob, iv) ! [5.0] Perform optional maximum error check: !----------------------------------------------------------------------- - call da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_sonde_sfc(iv,ob, it, num_qcstat_conv) deallocate (model_u) deallocate (model_v) diff --git a/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sound.inc b/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sound.inc index 90afe4e5..d6a7cd66 100644 --- a/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sound.inc +++ b/wrfv2_fire/var/da/da_sound/da_get_innov_vector_sound.inc @@ -42,6 +42,17 @@ subroutine da_get_innov_vector_sound (it,num_qcstat_conv, grid, ob, iv) model_t(:,:) = 0.0 model_q(:,:) = 0.0 + if ( it > 1 ) then + do n=iv%info(sound)%n1,iv%info(sound)%n2 + do k=1, iv%info(sound)%levels(n) + if (iv%sound(n)%u(k)%qc == fails_error_max) iv%sound(n)%u(k)%qc = 0 + if (iv%sound(n)%v(k)%qc == fails_error_max) iv%sound(n)%v(k)%qc = 0 + if (iv%sound(n)%t(k)%qc == fails_error_max) iv%sound(n)%t(k)%qc = 0 + if (iv%sound(n)%q(k)%qc == fails_error_max) iv%sound(n)%q(k)%qc = 0 + end do + end do + end if + do n=iv%info(sound)%n1, iv%info(sound)%n2 if (iv%info(sound)%levels(n) < 1) cycle @@ -148,7 +159,8 @@ subroutine da_get_innov_vector_sound (it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !---------------------------------------------------------------------- - call da_check_max_iv_sound (iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_sound (iv, it, num_qcstat_conv) if (check_buddy) call da_check_buddy_sound(iv, grid%dx, it) ! diff --git a/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmi_rv.inc b/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmi_rv.inc index 306ea2d2..53aa6aa5 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmi_rv.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmi_rv.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_ssmi_rv(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -21,34 +24,28 @@ subroutine da_check_max_iv_ssmi_rv(iv, it, num_qcstat_conv) do n=iv%info(ssmi_rv)%n1,iv%info(ssmi_rv)%n2 - if( iv%ssmi_rv(n)%tpw%qc == fails_error_max .and. it > 1) iv%ssmi_rv(n)%tpw%qc = 0 - if( iv%ssmi_rv(n)%tpw%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & - call da_max_error_qc (it, iv%info(ssmi_rv), n, iv%ssmi_rv(n)%tpw, max_error_pw, failed) - if( iv%info(ssmi_rv)%proc_domain(1,n) ) then - num_qcstat_conv(1,ssmi_rv,7,1) = num_qcstat_conv(1,ssmi_rv,7,1) + 1 - if(failed) then - num_qcstat_conv(2,ssmi_rv,7,1) = num_qcstat_conv(2,ssmi_rv,7,1) + 1 - write(qcstat_conv_unit,'(2x,a10,2x,a4,2f12.2,a12)')& - 'ssmi_rv',ob_vars(7),iv%info(ssmi_rv)%lat(1,n),iv%info(ssmi_rv)%lon(1,n),'1013.25' - end if - end if + if ( iv%ssmi_rv(n)%tpw%qc >= obs_qc_pointer ) & + call da_max_error_qc (it, iv%info(ssmi_rv), n, iv%ssmi_rv(n)%tpw, max_error_pw, failed) + if ( iv%info(ssmi_rv)%proc_domain(1,n) ) then + num_qcstat_conv(1,ssmi_rv,7,1) = num_qcstat_conv(1,ssmi_rv,7,1) + 1 + if (failed) then + num_qcstat_conv(2,ssmi_rv,7,1) = num_qcstat_conv(2,ssmi_rv,7,1) + 1 + write(qcstat_conv_unit,'(2x,a10,2x,a4,2f12.2,a12)')& + 'ssmi_rv',ob_vars(7),iv%info(ssmi_rv)%lat(1,n),iv%info(ssmi_rv)%lon(1,n),'1013.25' + end if end if - if( iv%ssmi_rv(n)%speed%qc == fails_error_max .and. it > 1) iv%ssmi_rv(n)%speed%qc = 0 - if( iv%ssmi_rv(n)%speed%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & - call da_max_error_qc (it, iv%info(ssmi_rv), n, iv%ssmi_rv(n)%speed, max_error_uv, failed) - if( iv%info(ssmi_rv)%proc_domain(1,n) ) then - num_qcstat_conv(1,ssmi_rv,6,1) = num_qcstat_conv(1,ssmi_rv,6,1) + 1 - if(failed)then - num_qcstat_conv(2,ssmi_rv,6,1) = num_qcstat_conv(2,ssmi_rv,6,1) + 1 - write(qcstat_conv_unit,'(2x,a10,2x,a4,2f12.2,a12)')& - 'ssmi_rv',ob_vars(6),iv%info(ssmi_rv)%lat(1,n),iv%info(ssmi_rv)%lon(1,n),'1013.25' - endif - end if + if ( iv%ssmi_rv(n)%speed%qc >= obs_qc_pointer ) & + call da_max_error_qc (it, iv%info(ssmi_rv), n, iv%ssmi_rv(n)%speed, max_error_uv, failed) + if ( iv%info(ssmi_rv)%proc_domain(1,n) ) then + num_qcstat_conv(1,ssmi_rv,6,1) = num_qcstat_conv(1,ssmi_rv,6,1) + 1 + if (failed)then + num_qcstat_conv(2,ssmi_rv,6,1) = num_qcstat_conv(2,ssmi_rv,6,1) + 1 + write(qcstat_conv_unit,'(2x,a10,2x,a4,2f12.2,a12)')& + 'ssmi_rv',ob_vars(6),iv%info(ssmi_rv)%lat(1,n),iv%info(ssmi_rv)%lon(1,n),'1013.25' + end if end if end do diff --git a/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt1.inc b/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt1.inc index 87d242ee..d9575ef4 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt1.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt1.inc @@ -25,17 +25,16 @@ subroutine da_check_max_iv_ssmt1(iv, it, num_qcstat_conv) do k = 1, iv%info(ssmt1)%levels(n) call da_get_print_lvl(iv%ssmt1(n)%p(k),ipr) - if( iv%ssmt1(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%ssmt1(n)%t(k)%qc =0 - if( iv%ssmt1(n)%t(k)%qc >= obs_qc_pointer ) then - call da_max_error_qc(it, iv%info(ssmt1), n, iv%ssmt1(n)%t(k), max_error_t, failed) - if( iv%info(ssmt1)%proc_domain(k,n) ) then - num_qcstat_conv(1,ssmt1,3,ipr) = num_qcstat_conv(1,ssmt1,3,ipr) + 1 - if(failed) then - num_qcstat_conv(2,ssmt1,3,ipr) = num_qcstat_conv(2,ssmt1,3,ipr) + 1 - write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& - 'ssmt1',ob_vars(3),iv%info(ssmt1)%lat(k,n),iv%info(ssmt1)%lon(k,n),0.01*iv%ssmt1(n)%p(k) - endif - endif + failed = .false. + if ( iv%ssmt1(n)%t(k)%qc >= obs_qc_pointer ) & + call da_max_error_qc(it, iv%info(ssmt1), n, iv%ssmt1(n)%t(k), max_error_t, failed) + if ( iv%info(ssmt1)%proc_domain(k,n) ) then + num_qcstat_conv(1,ssmt1,3,ipr) = num_qcstat_conv(1,ssmt1,3,ipr) + 1 + if (failed) then + num_qcstat_conv(2,ssmt1,3,ipr) = num_qcstat_conv(2,ssmt1,3,ipr) + 1 + write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& + 'ssmt1',ob_vars(3),iv%info(ssmt1)%lat(k,n),iv%info(ssmt1)%lon(k,n),0.01*iv%ssmt1(n)%p(k) + endif endif end do diff --git a/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt2.inc b/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt2.inc index 7e7a7724..60480385 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt2.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_check_max_iv_ssmt2.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_ssmt2(iv, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -23,19 +26,18 @@ subroutine da_check_max_iv_ssmt2(iv, it, num_qcstat_conv) do n=iv%info(ssmt2)%n1,iv%info(ssmt2)%n2 do k = 1, iv%info(ssmt2)%levels(n) - - if( iv%ssmt2(n)%rh(k)%qc == fails_error_max .and. it > 1)iv%ssmt2(n)%rh(k)%qc =0 - if( iv%ssmt2(n)%rh(k)%qc >= obs_qc_pointer ) then call da_get_print_lvl(iv%ssmt2(n)%p(k),ipr) - call da_max_error_qc (it, iv%info(ssmt2), n, iv%ssmt2(n)%rh(k), max_error_q, failed) - if( iv%info(ssmt2)%proc_domain(k,n) ) then - num_qcstat_conv(1,ssmt2,4,ipr) = num_qcstat_conv(1,ssmt2,4,ipr) + 1 - if(failed)then - num_qcstat_conv(2,ssmt2,4,ipr) = num_qcstat_conv(2,ssmt2,4,ipr) + 1 - write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& - 'ssmt2',ob_vars(4),iv%info(ssmt2)%lat(k,n),iv%info(ssmt2)%lon(k,n),0.01*iv%ssmt2(n)%p(k) - endif - endif + + failed = .false. + if ( iv%ssmt2(n)%rh(k)%qc >= obs_qc_pointer ) & + call da_max_error_qc (it, iv%info(ssmt2), n, iv%ssmt2(n)%rh(k), max_error_q, failed) + if ( iv%info(ssmt2)%proc_domain(k,n) ) then + num_qcstat_conv(1,ssmt2,4,ipr) = num_qcstat_conv(1,ssmt2,4,ipr) + 1 + if (failed) then + num_qcstat_conv(2,ssmt2,4,ipr) = num_qcstat_conv(2,ssmt2,4,ipr) + 1 + write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& + 'ssmt2',ob_vars(4),iv%info(ssmt2)%lat(k,n),iv%info(ssmt2)%lon(k,n),0.01*iv%ssmt2(n)%p(k) + endif endif end do end do diff --git a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_rv.inc b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_rv.inc index bb9840bf..545c18a3 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_rv.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_rv.inc @@ -24,6 +24,13 @@ subroutine da_get_innov_vector_ssmi_rv (it,num_qcstat_conv, grid, ob, iv) if (trace_use) call da_trace_entry("da_get_innov_vector_ssmi_rv") + if ( it > 1 ) then + do n=iv%info(ssmi_rv)%n1,iv%info(ssmi_rv)%n2 + if ( iv % ssmi_rv(n) % speed % qc == fails_error_max) iv % ssmi_rv(n) % speed % qc = 0 + if ( iv % ssmi_rv(n) % tpw % qc == fails_error_max) iv % ssmi_rv(n) % tpw % qc = 0 + end do + end if + do n=iv%info(ssmi_rv)%n1,iv%info(ssmi_rv)%n2 ! compute innovation vector @@ -62,7 +69,8 @@ subroutine da_get_innov_vector_ssmi_rv (it,num_qcstat_conv, grid, ob, iv) ! Perform optional maximum error check: !------------------------------------------------------------------ - call da_check_max_iv_ssmi_rv(iv, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_ssmi_rv(iv, it, num_qcstat_conv) if (trace_use) call da_trace_exit("da_get_innov_vector_ssmi_rv") diff --git a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_tb.inc b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_tb.inc index 9baff52c..55c6fb23 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_tb.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmi_tb.inc @@ -25,6 +25,18 @@ subroutine da_get_innov_vector_ssmi_tb (it, grid, ob, iv) if (trace_use) call da_trace_entry("da_get_innov_vector_ssmi_tb") + if ( it > 1 ) then + do n=iv%info(ssmi_tb)%n1,iv%info(ssmi_tb)%n2 + if(iv % ssmi_tb(n) % tb19v % qc == fails_error_max ) iv % ssmi_tb(n) % tb19v % qc = 0 + if(iv % ssmi_tb(n) % tb19h % qc == fails_error_max ) iv % ssmi_tb(n) % tb19h % qc = 0 + if(iv % ssmi_tb(n) % tb22v % qc == fails_error_max ) iv % ssmi_tb(n) % tb22v % qc = 0 + if(iv % ssmi_tb(n) % tb37v % qc == fails_error_max ) iv % ssmi_tb(n) % tb37v % qc = 0 + if(iv % ssmi_tb(n) % tb37h % qc == fails_error_max ) iv % ssmi_tb(n) % tb37h % qc = 0 + if(iv % ssmi_tb(n) % tb85v % qc == fails_error_max ) iv % ssmi_tb(n) % tb85v % qc = 0 + if(iv % ssmi_tb(n) % tb85h % qc == fails_error_max ) iv % ssmi_tb(n) % tb85h % qc = 0 + end do + end if + do n=iv%info(ssmi_tb)%n1,iv%info(ssmi_tb)%n2 ! compute innovation vector ! ========================= diff --git a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt1.inc b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt1.inc index c25589e5..dc8a4dab 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt1.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt1.inc @@ -28,6 +28,14 @@ subroutine da_get_innov_vector_ssmt1(it,num_qcstat_conv,grid, ob, iv) allocate (model_t(1:iv%info(ssmt1)%max_lev,iv%info(ssmt1)%n1:iv%info(ssmt1)%n2)) model_t(:,:) = 0.0 + if ( it > 1 )then + do n=iv%info(ssmt1)%n1,iv%info(ssmt1)%n2 + do k = 1, iv%info(ssmt1)%levels(n) + if(iv % ssmt1(n) % t(k) % qc == fails_error_max)iv % ssmt1(n) % t(k) % qc = 0 + end do + end do + end if + do n=iv%info(ssmt1)%n1,iv%info(ssmt1)%n2 num_levs = iv%info(ssmt1)%levels(n) diff --git a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt2.inc b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt2.inc index 47290ebb..cf42e29b 100644 --- a/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt2.inc +++ b/wrfv2_fire/var/da/da_ssmi/da_get_innov_vector_ssmt2.inc @@ -27,6 +27,14 @@ subroutine da_get_innov_vector_ssmt2 (it, num_qcstat_conv,grid, ob, iv) allocate (model_rh(1:iv%info(ssmt2)%max_lev,iv%info(ssmt2)%n1:iv%info(ssmt2)%n2)) model_rh(:,:) = 0.0 + if ( it > 1 )then + do n=iv%info(ssmt2)%n1,iv%info(ssmt2)%n2 + do k = 1, iv%info(ssmt1)%levels(n) + if(iv % ssmt2(n) % rh(k) % qc == fails_error_max)iv % ssmt2(n) % rh(k) % qc = 0 + end do + end do + end if + do n=iv%info(ssmt2)%n1,iv%info(ssmt2)%n2 num_levs = iv%info(ssmt2)%levels(n) diff --git a/wrfv2_fire/var/da/da_synop/da_check_max_iv_synop.inc b/wrfv2_fire/var/da/da_synop/da_check_max_iv_synop.inc index 25a8871d..98c39f35 100644 --- a/wrfv2_fire/var/da/da_synop/da_check_max_iv_synop.inc +++ b/wrfv2_fire/var/da/da_synop/da_check_max_iv_synop.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_synop(iv,ob, it, num_qcstat_conv) !------------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !------------------------------------------------------------------------- implicit none @@ -23,10 +26,8 @@ subroutine da_check_max_iv_synop(iv,ob, it, num_qcstat_conv) do n=iv%info(synop)%n1,iv%info(synop)%n2 - if( iv%synop(n)%u%qc == fails_error_max .and. it > 1) iv%synop(n)%u%qc =0 - if( iv%synop(n)%u%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%synop(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(synop), n, iv%synop(n)%u, max_error_uv, failed) if( iv%info(synop)%proc_domain(1,n) ) then num_qcstat_conv(1,synop,1,1)= num_qcstat_conv(1,synop,1,1) + 1 @@ -36,11 +37,9 @@ subroutine da_check_max_iv_synop(iv,ob, it, num_qcstat_conv) 'synop',ob_vars(1),iv%info(synop)%lat(1,n),iv%info(synop)%lon(1,n),0.01*ob%synop(n)%p end if end if - end if - if( iv%synop(n)%v%qc == fails_error_max .and. it > 1) iv%synop(n)%v%qc =0 - if( iv%synop(n)%v%qc >= obs_qc_pointer ) then + failed=.false. - if( check_max_iv) & + if( iv%synop(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(synop), n, iv%synop(n)%v, max_error_uv, failed) if( iv%info(synop)%proc_domain(1,n) ) then num_qcstat_conv(1,synop,2,1)= num_qcstat_conv(1,synop,2,1) + 1 @@ -50,12 +49,9 @@ subroutine da_check_max_iv_synop(iv,ob, it, num_qcstat_conv) 'synop',ob_vars(2),iv%info(synop)%lat(1,n),iv%info(synop)%lon(1,n),0.01*ob%synop(n)%p end if end if - end if - if( iv%synop(n)%t%qc == fails_error_max .and. it > 1) iv%synop(n)%t%qc =0 - if( iv%synop(n)%t%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%synop(n)%t%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(synop), n, iv%synop(n)%t, max_error_t , failed) if( iv%info(synop)%proc_domain(1,n) ) then num_qcstat_conv(1,synop,3,1)= num_qcstat_conv(1,synop,3,1) + 1 @@ -65,12 +61,9 @@ subroutine da_check_max_iv_synop(iv,ob, it, num_qcstat_conv) 'synop',ob_vars(3),iv%info(synop)%lat(1,n),iv%info(synop)%lon(1,n),0.01*ob%synop(n)%p end if end if - end if - if( iv%synop(n)%p%qc == fails_error_max .and. it > 1) iv%synop(n)%p%qc =0 - if( iv%synop(n)%p%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%synop(n)%p%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(synop), n, iv%synop(n)%p, max_error_p , failed) if( iv%info(synop)%proc_domain(1,n) ) then num_qcstat_conv(1,synop,5,1)= num_qcstat_conv(1,synop,5,1) + 1 @@ -80,19 +73,16 @@ subroutine da_check_max_iv_synop(iv,ob, it, num_qcstat_conv) 'synop',ob_vars(5),iv%info(synop)%lat(1,n),iv%info(synop)%lon(1,n),0.01*ob%synop(n)%p end if end if - end if - if( iv%synop(n)%q%qc == fails_error_max .and. it > 1) iv%synop(n)%q%qc =0 - if( iv%synop(n)%q%qc >= obs_qc_pointer ) then failed=.false. - if( iv%synop(n)%t%qc == fails_error_max .or. iv%synop(n)%p%qc == fails_error_max) then - failed=.true. - iv%synop(n)%q%qc = fails_error_max - iv%synop(n)%q%inv = 0.0 - else - if( check_max_iv) & - call da_max_error_qc (it, iv%info(synop), n, iv%synop(n)%q, max_error_q , failed) - endif + if( iv%synop(n)%q%qc >= obs_qc_pointer ) then + if( iv%synop(n)%t%qc == fails_error_max .or. iv%synop(n)%p%qc == fails_error_max) then + failed=.true. + iv%synop(n)%q%qc = fails_error_max + iv%synop(n)%q%inv = 0.0 + else + call da_max_error_qc (it, iv%info(synop), n, iv%synop(n)%q, max_error_q , failed) + endif if( iv%info(synop)%proc_domain(1,n) ) then num_qcstat_conv(1,synop,4,1)= num_qcstat_conv(1,synop,4,1) + 1 if(failed) then diff --git a/wrfv2_fire/var/da/da_synop/da_get_innov_vector_synop.inc b/wrfv2_fire/var/da/da_synop/da_get_innov_vector_synop.inc index 755ee8e2..e78cf3e1 100644 --- a/wrfv2_fire/var/da/da_synop/da_get_innov_vector_synop.inc +++ b/wrfv2_fire/var/da/da_synop/da_get_innov_vector_synop.inc @@ -43,6 +43,16 @@ subroutine da_get_innov_vector_synop( it,num_qcstat_conv, grid, ob, iv) allocate (model_p (1,iv%info(synop)%n1:iv%info(synop)%n2)) allocate (model_hsm(1,iv%info(synop)%n1:iv%info(synop)%n2)) + if ( it > 1 ) then + do n=iv%info(synop)%n1,iv%info(synop)%n2 + if (iv%synop(n)%u%qc == fails_error_max) iv%synop(n)%u%qc = 0 + if (iv%synop(n)%v%qc == fails_error_max) iv%synop(n)%v%qc = 0 + if (iv%synop(n)%t%qc == fails_error_max) iv%synop(n)%t%qc = 0 + if (iv%synop(n)%p%qc == fails_error_max) iv%synop(n)%p%qc = 0 + if (iv%synop(n)%q%qc == fails_error_max) iv%synop(n)%q%qc = 0 + end do + end if + if (sfc_assi_options == sfc_assi_options_1) then do n=iv%info(synop)%n1,iv%info(synop)%n2 @@ -73,15 +83,6 @@ subroutine da_get_innov_vector_synop( it,num_qcstat_conv, grid, ob, iv) if (iv % synop(n) % h < v_h(kts)) then iv%info(synop)%zk(:,n) = 1.0+1.0e-6 call da_obs_sfc_correction(iv%info(synop), iv%synop(n), n, grid%xb) - - ! To keep the original "ob" with no change for multiple - ! outer-loops use: - ! ob%synop(n)%p = iv%synop(n)%p%inv - ! ob%synop(n)%t = iv%synop(n)%t%inv - ! ob%synop(n)%q = iv%synop(n)%q%inv - ! ob%synop(n)%u = iv%synop(n)%u%inv - ! ob%synop(n)%v = iv%synop(n)%v%inv - else call da_to_zk(iv % synop(n) % h, v_h, v_interp_h, iv%info(synop)%zk(1,n)) end if @@ -127,7 +128,7 @@ subroutine da_get_innov_vector_synop( it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_3d (grid%xb%q, iv%info(synop), model_q) call da_interp_lin_3d (grid%xb%p, iv%info(synop), model_p) else if (sfc_assi_options == sfc_assi_options_2) then - ! Surface data assmiilation approach 2 + ! Surface data assimilation approach 2 !------------------------------------ ! 1.2.1 Surface assmiilation approach 2(10-m u, v, 2-m t, q, and sfc_p) @@ -140,6 +141,13 @@ subroutine da_get_innov_vector_synop( it,num_qcstat_conv, grid, ob, iv) call da_interp_lin_2d (grid%xb%terr, iv%info(synop), 1, model_hsm(1,:)) do n=iv%info(synop)%n1,iv%info(synop)%n2 + + iv%synop(n)%p%inv = ob%synop(n)%p + iv%synop(n)%t%inv = ob%synop(n)%t + iv%synop(n)%q%inv = ob%synop(n)%q + iv%synop(n)%u%inv = ob%synop(n)%u + iv%synop(n)%v%inv = ob%synop(n)%v + if (iv%synop(n)%p%qc >= 0) then ho = iv%synop(n)%h to = -888888.0 @@ -167,7 +175,6 @@ subroutine da_get_innov_vector_synop( it,num_qcstat_conv, grid, ob, iv) !-------------------------------------------------------------------- ! [3.0] Fast interpolation: !-------------------------------------------------------------------- - if (ob % synop(n) % u > missing_r .AND. iv % synop(n) % u % qc >= obs_qc_pointer) then iv % synop(n) % u % inv = iv%synop(n)%u%inv - model_u(1,n) else @@ -203,7 +210,8 @@ subroutine da_get_innov_vector_synop( it,num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !-------------------------------------------------------------------- - call da_check_max_iv_synop(iv,ob, it,num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_synop(iv,ob, it,num_qcstat_conv) if (check_buddy) call da_check_buddy_synop(iv, ob, grid%dx, it) ! diff --git a/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar.inc b/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar.inc index c84aaf6d..8b3968c4 100644 --- a/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar.inc +++ b/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_tamdar(iv, it,num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -22,65 +25,54 @@ subroutine da_check_max_iv_tamdar(iv, it,num_qcstat_conv) do n = iv%info(tamdar)%n1,iv%info(tamdar)%n2 do k = 1, iv%info(tamdar)%levels(n) call da_get_print_lvl(iv%tamdar(n)%p(k),ipr) - if( iv%tamdar(n)%u(k)%qc == fails_error_max .and. it > 1 )iv%tamdar(n)%u(k)%qc =0 - if( iv%tamdar(n)%u(k)%qc >= obs_qc_pointer ) then + failed=.false. - if( check_max_iv) & + if( iv%tamdar(n)%u(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(tamdar), n, iv%tamdar(n)%u(k), max_error_uv,failed) if( iv%info(tamdar)%proc_domain(k,n) ) then - num_qcstat_conv(1,tamdar,1,ipr) = num_qcstat_conv(1,tamdar,1,ipr) + 1 + num_qcstat_conv(1,tamdar,1,ipr) = num_qcstat_conv(1,tamdar,1,ipr) + 1 if(failed) then num_qcstat_conv(2,tamdar,1,ipr) = num_qcstat_conv(2,tamdar,1,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'tamdar',ob_vars(1),iv%info(tamdar)%lat(k,n),iv%info(tamdar)%lon(k,n),0.01*iv%tamdar(n)%p(k) end if end if - end if - if( iv%tamdar(n)%v(k)%qc == fails_error_max .and. it > 1 )iv%tamdar(n)%v(k)%qc =0 - if( iv%tamdar(n)%v(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%tamdar(n)%v(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(tamdar), n, iv%tamdar(n)%v(k), max_error_uv,failed) if( iv%info(tamdar)%proc_domain(k,n) ) then - num_qcstat_conv(1,tamdar,2,ipr) = num_qcstat_conv(1,tamdar,2,ipr) + 1 + num_qcstat_conv(1,tamdar,2,ipr) = num_qcstat_conv(1,tamdar,2,ipr) + 1 if(failed) then num_qcstat_conv(2,tamdar,2,ipr) = num_qcstat_conv(2,tamdar,2,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'tamdar',ob_vars(2),iv%info(tamdar)%lat(k,n),iv%info(tamdar)%lon(k,n),0.01*iv%tamdar(n)%p(k) end if end if - end if - if( iv%tamdar(n)%t(k)%qc == fails_error_max .and. it > 1 )iv%tamdar(n)%t(k)%qc =0 - if( iv%tamdar(n)%t(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%tamdar(n)%t(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(tamdar), n, iv%tamdar(n)%t(k), max_error_t ,failed) if( iv%info(tamdar)%proc_domain(k,n) ) then - num_qcstat_conv(1,tamdar,3,ipr) = num_qcstat_conv(1,tamdar,3,ipr) + 1 + num_qcstat_conv(1,tamdar,3,ipr) = num_qcstat_conv(1,tamdar,3,ipr) + 1 if(failed) then num_qcstat_conv(2,tamdar,3,ipr) = num_qcstat_conv(2,tamdar,3,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'tamdar',ob_vars(3),iv%info(tamdar)%lat(k,n),iv%info(tamdar)%lon(k,n),0.01*iv%tamdar(n)%p(k) end if end if - end if - if( iv%tamdar(n)%q(k)%qc == fails_error_max .and. it > 1 )iv%tamdar(n)%q(k)%qc =0 - if( iv%tamdar(n)%q(k)%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%tamdar(n)%q(k)%qc >= obs_qc_pointer ) & call da_max_error_qc (it,iv%info(tamdar), n, iv%tamdar(n)%q(k), max_error_q ,failed) if( iv%info(tamdar)%proc_domain(k,n) ) then - num_qcstat_conv(1,tamdar,4,ipr) = num_qcstat_conv(1,tamdar,4,ipr) + 1 + num_qcstat_conv(1,tamdar,4,ipr) = num_qcstat_conv(1,tamdar,4,ipr) + 1 if(failed) then num_qcstat_conv(2,tamdar,4,ipr) = num_qcstat_conv(2,tamdar,4,ipr) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& 'tamdar',ob_vars(4),iv%info(tamdar)%lat(k,n),iv%info(tamdar)%lon(k,n),0.01*iv%tamdar(n)%p(k) end if end if - end if end do end do diff --git a/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar_sfc.inc b/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar_sfc.inc index 6b533502..138074b5 100644 --- a/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar_sfc.inc +++ b/wrfv2_fire/var/da/da_tamdar/da_check_max_iv_tamdar_sfc.inc @@ -2,6 +2,9 @@ subroutine da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) !----------------------------------------------------------------------- ! Purpose: TBD + ! Update: + ! Removed Outerloop check as it is done in da_get_innov + ! Author: Syed RH Rizvi, MMM/NESL/NCAR, Date: 07/12/2009 !----------------------------------------------------------------------- implicit none @@ -23,10 +26,8 @@ subroutine da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) !--------------------------------------------------------------------------- do n=iv%info(tamdar_sfc)%n1,iv%info(tamdar_sfc)%n2 - if( iv%tamdar_sfc(n)%u%qc == fails_error_max .and. it > 1 )iv%tamdar_sfc(n)%u%qc =0 - if( iv%tamdar_sfc(n)%u%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%tamdar_sfc(n)%u%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%u, max_error_uv, failed) if( iv%info(tamdar_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,tamdar_sfc,1,1)= num_qcstat_conv(1,tamdar_sfc,1,1) + 1 @@ -36,12 +37,9 @@ subroutine da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) 'tamdar_sfc',ob_vars(1),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p end if end if - end if - if( iv%tamdar_sfc(n)%v%qc == fails_error_max .and. it > 1 )iv%tamdar_sfc(n)%v%qc =0 - if( iv%tamdar_sfc(n)%v%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%tamdar_sfc(n)%v%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%v, max_error_uv, failed) if( iv%info(tamdar_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,tamdar_sfc,2,1)= num_qcstat_conv(1,tamdar_sfc,2,1) + 1 @@ -51,12 +49,9 @@ subroutine da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) 'tamdar_sfc',ob_vars(2),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p end if end if - end if - if( iv%tamdar_sfc(n)%t%qc == fails_error_max .and. it > 1 )iv%tamdar_sfc(n)%t%qc =0 - if( iv%tamdar_sfc(n)%t%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & + if( iv%tamdar_sfc(n)%t%qc >= obs_qc_pointer ) & call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%t, max_error_t , failed) if( iv%info(tamdar_sfc)%proc_domain(1,n) ) then num_qcstat_conv(1,tamdar_sfc,3,1)= num_qcstat_conv(1,tamdar_sfc,3,1) + 1 @@ -66,41 +61,40 @@ subroutine da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) 'tamdar_sfc',ob_vars(3),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p end if end if - end if - if( iv%tamdar_sfc(n)%q%qc == fails_error_max .and. it > 1 )iv%tamdar_sfc(n)%q%qc =0 - if( iv%tamdar_sfc(n)%q%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & - call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%q, max_error_q , failed) + if( iv%tamdar_sfc(n)%p%qc >= obs_qc_pointer ) & + call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%p, max_error_p , failed) if( iv%info(tamdar_sfc)%proc_domain(1,n) ) then - num_qcstat_conv(1,tamdar_sfc,4,1)= num_qcstat_conv(1,tamdar_sfc,4,1) + 1 + num_qcstat_conv(1,tamdar_sfc,5,1)= num_qcstat_conv(1,tamdar_sfc,5,1) + 1 if(failed) then - num_qcstat_conv(2,tamdar_sfc,4,1)= num_qcstat_conv(2,tamdar_sfc,4,1) + 1 + num_qcstat_conv(2,tamdar_sfc,5,1)= num_qcstat_conv(2,tamdar_sfc,5,1) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& - 'tamdar_sfc',ob_vars(4),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p + 'tamdar_sfc',ob_vars(5),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p end if end if - end if - if( iv%tamdar_sfc(n)%p%qc == fails_error_max .and. it > 1 )iv%tamdar_sfc(n)%p%qc =0 - if( iv%tamdar_sfc(n)%p%qc >= obs_qc_pointer ) then failed=.false. - if( check_max_iv) & - call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%p, max_error_p , failed) + if( iv%tamdar_sfc(n)%q%qc >= obs_qc_pointer ) then + if( iv%tamdar_sfc(n)%t%qc == fails_error_max .or. iv%tamdar_sfc(n)%p%qc == fails_error_max) then + failed=.true. + iv%tamdar_sfc(n)%q%qc = fails_error_max + iv%tamdar_sfc(n)%q%inv = 0.0 + else + call da_max_error_qc (it, iv%info(tamdar_sfc), n, iv%tamdar_sfc(n)%q, max_error_q , failed) + endif if( iv%info(tamdar_sfc)%proc_domain(1,n) ) then - num_qcstat_conv(1,tamdar_sfc,5,1)= num_qcstat_conv(1,tamdar_sfc,5,1) + 1 + num_qcstat_conv(1,tamdar_sfc,4,1)= num_qcstat_conv(1,tamdar_sfc,4,1) + 1 if(failed) then - num_qcstat_conv(2,tamdar_sfc,5,1)= num_qcstat_conv(2,tamdar_sfc,5,1) + 1 + num_qcstat_conv(2,tamdar_sfc,4,1)= num_qcstat_conv(2,tamdar_sfc,4,1) + 1 write(qcstat_conv_unit,'(2x,a10,2x,a4,3f12.2)')& - 'tamdar_sfc',ob_vars(5),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p + 'tamdar_sfc',ob_vars(4),iv%info(tamdar_sfc)%lat(1,n),iv%info(tamdar_sfc)%lon(1,n),0.01*ob%tamdar_sfc(n)%p + end if end if end if - end if + end do if (trace_use_dull) call da_trace_exit("da_check_max_iv_tamdar_sfc") end subroutine da_check_max_iv_tamdar_sfc - - diff --git a/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar.inc b/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar.inc index 9eda04ab..5f0fa73d 100644 --- a/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar.inc +++ b/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar.inc @@ -40,6 +40,17 @@ subroutine da_get_innov_vector_tamdar (it, num_qcstat_conv, grid, ob, iv) model_t(:,:) = 0.0 model_q(:,:) = 0.0 + if ( it > 1 ) then + do n=iv%info(tamdar)%n1,iv%info(tamdar)%n2 + do k=1, iv%info(tamdar)%levels(n) + if (iv%tamdar(n)%u(k)%qc == fails_error_max) iv%tamdar(n)%u(k)%qc = 0 + if (iv%tamdar(n)%v(k)%qc == fails_error_max) iv%tamdar(n)%v(k)%qc = 0 + if (iv%tamdar(n)%t(k)%qc == fails_error_max) iv%tamdar(n)%t(k)%qc = 0 + if (iv%tamdar(n)%q(k)%qc == fails_error_max) iv%tamdar(n)%q(k)%qc = 0 + end do + end do + end if + do n=iv%info(tamdar)%n1, iv%info(tamdar)%n2 if (iv%info(tamdar)%levels(n) < 1) cycle diff --git a/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar_sfc.inc b/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar_sfc.inc index 8ea32fe4..7d985770 100644 --- a/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar_sfc.inc +++ b/wrfv2_fire/var/da/da_tamdar/da_get_innov_vector_tamdar_sfc.inc @@ -38,6 +38,17 @@ subroutine da_get_innov_vector_tamdar_sfc( it, num_qcstat_conv, grid, ob, iv) allocate (model_p(1,iv%info(tamdar_sfc)%n1:iv%info(tamdar_sfc)%n2)) allocate (model_q(1,iv%info(tamdar_sfc)%n1:iv%info(tamdar_sfc)%n2)) allocate (model_hsm(1,iv%info(tamdar_sfc)%n1:iv%info(tamdar_sfc)%n2)) + + if ( it > 1 ) then + do n=iv%info(tamdar_sfc)%n1,iv%info(tamdar_sfc)%n2 + if (iv%tamdar_sfc(n)%u%qc == fails_error_max) iv%tamdar_sfc(n)%u%qc = 0 + if (iv%tamdar_sfc(n)%v%qc == fails_error_max) iv%tamdar_sfc(n)%v%qc = 0 + if (iv%tamdar_sfc(n)%t%qc == fails_error_max) iv%tamdar_sfc(n)%t%qc = 0 + if (iv%tamdar_sfc(n)%p%qc == fails_error_max) iv%tamdar_sfc(n)%p%qc = 0 + if (iv%tamdar_sfc(n)%q%qc == fails_error_max) iv%tamdar_sfc(n)%q%qc = 0 + end do + end if + if (sfc_assi_options == sfc_assi_options_1) then do n=iv%info(tamdar_sfc)%n1,iv%info(tamdar_sfc)%n2 ! [1.1] Get horizontal interpolation weights: @@ -69,16 +80,6 @@ subroutine da_get_innov_vector_tamdar_sfc( it, num_qcstat_conv, grid, ob, iv) if (iv % tamdar_sfc(n) % h < v_h(kts)) then iv%info(tamdar_sfc)%zk(:,n) = 1.0+1.0e-6 call da_obs_sfc_correction(iv%info(tamdar_sfc), iv%tamdar_sfc(n), n, grid%xb) - - ! To keep the original "ob" with no change for multiple - ! outer-loops use: - - ! ob%tamdar_sfc(n)%p = iv%tamdar_sfc(n)%p%inv - ! ob%tamdar_sfc(n)%t = iv%tamdar_sfc(n)%t%inv - ! ob%tamdar_sfc(n)%q = iv%tamdar_sfc(n)%q%inv - ! ob%tamdar_sfc(n)%u = iv%tamdar_sfc(n)%u%inv - ! ob%tamdar_sfc(n)%v = iv%tamdar_sfc(n)%v%inv - else call da_to_zk(iv % tamdar_sfc(n) % h, v_h, v_interp_h, iv%info(tamdar_sfc)%zk(1,n)) end if @@ -123,8 +124,8 @@ subroutine da_get_innov_vector_tamdar_sfc( it, num_qcstat_conv, grid, ob, iv) call da_interp_lin_3d (grid%xb%q, iv%info(tamdar_sfc), model_q) call da_interp_lin_3d (grid%xb%p, iv%info(tamdar_sfc), model_p) - else if (sfc_assi_options == 2) then - ! 1.2.1 Surface assmiilation approach 2(10-m u, v, 2-m t, q, and sfc_p) + else if (sfc_assi_options == sfc_assi_options_2) then + ! 1.2.1 Surface assimilation approach 2(10-m u, v, 2-m t, q, and sfc_p) #ifdef A2C call da_interp_lin_3d (grid%xb%u, iv%info(tamdar_sfc), model_u,'u') call da_interp_lin_3d (grid%xb%v, iv%info(tamdar_sfc), model_v,'v') @@ -138,6 +139,12 @@ subroutine da_get_innov_vector_tamdar_sfc( it, num_qcstat_conv, grid, ob, iv) do n=iv%info(tamdar_sfc)%n1,iv%info(tamdar_sfc)%n2 + iv%tamdar_sfc(n)%p%inv = ob%tamdar_sfc(n)%p + iv%tamdar_sfc(n)%t%inv = ob%tamdar_sfc(n)%t + iv%tamdar_sfc(n)%q%inv = ob%tamdar_sfc(n)%q + iv%tamdar_sfc(n)%u%inv = ob%tamdar_sfc(n)%u + iv%tamdar_sfc(n)%v%inv = ob%tamdar_sfc(n)%v + if (iv%tamdar_sfc(n)%p%qc >= 0) then ! model surface p, t, q, h at observed site: @@ -204,7 +211,9 @@ subroutine da_get_innov_vector_tamdar_sfc( it, num_qcstat_conv, grid, ob, iv) ! [5.0] Perform optional maximum error check: !----------------------------------------------------------------------- - call da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) + if ( check_max_iv ) & + call da_check_max_iv_tamdar_sfc(iv,ob, it, num_qcstat_conv) + deallocate (model_u) deallocate (model_v) deallocate (model_t) diff --git a/wrfv2_fire/var/da/da_test/da_check.inc b/wrfv2_fire/var/da/da_test/da_check.inc index aa050196..c12c16a3 100644 --- a/wrfv2_fire/var/da/da_test/da_check.inc +++ b/wrfv2_fire/var/da/da_test/da_check.inc @@ -49,13 +49,13 @@ subroutine da_check(grid, config_flags, cv_size, xbx, be, ep, iv, vv, vp, y) ! vv_to_vp adjoint test: !------------------------------------------------------------------------- - call da_check_vvtovp_adjoint(be % ne, grid%xb, be, vv, vp) + call da_check_vvtovp_adjoint(grid, be % ne, grid%xb, be, vv, vp) !------------------------------------------------------------------------- ! vptox adjoint test: !------------------------------------------------------------------------- - call da_check_vptox_adjoint(grid,be % ne, be, ep, vp, cv_size) + call da_check_vptox_adjoint(grid, be % ne, be, ep, vp, cv_size) !------------------------------------------------------------------------- ! vtox adjoint test: = diff --git a/wrfv2_fire/var/da/da_test/da_check_cvtovv_adjoint.inc b/wrfv2_fire/var/da/da_test/da_check_cvtovv_adjoint.inc index 16a23fce..52b411fc 100644 --- a/wrfv2_fire/var/da/da_test/da_check_cvtovv_adjoint.inc +++ b/wrfv2_fire/var/da/da_test/da_check_cvtovv_adjoint.inc @@ -57,7 +57,7 @@ subroutine da_check_cvtovv_adjoint(grid, cv_size, xbx, be, cv, vv) + sum(vv % v5(its:ite,jts:jte,1:be%v5%mz)**2) if (be % ne > 0) then - adj_par_lhs = adj_par_lhs + sum(vv % alpha(its:ite,jts:jte,1:be%ne)**2) + adj_par_lhs = adj_par_lhs + sum(vv % alpha(its:ite,jts:jte,1:be%alpha%mz,1:be%ne)**2) end if !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_test/da_check_vp_errors.inc b/wrfv2_fire/var/da/da_test/da_check_vp_errors.inc index 422e46f5..20841b7b 100644 --- a/wrfv2_fire/var/da/da_test/da_check_vp_errors.inc +++ b/wrfv2_fire/var/da/da_test/da_check_vp_errors.inc @@ -19,7 +19,7 @@ subroutine da_check_vp_errors(vp1, vp2, ne, & real :: rms_diff ! RMS of differnce. real, dimension(its:ite, jts:jte, kts:kte) :: diff ! Difference - real :: diff_alpha(its:ite,jts:jte,1:ne) + real :: diff_alpha(its:ite,jts:jte,kts:kte,1:ne) if (trace_use) call da_trace_entry("da_check_vp_errors") @@ -128,13 +128,12 @@ subroutine da_check_vp_errors(vp1, vp2, ne, & if (ne > 0) then inv_size = 1.0 / real((ite-its+1) * (jte-jts+1) * ne) - diff_alpha(its:ite,jts:jte,1:ne) = vp2 % alpha(its:ite,jts:jte,1:ne) - & - vp1 % alpha(its:ite,jts:jte,1:ne) - - rms_fild = sqrt(sum(vp1 % alpha(its:ite, jts:jte,1:ne) & - * vp1 % alpha(its:ite, jts:jte,1:ne)) * inv_size) - rms_diff = sqrt(sum(diff_alpha(its:ite, jts:jte,1:ne) & - * diff_alpha(its:ite, jts:jte,1:ne)) * inv_size) + diff_alpha(its:ite,jts:jte,kts:kte,1:ne) = vp2 % alpha(its:ite,jts:jte,kts:kte,1:ne) - & + vp1 % alpha(its:ite,jts:jte,kts:kte,1:ne) + rms_fild = sqrt(sum(vp1 % alpha(its:ite,jts:jte,kts:kte,1:ne) & + * vp1 % alpha(its:ite,jts:jte,kts:kte,1:ne)) * inv_size) + rms_diff = sqrt(sum(diff_alpha(its:ite,jts:jte,kts:kte,1:ne) & + * diff_alpha(its:ite,jts:jte,kts:kte,1:ne)) * inv_size) if (rms_fild /= 0.0) then write(unit=stdout, fmt='(a,1pe10.4)') ' alpha RMS error/RMS field = ',& diff --git a/wrfv2_fire/var/da/da_test/da_check_vptox_adjoint.inc b/wrfv2_fire/var/da/da_test/da_check_vptox_adjoint.inc index cc5a66fd..9186b9c1 100644 --- a/wrfv2_fire/var/da/da_test/da_check_vptox_adjoint.inc +++ b/wrfv2_fire/var/da/da_test/da_check_vptox_adjoint.inc @@ -1,4 +1,4 @@ -subroutine da_check_vptox_adjoint(grid,ne, be, ep, vp, cv_size) +subroutine da_check_vptox_adjoint(grid, ne, be, ep, vp, cv_size) !--------------------------------------------------------------------------- ! Purpose: Test Vp to X routine and adjoint for compatibility. @@ -28,7 +28,7 @@ subroutine da_check_vptox_adjoint(grid,ne, be, ep, vp, cv_size) real :: vp2_v3(ims:ime,jms:jme,kms:kme) real :: vp2_v4(ims:ime,jms:jme,kms:kme) real :: vp2_v5(ims:ime,jms:jme,kms:kme) - real :: vp2_alpha(ims:ime,jms:jme,1:ne) + real :: vp2_alpha(ims:ime,jms:jme,kms:kme,1:ne) if (trace_use) call da_trace_entry("da_check_vptox_adjoint") @@ -92,7 +92,7 @@ subroutine da_check_vptox_adjoint(grid,ne, be, ep, vp, cv_size) vp2_v3(:,:,:) = vp % v3(:,:,:) vp2_v4(:,:,:) = vp % v4(:,:,:) vp2_v5(:,:,:) = vp % v5(:,:,:) - if (be % ne > 0) vp2_alpha(:,:,:) = vp % alpha(:,:,:) + if (be % ne > 0) vp2_alpha(:,:,:,:) = vp % alpha(:,:,:,:) !------------------------------------------------------------------------- ! [2.0] Perform x = U vp transform: @@ -232,8 +232,8 @@ subroutine da_check_vptox_adjoint(grid,ne, be, ep, vp, cv_size) adj_par_rhs if (be % ne > 0) then - adj_par_rhs = sum(vp % alpha(its:ite,jts:jte,:) * & - vp2_alpha(its:ite,jts:jte,:)) + adj_par_rhs + adj_par_rhs = sum(vp % alpha(its:ite,jts:jte,kts:kte,:) * & + vp2_alpha(its:ite,jts:jte,kts:kte,:)) + adj_par_rhs end if if ( cv_options == 3 ) adj_par_rhs = sum (cv_2*cv) @@ -263,7 +263,7 @@ subroutine da_check_vptox_adjoint(grid,ne, be, ep, vp, cv_size) vp % v3(:,:,:) = vp2_v3(:,:,:) vp % v4(:,:,:) = vp2_v4(:,:,:) vp % v5(:,:,:) = vp2_v5(:,:,:) - if (be % ne > 0) vp % alpha(:,:,:) = vp2_alpha(:,:,:) + if (be % ne > 0) vp % alpha(:,:,:,:) = vp2_alpha(:,:,:,:) write(unit=stdout, fmt='(/a/)') 'da_check_vptox_adjoint: Test Finished:' diff --git a/wrfv2_fire/var/da/da_test/da_check_vvtovp_adjoint.inc b/wrfv2_fire/var/da/da_test/da_check_vvtovp_adjoint.inc index 8f7ee9e0..e7e995d9 100644 --- a/wrfv2_fire/var/da/da_test/da_check_vvtovp_adjoint.inc +++ b/wrfv2_fire/var/da/da_test/da_check_vvtovp_adjoint.inc @@ -1,4 +1,4 @@ -subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) +subroutine da_check_vvtovp_adjoint(grid, ne, xb, be, vv, vp) !--------------------------------------------------------------------------- ! Purpose: Test Vv to Vp routine and adjoint for compatibility. @@ -8,6 +8,7 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) implicit none + type (domain), intent(in) :: grid integer, intent(in) :: ne ! Ensemble size. type (xb_type), intent(in) :: xb ! first guess (local). type (be_type), intent(in) :: be ! background error structure. @@ -24,7 +25,7 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) real :: vv2_v3(ims:ime,jms:jme,kms:kme) real :: vv2_v4(ims:ime,jms:jme,kms:kme) real :: vv2_v5(ims:ime,jms:jme,kms:kme) - real :: vv2_alpha(ims:ime,jms:jme,1:ne) + real :: vv2_alpha(ims:ime,jms:jme,kts:kte,1:ne) if (trace_use) call da_trace_entry("da_check_vvtovp_adjoint") @@ -44,7 +45,7 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) ! [2.0] Perform Vp = U_v Vv transform: !---------------------------------------------------------------------- - call da_vertical_transform('u', be, & + call da_vertical_transform(grid, 'u', be, & xb % vertical_inner_product, & vv, vp) @@ -60,7 +61,7 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) if (be % ne > 0) then adj_par_lhs = adj_par_lhs + & - sum(vp % alpha(its:ite,jts:jte,1:be%ne)**2) * inv_typ_vpalpha_sumsq + sum(vp % alpha(its:ite,jts:jte,kts:kte,1:be%ne)**2) * inv_typ_vpalpha_sumsq end if !---------------------------------------------------------------------- @@ -79,8 +80,8 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) inv_typ_vp5_sumsq if (be % ne > 0) then - vp % alpha(its:ite,jts:jte,1:be%ne) = & - vp % alpha(its:ite,jts:jte,1:be%ne) * inv_typ_vpalpha_sumsq + vp % alpha(its:ite,jts:jte,kts:kte,1:be%ne) = & + vp % alpha(its:ite,jts:jte,kts:kte,1:be%ne) * inv_typ_vpalpha_sumsq end if !---------------------------------------------------------------------- @@ -94,10 +95,10 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) vv2_v5(its:ite,jts:jte,1:be%v5%mz) = vv % v5(its:ite,jts:jte,1:be%v5%mz) if (be % ne > 0) then - vv2_alpha(its:ite,jts:jte,1:be%ne) = vv % alpha(its:ite,jts:jte,1:be%ne) + vv2_alpha(its:ite,jts:jte,kts:kte,1:be%ne) = vv % alpha(its:ite,jts:jte,kts:kte,1:be%ne) end if - call da_vertical_transform('u_adj', be, & + call da_vertical_transform(grid, 'u_adj', be, & xb % vertical_inner_product, & vv, vp) @@ -122,8 +123,8 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) adj_par_rhs = sum(vv % v5(its:ite,jts:jte,1:be%v5%mz) * & vv2_v5(its:ite,jts:jte,1:be%v5%mz)) + adj_par_rhs if (be % ne > 0) & - adj_par_rhs = sum(vv % alpha(its:ite,jts:jte,1:be%ne) * & - vv2_alpha(its:ite,jts:jte,1:be%ne)) + adj_par_rhs + adj_par_rhs = sum(vv % alpha(its:ite,jts:jte,kts:kte,1:be%ne) * & + vv2_alpha(its:ite,jts:jte,kts:kte,1:be%ne)) + adj_par_rhs !---------------------------------------------------------------------- ! [7.0] Print output: @@ -151,7 +152,7 @@ subroutine da_check_vvtovp_adjoint(ne, xb, be, vv, vp) vv % v5(its:ite,jts:jte,1:be%v5%mz) = vv2_v5(its:ite,jts:jte,1:be%v5%mz) if (be % ne > 0) then - vv % alpha(its:ite,jts:jte,1:be%ne) = vv2_alpha(its:ite,jts:jte,1:be%ne) + vv % alpha(its:ite,jts:jte,kts:kte,1:be%ne) = vv2_alpha(its:ite,jts:jte,kts:kte,1:be%ne) end if write(unit=stdout, fmt='(/a/)') 'da_check_vvtovp_adjoint: Test Finished.' diff --git a/wrfv2_fire/var/da/da_test/da_test_vxtransform.inc b/wrfv2_fire/var/da/da_test/da_test_vxtransform.inc index 087904f0..8fce16d7 100644 --- a/wrfv2_fire/var/da/da_test/da_test_vxtransform.inc +++ b/wrfv2_fire/var/da/da_test/da_test_vxtransform.inc @@ -111,7 +111,7 @@ subroutine da_test_vxtransform( grid, xbx, be, vv, vp) if ( vert_corr == vert_corr_2 ) then ! perform vv = u_v^{-1} vp transform: - call da_vertical_transform ('u_inv', be, grid%xb % vertical_inner_product, vv, vp) + call da_vertical_transform (grid, 'u_inv', be, grid%xb % vertical_inner_product, vv, vp) else vv % v1(its:ite,jts:jte,1:kz_vv(1)) = vp % v1(its:ite,jts:jte,1:kz_vp(1)) vv % v2(its:ite,jts:jte,1:kz_vv(2)) = vp % v2(its:ite,jts:jte,1:kz_vp(2)) @@ -129,7 +129,7 @@ subroutine da_test_vxtransform( grid, xbx, be, vv, vp) !---------------------------------------------------------------------- if ( vert_corr == vert_corr_2 ) then ! perform vp = u_v (vv) transform: - call da_vertical_transform ('u', be, grid%xb % vertical_inner_product, vv, vp) + call da_vertical_transform (grid, 'u', be, grid%xb % vertical_inner_product, vv, vp) else vp % v1(its:ite,jts:jte,1:kz_vv(1)) = vv % v1(its:ite,jts:jte,1:kz_vv(1)) vp % v2(its:ite,jts:jte,1:kz_vv(2)) = vv % v2(its:ite,jts:jte,1:kz_vv(2)) diff --git a/wrfv2_fire/var/da/da_tools/da_convert_zk.inc b/wrfv2_fire/var/da/da_tools/da_convert_zk.inc index fb9cd428..4ff7a7a5 100644 --- a/wrfv2_fire/var/da/da_tools/da_convert_zk.inc +++ b/wrfv2_fire/var/da/da_tools/da_convert_zk.inc @@ -11,8 +11,9 @@ subroutine da_convert_zk (info) if (trace_use) call da_trace_entry("da_convert_zk") - where ( (info%zk(:,info%n1:info%n2) > 0.0 & - .and. info%zk(:,info%n1:info%n2) .ne. missing_r) .or. anal_type_verify) + where ( (info%zk(:,info%n1:info%n2) > 0.0 .or. anal_type_verify) & + .and. info%zk(:,info%n1:info%n2) .ne. missing_r) + info%k(:,info%n1:info%n2) = int ( info%zk(:,info%n1:info%n2)) diff --git a/wrfv2_fire/var/da/da_transfer_model/da_transfer_kmatoxb.inc b/wrfv2_fire/var/da/da_transfer_model/da_transfer_kmatoxb.inc index 9b893bc2..8d071ed2 100644 --- a/wrfv2_fire/var/da/da_transfer_model/da_transfer_kmatoxb.inc +++ b/wrfv2_fire/var/da/da_transfer_model/da_transfer_kmatoxb.inc @@ -401,7 +401,7 @@ subroutine da_transfer_kmatoxb(xbx, grid) ! Calculate dew point temperature: !--------------------------------------------------------------------------- - call da_trh_to_td(grid%xb % rh, grid%xb % t, grid%xb % td) + call da_trh_to_td (grid) if (print_detail_xb) then i=is; j=js; k=ks diff --git a/wrfv2_fire/var/da/da_transfer_model/da_transfer_model.f90 b/wrfv2_fire/var/da/da_transfer_model/da_transfer_model.f90 index 4188b82d..f0be4ef2 100644 --- a/wrfv2_fire/var/da/da_transfer_model/da_transfer_model.f90 +++ b/wrfv2_fire/var/da/da_transfer_model/da_transfer_model.f90 @@ -14,7 +14,7 @@ module da_transfer_model ntasks_x, ntasks_y, data_order_xyz, mytask, & ntasks, data_order_xy use module_comm_dm, only : halo_xa_sub, halo_init_sub, halo_psichi_uv_adj_sub, & - halo_xb_sub, halo_xb_uv_sub + halo_xb_sub, halo_xb_uv_sub, halo_em_c_sub #endif use da_control, only : cos_xls, sin_xls, cos_xle, sin_xle, trace_use, & diff --git a/wrfv2_fire/var/da/da_transfer_model/da_transfer_wrftoxb.inc b/wrfv2_fire/var/da/da_transfer_model/da_transfer_wrftoxb.inc index e1daf963..1e0260a5 100644 --- a/wrfv2_fire/var/da/da_transfer_model/da_transfer_wrftoxb.inc +++ b/wrfv2_fire/var/da/da_transfer_model/da_transfer_wrftoxb.inc @@ -13,7 +13,7 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) type(domain), intent(inout) :: grid type(grid_config_rec_type), intent(in) :: config_flags - integer :: i, j, k + integer :: i, j, k, ij real :: theta, tmpvar @@ -289,7 +289,12 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) ' ubound(grid%v_2)=', ubound(grid%v_2) end if - do j=jts,jte + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k, cvpm, cpovcv, ppb, temp, ttb ) & + !$OMP PRIVATE ( albn, qvf1, aln, theta ) + do ij = 1 , grid%num_tiles + + do j=grid%j_start(ij), grid%j_end(ij) k = kte+1 do i=its,ite @@ -340,6 +345,10 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) ! Adapted the code from WRF module_big_step_utilitites_em.F ---- ! subroutine calc_p_rho_phi Y.-R. Guo (10/20/2004) + ! NOTE: as of V3.1, P (pressure perturbation) and PB (base state pressure) + ! are included in the wrfinput file. However, P and PB are still + ! re-calculated here. + cvpm = - (1.0 - gas_constant/cp) cpovcv = cp / (cp - gas_constant) @@ -347,6 +356,7 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) do i=its,ite ! The base specific volume (from real.init.code) ppb = grid%znu(k) * grid%mub(i,j) + ptop + grid%pb(i,j,k) = ppb temp = MAX ( iso_temp, base_temp + base_lapse*log(ppb/base_pres) ) ttb = temp * (base_pres/ppb)**kappa ! ttb = (base_temp + base_lapse*log(ppb/base_pres)) * & @@ -390,8 +400,8 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) ! Convert to specific humidity from mixing ratio of water vapor: grid%xb%q(i,j,k)=grid%xb%q(i,j,k)/(1.0+grid%xb%q(i,j,k)) - if (num_pseudo == 0 .and. grid%xb%q(i,j,k) < 1.0e-6) & - grid%xb%q(i,j,k) = 1.0e-6 + if (num_pseudo == 0 .and. grid%xb%q(i,j,k) < 1.0e-9) & + grid%xb%q(i,j,k) = 1.0e-9 ! Background qrn needed for radar radial velocity assmiilation: @@ -433,6 +443,8 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) end do end do + end do + !$OMP END PARALLEL DO grid%xb%ztop = grid%xb%hf(its,jts,kte+1) @@ -525,7 +537,11 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) 'grid%xb % map_factor(its,jts)=', grid%xb % map_factor(its,jts) end if - do j=jts,jte + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, tmpvar, height, message ) + do ij = 1 , grid%num_tiles + + do j=grid%j_start(ij),grid%j_end(ij) do i=its,ite if (grid%xb%ztop < grid%xb%hf(i,j,kte+1)) & grid%xb%ztop = grid%xb%hf(i,j,kte+1) @@ -563,25 +579,33 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) end do end do + end do + !$OMP END PARALLEL DO + !--------------------------------------------------------------------------- ! Calculate saturation vapour pressure and relative humidity: !--------------------------------------------------------------------------- - do j=jts,jte + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, k, j, i ) + do ij = 1 , grid%num_tiles do k=kts,kte - do i=its,ite - call da_tpq_to_rh(grid%xb % t(i,j,k), grid%xb % p(i,j,k), & - grid%xb % q(i,j,k), grid%xb %es(i,j,k), grid%xb %qs(i,j,k), & - grid%xb %rh(i,j,k)) + do j=grid%j_start(ij),grid%j_end(ij) + do i=its,ite + call da_tpq_to_rh(grid%xb % t(i,j,k), grid%xb % p(i,j,k), & + grid%xb % q(i,j,k), grid%xb %es(i,j,k), grid%xb %qs(i,j,k), & + grid%xb %rh(i,j,k)) + end do end do end do end do + !$OMP END PARALLEL DO !--------------------------------------------------------------------------- ! Calculate dew point temperature: !--------------------------------------------------------------------------- - call da_trh_to_td(grid%xb % rh, grid%xb % t, grid%xb % td) + call da_trh_to_td (grid) if (print_detail_xb) then i=its; j=jts; k=kts @@ -617,7 +641,15 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) tmpvar = log(10.0/0.0001) - do j=jts,jte + !$OMP PARALLEL DO & +#ifndef A2C + !$OMP PRIVATE (ij, i, j, height) +#else + !$OMP PRIVATE (ij, i, j, height, uu, vv) +#endif + do ij = 1, grid%num_tiles + + do j=grid%j_start(ij), grid%j_end(ij) do i=its,ite height = grid%xb%h(i,j,kts) - grid%xb%terr(i,j) rgh_fac(i,j) = 1.0/log(height/0.0001) @@ -633,6 +665,9 @@ subroutine da_transfer_wrftoxb(xbx, grid, config_flags) end do end do + end do + !$OMP END PARALLEL DO + !--------------------------------------------------------------------------- ! Brightness temperature SH Chen !--------------------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_transfer_model/da_transfer_xatowrf.inc b/wrfv2_fire/var/da/da_transfer_model/da_transfer_xatowrf.inc index f2b0c4be..d56d5520 100644 --- a/wrfv2_fire/var/da/da_transfer_model/da_transfer_xatowrf.inc +++ b/wrfv2_fire/var/da/da_transfer_model/da_transfer_xatowrf.inc @@ -14,6 +14,8 @@ subroutine da_transfer_xatowrf(grid) ! grid%t_2 ! grid%moist ! grid%p + ! grid%psfc + ! grid%t2, grid%q2, grid%u10, grid%v10, grid%th2 ! !--------------------------------------------------------------------------- @@ -36,12 +38,14 @@ subroutine da_transfer_xatowrf(grid) real, dimension(ims:ime,jms:jme) :: mu_cgrid - real :: t_full , p_full, rho_full, q_full, ph_full , ph_xb_hd, & + real :: t_full , p_full, rho_dry, q_full, ph_full , ph_xb_hd, & qvf1, qvf2, qvf1_b, qvf2_b + real :: uu, vv, ps1, ps2, ts1, ts2, qv1, qv2, height + if (trace_use) call da_trace_entry("da_transfer_xatowrf") - ! To kteep the background PH perturbation: + ! To keep the background PH perturbation: do j=jts,jte do i=its,ite @@ -203,16 +207,16 @@ subroutine da_transfer_xatowrf(grid) p_full = grid%xa%p(i,j,k) + grid%xb%p(i,j,k) q_full = grid%moist(i,j,k,P_QV) + q_cgrid(i,j,k) - ! Note: According to WRF, thits its the dry air density used to + ! Note: According to WRF, this is the dry air density used to ! compute the geopotential height: - rho_full = p_full / (gas_constant*t_full*(1.0+q_full/rd_over_rv)) + rho_dry = p_full / (gas_constant*t_full*(1.0+q_full/rd_over_rv)) ! To compute the theta increment with the full fitelds: grid%t_2(i,j,k) = t_full*(base_pres/p_full)**kappa - t0 ! The full fiteld of analysis ph: ph_full = ph_full & - - grid%xb%dnw(k) * (grid%xb%psac(i,j)+mu_cgrid(i,j)) / rho_full + - grid%xb%dnw(k) * (grid%xb%psac(i,j)+mu_cgrid(i,j)) / rho_dry ! background hydrostatic phi: ph_xb_hd = ph_xb_hd & @@ -348,6 +352,7 @@ subroutine da_transfer_xatowrf(grid) do i=its,ite grid%mu_2(i,j) = grid%mu_2(i,j) + mu_cgrid(i,j) grid%w_2(i,j,kte+1)= grid%w_2(i,j,kte+1) + grid%xa%w(i,j,kte+1) + grid%psfc(i,j) = grid%psfc(i,j) + grid%xa%psfc(i,j) end do do k=kts,kte @@ -358,9 +363,6 @@ subroutine da_transfer_xatowrf(grid) #endif grid%w_2(i,j,k) = grid%w_2(i,j,k) + grid%xa%w(i,j,k) grid%moist(i,j,k,P_QV) = grid%moist(i,j,k,P_QV) + q_cgrid(i,j,k) - ! makte sure qv its positive. - if (num_pseudo == 0 .and. grid%moist(i,j,k,P_QV) < 1.0e-6) & - grid%moist(i,j,k,P_QV) = 1.0e-6 if (size(grid%moist,dim=4) >= 4) then grid%moist(i,j,k,p_qc) = grid%moist(i,j,k,p_qc) + grid%xa%qcw(i,j,k) @@ -422,6 +424,40 @@ subroutine da_transfer_xatowrf(grid) end if #endif +#ifdef DM_PARALLEL +#include "HALO_EM_C.inc" +#endif +! re-calculate T2, Q2, U10, V10, TH2 using updated fields + + do j=jts,jte + do i=its,ite + uu = 0.5*(grid%u_2(i,j,kts)+grid%u_2(i+1,j,kts) ) + vv = 0.5*(grid%v_2(i,j,kts)+grid%v_2(i,j+1,kts) ) + ps1 = grid%p(i,j,kts) + grid%pb(i,j,kts) + ps2 = grid%p(i,j,kts+1) + grid%pb(i,j,kts+1) + ts1 = (t0+grid%t_2(i,j,kts))*(ps1/base_pres)**kappa + ts2 = (t0+grid%t_2(i,j,kts+1))*(ps2/base_pres)**kappa + qv1 = grid%moist(i,j,kts, p_qv)/(1.0+grid%moist(i,j,kts,p_qv)) + qv2 = grid%moist(i,j,kts+1, p_qv)/(1.0+grid%moist(i,j,kts+1,p_qv)) + height = 0.5*(grid%phb(i,j,kts)+grid%ph_2(i,j,kts)+ & + grid%phb(i,j,kts+1)+grid%ph_2(i,j,kts+1))/gravity + height = height - grid%ht(i,j) + if (height <= 0.0) then + message(1) = "Negative height found" + write (unit=message(2),FMT='(2I6,A,F10.2,A,F10.2)') & + i,j,' ht = ',height ,' terr = ',grid%ht(i,j) + call da_error(__FILE__,__LINE__, message(1:2)) + end if + call da_sfc_wtq(grid%psfc(i,j), grid%tsk(i,j), & + ps1, ts1, qv1, uu, vv, & + ps2, ts2, qv2, & + height, grid%xb%rough(i,j),grid%xb%xland(i,j), & + grid%u10(i,j), grid%v10(i,j), grid%t2(i,j), & + grid%q2(i,j), grid%xb%regime(i,j)) + grid%th2(i,j) = grid%t2(i,j)*(base_pres/ps1)**kappa + end do + end do + if (print_detail_xa) then write(unit=stdout, fmt=*) 'simple variables:' diff --git a/wrfv2_fire/var/da/da_varbc/da_varbc.f90 b/wrfv2_fire/var/da/da_varbc/da_varbc.f90 index ef8a905c..e5356369 100644 --- a/wrfv2_fire/var/da/da_varbc/da_varbc.f90 +++ b/wrfv2_fire/var/da/da_varbc/da_varbc.f90 @@ -6,11 +6,11 @@ module da_varbc #if defined(RTTOV) || defined(CRTM) use module_dm, only : wrf_dm_sum_real, wrf_dm_sum_reals, wrf_dm_sum_integer - use module_radiance, only : q2ppmv + use module_radiance, only : q2ppmv, satinfo use da_control, only : trace_use,missing_r, qc_varbc_bad, rtm_option, & stdout,rtm_option_rttov,rtm_option_crtm, filename_len, cv_size_domain, & cv_size_domain_jp, use_varbc, freeze_varbc, varbc_factor, varbc_nobsmin, & - rootproc, ierr, comm + rootproc, varbc_nbgerr, ierr, comm, max_ext_its use da_define_structures, only : iv_type, y_type, be_type, & varbc_info_type,varbc_type use da_radiance1, only : stats_rad_type diff --git a/wrfv2_fire/var/da/da_varbc/da_varbc_coldstart.inc b/wrfv2_fire/var/da/da_varbc/da_varbc_coldstart.inc index 7a54fe1e..d9372903 100644 --- a/wrfv2_fire/var/da/da_varbc/da_varbc_coldstart.inc +++ b/wrfv2_fire/var/da/da_varbc/da_varbc_coldstart.inc @@ -94,7 +94,8 @@ iv%instid(inst)%varbc(k)%param(1) = mode Deallocate ( hist, hist_tot ) - write(unit=stdout,fmt='(A,A,I5,A,F5.2)') 'VARBC: Cold-starting ', & + if ( satinfo(inst)%iuse(k) == 1 ) & + write(unit=stdout,fmt='(A,A,I5,A,F5.2)') 'VARBC: Cold-starting ', & trim(adjustl(iv%instid(inst)%rttovid_string)),iv%instid(inst)%ichan(k),& ' --> ',mode end if @@ -115,12 +116,17 @@ ! Accumulate statistics for predictor mean/std ! --------------------------------------------- - do i = 1, npredmax - mean(i) = SUM(iv%instid(inst)%varbc_info%pred(i,1:num_rad), & - MASK=iv%instid(inst)%info%proc_domain(1,1:num_rad)) ! do not count HALO - rms(i) = SUM(iv%instid(inst)%varbc_info%pred(i,1:num_rad)**2, & - MASK=iv%instid(inst)%info%proc_domain(1,1:num_rad)) ! do not count HALO - end do + if (num_rad > 0) then + do i = 1, npredmax + mean(i) = SUM( iv%instid(inst)%varbc_info%pred(i,1:num_rad), & + MASK=iv%instid(inst)%info%proc_domain(1,1:num_rad)) ! do not count HALO + rms(i) = SUM( iv%instid(inst)%varbc_info%pred(i,1:num_rad)**2, & + MASK=iv%instid(inst)%info%proc_domain(1,1:num_rad)) ! do not count HALO + end do + else + mean = 0.0 + rms = 0.0 + end if ! Do inter-processor communication to gather statistics ! ------------------------------------------------------ diff --git a/wrfv2_fire/var/da/da_varbc/da_varbc_init.inc b/wrfv2_fire/var/da/da_varbc/da_varbc_init.inc index e5862bdd..70f9ab02 100644 --- a/wrfv2_fire/var/da/da_varbc/da_varbc_init.inc +++ b/wrfv2_fire/var/da/da_varbc/da_varbc_init.inc @@ -27,9 +27,6 @@ character(len=120) :: cline logical :: lvarbc_read, limatch, lmatch - type (varbc_info_type),pointer :: varbc_info(:) - type (varbc_type), pointer :: varbc(:,:) - if (trace_use) call da_trace_entry("da_varbc_init") !-------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_varbc/da_varbc_precond.inc b/wrfv2_fire/var/da/da_varbc/da_varbc_precond.inc index 5321de5a..cc84d0fc 100644 --- a/wrfv2_fire/var/da/da_varbc/da_varbc_precond.inc +++ b/wrfv2_fire/var/da/da_varbc/da_varbc_precond.inc @@ -13,7 +13,6 @@ type (iv_type), intent (inout) :: iv ! Innovation - type (stats_rad_type), pointer :: rad integer :: inst, n, i, j, k, ii, jj integer :: npred, npredmax, num_rad, num_rad_active real, allocatable :: hessian(:,:), eignvec(:,:), eignval(:) @@ -41,7 +40,8 @@ .AND.(iv%instid(inst)%tb_qc(k,1:num_rad) > qc_varbc_bad) ) iv%instid(inst)%varbc(k)%nobs = wrf_dm_sum_integer(num_rad_active) - write(unit=stdout,fmt='(A,I6,3A,I5)') & + if ( satinfo(inst)%iuse(k) == 1 ) & + write(unit=stdout,fmt='(A,I6,3A,I5)') & 'VARBC:',iv%instid(inst)%varbc(k)%nobs,' active observations for ', & trim(adjustl(iv%instid(inst)%rttovid_string)),' channel', & iv%instid(inst)%ichan(k) @@ -94,7 +94,8 @@ if (.not. iv%instid(inst)%info%proc_domain(1,n)) cycle ! do not sum up HALO data bgerr_local = bgerr_local + iv%instid(inst)%tb_error(k,n)**2 / & - iv%instid(inst)%varbc_info%nbgerr(ii) + varbc_nbgerr + ! iv%instid(inst)%varbc_info%nbgerr(ii) end do iv%instid(inst)%varbc(k)%bgerr(i) = wrf_dm_sum_real(bgerr_local) / & diff --git a/wrfv2_fire/var/da/da_varbc/da_varbc_update.inc b/wrfv2_fire/var/da/da_varbc/da_varbc_update.inc index 031e03ac..b54dfbfe 100644 --- a/wrfv2_fire/var/da/da_varbc/da_varbc_update.inc +++ b/wrfv2_fire/var/da/da_varbc/da_varbc_update.inc @@ -1,4 +1,4 @@ - subroutine da_varbc_update (cv_size, cv, iv) + subroutine da_varbc_update (it, cv_size, cv, iv) !--------------------------------------------------------------------------- ! PURPOSE: Update VarBC parameters and write into file @@ -14,6 +14,7 @@ implicit none + integer, intent(in) :: it !outer loop counting integer, intent(in) :: cv_size real, intent(in) :: cv(cv_size) ! Control variable structure. type (iv_type), intent(inout) :: iv ! Obs. increment structure. @@ -36,7 +37,11 @@ 'VARBC: Updating parameters and writing information in VARBC.out file' call da_get_unit(iunit) - filename = 'VARBC.out' + if ( it == max_ext_its ) then + filename = 'VARBC.out' + else + write(unit=filename, fmt='(a,i2.2)') 'VARBC.out_',it + end if open(unit=iunit,file=filename,form='formatted',iostat = iost,status='replace') if (iost /= 0) then @@ -81,11 +86,13 @@ where (iv%instid(inst)%varbc(ichan)%pred_use == 0) & iv%instid(inst)%varbc(ichan)%pred_use = 1 else - if (count(iv%instid(inst)%varbc(ichan)%pred_use == 0) > 0) & - write(unit=stdout,fmt='(A,A,I5)') & + if ( satinfo(inst)%iuse(ichan) == 1) then + if (count(iv%instid(inst)%varbc(ichan)%pred_use == 0) > 0) & + write(unit=stdout,fmt='(A,A,I5)') & 'VARBC: Not enough data to keep statistics for ', & trim(iv%instid(inst)%rttovid_string), & iv%instid(inst)%ichan(ichan) + end if end if if (use_varbc) then !--------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_verif_obs/da_verif_obs.f90 b/wrfv2_fire/var/da/da_verif_obs/da_verif_obs.f90 index f473d515..92501474 100644 --- a/wrfv2_fire/var/da/da_verif_obs/da_verif_obs.f90 +++ b/wrfv2_fire/var/da/da_verif_obs/da_verif_obs.f90 @@ -24,7 +24,7 @@ program da_verif_obs if_plot_profiler, if_plot_polaramv, if_plot_qscat, if_plot_rmse, & if_plot_sound, if_plot_sonde_sfc, if_plot_synop, if_plot_surface, & if_plot_upr, if_plot_ships, if_plot_metar, interval, stdp, start_date, & - if_plot_geoamv + if_plot_geoamv, stdh use da_verif_obs_init, only : initialize_surface_type, initialize_upr_type, & initialize_gpspw_type, initialize_gpsref_type, da_advance_cymdh , & initialize_t_tab @@ -37,7 +37,7 @@ program da_verif_obs character*5 :: stn_id integer :: n, k, kk, l, levels, dummy_i - real :: lat, lon, press, dummy + real :: lat, lon, press, height, dummy real :: u_obs, u_inv, u_error, u_inc, & v_obs, v_inv, v_error, v_inc, & t_obs, t_inv, t_error, t_inc, & @@ -47,7 +47,7 @@ program da_verif_obs real :: tpw_obs, tpw_inv, tpw_err, tpw_inc real :: ref_obs, ref_inv, ref_err, ref_inc integer :: u_qc, v_qc, t_qc, p_qc, q_qc, tpw_qc, spd_qc, ref_qc - integer :: npr, ier, iexp + integer :: npr, nht, ier, iexp character*10 :: date, new_date ! Current date (ccyymmddhh). integer :: sdate, cdate, edate ! Starting, current ending dates. logical :: if_write, is_file @@ -529,19 +529,20 @@ program da_verif_obs IF ( num_obs > 0 ) THEN DO n = 1, num_obs - read(diag_unit_in,'(i8)') levels + read(diag_unit_in,'(i8)') levels DO k = 1, levels - read(diag_unit_in,'(2i8,a5,2f9.2,f17.7,5(2f17.7,i8,2f17.7))', err= 1000)& + read(diag_unit_in,'(2i8,a5,2f9.2,f17.7,5(2f17.7,i8,2f17.7))', err= 1000)& kk, l, stn_id, & ! Station - lat, lon, press, & ! Lat/lon, dummy + lat, lon, height, & ! Lat/lon, dummy ref_obs, ref_inv, ref_qc, ref_err, ref_inc - if (if_write) then - if( ref_qc >= 0) then - call update_stats(gpsref%refomb(k),gpsref%refoma(k),ref_inv,ref_inc) - call update_stats(ggpsref%refomb(k),ggpsref%refoma(k),ref_inv,ref_inc) - end if - endif - END DO ! loop over levels + if (if_write .and. height > 0.0) then + call get_std_ht_level(height, nht, stdh, nstdh) + if ( ref_qc >= 0) then + call update_stats(gpsref%refomb(nht),gpsref%refoma(nht),ref_inv,ref_inc) + call update_stats(ggpsref%refomb(nht),ggpsref%refoma(nht),ref_inv,ref_inc) + end if + end if + END DO ! loop over levels END DO ! loop over Obs ENDIF go to 1 @@ -656,6 +657,36 @@ subroutine get_std_pr_level(prs, npr, stdp, nstd) end subroutine get_std_pr_level +subroutine get_std_ht_level(height, nht, stdh, nstdh) + + implicit none + + integer, intent(in ) :: nstdh + real, intent(in) :: stdh(nstdh) + integer, intent(out) :: nht + real, intent(in) :: height + + real :: ht + integer :: k + + ht = height*0.001 ! m to km + if ( ht <= stdh(1) ) then + nht = 1 + return + else if ( ht > stdh(nstdh-1) ) then + nht = nstdh + return + else + do k = 2,nstdh - 1 + if ( ht <= stdh(k) ) then + nht = k + return + end if + end do + end if + +end subroutine get_std_ht_level + subroutine update_stats(stats_omb, stats_oma, omb, oma) implicit none diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp.inc index 9b4ac13e..c4463646 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp.inc @@ -19,23 +19,23 @@ subroutine da_add_flow_dependence_vp (ne, ep, vp, & ! psi: vp % v1(its:ite,jts:jte,k) = vp % v1(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & + vp % alpha(its:ite,jts:jte,k,n) * & ep % v1(its:ite,jts:jte,k,n) ! chi_u: vp % v2(its:ite,jts:jte,k) = vp % v2(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & + vp % alpha(its:ite,jts:jte,k,n) * & ep % v2(its:ite,jts:jte,k,n) ! t_u: vp % v3(its:ite,jts:jte,k) = vp % v3(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & + vp % alpha(its:ite,jts:jte,k,n) * & ep % v3(its:ite,jts:jte,k,n) ! rh: vp % v4(its:ite,jts:jte,k) = vp % v4(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & + vp % alpha(its:ite,jts:jte,k,n) * & ep % v4(its:ite,jts:jte,k,n) ! ps_u vp % v5(its:ite,jts:jte,k) = vp % v5(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & + vp % alpha(its:ite,jts:jte,k,n) * & ep % v5(its:ite,jts:jte,k,n) end do end do diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp_adj.inc index 7c9302e9..b4eb0029 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_vp_adj.inc @@ -12,32 +12,32 @@ subroutine da_add_flow_dependence_vp_adj (ne, ep, vp) integer :: n, k! Loop counters. - vp % alpha(:,:,:) = 0.0 + vp % alpha(:,:,:,:) = 0.0 do n = ne, 1, -1 do k = kte, kts, -1 - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & + vp % alpha(its:ite,jts:jte,k,n) = vp % alpha(its:ite,jts:jte,k,n) + & ep % v5(its:ite,jts:jte,k,n) * & vp % v5(its:ite,jts:jte,k) ! rh: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & + vp % alpha(its:ite,jts:jte,k,n) = vp % alpha(its:ite,jts:jte,k,n) + & ep % v4(its:ite,jts:jte,k,n) * & vp % v4(its:ite,jts:jte,k) ! t_u: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & + vp % alpha(its:ite,jts:jte,k,n) = vp % alpha(its:ite,jts:jte,k,n) + & ep % v3(its:ite,jts:jte,k,n) * & vp % v3(its:ite,jts:jte,k) ! chi_u: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & + vp % alpha(its:ite,jts:jte,k,n) = vp % alpha(its:ite,jts:jte,k,n) + & ep % v2(its:ite,jts:jte,k,n) * & vp % v2(its:ite,jts:jte,k) ! psi: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & + vp % alpha(its:ite,jts:jte,k,n) = vp % alpha(its:ite,jts:jte,k,n) + & ep % v1(its:ite,jts:jte,k,n) * & vp % v1(its:ite,jts:jte,k) diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa.inc dissimilarity index 61% index cbfd24ba..e7594a0d 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa.inc @@ -1,47 +1,52 @@ -subroutine da_add_flow_dependence_xa (grid, ne, ep, vp) - - !----------------------------------------------------------------------- - ! Purpose: Add flow-dependent increments in model space (grid%xa). - !----------------------------------------------------------------------- - - implicit none - - type (domain), intent(inout) :: grid - integer, intent(in) :: ne ! Ensemble size. - type (ep_type), intent(in) :: ep ! Ensemble perturbations. - type (vp_type), intent(in) :: vp ! CV on grid structure. - - integer :: n, k! Loop counters. - - do n = 1, ne - do k = kts, kte - - ! u: - grid%xa % u(its:ite,jts:jte,k) = grid%xa % u(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & - ep % v1(its:ite,jts:jte,k,n) ! v1 = u - ! v: - grid%xa % v(its:ite,jts:jte,k) = grid%xa % v(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & - ep % v2(its:ite,jts:jte,k,n) ! v2 = v - ! t: - grid%xa % t(its:ite,jts:jte,k) = grid%xa % t(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & - ep % v3(its:ite,jts:jte,k,n) ! v3 = t - ! q: - grid%xa % q(its:ite,jts:jte,k) = grid%xa % q(its:ite,jts:jte,k) + & - vp % alpha(its:ite,jts:jte,n) * & - ep % v4(its:ite,jts:jte,k,n) ! v4 = q - end do - - ! ps: - grid%xa % psfc(its:ite,jts:jte) = grid%xa % psfc(its:ite,jts:jte) + & - vp % alpha(its:ite,jts:jte,n) * & - ep % v5(its:ite,jts:jte,1,n) ! v5 = ps - end do - - if (trace_use) call da_trace_exit("da_add_flow_dependence_xa") - -end subroutine da_add_flow_dependence_xa - - +subroutine da_add_flow_dependence_xa (grid, ne, ep, vp) + + !----------------------------------------------------------------------- + ! Purpose: Add flow-dependent increments in model space (grid%xa). + !----------------------------------------------------------------------- + + implicit none + + type (domain), intent(inout) :: grid + integer, intent(in) :: ne ! Ensemble size. + type (ep_type), intent(in) :: ep ! Ensemble perturbations. + type (vp_type), intent(in) :: vp ! CV on grid structure. + + integer :: i, j, k, n ! Loop counters. + real :: alpha ! Local alpha copy. + + do k = kts, kte + do j = jts, jte + do i = its, ite + + do n = 1, ne + alpha = vp % alpha(i,j,k,n) + + ! u: + grid%xa % u(i,j,k) = grid%xa % u(i,j,k) + alpha * ep % v1(i,j,k,n) ! v1 = u + + ! v: + grid%xa % v(i,j,k) = grid%xa % v(i,j,k) + alpha * ep % v2(i,j,k,n) ! v2 = v + + ! t: + grid%xa % t(i,j,k) = grid%xa % t(i,j,k) + alpha * ep % v3(i,j,k,n) ! v3 = t + + ! q: + grid%xa % q(i,j,k) = grid%xa % q(i,j,k) + alpha * ep % v4(i,j,k,n) ! v4 = q + + end do + end do + end do + end do + + ! ps: + do n = 1, ne + grid%xa % psfc(its:ite,jts:jte) = grid%xa % psfc(its:ite,jts:jte) + & + vp % alpha(its:ite,jts:jte,1,n) * & + ep % v5(its:ite,jts:jte,1,n) ! v5 = ps + end do + + if (trace_use) call da_trace_exit("da_add_flow_dependence_xa") + +end subroutine da_add_flow_dependence_xa + + diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa_adj.inc dissimilarity index 61% index e028da41..16c4da42 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_add_flow_dependence_xa_adj.inc @@ -1,52 +1,45 @@ -subroutine da_add_flow_dependence_xa_adj (ne, ep, xa, vp) - - !----------------------------------------------------------------------- - ! Purpose: Add flow-dependent increments in model space (xa). - !----------------------------------------------------------------------- - - implicit none - - integer, intent(in) :: ne ! Ensemble size. - type (ep_type), intent(in) :: ep ! Ensemble perturbations. - type (x_type), intent(in) :: xa ! Analysis increments. - type (vp_type), intent(inout) :: vp ! CV on grid structure. - - integer :: n, k! Loop counters. - - vp % alpha(:,:,:) = 0.0 - - do n = ne, 1, -1 - ! ps: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & - ep % v5(its:ite,jts:jte,1,n) * & ! v5 = ps - xa % psfc(its:ite,jts:jte) - - do k = kte, kts, -1 - - ! q: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & - ep % v4(its:ite,jts:jte,k,n) * & ! v4 = q - xa % q(its:ite,jts:jte,k) - - ! t: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & - ep % v3(its:ite,jts:jte,k,n) * & ! v3 = t - xa % t(its:ite,jts:jte,k) - - ! v: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & - ep % v2(its:ite,jts:jte,k,n) * & ! v2 = v - xa % v(its:ite,jts:jte,k) - - ! u: - vp % alpha(its:ite,jts:jte,n) = vp % alpha(its:ite,jts:jte,n) + & - ep % v1(its:ite,jts:jte,k,n) * & ! v1 = u - xa % u(its:ite,jts:jte,k) - end do - end do - - if (trace_use) call da_trace_exit("da_add_flow_dependence_xa_adj") - -end subroutine da_add_flow_dependence_xa_adj - - +subroutine da_add_flow_dependence_xa_adj (ne, ep, xa, vp) + + !----------------------------------------------------------------------- + ! Purpose: Add flow-dependent increments in model space (xa). + !----------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: ne ! Ensemble size. + type (ep_type), intent(in) :: ep ! Ensemble perturbations. + type (x_type), intent(in) :: xa ! Analysis increments. + type (vp_type), intent(inout) :: vp ! CV on grid structure. + + integer :: i, j, k, n ! Loop counters. + real :: alpha ! Local alpha copy. + + vp % alpha = 0.0 + + do n = ne, 1, -1 + ! ps: + vp % alpha(its:ite,jts:jte,1,n) = vp % alpha(its:ite,jts:jte,1,n) + & + ep % v5(its:ite,jts:jte,1,n) * & ! v5 = ps + xa % psfc(its:ite,jts:jte) + end do + + do k = kte, kts, -1 + do j = jte, jts, -1 + do i = ite, its, -1 + + do n = ne, 1, -1 + alpha = 0.0 + alpha = alpha + ep % v4(i,j,k,n) * xa % q(i,j,k) + alpha = alpha + ep % v3(i,j,k,n) * xa % t(i,j,k) + alpha = alpha + ep % v2(i,j,k,n) * xa % v(i,j,k) + alpha = alpha + ep % v1(i,j,k,n) * xa % u(i,j,k) + vp % alpha(i,j,k,n) = vp % alpha(i,j,k,n) + alpha + end do + end do + end do + end do + + if (trace_use) call da_trace_exit("da_add_flow_dependence_xa_adj") + +end subroutine da_add_flow_dependence_xa_adj + diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_apply_be.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_apply_be.inc index c1007162..45d5d4e4 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_apply_be.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_apply_be.inc @@ -7,7 +7,7 @@ SUBROUTINE da_apply_be( be, cv, vp, grid ) TYPE (vp_type), INTENT(INOUT) :: vp ! Grid point/EOF equivalent. type (domain) , intent(inout) :: grid ! Dimensions and xpose buffers. - INTEGER :: i,j,k + INTEGER :: i,j,k,ij !------------------------------------------------------------------------- ! [1.0] Make local-grid copy of vp from 1-dimensional global-grid cv. @@ -18,8 +18,11 @@ SUBROUTINE da_apply_be( be, cv, vp, grid ) ! [2.0] Transform control variable: + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, k, j, i ) + do ij = 1, grid%num_tiles do k=grid%xp%kts,grid%xp%kte - do j=grid%xp%jts,grid%xp%jte + do j=grid%j_start(ij), grid%j_end(ij) do i=grid%xp%its,grid%xp%ite vp % v1(i,j,k)=vp % v1(i,j,k)*be % corz(i,j,k,1) vp % v2(i,j,k)=vp % v2(i,j,k)*be % corz(i,j,k,2) @@ -28,14 +31,21 @@ SUBROUTINE da_apply_be( be, cv, vp, grid ) enddo enddo enddo + enddo + !$OMP END PARALLEL DO !-----Transform 5th control variable k=1 - do j=grid%xp%jts,grid%xp%jte + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j ) + do ij = 1, grid%num_tiles + do j=grid%j_start(ij),grid%j_end(ij) do i=grid%xp%its,grid%xp%ite vp % v5(i,j,k)=vp % v5(i,j,k)*be % corp(i,j) enddo enddo + enddo + !$OMP END PARALLEL DO CALL da_apply_rf( be, vp , grid ) diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal.inc index 733afa81..bd7a5051 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal.inc @@ -6,7 +6,7 @@ SUBROUTINE da_transform_bal( vp, be, grid ) TYPE (be_type), INTENT(IN) :: be ! Background errors. type (domain) , intent(inout) :: grid ! Domain variables. - INTEGER :: i, j, k, kk ! Loop counters. + INTEGER :: i, j, k, kk, ij ! Loop counters. !------------------------------------------------------------------- ! [1.0] Initialise: @@ -15,46 +15,90 @@ SUBROUTINE da_transform_bal( vp, be, grid ) ! linear balance btw psi and t-b, Psfc_b and chi_b ! [3.1] Calculate t_b from psi - grid%xa%t(its:ite,jts:jte,kts:kte)=vp%v3(its:ite,jts:jte,kts:kte) - - DO kk = kts,kte - DO k = kts,kte - DO j = jts,jte - DO i= its,ite - grid%xa%t(i,j,k) = grid%xa%t(i,j,k) + & - be%agvz(i,j,k,kk) * vp%v1(i,j,kk) - END DO - END DO + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, k, ij) + DO ij = 1, grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%t(i,j,k)=vp%v3(i,j,k) + END DO + END DO + END DO END DO + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, k, kk, ij) + DO ij = 1, grid%num_tiles + DO kk = kts,kte + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%t(i,j,k) = grid%xa%t(i,j,k) + & + be%agvz(i,j,k,kk) * vp%v1(i,j,kk) + END DO + END DO + END DO + END DO END DO + !$OMP END PARALLEL DO ! [3.2] Calculate chi_b from psi + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, k, ij) + DO ij = 1, grid%num_tiles DO k = kts,kte - DO j = jts,jte - DO i= its,ite - vp%v2(i,j,k) = vp%v2(i,j,k) + & - be%bvz(i,j,k) * vp%v1(i,j,k) - END DO - END DO + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp%v2(i,j,k) = vp%v2(i,j,k) + & + be%bvz(i,j,k) * vp%v1(i,j,k) + END DO + END DO END DO + END DO + !$OMP END PARALLEL DO ! [3.3] Calculate Psfc_b from psi - grid%xa%psfc(its:ite,jts:jte)=vp%v5(its:ite,jts:jte,1) - - DO kk = kts,kte - DO j = jts,jte - DO i= its,ite - grid%xa%psfc(i,j) = grid%xa%psfc(i,j) + & - be%wgvz(i,j,kk) * vp%v1(i,j,kk) - END DO + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, ij) + DO ij = 1, grid%num_tiles + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%psfc(i,j)=vp%v5(i,j,1) + END DO + END DO END DO + !$OMP END PARALLEL DO + + + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, k, ij) + DO ij = 1, grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%psfc(i,j) = grid%xa%psfc(i,j) + & + be%wgvz(i,j,k) * vp%v1(i,j,k) + END DO + END DO + END DO END DO + !$OMP END PARALLEL DO !--convert from delt.ln(ps) to delt.ps - grid%xa%psfc(its:ite,jts:jte) = grid%xa%psfc(its:ite,jts:jte) & - * grid%xb%psfc(its:ite,jts:jte) + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, ij) + DO ij = 1, grid%num_tiles + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%psfc(i,j) = grid%xa%psfc(i,j) * grid%xb%psfc(i,j) + END DO + END DO + END DO + !$OMP END PARALLEL DO ! [3.4] Transform psi and chi to u and v: @@ -70,8 +114,18 @@ SUBROUTINE da_transform_bal( vp, be, grid ) IF ( cv_options == 3 ) THEN - grid%xa%q(its:ite,jts:jte,kts:kte) = vp%v4(its:ite,jts:jte,kts:kte) * & - grid%xb%qs(its:ite,jts:jte,kts:kte) + !$OMP PARALLEL DO & + !$OMP PRIVATE (i, j, k, ij) + DO ij = 1, grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%q(i,j,k) = vp%v4(i,j,k) * grid%xb%qs(i,j,k) + END DO + END DO + END DO + END DO + !$OMP END PARALLEL DO ELSE IF ( cv_options_hum == 1 ) THEN grid%xa%q(its:ite,jts:jte,kts:kte) = vp%v4(its:ite,jts:jte,kts:kte) diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal_adj.inc index 7d56ccb5..5b0d04ef 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_bal_adj.inc @@ -6,7 +6,7 @@ SUBROUTINE da_transform_bal_adj( vp, be, grid ) TYPE (be_type), INTENT(IN) :: be ! Background errors. type (domain) , intent(inout) :: grid ! Dimensions and xpose buffers. - INTEGER :: i, j, k, kk, iunit ! Loop counters. + INTEGER :: i, j, k, kk, ij, iunit ! Loop counters. !------------------------------------------------------------------- ! [1.0] Initialise: !------------------------------------------------------------------- @@ -20,8 +20,19 @@ SUBROUTINE da_transform_bal_adj( vp, be, grid ) #include "HALO_PSICHI_UV_ADJ.inc" #endif - vp%v1(:,:,:)=0. - vp%v2(:,:,:)=0. + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, ij ) + DO ij = 1 , grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp%v1(i,j,k)=0. + vp%v2(i,j,k)=0. + END DO + END DO + END DO + ENDDO + !$OMP END PARALLEL DO call da_psichi_to_uv_adj( grid%xa % u, grid%xa % v, grid%xb % coefx, & grid%xb % coefy, vp % v1, vp % v2 ) @@ -29,51 +40,104 @@ SUBROUTINE da_transform_bal_adj( vp, be, grid ) ! [3.3] adj Calculate Psfc_b from psi !--convert from delt.ps to delt.ln(ps) - grid%xa%psfc(its:ite,jts:jte) = grid%xa%psfc(its:ite,jts:jte) & - * grid%xb%psfc(its:ite,jts:jte) - - DO kk = kts,kte - DO j = jts,jte - DO i= its,ite - vp % v1(i,j,kk)= vp % v1(i,j,kk)+ & - be % wgvz(i,j,kk) * grid%xa % psfc(i,j) - END DO - END DO - END DO - - vp % v5(its:ite,jts:jte,1)=grid%xa % psfc(its:ite,jts:jte) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, ij ) + DO ij = 1 , grid%num_tiles + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + grid%xa%psfc(i,j) = grid%xa%psfc(i,j) * grid%xb%psfc(i,j) + END DO + END DO + END DO + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, ij ) + DO ij = 1 , grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp % v1(i,j,k)= vp % v1(i,j,k)+ & + be % wgvz(i,j,k) * grid%xa % psfc(i,j) + END DO + END DO + END DO + END DO + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, ij ) + DO ij = 1 , grid%num_tiles + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp % v5(i,j,1)=grid%xa % psfc(i,j) + END DO + END DO + END DO + !$OMP END PARALLEL DO ! [3.2] adj Calculate chi_b from psi - DO k = kts,kte - DO j = jts,jte - DO i= its,ite - vp % v1(i,j,k)= vp % v1(i,j,k)+ & + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, ij ) + DO ij = 1 , grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp % v1(i,j,k)= vp % v1(i,j,k)+ & be % bvz(i,j,k) * vp % v2(i,j,k) + END DO + END DO END DO - END DO - END DO + END DO + !$OMP END PARALLEL DO ! [3.1] Calculate t_b from psi - DO kk = kts,kte - DO k = kts,kte - DO j = jts,jte - DO i= its,ite - vp % v1(i,j,kk)= vp % v1(i,j,kk)+ & + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, kk, ij ) + DO ij = 1 , grid%num_tiles + DO kk = kts,kte + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp % v1(i,j,kk)= vp % v1(i,j,kk)+ & be % agvz(i,j,k,kk) * grid%xa % t(i,j,k) + END DO + END DO + END DO END DO - END DO - END DO END DO - - vp % v3(its:ite,jts:jte,kts:kte)= grid%xa % t(its:ite,jts:jte,kts:kte) + !$OMP END PARALLEL DO + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, ij ) + DO ij = 1 , grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp % v3(i,j,k)= grid%xa % t(i,j,k) + END DO + END DO + END DO + END DO + !$OMP END PARALLEL DO ! [3.5] treat humidity IF ( cv_options == 3 ) THEN - vp % v4(its:ite,jts:jte,kts:kte) = grid%xa % q(its:ite,jts:jte,kts:kte) & - * grid%xb % qs(its:ite,jts:jte,kts:kte) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i, j, k, ij ) + DO ij = 1 , grid%num_tiles + DO k = kts,kte + DO j = grid%j_start(ij), grid%j_end(ij) + DO i= its,ite + vp % v4(i,j,k) = grid%xa % q(i,j,k) * grid%xb % qs(i,j,k) + END DO + END DO + END DO + END DO + !$OMP END PARALLEL DO ELSE IF ( cv_options_hum == 1 ) THEN diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox.inc index 9609461e..38722e02 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox.inc @@ -14,7 +14,7 @@ subroutine da_transform_vptox(grid, vp, be, ep) type (be_type), intent(in), optional :: be ! Background errors. type (ep_type), intent(in), optional :: ep ! Ensemble perturbations. - integer :: k, j, k1 ! Loop counters. + integer :: i, k, j, k1, ij ! Loop counters. if (trace_use) call da_trace_entry("da_transform_vptox") @@ -30,33 +30,56 @@ subroutine da_transform_vptox(grid, vp, be, ep) ! [2] Impose statistical balance constraints: !-------------------------------------------------------------------------- + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, k1, k, j, i) + do ij = 1 , grid%num_tiles + ! Chi: do k = kts, kte - do j = jts, jte - vp%v2(its:ite,j,k) = vp%v2(its:ite,j,k) + be%reg_chi(j,k)* vp%v1(its:ite,j,k) + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + vp%v2(i,j,k) = vp%v2(i,j,k) + be%reg_chi(j,k)* vp%v1(i,j,k) + end do end do end do ! Temperature: - grid%xa%t(its:ite,jts:jte,kts:kte) = vp%v3(its:ite,jts:jte,kts:kte) + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa%t(i,j,k) = vp%v3(i,j,k) + end do + end do + end do do k1 = kts, kte do k = kts, kte - do j = jts, jte - grid%xa%t(its:ite,j,k) = grid%xa%t(its:ite,j,k) + be%reg_t(j,k,k1)*vp%v1(its:ite,j,k1) + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa%t(i,j,k) = grid%xa%t(i,j,k) + be%reg_t(j,k,k1)*vp%v1(i,j,k1) + end do end do end do end do ! Surface Pressure - grid%xa%psfc(its:ite,jts:jte) = vp%v5(its:ite,jts:jte,1) + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa%psfc(i,j) = vp%v5(i,j,1) + end do + end do + do k = kts,kte - do j = jts,jte - grid%xa%psfc(its:ite,j) = grid%xa%psfc(its:ite,j) + be%reg_ps(j,k)*vp%v1(its:ite,j,k) + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa%psfc(i,j) = grid%xa%psfc(i,j) + be%reg_ps(j,k)*vp%v1(i,j,k) + end do end do end do + end do + !$OMP END PARALLEL DO !-------------------------------------------------------------------------- ! [3] Transform to model variable space: !-------------------------------------------------------------------------- @@ -104,8 +127,18 @@ subroutine da_transform_vptox(grid, vp, be, ep) grid%xb%qs(its:ite,jts:jte,kts:kte) else ! Pseudo RH --> Water vapor mixing ratio: - grid%xa % q(its:ite,jts:jte,kts:kte) = vp%v4(its:ite,jts:jte,kts:kte) * & - grid%xb%qs(its:ite,jts:jte,kts:kte) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, i, j, k ) + do ij = 1 , grid%num_tiles + do k = kts, kte + do j = grid%j_start(ij), grid%j_end(ij) + do i = its, ite + grid%xa % q(i,j,k) = vp%v4(i,j,k) * grid%xb%qs(i,j,k) + enddo + enddo + enddo + enddo + !$OMP END PARALLEL DO end if !--------------------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox_adj.inc index 391b7fbd..cb83d2b3 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vptox_adj.inc @@ -13,7 +13,7 @@ subroutine da_transform_vptox_adj(grid, vp, be, ep) type (ep_type), intent(in) :: ep ! Ensemble perturbation. type (be_type), intent(in), optional :: be ! Background errors. - integer :: k, j, k1 ! Loop counters. + integer :: i, k, j, ij, k1 ! Loop counters. if (trace_use) call da_trace_entry("da_transform_vptox_adj") @@ -35,8 +35,18 @@ subroutine da_transform_vptox_adj(grid, vp, be, ep) + grid%xa%qt(its:ite,jts:jte,kts:kte) * grid%xb%qs(its:ite,jts:jte,kts:kte) else ! Pseudo RH --> Water vapor mixing ratio: - vp%v4(its:ite,jts:jte,kts:kte) = vp%v4(its:ite,jts:jte,kts:kte) & - + grid%xa%q (its:ite,jts:jte,kts:kte) * grid%xb%qs(its:ite,jts:jte,kts:kte) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + do ij = 1 , grid%num_tiles + do k = kts,kte + do j = grid%j_start(ij),grid%j_end(ij) + do i = its, ite + vp%v4(i,j,k) = vp%v4(i,j,k) + grid%xa%q(i,j,k) * grid%xb%qs(i,j,k) + end do + end do + end do + end do + !$OMP END PARALLEL DO end if #ifdef A2C @@ -79,31 +89,54 @@ subroutine da_transform_vptox_adj(grid, vp, be, ep) ! [2] Impose statistical balance constraints: !-------------------------------------------------------------------------- + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, k, j, k1, i ) + do ij = 1 , grid%num_tiles + ! Surface Pressure - do k=kts,kte - do j=jts,jte - vp%v1(its:ite,j,k) = vp%v1(its:ite,j,k) + be%reg_ps(j,k)*grid%xa%psfc(its:ite,j) + do k= kts,kte + do j= grid%j_start(ij),grid%j_end(ij) + do i = its, ite + vp%v1(i,j,k) = vp%v1(i,j,k) + be%reg_ps(j,k)*grid%xa%psfc(i,j) + end do + end do + end do + do j= grid%j_start(ij),grid%j_end(ij) + do i = its, ite + vp%v5(i,j,1) = grid%xa%psfc(i,j) end do end do - vp%v5(its:ite,jts:jte,1) = grid%xa%psfc(its:ite,jts:jte) ! Temperature do k1 = kts,kte do k = kts,kte - do j = jts,jte - vp%v1(its:ite,j,k1) = vp%v1(its:ite,j,k1) + be%reg_t(j,k,k1)*grid%xa%t(its:ite,j,k) + do j = grid%j_start(ij),grid%j_end(ij) + do i = its, ite + vp%v1(i,j,k1) = vp%v1(i,j,k1) + be%reg_t(j,k,k1)*grid%xa%t(i,j,k) + end do + end do + end do + end do + do k = kts,kte + do j = grid%j_start(ij),grid%j_end(ij) + do i = its, ite + vp%v3(i,j,k) = grid%xa%t(i,j,k) end do end do end do - vp%v3(its:ite,jts:jte,kts:kte) = grid%xa%t(its:ite,jts:jte,kts:kte) ! Chi do k = kts,kte - do j = jts,jte - vp%v1(its:ite,j,k) = vp%v1(its:ite,j,k) + be%reg_chi(j,k)*vp%v2(its:ite,j,k) + do j = grid%j_start(ij),grid%j_end(ij) + do i = its, ite + vp%v1(i,j,k) = vp%v1(i,j,k) + be%reg_chi(j,k)*vp%v2(i,j,k) + end do end do end do + enddo + !$OMP END PARALLEL DO + !--------------------------------------------------------------------------- ! [1] Add flow-dependent increments in control variable space (vp): !--------------------------------------------------------------------------- diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv.inc index 20806201..7e1e6dfd 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv.inc @@ -12,7 +12,9 @@ subroutine da_transform_vtovv(grid, cv_size, be, cv, vv) real, intent(in) :: cv(1:cv_size) ! control variables. type(vp_type), intent(inout) :: vv ! Grid point/EOF equivalent. + integer :: n ! Loop counter. integer :: mz ! Vertical truncation. + integer :: ne ! Ensemble size. if (trace_use) call da_trace_entry("da_transform_vtovv") @@ -20,7 +22,7 @@ subroutine da_transform_vtovv(grid, cv_size, be, cv, vv) ! [1.0] Fill vv arrays from 1-dimensional cv array. !------------------------------------------------------------------------- - call da_cv_to_vv(cv_size, cv, (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%ne /), vv) + call da_cv_to_vv(cv_size, cv, (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%alpha%mz, be%ne /), vv) !------------------------------------------------------------------------- ! [2.0] Perform VToVV Transform: @@ -63,13 +65,15 @@ subroutine da_transform_vtovv(grid, cv_size, be, cv, vv) ! [2.6] Transform alpha control variable - mz = be % alpha % mz - if (mz > 0) then - call da_transform_through_rf(grid, mz, be % alpha % rf_alpha, be % alpha % val, vv % alpha) + ne = be % ne + if (ne > 0) then + mz = be % alpha % mz + do n = 1, ne + call da_transform_through_rf(grid, mz, be % alpha % rf_alpha, be % alpha % val, vv % alpha(:,:,:,n) ) + end do end if if (trace_use) call da_trace_exit("da_transform_vtovv") end subroutine da_transform_vtovv - diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_adj.inc index c1b85695..225b90dd 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_adj.inc @@ -12,7 +12,9 @@ subroutine da_transform_vtovv_adj(grid, cv_size, be, cv, vv) real, intent(inout) :: cv(1:cv_size) ! control variables. type(vp_type), intent(inout) :: vv ! Grid point/EOF control var. + integer :: n ! Loop counter. integer :: mz ! Vertical truncation. + integer :: ne ! Ensemble size. if (trace_use) call da_trace_entry("da_transform_vtovv_adj") @@ -57,16 +59,20 @@ subroutine da_transform_vtovv_adj(grid, cv_size, be, cv, vv) ! [2.6] Transform alpha control variable - mz = be % alpha % mz - if (mz > 0) then - call da_transform_through_rf_adj(grid, mz, be % alpha % rf_alpha, be % alpha % val, vv % alpha) + ne = be % ne + if (ne > 0) then + mz = be % alpha % mz + do n = 1, ne + call da_transform_through_rf_adj(grid, mz, be % alpha % rf_alpha, be % alpha % val, vv % alpha(:,:,:,n)) + end do end if !------------------------------------------------------------------------- ! [1.0] Fill 1D cv array from 3-dimensional vv arrays. !------------------------------------------------------------------------- - call da_vv_to_cv(vv, grid%xp, (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%ne /), cv_size, cv) + call da_vv_to_cv( vv, grid%xp, (/ be%v1%mz, be%v2%mz, be%v3%mz, be%v4%mz, be%v5%mz, be%alpha%mz, be%ne /), & + cv_size, cv) if (trace_use) call da_trace_exit("da_transform_vtovv_adj") diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global.inc index a303f8f7..1878c178 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global.inc @@ -12,7 +12,7 @@ subroutine da_transform_vtovv_global (cv_size, xbx, be, cv, vv) real, intent(in) :: cv(1:cv_size) ! control variables. type(vp_type), intent(inout) :: vv ! grdipt/eof cv (local). - integer :: k, m ! Loop counters. + integer :: k, m, n ! Loop counters. integer :: cv_s ! Counter. integer :: cv_e ! Counter. @@ -77,14 +77,16 @@ subroutine da_transform_vtovv_global (cv_size, xbx, be, cv, vv) ! [2] Spectral to grid transform for flow-dependent control variables: !------------------------------------------------------------------------- - do m = 1, be % ne - cv_e = cv_s + 2 * be % cv % size_alphac - 1 - call da_vtovv_spectral(be % alpha % max_wave, be % cv % size_alphac, & - xbx % lenr, xbx % lenwrk, xbx % lensav, & - xbx % inc, xbx % alp_size, xbx % alp, & - xbx % wsave, be % alpha % power(0:be%alpha%max_wave,1), & - cv(cv_s:cv_e), vv%alpha(its:ite,jts:jte,m)) - cv_s = cv_e + 1 + do n = 1, be % ne + do m = 1, be % alpha % mz + cv_e = cv_s + 2 * be % cv % size_alphac - 1 + call da_vtovv_spectral(be % alpha % max_wave, be % cv % size_alphac, & + xbx % lenr, xbx % lenwrk, xbx % lensav, & + xbx % inc, xbx % alp_size, xbx % alp, & + xbx % wsave, be % alpha % power(0:be%alpha%max_wave,1), & + cv(cv_s:cv_e), vv%alpha(its:ite,jts:jte,m,n)) + cv_s = cv_e + 1 + end do end do if (trace_use) call da_trace_exit("da_transform_vtovv_global") diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global_adj.inc index 98cc802b..9b01d58f 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtovv_global_adj.inc @@ -12,7 +12,7 @@ subroutine da_transform_vtovv_global_adj (cv_size, xbx, be, cv, vv) real, intent(out) :: cv(1:cv_size) ! control variables. type(vp_type), intent(in) :: vv ! grdipt/eof cv (local). - integer :: k, m ! Loop counters. + integer :: k, m, n ! Loop counters. integer :: cv_s ! Counter. integer :: cv_e ! Counter. @@ -77,14 +77,16 @@ subroutine da_transform_vtovv_global_adj (cv_size, xbx, be, cv, vv) ! [2] Spectral to grid transform for flow-dependent control variables: !------------------------------------------------------------------------- - do m = 1, be % ne - cv_e = cv_s + 2 * be % cv % size_alphac - 1 - call da_vtovv_spectral_adj(be % alpha % max_wave, be % cv % size_alphac, & - xbx % lenr, xbx % lenwrk, xbx % lensav, & - xbx % inc, xbx % alp_size, xbx % alp, & - xbx % wsave, be % alpha % power(0:be%alpha%max_wave,1), & - cv(cv_s:cv_e), vv%alpha(its:ite,jts:jte,m)) - cv_s = cv_e + 1 + do n = 1, be % ne + do m = 1, be % alpha % mz + cv_e = cv_s + 2 * be % cv % size_alphac - 1 + call da_vtovv_spectral_adj(be % alpha % max_wave, be % cv % size_alphac, & + xbx % lenr, xbx % lenwrk, xbx % lensav, & + xbx % inc, xbx % alp_size, xbx % alp, & + xbx % wsave, be % alpha % power(0:be%alpha%max_wave,1), & + cv(cv_s:cv_e), vv%alpha(its:ite,jts:jte,m,n)) + cv_s = cv_e + 1 + end do end do if (trace_use) call da_trace_exit("da_transform_vtovv_global_adj") diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox.inc index 519da4a9..51d1c361 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox.inc @@ -43,7 +43,7 @@ subroutine da_transform_vtox(grid, cv_size, xbx, be, ep, cv, vv, vp) else if (vert_corr == vert_corr_2) then - call da_vertical_transform('u', be, grid%xb % vertical_inner_product, vv, vp) + call da_vertical_transform(grid, 'u', be, grid%xb % vertical_inner_product, vv, vp) else vp % v1(its:ite,jts:jte,kts:kte) = vv % v1(its:ite,jts:jte,kts:kte) vp % v2(its:ite,jts:jte,kts:kte) = vv % v2(its:ite,jts:jte,kts:kte) @@ -52,7 +52,7 @@ subroutine da_transform_vtox(grid, cv_size, xbx, be, ep, cv, vv, vp) vp % v5(its:ite,jts:jte,kts:kte) = vv % v5(its:ite,jts:jte,kts:kte) if (be % ne > 0) then - vp % alpha(its:ite,jts:jte,1:be%ne) = vv%alpha(its:ite,jts:jte,1:be%ne) + vp % alpha(its:ite,jts:jte,kts:kte,1:be%ne) = vv%alpha(its:ite,jts:jte,kts:kte,1:be%ne) end if end if diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox_adj.inc index d4b6fdbf..d73bd65e 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vtox_adj.inc @@ -39,7 +39,7 @@ subroutine da_transform_vtox_adj(grid, cv_size, xbx, be, ep, vp, vv, cv) call da_zero_vp_type (vv) if (vert_corr == 2) then - call da_vertical_transform('u_adj', be, & + call da_vertical_transform(grid, 'u_adj', be, & grid%xb % vertical_inner_product, vv, vp) else vv % v1(its:ite,jts:jte,kts:kte) = vp % v1(its:ite,jts:jte,kts:kte) @@ -50,8 +50,8 @@ subroutine da_transform_vtox_adj(grid, cv_size, xbx, be, ep, vp, vv, cv) ! Uv for alpha is a null transform: if (be % ne > 0) then - vv % alpha(its:ite,jts:jte,1:be%ne) = & - vp % alpha(its:ite,jts:jte,1:be%ne) + vv % alpha(its:ite,jts:jte,kts:kte,1:be%ne) = & + vp % alpha(its:ite,jts:jte,kts:kte,1:be%ne) end if end if diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp.inc index 41c34523..55d62fd8 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp.inc @@ -1,4 +1,4 @@ -subroutine da_transform_vvtovp(evec, eval, vertical_wgt, vv, vp, mz, levels) +subroutine da_transform_vvtovp(grid, evec, eval, vertical_wgt, vv, vp, mz, levels) !--------------------------------------------------------------------------- ! Purpose: Transform from fields on vertical EOFS to fields on vertical @@ -9,6 +9,7 @@ subroutine da_transform_vvtovp(evec, eval, vertical_wgt, vv, vp, mz, levels) implicit none + type (domain), intent(in) :: grid integer, intent(in) :: mz ! # vertical modes. integer, intent(in) :: levels ! # no. of levels @@ -18,7 +19,7 @@ subroutine da_transform_vvtovp(evec, eval, vertical_wgt, vv, vp, mz, levels) real, intent(in) :: vv(ims:ime,jms:jme,kms:kme) ! CV in EOF space. real, intent(out) :: vp(ims:ime,jms:jme,kms:kme)! CV in level space. - integer :: i, j, k, m ! Loop counters. + integer :: i, j, k, m, ij ! Loop counters. real :: temp if (trace_use_dull) call da_trace_entry("da_transform_vvtovp") @@ -27,18 +28,23 @@ subroutine da_transform_vvtovp(evec, eval, vertical_wgt, vv, vp, mz, levels) ! [1.0] Perform vp(i,j,k) = E L^{1/2} vv(i,j,m) transform: !------------------------------------------------------------------- - vp = 0.0 - do k = kts, levels - do m = 1, mz - do j = jts, jte - temp = evec(j,k,m) * eval(j,m) - - do i = its, ite - vp(i,j,k) = vp(i,j,k) + temp*vv(i,j,m) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, k, m, j, i, temp ) + do ij = 1 , grid%num_tiles + vp(:,grid%j_start(ij):grid%j_end(ij),:) = 0.0 + do k = kts, levels + do m = 1, mz + do j = grid%j_start(ij), grid%j_end(ij) + temp = evec(j,k,m) * eval(j,m) + + do i = its, ite + vp(i,j,k) = vp(i,j,k) + temp*vv(i,j,m) + end do end do end do end do end do + !$OMP END PARALLEL DO !------------------------------------------------------------------- ! [2.0] Apply inner-product weighting if vertical_ip /= vertical_ip_0: diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc index 28ddaa6c..628ddc11 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_transform_vvtovp_adj.inc @@ -1,4 +1,4 @@ -subroutine da_transform_vvtovp_adj(evec, eval, vertical_wgt, vp, vv, mz, levels) +subroutine da_transform_vvtovp_adj(grid, evec, eval, vertical_wgt, vp, vv, mz, levels) !--------------------------------------------------------------------------- ! Purpose: Adjoint of da_transform_vvtovp. @@ -6,6 +6,7 @@ subroutine da_transform_vvtovp_adj(evec, eval, vertical_wgt, vp, vv, mz, levels) implicit none + type (domain), intent(in) :: grid integer, intent(in) :: mz ! # vertical modes. integer, intent(in) :: levels ! no. of vertical levels @@ -15,7 +16,7 @@ subroutine da_transform_vvtovp_adj(evec, eval, vertical_wgt, vp, vv, mz, levels) real, intent(inout) :: vp(ims:ime,jms:jme,kms:kme)! CV in level space. real, intent(out) :: vv(ims:ime,jms:jme,kms:kme)! CV in EOF space. - integer :: i, j, m, k ! Loop counters. + integer :: i, j, m, k, ij ! Loop counters. real :: temp if (trace_use_dull) call da_trace_entry("da_transform_vvtovp_adj") @@ -33,20 +34,25 @@ subroutine da_transform_vvtovp_adj(evec, eval, vertical_wgt, vp, vv, mz, levels) ! [2.0] Perform vp(i,j,k) = E L^{1/2} vv(i,j,m) transform: !------------------------------------------------------------------- - vv = 0.0 - do m = 1, mz - do k = kts, levels - do j = jts, jte - temp = evec(j,k,m) * eval(j,m) - - do i = its, ite - vv(i,j,m) = vv(i,j,m) + temp*vp(i,j,k) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij, m, k, j, i, temp ) + do ij = 1 , grid%num_tiles + vv(:,grid%j_start(ij):grid%j_end(ij),:) = 0.0 + do m = 1, mz + do k = kts, levels + do j = grid%j_start(ij), grid%j_end(ij) + temp = evec(j,k,m) * eval(j,m) + + do i = its, ite + vv(i,j,m) = vv(i,j,m) + temp*vp(i,j,k) + end do end do end do end do end do + !$OMP END PARALLEL DO - if (trace_use_dull) call da_trace_exit("da_transform_vvtovp_adj") + if (trace_use_dull) call da_trace_exit("da_transform_vvtovp_adj") end subroutine da_transform_vvtovp_adj diff --git a/wrfv2_fire/var/da/da_vtox_transforms/da_vertical_transform.inc b/wrfv2_fire/var/da/da_vtox_transforms/da_vertical_transform.inc index 97766210..6adcca0a 100644 --- a/wrfv2_fire/var/da/da_vtox_transforms/da_vertical_transform.inc +++ b/wrfv2_fire/var/da/da_vtox_transforms/da_vertical_transform.inc @@ -1,4 +1,4 @@ -subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) +subroutine da_vertical_transform(grid, string, be, vertical_wgt, vv, vp) !--------------------------------------------------------------------- ! Purpose: TBD @@ -6,13 +6,14 @@ subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) implicit none + type (domain), intent(in) :: grid character(len=*), intent(in) :: string ! Character operation type (be_type), intent(in) :: be ! Background error structure. real, intent(in) :: vertical_wgt(ims:ime,jms:jme,kms:kme) ! Weighting. type (vp_type), intent(inout) :: vv ! CV in gridpt/EOF space. type (vp_type), intent(inout) :: vp ! CV in gridpt/level space. - integer :: j, m ! Loop counters. + integer :: j, m, n ! Loop counters. real :: alpha_stddev_inv ! 1/ sigma_alpha real :: size_inv ! 1 / size. real :: alpha_me, alpha_ms, alpha_sd ! Alpha statistics. @@ -28,28 +29,28 @@ subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) !------------------------------------------------------------------- if (be % v1 % mz > 0) then - call da_transform_vvtovp (be % v1 % evec, be % v1 % val, vertical_wgt, & + call da_transform_vvtovp (grid, be % v1 % evec, be % v1 % val, vertical_wgt, & vv % v1, vp % v1, be % v1 % mz, kte) else vp % v1(its:ite,jts:jte,kts:kte) = 0.0 end if if (be % v2 % mz > 0) then - call da_transform_vvtovp (be % v2 % evec, be % v2 % val, vertical_wgt, & + call da_transform_vvtovp (grid, be % v2 % evec, be % v2 % val, vertical_wgt, & vv % v2, vp % v2, be % v2 % mz, kte) else vp % v2(its:ite,jts:jte,kts:kte) = 0.0 end if if (be % v3 % mz > 0) then - call da_transform_vvtovp (be % v3 % evec, be % v3 % val, vertical_wgt, & + call da_transform_vvtovp (grid, be % v3 % evec, be % v3 % val, vertical_wgt, & vv % v3, vp % v3, be % v3 % mz, kte) else vp % v3(its:ite,jts:jte,kts:kte) = 0.0 end if if (be % v4 % mz > 0) then - call da_transform_vvtovp (be % v4 % evec, be % v4 % val, vertical_wgt, & + call da_transform_vvtovp (grid, be % v4 % evec, be % v4 % val, vertical_wgt, & vv % v4, vp % v4, be % v4 % mz, kte) else vp % v4(its:ite,jts:jte,kts:kte) = 0.0 @@ -59,27 +60,26 @@ subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) if (global) then vp % v5(its:ite,jts:jte,1) = vv % v5(its:ite,jts:jte,1) else - call da_transform_vvtovp (be % v5 % evec, be % v5 % val, vertical_wgt, & - vv % v5, vp % v5, be % v5 % mz, kts) + call da_transform_vvtovp (grid, be % v5 % evec, be % v5 % val, vertical_wgt, & + vv % v5, vp % v5, be % v5 % mz, kts) end if else vp % v5(its:ite,jts:jte,kts:kts) = 0.0 end if - if (be % ne > 0) then - size_inv = 1.0 / ( (ite-its+1) * ( jte-jts+1) * be % ne ) - do m = 1, be % ne - do j = jts, jte - vp % alpha(its:ite,j,m) = vv % alpha(its:ite,j,m) * be % alpha % val(j,m) - end do + if ( be % ne > 0 .and. be % alpha % mz > 0 ) then + do n = 1, be % ne + call da_transform_vvtovp (grid, be % alpha % evec, be % alpha % val, vertical_wgt, & + vv % alpha(:,:,:,n), vp % alpha(:,:,:,n), be % alpha % mz, kte) end do ! Calculate alpha standard deviation diagnostic: - alpha_me = sum(vp % alpha(its:ite,jts:jte,:)) * size_inv - alpha_ms = sum(vp % alpha(its:ite,jts:jte,:) * vp % alpha(its:ite,jts:jte,:)) * & - size_inv - alpha_sd = sqrt( alpha_ms - alpha_me * alpha_me ) - write(6,'(a,f15.5)')' Alpha std. dev = ', alpha_sd +! size_inv = 1.0 / ( (ite-its+1) * ( jte-jts+1) * be % ne * be % alpha % mz ) +! alpha_me = sum(vp % alpha(its:ite,jts:jte,:)) * size_inv +! alpha_ms = sum(vp % alpha(its:ite,jts:jte,:) * vp % alpha(its:ite,jts:jte,:)) * & +! size_inv +! alpha_sd = sqrt( alpha_ms - alpha_me * alpha_me ) +! write(6,'(a,f15.5)')' Alpha std. dev = ', alpha_sd end if case ('u_inv'); @@ -122,12 +122,11 @@ subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) end if end if - if (be % ne > 0) then - do m = 1, be % ne - do j = jts, jte - alpha_stddev_inv = 1.0 / be % alpha % val(j,m) - vv % alpha(its:ite,j,m) = vp % alpha(its:ite,j,m) * alpha_stddev_inv - end do + if ( be % ne > 0 .and. be % alpha % mz > 0 ) then + do n = 1, be % ne + call da_transform_vptovv (be % alpha % evec, be % alpha % val, vertical_wgt, & + vp % alpha(:,:,:,n), vv % alpha(:,:,:,n), be % alpha % mz, kds,kde, & + ims,ime, jms,jme, kms,kme, its,ite, jts,jte, kts,kte) end do end if @@ -138,22 +137,22 @@ subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) !------------------------------------------------------------------- if (be % v1 % mz > 0) then - call da_transform_vvtovp_adj (be % v1 % evec, be % v1 % val, vertical_wgt, & + call da_transform_vvtovp_adj (grid, be % v1 % evec, be % v1 % val, vertical_wgt, & vp % v1, vv % v1, be % v1 % mz, kte) end if if (be % v2 % mz > 0) then - call da_transform_vvtovp_adj (be % v2 % evec, be % v2 % val, vertical_wgt, & + call da_transform_vvtovp_adj (grid, be % v2 % evec, be % v2 % val, vertical_wgt, & vp % v2, vv % v2, be % v2 % mz, kte) end if if (be % v3 % mz > 0) then - call da_transform_vvtovp_adj (be % v3 % evec, be % v3 % val, vertical_wgt, & + call da_transform_vvtovp_adj (grid, be % v3 % evec, be % v3 % val, vertical_wgt, & vp % v3, vv % v3, be % v3 % mz, kte) end if if (be % v4 % mz > 0) then - call da_transform_vvtovp_adj (be % v4 % evec, be % v4 % val, vertical_wgt, & + call da_transform_vvtovp_adj (grid, be % v4 % evec, be % v4 % val, vertical_wgt, & vp % v4, vv % v4, be % v4 % mz, kte) end if @@ -161,16 +160,15 @@ subroutine da_vertical_transform(string, be, vertical_wgt, vv, vp) if (global) then vv % v5(its:ite,jts:jte,1) = vp % v5(its:ite,jts:jte,1) else - call da_transform_vvtovp_adj (be % v5 % evec, be % v5 % val, vertical_wgt, & + call da_transform_vvtovp_adj (grid, be % v5 % evec, be % v5 % val, vertical_wgt, & vp % v5, vv % v5, be % v5 % mz, kts) end if end if - if (be % ne > 0) then - do m = 1, be % ne - do j = jts, jte - vv % alpha(its:ite,j,m) = vp % alpha(its:ite,j,m) * be % alpha % val(j,m) - end do + if ( be % ne > 0 .and. be % alpha % mz > 0 ) then + do n = 1, be % ne + call da_transform_vvtovp_adj (grid, be % alpha % evec, be % alpha % val, vertical_wgt, & + vp % alpha(:,:,:,n), vv % alpha(:,:,:,n), be % alpha % mz, kte) end do end if diff --git a/wrfv2_fire/var/external/bufr/bfrini.inc b/wrfv2_fire/var/external/bufr/bfrini.inc index 11041292..a89da850 100644 --- a/wrfv2_fire/var/external/bufr/bfrini.inc +++ b/wrfv2_fire/var/external/bufr/bfrini.inc @@ -66,11 +66,11 @@ TABD(MAXTBD,NFILES) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), & LD30(10),DXSTR(10) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4) COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT COMMON /DATELN/ LENDAT @@ -85,9 +85,9 @@ CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*56 DXSTR - CHARACTER*10 TAG +! CHARACTER*10 TAG CHARACTER*6 ADSN(5,2),DNDX(25,10) - CHARACTER*3 TYPX(5,2),TYPS,TYP + CHARACTER*3 TYPX(5,2),TYPS !,TYP CHARACTER*1 REPX(5,2),REPS CHARACTER*1 CSMF CHARACTER*1 CCMF diff --git a/wrfv2_fire/var/external/bufr/bufrlib.prm b/wrfv2_fire/var/external/bufr/bufrlib.prm index 5553a373..4b084d20 100644 --- a/wrfv2_fire/var/external/bufr/bufrlib.prm +++ b/wrfv2_fire/var/external/bufr/bufrlib.prm @@ -2,7 +2,7 @@ ! Maximum number of BUFR files that can be connected to the ! BUFRLIB software (for reading or writing) at any one time. - PARAMETER ( NFILES = 32 ) + PARAMETER ( NFILES = 16 ) !----------------------------------------------------------------------- ! Maximum length (in bytes) of a BUFR message that can be ! read or written by the BUFRLIB software. @@ -26,7 +26,7 @@ ! Maximum number of data values per subset in a compressed ! BUFR message. - PARAMETER ( MXCDV = 3000 ) + PARAMETER ( MXCDV = 2000 ) !----------------------------------------------------------------------- ! Maximum number of subsets in a compressed BUFR message. diff --git a/wrfv2_fire/var/external/bufr/closbf.inc b/wrfv2_fire/var/external/bufr/closbf.inc index ab5e6b26..5a3621b3 100644 --- a/wrfv2_fire/var/external/bufr/closbf.inc +++ b/wrfv2_fire/var/external/bufr/closbf.inc @@ -51,6 +51,41 @@ COMMON /NULBFR/ NULL(NFILES) + IF ( ALLOCATED (MSGP) ) DEALLOCATE (MSGP) + IF ( ALLOCATED (MSGS) ) DEALLOCATE (MSGS) + + IF ( ALLOCATED (MATX_S) ) DEALLOCATE (MATX_S) + IF ( ALLOCATED (CATX_S) ) DEALLOCATE (CATX_S) + IF ( ALLOCATED (KMIN_S) ) DEALLOCATE (KMIN_S) + IF ( ALLOCATED (KMAX_S) ) DEALLOCATE (KMAX_S) + IF ( ALLOCATED (KMIS_S) ) DEALLOCATE (KMIS_S) + IF ( ALLOCATED (KBIT_S) ) DEALLOCATE (KBIT_S) + IF ( ALLOCATED (ITYP_S) ) DEALLOCATE (ITYP_S) + IF ( ALLOCATED (IWID_S) ) DEALLOCATE (IWID_S) + IF ( ALLOCATED (CSTR_S) ) DEALLOCATE (CSTR_S) + + IF ( ALLOCATED (TAG) ) DEALLOCATE ( TAG ) + IF ( ALLOCATED (TYP) ) DEALLOCATE ( TYP ) + IF ( ALLOCATED (KNT) ) DEALLOCATE ( KNT ) + IF ( ALLOCATED (JUMP) ) DEALLOCATE ( JUMP ) + IF ( ALLOCATED (LINK) ) DEALLOCATE ( LINK ) + IF ( ALLOCATED (JMPB) ) DEALLOCATE ( JMPB ) + IF ( ALLOCATED (IBT) ) DEALLOCATE ( IBT ) + IF ( ALLOCATED (IRF) ) DEALLOCATE ( IRF ) + IF ( ALLOCATED (ISC) ) DEALLOCATE ( ISC ) + IF ( ALLOCATED (ITP) ) DEALLOCATE ( ITP ) + IF ( ALLOCATED (VALI) ) DEALLOCATE ( VALI ) + IF ( ALLOCATED (KNTI) ) DEALLOCATE ( KNTI ) + IF ( ALLOCATED (ISEQ) ) DEALLOCATE ( ISEQ ) + IF ( ALLOCATED (JSEQ) ) DEALLOCATE ( JSEQ ) + + IF ( ALLOCATED (NVAL) ) DEALLOCATE ( NVAL ) + IF ( ALLOCATED (INV) ) DEALLOCATE ( INV ) + IF ( ALLOCATED (VAL) ) DEALLOCATE ( VAL ) + + IF ( ALLOCATED (ITMP) ) DEALLOCATE (ITMP) + IF ( ALLOCATED (VTMP) ) DEALLOCATE (VTMP) + CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.GT.0 .AND. IM.NE.0) CALL CLOSMG(LUNIT) CALL WTSTAT(LUNIT,LUN,0,0) diff --git a/wrfv2_fire/var/external/bufr/conwin.inc b/wrfv2_fire/var/external/bufr/conwin.inc index 893b377e..810dbb88 100644 --- a/wrfv2_fire/var/external/bufr/conwin.inc +++ b/wrfv2_fire/var/external/bufr/conwin.inc @@ -48,12 +48,12 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / USRSTR / NNOD, NCON, NODS (20), NODC (10), IVLS (10), & KONS (10) - REAL(8) VAL +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/da_bufr.f90 b/wrfv2_fire/var/external/bufr/da_bufr.f90 index 085dbaaa..f1c9784a 100644 --- a/wrfv2_fire/var/external/bufr/da_bufr.f90 +++ b/wrfv2_fire/var/external/bufr/da_bufr.f90 @@ -6,120 +6,231 @@ module da_bufr #ifdef BUFR + integer :: MUNIT, MLAST + integer, allocatable, dimension(:) :: MSGP + integer, allocatable, dimension(:) :: MSGS + + integer, allocatable, dimension(:,:) :: MATX_S + integer, allocatable, dimension(:) :: KMIN_S + integer, allocatable, dimension(:) :: KMAX_S + logical, allocatable, dimension(:) :: KMIS_S + integer, allocatable, dimension(:) :: KBIT_S + integer, allocatable, dimension(:) :: ITYP_S + integer, allocatable, dimension(:) :: IWID_S + character*8, allocatable, dimension(:,:) :: CATX_S + character*8, allocatable, dimension(:) :: CSTR_S + logical :: FLUSH_S, WRIT1_S + integer :: NROW_S, NCOL_S, LUNC_S, KBYT_S + + integer :: MAXTAB, NTAB + character*10, allocatable, dimension(:) :: TAG + character*3, allocatable, dimension(:) :: TYP + integer, allocatable, dimension(:) :: KNT, JUMP, LINK, JMPB, IBT, IRF, ISC, ITP, VALI, KNTI, JSEQ + integer, allocatable, dimension(:,:) :: ISEQ + + integer, allocatable, dimension(:) :: NVAL(:) + integer, allocatable, dimension(:,:) :: INV(:,:) + real*8 , allocatable, dimension(:,:) :: VAL(:,:) + + integer, allocatable, dimension(:,:) :: ITMP + real*8 , allocatable, dimension(:,:) :: VTMP + contains +#include "addate.inc" #include "bfrini.inc" +#include "capit.inc" +#include "chekstab.inc" +#include "chrtrn.inc" +#include "chrtrna.inc" +#include "cktaba.inc" #include "closbf.inc" +#include "closmg.inc" +#include "cmpmsg.inc" #include "cmsgini.inc" #include "cnved4.inc" +#include "conwin.inc" +#include "copybf.inc" +#include "copymg.inc" +#include "copysb.inc" +#include "cpbfdx.inc" +#include "cpymem.inc" +#include "cpyupd.inc" +#include "datebf.inc" #include "datelen.inc" +#include "digit.inc" +#include "drfini.inc" +#include "drstpl.inc" +#include "dumpbf.inc" +#include "dxdump.inc" #include "dxinit.inc" +#include "dxmini.inc" +#include "elemdx.inc" +#include "getabdb.inc" #include "getlens.inc" +#include "getntbe.inc" #include "gets1loc.inc" +#include "gettbh.inc" +#include "getwin.inc" +#include "i4dy.inc" +#include "ibfms.inc" +#include "ichkstr.inc" +#include "icopysb.inc" +#include "idn30.inc" +#include "ifbget.inc" +#include "igetdate.inc" +#include "igetfxy.inc" +#include "igetntbl.inc" +#include "inctab.inc" +#include "invcon.inc" +#include "invmrg.inc" +#include "invtag.inc" +#include "invwin.inc" #include "ipkm.inc" +#include "ireadft.inc" +#include "ireadibm.inc" +#include "ireadmg.inc" +#include "ireadmm.inc" +#include "ireadns.inc" +#include "ireadsb.inc" +#include "iupb.inc" +#include "iupbs01.inc" +#include "iupbs1.inc" +#include "iupvs01.inc" +#include "iupvs1.inc" +#include "jstchr.inc" +#include "jstnum.inc" +#include "ljust.inc" +#include "lmsg.inc" +#include "lstjpb.inc" +#include "lstrpc.inc" +#include "lstrps.inc" +#include "makestab.inc" +#include "maxout.inc" +#include "mesgbc.inc" +#include "mesgbf.inc" +#include "minimg.inc" +#include "mova2i.inc" +#include "mrginv.inc" #include "msgini.inc" #include "msgupd.inc" #include "msgwrt.inc" #include "mvb.inc" +#include "nemock.inc" +#include "nemtab.inc" +#include "nemtba.inc" +#include "nemtbax.inc" +#include "nemtbd.inc" +#include "nenuaa.inc" +#include "nenubd.inc" +#include "nevn.inc" +#include "newwin.inc" +#include "nmbyt.inc" +#include "nmsub.inc" +#include "nmwrd.inc" +#include "numbck.inc" #include "numtab.inc" +#include "nvnwin.inc" +#include "nwords.inc" +#include "nxtwin.inc" #include "openbf.inc" +#include "openbt.inc" #include "openmb.inc" +#include "openmg.inc" #include "ovrbs1.inc" #include "pad.inc" #include "padmsg.inc" +#include "parseq.inc" #include "parstr.inc" #include "parusr.inc" +#include "parutg.inc" #include "pkb.inc" #include "pkbs1.inc" #include "pkc.inc" +#include "pkftbv.inc" #include "pktdd.inc" #include "pkvs01.inc" #include "pkvs1.inc" #include "posapn.inc" #include "posapx.inc" +#include "rcstpl.inc" +#include "rdbfdx.inc" +#include "rdcmps.inc" +#include "rdmemm.inc" +#include "rdmems.inc" +#include "rdmgsb.inc" +#include "rdmsgb.inc" +#include "rdmsgw.inc" +#include "rdmtbb.inc" +#include "rdmtbd.inc" +#include "rdtree.inc" +#include "rdusdx.inc" #include "readdx.inc" +#include "readerme.inc" +#include "readft.inc" +#include "readibm.inc" +#include "readlc.inc" #include "readmg.inc" +#include "readmm.inc" #include "readns.inc" #include "readsb.inc" +#include "rewnbf.inc" +#include "rsvfvm.inc" +#include "seqsdx.inc" +#include "sntbbe.inc" +#include "sntbde.inc" #include "status.inc" +#include "stdmsg.inc" #include "stndrd.inc" +#include "strcln.inc" #include "string.inc" +#include "strnum.inc" +#include "strsuc.inc" +#include "subupd.inc" +#include "tabent.inc" +#include "tabsub.inc" +#include "trybump.inc" +#include "ufbcnt.inc" +#include "ufbcpy.inc" +#include "ufbcup.inc" +#include "ufbdmp.inc" +#include "ufbevn.inc" +#include "ufbget.inc" +#include "ufbin3.inc" #include "ufbint.inc" +#include "ufbinx.inc" +#include "ufbmem.inc" +#include "ufbmms.inc" +#include "ufbmns.inc" +#include "ufbovr.inc" +#include "ufbpos.inc" +#include "ufbqcd.inc" +#include "ufbqcp.inc" #include "ufbrep.inc" +#include "ufbrms.inc" #include "ufbrp.inc" #include "ufbrw.inc" #include "ufbseq.inc" +#include "ufbsp.inc" +#include "ufbstp.inc" +#include "ufbtab.inc" +#include "ufbtam.inc" +#include "ufdump.inc" #include "upb.inc" +#include "upbb.inc" #include "upc.inc" +#include "upds3.inc" +#include "upftbv.inc" #include "usrtpl.inc" #include "wrcmps.inc" #include "wrdlen.inc" +#include "writcp.inc" #include "writdx.inc" +#include "writlc.inc" +#include "writsa.inc" #include "writsb.inc" #include "wrtree.inc" #include "wtstat.inc" -#include "closmg.inc" -#include "iupbs01.inc" -#include "iupb.inc" -#include "rdmsgw.inc" -#include "rdbfdx.inc" -#include "cpbfdx.inc" -#include "rdusdx.inc" -#include "nmwrd.inc" -#include "dxmini.inc" -#include "ichkstr.inc" -#include "nemtba.inc" -#include "nemtab.inc" -#include "i4dy.inc" -#include "invtag.inc" -#include "trybump.inc" -#include "nxtwin.inc" -#include "lstrps.inc" -#include "newwin.inc" -#include "drstpl.inc" -#include "invwin.inc" -#include "ibfms.inc" -#include "getwin.inc" -#include "conwin.inc" -#include "lstrpc.inc" -#include "parutg.inc" -#include "rdcmps.inc" -#include "rdtree.inc" -#include "cktaba.inc" -#include "rdmsgb.inc" -#include "idn30.inc" -#include "capit.inc" -#include "chrtrn.inc" -#include "makestab.inc" -#include "elemdx.inc" -#include "seqsdx.inc" -#include "nenuaa.inc" -#include "digit.inc" -#include "numbck.inc" -#include "nemock.inc" -#include "lmsg.inc" -#include "lstjpb.inc" -#include "invcon.inc" -#include "upbb.inc" -#include "rcstpl.inc" -#include "openbt.inc" -#include "nemtbax.inc" -#include "igetdate.inc" -#include "nenubd.inc" -#include "rsvfvm.inc" -#include "strnum.inc" -#include "jstnum.inc" -#include "jstchr.inc" -#include "tabsub.inc" -#include "chekstab.inc" -#include "strcln.inc" -#include "chrtrna.inc" -#include "inctab.inc" -#include "tabent.inc" -#include "strsuc.inc" -#include "nemtbd.inc" -#include "ireadmg.inc" -#include "ireadsb.inc" #endif diff --git a/wrfv2_fire/var/external/bufr/drstpl.inc b/wrfv2_fire/var/external/bufr/drstpl.inc index 85932279..3c1bc4da 100644 --- a/wrfv2_fire/var/external/bufr/drstpl.inc +++ b/wrfv2_fire/var/external/bufr/drstpl.inc @@ -47,13 +47,13 @@ INCLUDE 'bufrlib.prm' - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) - CHARACTER(10) TAG - CHARACTER(3) TYP +! CHARACTER(10) TAG +! CHARACTER(3) TYP !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/getwin.inc b/wrfv2_fire/var/external/bufr/getwin.inc index a594d0a6..7ea8824a 100644 --- a/wrfv2_fire/var/external/bufr/getwin.inc +++ b/wrfv2_fire/var/external/bufr/getwin.inc @@ -52,11 +52,11 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) CHARACTER(128) BORT_STR - REAL(8) VAL +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/inctab.inc b/wrfv2_fire/var/external/bufr/inctab.inc index b19d7b6f..96c5b672 100644 --- a/wrfv2_fire/var/external/bufr/inctab.inc +++ b/wrfv2_fire/var/external/bufr/inctab.inc @@ -51,15 +51,15 @@ INCLUDE 'bufrlib.prm' - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) CHARACTER ( * ) ATAG, ATYP CHARACTER(128) BORT_STR - CHARACTER(10) TAG - CHARACTER(3) TYP +! CHARACTER(10) TAG +! CHARACTER(3) TYP !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/invcon.inc b/wrfv2_fire/var/external/bufr/invcon.inc index 18dccd10..09e010ce 100644 --- a/wrfv2_fire/var/external/bufr/invcon.inc +++ b/wrfv2_fire/var/external/bufr/invcon.inc @@ -51,13 +51,13 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / USRSTR / NNOD, NCON, NODS (20), NODC (10), IVLS (10), & KONS (10) COMMON / QUIET / IPRT - REAL(8) VAL +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/invtag.inc b/wrfv2_fire/var/external/bufr/invtag.inc index 7e6105a8..138abccd 100644 --- a/wrfv2_fire/var/external/bufr/invtag.inc +++ b/wrfv2_fire/var/external/bufr/invtag.inc @@ -50,17 +50,17 @@ INCLUDE 'bufrlib.prm' - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / QUIET / IPRT - CHARACTER(10) TAG, TAGN - CHARACTER(3) TYP - REAL(8) VAL + CHARACTER(10) TAGN !, TAG +! CHARACTER(3) TYP +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/invwin.inc b/wrfv2_fire/var/external/bufr/invwin.inc index b6e2b956..45843128 100644 --- a/wrfv2_fire/var/external/bufr/invwin.inc +++ b/wrfv2_fire/var/external/bufr/invwin.inc @@ -51,11 +51,11 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / QUIET / IPRT - REAL(8) VAL +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/ipkm.inc b/wrfv2_fire/var/external/bufr/ipkm.inc index 933eaaa9..983d0cd5 100644 --- a/wrfv2_fire/var/external/bufr/ipkm.inc +++ b/wrfv2_fire/var/external/bufr/ipkm.inc @@ -49,7 +49,7 @@ COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) CHARACTER*128 BORT_STR - CHARACTER*1 CBAY(8) + CHARACTER*(*) CBAY CHARACTER*8 CINT EQUIVALENCE (CINT,INT) diff --git a/wrfv2_fire/var/external/bufr/lstjpb.inc b/wrfv2_fire/var/external/bufr/lstjpb.inc index 05c5fe96..dbc2c8aa 100644 --- a/wrfv2_fire/var/external/bufr/lstjpb.inc +++ b/wrfv2_fire/var/external/bufr/lstjpb.inc @@ -51,15 +51,15 @@ COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES), & INODE (NFILES), IDATE (NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) CHARACTER ( * ) JBTYP CHARACTER(128) BORT_STR - CHARACTER(10) TAG - CHARACTER(3) TYP +! CHARACTER(10) TAG +! CHARACTER(3) TYP !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/lstrpc.inc b/wrfv2_fire/var/external/bufr/lstrpc.inc index 38e22e72..e39a9200 100644 --- a/wrfv2_fire/var/external/bufr/lstrpc.inc +++ b/wrfv2_fire/var/external/bufr/lstrpc.inc @@ -54,14 +54,14 @@ COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES), & INODE (NFILES), IDATE (NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) CHARACTER(128) BORT_STR - CHARACTER(10) TAG - CHARACTER(3) TYP +! CHARACTER(10) TAG +! CHARACTER(3) TYP !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/lstrps.inc b/wrfv2_fire/var/external/bufr/lstrps.inc index 26fb820c..0a9e7c72 100644 --- a/wrfv2_fire/var/external/bufr/lstrps.inc +++ b/wrfv2_fire/var/external/bufr/lstrps.inc @@ -50,14 +50,14 @@ COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES), & INODE (NFILES), IDATE (NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) CHARACTER(128) BORT_STR - CHARACTER(10) TAG - CHARACTER(3) TYP +! CHARACTER(10) TAG +! CHARACTER(3) TYP !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/makestab.inc b/wrfv2_fire/var/external/bufr/makestab.inc index fc5cec1c..38752b78 100644 --- a/wrfv2_fire/var/external/bufr/makestab.inc +++ b/wrfv2_fire/var/external/bufr/makestab.inc @@ -68,27 +68,27 @@ COMMON / QUIET / IPRT COMMON / STBFR / IOLUN (NFILES), IOMSG (NFILES) - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / TABABD / NTBA (0:NFILES), NTBB (0:NFILES), NTBD (0: & NFILES), MTAB (MAXTBA, NFILES), IDNA (MAXTBA, NFILES, 2), IDNB ( & MAXTBB, NFILES), IDND (MAXTBD, NFILES), TABA (MAXTBA, NFILES), & TABB (MAXTBB, NFILES), TABD (MAXTBD, NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) CHARACTER(600) TABD CHARACTER(128) TABB CHARACTER(128) TABA CHARACTER(128) BORT_STR - CHARACTER(10) TAG +! CHARACTER(10) TAG CHARACTER(8) NEMO - CHARACTER(3) TYP +! CHARACTER(3) TYP DIMENSION LUS (NFILES) LOGICAL EXPAND - REAL(8) VAL +! REAL(8) VAL !----------------------------------------------------------------------- !----------------------------------------------------------------------- @@ -199,7 +199,8 @@ KNTI (NODE) = 0 ITP (NODE) = 0 ELSEIF (TYP (NODE) .EQ.'REP') THEN - VALI (NODE) = BMISS +! VALI (NODE) = BMISS + VALI (NODE) = 2147483647 KNTI (NODE) = IRF (NODE) ITP (NODE) = 0 ELSEIF (TYP (NODE) .EQ.'DRS') THEN @@ -215,11 +216,13 @@ KNTI (NODE) = 0 ITP (NODE) = 1 ELSEIF (TYP (NODE) .EQ.'NUM') THEN - VALI (NODE) = BMISS +! VALI (NODE) = BMISS + VALI (NODE) = 2147483647 KNTI (NODE) = 1 ITP (NODE) = 2 ELSEIF (TYP (NODE) .EQ.'CHR') THEN - VALI (NODE) = BMISS +! VALI (NODE) = BMISS + VALI (NODE) = 2147483647 KNTI (NODE) = 1 ITP (NODE) = 3 ELSE diff --git a/wrfv2_fire/var/external/bufr/msgini.inc b/wrfv2_fire/var/external/bufr/msgini.inc index 0ae762d7..0f07f95d 100644 --- a/wrfv2_fire/var/external/bufr/msgini.inc +++ b/wrfv2_fire/var/external/bufr/msgini.inc @@ -68,17 +68,17 @@ INODE(NFILES),IDATE(NFILES) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), & MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) CHARACTER*128 BORT_STR - CHARACTER*10 TAG +! CHARACTER*10 TAG CHARACTER*8 SUBTAG CHARACTER*4 BUFR0,SEVN - CHARACTER*3 TYP +! CHARACTER*3 TYP CHARACTER*1 TAB DATA BUFR0/'BUFR'/ diff --git a/wrfv2_fire/var/external/bufr/nemtbd.inc b/wrfv2_fire/var/external/bufr/nemtbd.inc index e1507bfc..b602cbab 100644 --- a/wrfv2_fire/var/external/bufr/nemtbd.inc +++ b/wrfv2_fire/var/external/bufr/nemtbd.inc @@ -204,9 +204,9 @@ 902 WRITE (BORT_STR, '("BUFRLIB: NEMTBD - TABLE D MNEMONIC ",A," IS A'& &//' ZERO LENGTH SEQUENCE")') NEMO CALL BORT (BORT_STR) - 903 WRITE (BORT_STR, '("BUFRLIB: NEMTBD - THERE ARE MORE THAN '//'(",I& - &4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '//'MNEMONIC ",A)& - &') MAXCD, NEMO + 903 WRITE (BORT_STR, '("BUFRLIB: NEMTBD - THERE ARE MORE THAN '//'(",I4& + &,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '//'MNEMONIC ",A)')& + MAXCD, NEMO CALL BORT (BORT_STR) 904 WRITE (BORT_STR, '("BUFRLIB: NEMTBD - REPLICATOR IS OUT OF ORDER '& &//'IN TABLE D SEQUENCE MNEMONIC ",A)') NEMO diff --git a/wrfv2_fire/var/external/bufr/newwin.inc b/wrfv2_fire/var/external/bufr/newwin.inc index 29d33cad..ac2c0a3d 100644 --- a/wrfv2_fire/var/external/bufr/newwin.inc +++ b/wrfv2_fire/var/external/bufr/newwin.inc @@ -49,11 +49,11 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) CHARACTER(128) BORT_STR - REAL(8) VAL +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/nxtwin.inc b/wrfv2_fire/var/external/bufr/nxtwin.inc index 509fc144..fcee73d6 100644 --- a/wrfv2_fire/var/external/bufr/nxtwin.inc +++ b/wrfv2_fire/var/external/bufr/nxtwin.inc @@ -51,11 +51,11 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) CHARACTER(128) BORT_STR - REAL(8) VAL +! REAL(8) VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/parusr.inc b/wrfv2_fire/var/external/bufr/parusr.inc index f962681e..8b41b733 100644 --- a/wrfv2_fire/var/external/bufr/parusr.inc +++ b/wrfv2_fire/var/external/bufr/parusr.inc @@ -87,14 +87,14 @@ ! DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE ! --------------------------------------------------------- - CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL) + CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL_S) IF(KON.NE.0) THEN ! .... it is a condition node NCON = NCON+1 IF(NCON.GT.MAXCON) GOTO 901 NODC(NCON) = NOD KONS(NCON) = KON - IVLS(NCON) = NINT(VAL) + IVLS(NCON) = NINT(VAL_S) ELSE ! .... it is a store node NNOD = NNOD+1 @@ -117,9 +117,9 @@ KONS(I) = KONS(J) KONS(J) = KON - VAL = IVLS(I) + VAL_S = IVLS(I) IVLS(I) = IVLS(J) - IVLS(J) = VAL + IVLS(J) = VAL_S ENDIF ENDDO ENDDO diff --git a/wrfv2_fire/var/external/bufr/parutg.inc b/wrfv2_fire/var/external/bufr/parutg.inc index 415dc38d..4a5b08af 100644 --- a/wrfv2_fire/var/external/bufr/parutg.inc +++ b/wrfv2_fire/var/external/bufr/parutg.inc @@ -114,16 +114,16 @@ COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES), & INODE (NFILES), IDATE (NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) COMMON / UTGPRM / PICKY CHARACTER(128) BORT_STR1, BORT_STR2 CHARACTER(20) UTG, ATAG - CHARACTER(10) TAG - CHARACTER(3) TYP, ATYP, BTYP +! CHARACTER(10) TAG + CHARACTER(3) ATYP, BTYP !, TYP CHARACTER(1) COND (5) DIMENSION BTYP (8), IOK (8) LOGICAL PICKY diff --git a/wrfv2_fire/var/external/bufr/rcstpl.inc b/wrfv2_fire/var/external/bufr/rcstpl.inc index 2b534502..0ca5fefe 100644 --- a/wrfv2_fire/var/external/bufr/rcstpl.inc +++ b/wrfv2_fire/var/external/bufr/rcstpl.inc @@ -65,24 +65,30 @@ MBAY (MXMSGLD4, NFILES) COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES), & INODE (NFILES), IDATE (NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / USRBIT / NBIT (MAXJL), MBIT (MAXJL) - COMMON / USRTMP / ITMP (MAXJL, MAXRCR), VTMP (MAXJL, MAXRCR) +! COMMON / USRTMP / ITMP (MAXJL, MAXRCR), VTMP (MAXJL, MAXRCR) CHARACTER(128) BORT_STR - CHARACTER(10) TAG - CHARACTER(3) TYP +! CHARACTER(10) TAG +! CHARACTER(3) TYP DIMENSION NBMP (2, MAXRCR), NEWN (2, MAXRCR) DIMENSION KNX (MAXRCR) - REAL(8) VAL, VTMP +! REAL(8) VTMP !, VAL !----------------------------------------------------------------------- !----------------------------------------------------------------------- + IF ( .NOT. ALLOCATED (NVAL) ) ALLOCATE ( NVAL(NFILES) ) + IF ( .NOT. ALLOCATED (INV) ) ALLOCATE ( INV(MAXJL,NFILES) ) + IF ( .NOT. ALLOCATED (VAL) ) ALLOCATE ( VAL(MAXJL,NFILES) ) + + IF ( .NOT. ALLOCATED (ITMP) ) ALLOCATE (ITMP (MAXJL, MAXRCR)) + IF ( .NOT. ALLOCATED (VTMP) ) ALLOCATE (VTMP (MAXJL, MAXRCR)) ! SET THE INITIAL VALUES FOR THE TEMPLATE ! --------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/rdcmps.inc b/wrfv2_fire/var/external/bufr/rdcmps.inc index 82062c04..1d579e92 100644 --- a/wrfv2_fire/var/external/bufr/rdcmps.inc +++ b/wrfv2_fire/var/external/bufr/rdcmps.inc @@ -50,18 +50,18 @@ MBAY (MXMSGLD4, NFILES) COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES), & INODE (NFILES), IDATE (NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) - - CHARACTER(10) TAG +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) + +! CHARACTER(10) TAG CHARACTER(8) CREF, CVAL - CHARACTER(3) TYP +! CHARACTER(3) TYP EQUIVALENCE (CVAL, RVAL) - REAL(8) VAL, RVAL, UPS, TEN + REAL(8) RVAL, UPS, TEN !, VAL DATA TEN / 10 / diff --git a/wrfv2_fire/var/external/bufr/rdtree.inc b/wrfv2_fire/var/external/bufr/rdtree.inc index ac1ecb1f..bd9a8314 100644 --- a/wrfv2_fire/var/external/bufr/rdtree.inc +++ b/wrfv2_fire/var/external/bufr/rdtree.inc @@ -54,20 +54,20 @@ COMMON / BITBUF / MAXBYT, IBIT, IBAY (MXMSGLD4), MBYT (NFILES), & MBAY (MXMSGLD4, NFILES) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / USRBIT / NBIT (MAXJL), MBIT (MAXJL) - CHARACTER(10) TAG +! CHARACTER(10) TAG CHARACTER(8) CVAL - CHARACTER(3) TYP +! CHARACTER(3) TYP DIMENSION IVAL (MAXJL) EQUIVALENCE (CVAL, RVAL) - REAL(8) VAL, RVAL, UPS, TEN + REAL(8) RVAL, UPS, TEN !, VAL DATA TEN / 10. / diff --git a/wrfv2_fire/var/external/bufr/readns.inc b/wrfv2_fire/var/external/bufr/readns.inc index f330cbc0..c368d681 100644 --- a/wrfv2_fire/var/external/bufr/readns.inc +++ b/wrfv2_fire/var/external/bufr/readns.inc @@ -60,15 +60,15 @@ COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), & INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) - CHARACTER*10 TAG +! CHARACTER*10 TAG CHARACTER*8 SUBSET - CHARACTER*3 TYP +! CHARACTER*3 TYP !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/seqsdx.inc b/wrfv2_fire/var/external/bufr/seqsdx.inc index a38c35f1..015f1d8f 100644 --- a/wrfv2_fire/var/external/bufr/seqsdx.inc +++ b/wrfv2_fire/var/external/bufr/seqsdx.inc @@ -78,7 +78,7 @@ ! entry within TABD(*,LUN) so that we can access the entry and then ! add the decoded sequence information to it. - CALL NEMTAB (LUN, NEMO, IDN, TAB, ISEQ) + CALL NEMTAB (LUN, NEMO, IDN, TAB, ISEQ_S) IF (TAB.NE.'D') GOTO 900 CALL PARSTR (SEQS, TAGS, MAXTGS, NTAG, ' ', .TRUE.) IF (NTAG.EQ.0) GOTO 901 @@ -167,9 +167,9 @@ ! WRITE THE DESCRIPTOR STRING INTO TABD ARRAY ! ------------------------------------------- ! .... first look for a replication descriptor - IF (IREP.GT.0) CALL PKTDD (ISEQ, LUN, IDNR (IREP, 1) + NUMR, IRET) + IF (IREP.GT.0) CALL PKTDD (ISEQ_S, LUN, IDNR (IREP, 1) + NUMR, IRET) IF (IRET.LT.0) GOTO 913 - CALL PKTDD (ISEQ, LUN, IDN, IRET) + CALL PKTDD (ISEQ_S, LUN, IDN, IRET) IF (IRET.LT.0) GOTO 914 ENDDO diff --git a/wrfv2_fire/var/external/bufr/stndrd.inc b/wrfv2_fire/var/external/bufr/stndrd.inc index e649eed4..b0c21f76 100644 --- a/wrfv2_fire/var/external/bufr/stndrd.inc +++ b/wrfv2_fire/var/external/bufr/stndrd.inc @@ -188,10 +188,10 @@ CALL UPB(LSUB,16,MSGIN,IBIT) DO L=1,LSUB-2 - CALL UPB(NVAL,8,MSGIN,IBIT) + CALL UPB(NVAL_S,8,MSGIN,IBIT) LBYTO = LBYTO + 1 IF(LBYTO.GT.MXBYTO) GOTO 905 - CALL PKB(NVAL,8,MSGOT,JBIT) + CALL PKB(NVAL_S,8,MSGOT,JBIT) ENDDO DO K=1,8 diff --git a/wrfv2_fire/var/external/bufr/tabent.inc b/wrfv2_fire/var/external/bufr/tabent.inc index b37ff613..03ad6dd6 100644 --- a/wrfv2_fire/var/external/bufr/tabent.inc +++ b/wrfv2_fire/var/external/bufr/tabent.inc @@ -62,17 +62,17 @@ COMMON / REPTAB / IDNR (5, 2), TYPS (5, 2), REPS (5, 2), LENS (5) - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) COMMON / TABCCC / ICDW, ICSC, ICRV, INCW CHARACTER(128) BORT_STR CHARACTER(24) UNIT - CHARACTER(10) TAG, RTAG + CHARACTER(10) RTAG !, TAG CHARACTER(8) NEMO - CHARACTER(3) TYP, TYPS, TYPT + CHARACTER(3) TYPS, TYPT !, TYP CHARACTER(1) REPS, TAB !----------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/tabsub.inc b/wrfv2_fire/var/external/bufr/tabsub.inc index 23c27a86..39ac0f17 100644 --- a/wrfv2_fire/var/external/bufr/tabsub.inc +++ b/wrfv2_fire/var/external/bufr/tabsub.inc @@ -177,16 +177,16 @@ INCLUDE 'bufrlib.prm' - COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & - MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & - IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& - ISEQ (MAXJL, 2), JSEQ (MAXJL) +! COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT ( & +! MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL), & +! IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),& +! ISEQ (MAXJL, 2), JSEQ (MAXJL) COMMON / TABCCC / ICDW, ICSC, ICRV, INCW CHARACTER(128) BORT_STR - CHARACTER(10) TAG +! CHARACTER(10) TAG CHARACTER(8) NEMO, NEMS, NEM - CHARACTER(3) TYP +! CHARACTER(3) TYP CHARACTER(1) TAB DIMENSION NEM (MAXCD, 10), IRP (MAXCD, 10), KRP (MAXCD, 10) DIMENSION DROP (10), JMP0 (10), NODL (10), NTAG (10, 2) @@ -205,6 +205,21 @@ ! Table D mnemonics within internal BUFR Table D array TABD(*,LUN). ! Thus, the following test is valid. + IF ( .NOT. ALLOCATED (TAG) ) ALLOCATE ( TAG (MAXJL) ) + IF ( .NOT. ALLOCATED (TYP) ) ALLOCATE ( TYP (MAXJL) ) + IF ( .NOT. ALLOCATED (KNT) ) ALLOCATE ( KNT (MAXJL) ) + IF ( .NOT. ALLOCATED (JUMP) ) ALLOCATE ( JUMP (MAXJL) ) + IF ( .NOT. ALLOCATED (LINK) ) ALLOCATE ( LINK (MAXJL) ) + IF ( .NOT. ALLOCATED (JMPB) ) ALLOCATE ( JMPB (MAXJL) ) + IF ( .NOT. ALLOCATED (IBT) ) ALLOCATE ( IBT (MAXJL) ) + IF ( .NOT. ALLOCATED (IRF) ) ALLOCATE ( IRF (MAXJL) ) + IF ( .NOT. ALLOCATED (ISC) ) ALLOCATE ( ISC (MAXJL) ) + IF ( .NOT. ALLOCATED (ITP) ) ALLOCATE ( ITP (MAXJL) ) + IF ( .NOT. ALLOCATED (VALI) ) ALLOCATE ( VALI (MAXJL) ) + IF ( .NOT. ALLOCATED (KNTI) ) ALLOCATE ( KNTI (MAXJL) ) + IF ( .NOT. ALLOCATED (ISEQ) ) ALLOCATE ( ISEQ (MAXJL,2) ) + IF ( .NOT. ALLOCATED (JSEQ) ) ALLOCATE ( JSEQ (MAXJL) ) + CALL NEMTAB (LUN, NEMO, IDN, TAB, ITAB) IF (TAB.NE.'D') GOTO 900 diff --git a/wrfv2_fire/var/external/bufr/trybump.inc b/wrfv2_fire/var/external/bufr/trybump.inc index 3505ed25..bea3ed96 100644 --- a/wrfv2_fire/var/external/bufr/trybump.inc +++ b/wrfv2_fire/var/external/bufr/trybump.inc @@ -71,12 +71,12 @@ INCLUDE 'bufrlib.prm' - COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & - NFILES) +! COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, & +! NFILES) COMMON / USRSTR / NNOD, NCON, NODS (20), NODC (10), IVLS (10), & KONS (10) - REAL(8) USR (I1, I2), VAL + REAL(8) USR (I1, I2)!, VAL !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/ufbint.inc b/wrfv2_fire/var/external/bufr/ufbint.inc index 91f5a63a..9e0bcdfd 100644 --- a/wrfv2_fire/var/external/bufr/ufbint.inc +++ b/wrfv2_fire/var/external/bufr/ufbint.inc @@ -304,12 +304,12 @@ COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), & INODE(NFILES),IDATE(NFILES) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2 - REAL*8 USR(I1,I2),VAL + REAL*8 USR(I1,I2)!,VAL DATA IFIRST1/0/,IFIRST2/0/ diff --git a/wrfv2_fire/var/external/bufr/ufbrep.inc b/wrfv2_fire/var/external/bufr/ufbrep.inc index 5ee390ef..e38ba711 100644 --- a/wrfv2_fire/var/external/bufr/ufbrep.inc +++ b/wrfv2_fire/var/external/bufr/ufbrep.inc @@ -115,13 +115,13 @@ COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), & INODE(NFILES),IDATE(NFILES) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /ACMODE/ IAC COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2 - REAL*8 USR(I1,I2),VAL + REAL*8 USR(I1,I2)!,VAL DATA IFIRST1/0/,IFIRST2/0/ diff --git a/wrfv2_fire/var/external/bufr/ufbrp.inc b/wrfv2_fire/var/external/bufr/ufbrp.inc index 1a22ccb5..6a1759da 100644 --- a/wrfv2_fire/var/external/bufr/ufbrp.inc +++ b/wrfv2_fire/var/external/bufr/ufbrp.inc @@ -75,10 +75,10 @@ INCLUDE 'bufrlib.prm' - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) - REAL*8 USR(I1,I2),VAL + REAL*8 USR(I1,I2)!,VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- diff --git a/wrfv2_fire/var/external/bufr/ufbrw.inc b/wrfv2_fire/var/external/bufr/ufbrw.inc index 0f93a383..16627968 100644 --- a/wrfv2_fire/var/external/bufr/ufbrw.inc +++ b/wrfv2_fire/var/external/bufr/ufbrw.inc @@ -84,22 +84,26 @@ INCLUDE 'bufrlib.prm' - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /QUIET / IPRT - CHARACTER*10 TAG - CHARACTER*3 TYP - REAL*8 USR(I1,I2),VAL +! CHARACTER*10 TAG +! CHARACTER*3 TYP + REAL*8 USR(I1,I2)!,VAL !---------------------------------------------------------------------- !---------------------------------------------------------------------- + IF ( .NOT. ALLOCATED (NVAL) ) ALLOCATE ( NVAL(NFILES) ) + IF ( .NOT. ALLOCATED (INV) ) ALLOCATE ( INV(MAXJL,NFILES) ) + IF ( .NOT. ALLOCATED (VAL) ) ALLOCATE ( VAL(MAXJL,NFILES) ) + IRET = 0 ! LOOP OVER COND WINDOWS diff --git a/wrfv2_fire/var/external/bufr/ufbseq.inc b/wrfv2_fire/var/external/bufr/ufbseq.inc index acf81610..5c278732 100644 --- a/wrfv2_fire/var/external/bufr/ufbseq.inc +++ b/wrfv2_fire/var/external/bufr/ufbseq.inc @@ -125,19 +125,19 @@ COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), & INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR - CHARACTER*10 TAG,TAGS(MTAG) - CHARACTER*3 TYP - REAL*8 USR(I1,I2),VAL + CHARACTER*10 TAGS(MTAG) !, TAG +! CHARACTER*3 TYP + REAL*8 USR(I1,I2)!,VAL DATA IFIRST1/0/,IFIRST2/0/ @@ -146,6 +146,10 @@ !---------------------------------------------------------------------- !---------------------------------------------------------------------- + IF ( .NOT. ALLOCATED (NVAL) ) ALLOCATE ( NVAL(NFILES) ) + IF ( .NOT. ALLOCATED (INV) ) ALLOCATE ( INV(MAXJL,NFILES) ) + IF ( .NOT. ALLOCATED (VAL) ) ALLOCATE ( VAL(MAXJL,NFILES) ) + IRET = 0 ! CHECK THE FILE STATUS AND I-NODE diff --git a/wrfv2_fire/var/external/bufr/usrtpl.inc b/wrfv2_fire/var/external/bufr/usrtpl.inc index 26ae9df7..f9fde48f 100644 --- a/wrfv2_fire/var/external/bufr/usrtpl.inc +++ b/wrfv2_fire/var/external/bufr/usrtpl.inc @@ -61,24 +61,28 @@ COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), & INODE(NFILES),IDATE(NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /QUIET / IPRT CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*3 TYP +! CHARACTER*10 TAG +! CHARACTER*3 TYP DIMENSION ITMP(MAXJL) LOGICAL DRP,DRS,DRB,DRX - REAL*8 VAL,VTMP(MAXJL) + REAL*8 VTMP(MAXJL) !, VAL !----------------------------------------------------------------------- !----------------------------------------------------------------------- + IF ( .NOT. ALLOCATED (NVAL) ) ALLOCATE ( NVAL(NFILES) ) + IF ( .NOT. ALLOCATED (INV) ) ALLOCATE ( INV(MAXJL,NFILES) ) + IF ( .NOT. ALLOCATED (VAL) ) ALLOCATE ( VAL(MAXJL,NFILES) ) + IF(IPRT.GE.2) THEN PRINT* PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++' diff --git a/wrfv2_fire/var/external/bufr/wrcmps.inc b/wrfv2_fire/var/external/bufr/wrcmps.inc index 618670a6..a35ca98e 100644 --- a/wrfv2_fire/var/external/bufr/wrcmps.inc +++ b/wrfv2_fire/var/external/bufr/wrcmps.inc @@ -10,7 +10,7 @@ ! IT THEN TRIES TO ADD IT TO THE COMPRESSED BUFR MESSAGE THAT IS ! CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNIX) (ARRAY MESG). IF THE ! SUBSET WILL NOT FIT INTO THE CURRENTLY OPEN MESSAGE, THEN THAT -! COMPRESSED MESSAGE IS FLUSHED TO LUNIX AND A NEW ONE IS CREATED IN +! COMPRESSED MESSAGE IS FLUSH_SED TO LUNIX AND A NEW ONE IS CREATED IN ! ORDER TO HOLD THE CURRENT SUBSET (STILL STORED FOR COMPRESSION). ! THIS SUBROUTINE PERFORMS FUNCTIONS SIMILAR TO BUFR ARCHIVE LIBRARY ! SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES. @@ -22,7 +22,7 @@ ! 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) ! INCREASED FROM 15000 TO 16000 (WAS IN ! VERIFICATION VERSION); LOGICAL VARIABLES -! "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL +! "WRIT1_S" AND "FLUSH_S" NOW SAVED IN GLOBAL ! MEMORY (IN COMMON BLOCK /COMPRS/), THIS ! FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD ! TO MESSAGES BEING WRITTEN OUT BEFORE THEY @@ -37,13 +37,13 @@ ! MAXIMUM MESSAGE LENGTH INCREASED FROM ! 20,000 TO 50,000 BYTES ! 2004-08-18 J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST' -! 2) ADDED 'KMISS' TO FIX BUG WHICH WOULD +! 2) ADDED 'KMIS_SS' TO FIX BUG WHICH WOULD ! OCCASIONALLY SKIP OVER SUBSETS ! 3) ADDED LOGIC TO MAKE SURE MISSING VALUES ! ARE REPRESENTED BY INCREMENTS WITH ALL ! BITS ON ! 4) REMOVED TWO UNECESSARY REFERENCES TO -! 'WRIT1' +! 'WRIT1_S' ! 2005-11-29 J. ATOR -- FIX INITIALIZATION BUG FOR CHARACTER ! COMPRESSION; INCREASE MXCSB TO 4000; ! USE IUPBS01; CHECK EDITION NUMBER OF BUFR @@ -53,7 +53,7 @@ ! INPUT ARGUMENT LIST: ! LUNIX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER ! FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A -! "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT) +! "FLUSH_S" CALL AND THE BUFFER MUST BE CLEARED OUT) ! ! REMARKS: ! THIS ROUTINE CALLS: BORT CMSGINI IUPBS01 MSGWRT @@ -76,37 +76,39 @@ INODE(NFILES),IDATE(NFILES) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), & MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) COMMON /USRBIT/ NBIT(MAXJL),MBIT(MAXJL) - COMMON /COMPRS/ MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB),KMIN(MXCDV), & - KMAX(MXCDV),KMIS(MXCDV),KBIT(MXCDV),ITYP(MXCDV), & - IWID(MXCDV),NROW,NCOL,LUNC,KBYT,WRIT1,FLUSH, & - CSTR(MXCDV) +! COMMON /COMPRS/ MATX_S(MXCDV,MXCSB),CATX_S(MXCDV,MXCSB),KMIN_S(MXCDV), & +! KMAX_S(MXCDV),KMIS_S(MXCDV),KBIT_S(MXCDV),ITYP_S(MXCDV), & +! IWID_S(MXCDV),NROW_S,NCOL_S,LUNC_S,KBYT_S,WRIT1_S,FLUSH_S, & +! CSTR_S(MXCDV) COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) CHARACTER*128 BORT_STR - CHARACTER*10 TAG - CHARACTER*8 CATX,SUBSET,CSTR,CMNEM - CHARACTER*3 TYP +! CHARACTER*10 TAG +! CHARACTER*8 CATX_S,SUBSET,CSTR_S,CMNEM + CHARACTER*8 SUBSET,CMNEM +! CHARACTER*3 TYP DIMENSION MESG(MXMSGLD4) ! NOTE THE FOLLOWING FLAGS: ! FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE ! FIRST SUBSET OF A NEW MESSAGE -! FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED -! WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY +! FLUSH_S - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED +! WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH_S ANY ! PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY ! IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!) -! WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS +! WRIT1_S - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS ! TO BE WRITTEN OUT - LOGICAL FIRST,FLUSH,WRIT1,KMIS,KMISS,EDGE4 - REAL*8 VAL +! LOGICAL FIRST,FLUSH_S,WRIT1_S,KMIS_S,KMIS_SS,EDGE4 + LOGICAL FIRST,KMIS_SS,EDGE4 +! REAL*8 VAL DATA FIRST/.TRUE./ @@ -114,6 +116,17 @@ !----------------------------------------------------------------------- RLN2 = 1./LOG(2.) + + IF ( .NOT. ALLOCATED (MATX_S) ) ALLOCATE ( MATX_S(MXCDV,MXCSB) ) + IF ( .NOT. ALLOCATED (CATX_S) ) ALLOCATE ( CATX_S(MXCDV,MXCSB) ) + IF ( .NOT. ALLOCATED (KMIN_S) ) ALLOCATE ( KMIN_S(MXCDV) ) + IF ( .NOT. ALLOCATED (KMAX_S) ) ALLOCATE ( KMAX_S(MXCDV) ) + IF ( .NOT. ALLOCATED (KMIS_S) ) ALLOCATE ( KMIS_S(MXCDV) ) + IF ( .NOT. ALLOCATED (KBIT_S) ) ALLOCATE ( KBIT_S(MXCDV) ) + IF ( .NOT. ALLOCATED (ITYP_S) ) ALLOCATE ( ITYP_S(MXCDV) ) + IF ( .NOT. ALLOCATED (IWID_S) ) ALLOCATE ( IWID_S(MXCDV) ) + IF ( .NOT. ALLOCATED (CSTR_S) ) ALLOCATE ( CSTR_S(MXCDV) ) + !----------------------------------------------------------------------- ! GET THE UNIT AND SUBSET TAG @@ -128,16 +141,16 @@ ! MESSAGE FOR OUTPUT. 1 IF(FIRST) THEN - KBYT = 0 - NCOL = 0 - LUNC = LUN - NROW = NVAL(LUN) + KBYT_S = 0 + NCOL_S = 0 + LUNC_S = LUN + NROW_S = NVAL(LUN) FIRST = .FALSE. - FLUSH = .FALSE. - WRIT1 = .FALSE. + FLUSH_S = .FALSE. + WRIT1_S = .FALSE. ! THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE -! HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY +! HOW MANY BYTES (KBYT_S) WILL BE TAKEN UP IN A MESSAGE BY ! THE INFORMATION IN SECTIONS 0, 1, 2 AND 3. THIS WILL ! ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL ! FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB. LATER ON, @@ -145,7 +158,7 @@ ! INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED ! BUFR MESSAGE THAT WILL BE WRITTEN OUT. - CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL,KBYT) + CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL_S,KBYT_S) ! CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED @@ -163,17 +176,17 @@ ENDIF - IF(LUN.NE.LUNC) GOTO 900 + IF(LUN.NE.LUNC_S) GOTO 900 -! IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT +! IF THIS IS A "FLUSH_S" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT ! THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE ! THE FINAL COMPRESSED BUFR MESSAGE. IF(LUNIX.LT.0) THEN - IF(NCOL.EQ.0) GOTO 100 - IF(NCOL.GT.0) THEN - FLUSH = .TRUE. - WRIT1 = .TRUE. + IF(NCOL_S.EQ.0) GOTO 100 + IF(NCOL_S.GT.0) THEN + FLUSH_S = .TRUE. + WRIT1_S = .TRUE. ICOL = 1 GOTO 20 ENDIF @@ -182,9 +195,9 @@ ! CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS ! --------------------------------------------------- - IF(NCOL+1.GT.MXCSB) THEN + IF(NCOL_S+1.GT.MXCSB) THEN GOTO 50 - ELSEIF(NVAL(LUN).NE.NROW) THEN + ELSEIF(NVAL(LUN).NE.NROW_S) THEN GOTO 50 ELSEIF(NVAL(LUN).GT.MXCDV) THEN GOTO 901 @@ -198,17 +211,17 @@ ! RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL ! REFERENCE VALUES, INCREMENTS, ETC.) - 10 NCOL = NCOL+1 - ICOL = NCOL + 10 NCOL_S = NCOL_S+1 + ICOL = NCOL_S IBIT = 16 DO I=1,NVAL(LUN) NODE = INV(I,LUN) - ITYP(I) = ITP(NODE) - IWID(I) = IBT(NODE) - IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN - CALL UPB(MATX(I,NCOL),IBT(NODE),IBAY,IBIT) - ELSEIF(ITYP(I).EQ.3) THEN - CALL UPC(CATX(I,NCOL),IBT(NODE)/8,IBAY,IBIT) + ITYP_S(I) = ITP(NODE) + IWID_S(I) = IBT(NODE) + IF(ITYP_S(I).EQ.1.OR.ITYP_S(I).EQ.2) THEN + CALL UPB(MATX_S(I,NCOL_S),IBT(NODE),IBAY,IBIT) + ELSEIF(ITYP_S(I).EQ.3) THEN + CALL UPC(CATX_S(I,NCOL_S),IBT(NODE)/8,IBAY,IBIT) ENDIF ENDDO @@ -220,32 +233,32 @@ ! IN THE MESSAGE) 20 LDATA = 0 - IF(NCOL.LE.0) GOTO 902 - DO I=1,NROW - IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) THEN + IF(NCOL_S.LE.0) GOTO 902 + DO I=1,NROW_S + IF(ITYP_S(I).EQ.1 .OR. ITYP_S(I).EQ.2) THEN ! ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES, -! SO KMIS(I) WILL STORE: +! SO KMIS_S(I) WILL STORE: ! .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING" ! .TRUE. OTHERWISE - IMISS = 2**IWID(I)-1 + IMISS = 2**IWID_S(I)-1 IF(ICOL.EQ.1) THEN - KMIN(I) = IMISS - KMAX(I) = 0 - KMIS(I) = .FALSE. + KMIN_S(I) = IMISS + KMAX_S(I) = 0 + KMIS_S(I) = .FALSE. ENDIF - DO J=ICOL,NCOL - IF(MATX(I,J).LT.IMISS) THEN - KMIN(I) = MIN(KMIN(I),MATX(I,J)) - KMAX(I) = MAX(KMAX(I),MATX(I,J)) + DO J=ICOL,NCOL_S + IF(MATX_S(I,J).LT.IMISS) THEN + KMIN_S(I) = MIN(KMIN_S(I),MATX_S(I,J)) + KMAX_S(I) = MAX(KMAX_S(I),MATX_S(I,J)) ELSE - KMIS(I) = .TRUE. + KMIS_S(I) = .TRUE. ENDIF ENDDO - KMISS = KMIS(I).AND.KMIN(I).LT.IMISS - RANGE = MAX(1,KMAX(I)-KMIN(I)+1) - IF(ITYP(I).EQ.1.AND.RANGE.GT.1) THEN + KMIS_SS = KMIS_S(I).AND.KMIN_S(I).LT.IMISS + RANGE = MAX(1,KMAX_S(I)-KMIN_S(I)+1) + IF(ITYP_S(I).EQ.1.AND.RANGE.GT.1) THEN ! THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX ! ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE @@ -255,66 +268,66 @@ ! EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN ! OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN. - IF(KMISS) GOTO 903 - WRIT1 = .TRUE. - NCOL = NCOL-1 + IF(KMIS_SS) GOTO 903 + WRIT1_S = .TRUE. + NCOL_S = NCOL_S-1 ICOL = 1 GOTO 20 - ELSEIF(ITYP(I).EQ.2.AND.(RANGE.GT.1..OR.KMISS)) THEN + ELSEIF(ITYP_S(I).EQ.2.AND.(RANGE.GT.1..OR.KMIS_SS)) THEN ! THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX ! ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL. ! COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE ! LARGEST OF THE INCREMENTS. - KBIT(I) = NINT(LOG(RANGE)*RLN2) - IF(2**KBIT(I)-1.LE.RANGE) KBIT(I) = KBIT(I)+1 + KBIT_S(I) = NINT(LOG(RANGE)*RLN2) + IF(2**KBIT_S(I)-1.LE.RANGE) KBIT_S(I) = KBIT_S(I)+1 ! HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER ! EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING ! DESCRIPTOR! - IF(KBIT(I).GT.IWID(I)) KBIT(I) = IWID(I) + IF(KBIT_S(I).GT.IWID_S(I)) KBIT_S(I) = IWID_S(I) ELSE ! THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX ! ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE ! INCREMENTS WILL BE OMITTED FROM THE MESSAGE. - KBIT(I) = 0 + KBIT_S(I) = 0 ENDIF - LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) - ELSEIF(ITYP(I).EQ.3) THEN + LDATA = LDATA + IWID_S(I) + 6 + NCOL_S*KBIT_S(I) + ELSEIF(ITYP_S(I).EQ.3) THEN ! ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES, -! SO KMIS(I) WILL STORE: +! SO KMIS_S(I) WILL STORE: ! .FALSE. IF ALL SUCH VALUES ARE IDENTICAL ! .TRUE. OTHERWISE IF(ICOL.EQ.1) THEN - CSTR(I) = CATX(I,1) - KMIS(I) = .FALSE. + CSTR_S(I) = CATX_S(I,1) + KMIS_S(I) = .FALSE. ENDIF - DO J=ICOL,NCOL - IF ( (.NOT.KMIS(I)) .AND. (CSTR(I).NE.CATX(I,J)) ) THEN - KMIS(I) = .TRUE. + DO J=ICOL,NCOL_S + IF ( (.NOT.KMIS_S(I)) .AND. (CSTR_S(I).NE.CATX_S(I,J)) ) THEN + KMIS_S(I) = .TRUE. ENDIF ENDDO - IF (KMIS(I)) THEN + IF (KMIS_S(I)) THEN ! THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX ! ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL. - KBIT(I) = IWID(I) + KBIT_S(I) = IWID_S(I) ELSE ! THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX ! ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE ! INCREMENTS WILL BE OMITTED FROM THE MESSAGE. - KBIT(I) = 0 + KBIT_S(I) = 0 ENDIF - LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) + LDATA = LDATA + IWID_S(I) + 6 + NCOL_S*KBIT_S(I) ENDIF ENDDO @@ -333,7 +346,7 @@ ! CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN ! ------------------------------------------------------------------ - IF(IBYT+KBYT+8.GT.MAXCMB) THEN + IF(IBYT+KBYT_S+8.GT.MAXCMB) THEN ! THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE. ! SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED, @@ -342,16 +355,16 @@ ! (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A ! NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!). - WRIT1 = .TRUE. - NCOL = NCOL-1 + WRIT1_S = .TRUE. + NCOL_S = NCOL_S-1 ICOL = 1 GOTO 20 - ELSEIF(.NOT.WRIT1) THEN + ELSEIF(.NOT.WRIT1_S) THEN ! ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN. CALL USRTPL(LUN,1,1) - NSUB(LUN) = -NCOL + NSUB(LUN) = -NCOL_S GOTO 100 ENDIF @@ -362,35 +375,35 @@ ! INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED ! BUFR MESSAGE THAT WILL BE WRITTEN OUT. - 50 CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL,IBYT) + 50 CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL_S,IBYT) ! NOW ADD THE SECTION 4 DATA. IBIT = IBYT*8 - DO I=1,NROW - IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN - CALL PKB(KMIN(I),IWID(I),MESG,IBIT) - CALL PKB(KBIT(I), 6,MESG,IBIT) - IF(KBIT(I).GT.0) THEN - DO J=1,NCOL - IF(MATX(I,J).LT.2**IWID(I)-1) THEN - INCR = MATX(I,J)-KMIN(I) + DO I=1,NROW_S + IF(ITYP_S(I).EQ.1.OR.ITYP_S(I).EQ.2) THEN + CALL PKB(KMIN_S(I),IWID_S(I),MESG,IBIT) + CALL PKB(KBIT_S(I), 6,MESG,IBIT) + IF(KBIT_S(I).GT.0) THEN + DO J=1,NCOL_S + IF(MATX_S(I,J).LT.2**IWID_S(I)-1) THEN + INCR = MATX_S(I,J)-KMIN_S(I) ELSE - INCR = 2**KBIT(I)-1 + INCR = 2**KBIT_S(I)-1 ENDIF - CALL PKB(INCR,KBIT(I),MESG,IBIT) + CALL PKB(INCR,KBIT_S(I),MESG,IBIT) ENDDO ENDIF - ELSEIF(ITYP(I).EQ.3) THEN - NCHR = IWID(I)/8 - IF(KBIT(I).GT.0) THEN - CALL PKB( 0,IWID(I),MESG,IBIT) + ELSEIF(ITYP_S(I).EQ.3) THEN + NCHR = IWID_S(I)/8 + IF(KBIT_S(I).GT.0) THEN + CALL PKB( 0,IWID_S(I),MESG,IBIT) CALL PKB(NCHR, 6,MESG,IBIT) - DO J=1,NCOL - CALL PKC(CATX(I,J),NCHR,MESG,IBIT) + DO J=1,NCOL_S + CALL PKC(CATX_S(I,J),NCHR,MESG,IBIT) ENDDO ELSE - CALL PKC(CSTR(I),NCHR,MESG,IBIT) + CALL PKC(CSTR_S(I),NCHR,MESG,IBIT) CALL PKB( 0, 6,MESG,IBIT) ENDIF ENDIF @@ -418,21 +431,21 @@ CALL MSGWRT(LUNIT,MESG,NBYT) - MAXROW = MAX(MAXROW,NROW) - MAXCOL = MAX(MAXCOL,NCOL) + MAXROW = MAX(MAXROW,NROW_S) + MAXCOL = MAX(MAXCOL,NCOL_S) NCMSGS = NCMSGS+1 - NCSUBS = NCSUBS+NCOL + NCSUBS = NCSUBS+NCOL_S NCBYTS = NCBYTS+NBYT ! RESET ! ----- -! NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK +! NOW, UNLESS THIS WAS A "FLUSH_S" CALL TO THIS SUBROUTINE, GO BACK ! AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE ! WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT. FIRST = .TRUE. - IF(.NOT.FLUSH) GOTO 1 + IF(.NOT.FLUSH_S) GOTO 1 ! EXITS ! ----- @@ -440,14 +453,14 @@ 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '// & 'CALL (",I3,") .NE. I/O STREAM INDEX FOR INITIAL CALL (",I3,")'// & - ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC,LUNIX + ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC_S,LUNIX CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// & 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE '// & 'COMPRESSION MATRIX (",I6,")")') NVAL(LUN),MXCDV CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// & - 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL + 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL_S CALL BORT(BORT_STR) 903 CALL BORT('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR') 904 CALL BORT('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// & diff --git a/wrfv2_fire/var/external/bufr/wrtree.inc b/wrfv2_fire/var/external/bufr/wrtree.inc index 7d729791..772b6400 100644 --- a/wrfv2_fire/var/external/bufr/wrtree.inc +++ b/wrfv2_fire/var/external/bufr/wrtree.inc @@ -52,19 +52,19 @@ COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), & MBAY(MXMSGLD4,NFILES) - COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & - JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & - IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & - ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & - ISEQ(MAXJL,2),JSEQ(MAXJL) - COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) - - CHARACTER*10 TAG +! COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), & +! JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), & +! IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), & +! ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), & +! ISEQ(MAXJL,2),JSEQ(MAXJL) +! COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES) + +! CHARACTER*10 TAG CHARACTER*8 CVAL - CHARACTER*3 TYP +! CHARACTER*3 TYP DIMENSION IVAL(MAXJL) EQUIVALENCE (CVAL,RVAL) - REAL*8 VAL,RVAL,PKS,TEN + REAL*8 RVAL,PKS,TEN !,VAL DATA TEN /10./ diff --git a/wrfv2_fire/var/gen_be/Makefile b/wrfv2_fire/var/gen_be/Makefile index 268e6825..25f07758 100644 --- a/wrfv2_fire/var/gen_be/Makefile +++ b/wrfv2_fire/var/gen_be/Makefile @@ -13,6 +13,7 @@ gen_be : gen_be_ensrf.exe \ gen_be_stage0_wrf.exe \ gen_be_ep1.exe \ gen_be_ep2.exe \ + gen_be_vertloc.exe \ gen_be_stage1.exe \ gen_be_stage1_1dvar.exe \ gen_be_stage2.exe \ @@ -61,6 +62,11 @@ gen_be_ep2.exe : gen_be_ep2.f90 $(GEN_BE_OBJS) $(GEN_BE_LIBS) $(SFC) -c $(FCFLAGS) -I../da $(MODULE_DIRS) $(WRFVAR_INC) $(PROMOTION) gen_be_ep2.f $(SFC) -o gen_be_ep2.exe $(LDFLAGS) $(GEN_BE_OBJS) gen_be_ep2.o $(GEN_BE_LIB) +gen_be_vertloc.exe : gen_be_vertloc.f90 $(GEN_BE_OBJS) $(GEN_BE_LIBS) + $(CPP) $(CPPFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc gen_be_vertloc.f90 > gen_be_vertloc.f + $(SFC) -c $(FCFLAGS) -I../da $(MODULE_DIRS) $(WRFVAR_INC) $(PROMOTION) gen_be_vertloc.f + $(SFC) -o gen_be_vertloc.exe $(LDFLAGS) $(GEN_BE_OBJS) gen_be_vertloc.o $(GEN_BE_LIB) + gen_be_stage1.exe : gen_be_stage1.f90 $(GEN_BE_OBJS) $(GEN_BE_LIBS) $(CPP) $(CPPFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc gen_be_stage1.f90 > gen_be_stage1.f $(SFC) -c $(FCFLAGS) -I../da $(MODULE_DIRS) $(WRFVAR_INC) $(PROMOTION) gen_be_stage1.f diff --git a/wrfv2_fire/var/gen_be/gen_be_ensmean.f90 b/wrfv2_fire/var/gen_be/gen_be_ensmean.f90 index 0a45487d..5f98d711 100644 --- a/wrfv2_fire/var/gen_be/gen_be_ensmean.f90 +++ b/wrfv2_fire/var/gen_be/gen_be_ensmean.f90 @@ -152,8 +152,6 @@ program gen_be_ensmean var, ' variable is not real type' call da_error(__FILE__,__LINE__,message(1:1)) end if -print *, var, ivtype, id_var -print *, istart, iend(1), iend(2), iend(3) end if ! Calculate accumulating mean and variance: diff --git a/wrfv2_fire/var/gen_be/gen_be_ep2.f90 b/wrfv2_fire/var/gen_be/gen_be_ep2.f90 index c6dda63d..9863b5a2 100644 --- a/wrfv2_fire/var/gen_be/gen_be_ep2.f90 +++ b/wrfv2_fire/var/gen_be/gen_be_ep2.f90 @@ -46,16 +46,22 @@ program gen_be_ep2 real, allocatable :: v(:,:,:) ! v-wind. real, allocatable :: temp(:,:,:) ! Temperature. real, allocatable :: q(:,:,:) ! Specific humidity. + real, allocatable :: qcloud(:,:,:) ! Cloud. + real, allocatable :: qrain(:,:,:) ! Rain. real, allocatable :: psfc(:,:) ! Surface pressure. real, allocatable :: u_mean(:,:,:) ! u-wind. real, allocatable :: v_mean(:,:,:) ! v-wind. real, allocatable :: temp_mean(:,:,:) ! Temperature. real, allocatable :: q_mean(:,:,:) ! Specific humidity. + real, allocatable :: qcloud_mean(:,:,:) ! Cloud. + real, allocatable :: qrain_mean(:,:,:) ! Rain. real, allocatable :: psfc_mean(:,:) ! Surface pressure. real, allocatable :: u_mnsq(:,:,:) ! u-wind. real, allocatable :: v_mnsq(:,:,:) ! v-wind. real, allocatable :: temp_mnsq(:,:,:) ! Temperature. real, allocatable :: q_mnsq(:,:,:) ! Specific humidity. + real, allocatable :: qcloud_mnsq(:,:,:) ! Cloud. + real, allocatable :: qrain_mnsq(:,:,:) ! Rain. real, allocatable :: psfc_mnsq(:,:) ! Surface pressure. real, allocatable :: utmp(:,:) ! u-wind. @@ -101,7 +107,7 @@ program gen_be_ep2 else write(6,'(a,a)')' Computing gen_be ensemble forecast files for date ', date end if - write(6,'(a)')' Perturbations are in MODEL SPACE (u, v, t, q, ps)' + write(6,'(a)')' Perturbations are in MODEL SPACE (u, v, t, q, qcloud, qrain, ps)' write(6,'(a,i4)')' Ensemble Size = ', ne write(6,'(a,a)')' Directory = ', trim(directory) write(6,'(a,a)')' Filename = ', trim(filename) @@ -122,26 +128,36 @@ program gen_be_ep2 allocate( v(1:dim1,1:dim2,1:dim3) ) ! Note - interpolated to mass pts for output. allocate( temp(1:dim1,1:dim2,1:dim3) ) allocate( q(1:dim1,1:dim2,1:dim3) ) + allocate( qcloud(1:dim1,1:dim2,1:dim3) ) + allocate( qrain(1:dim1,1:dim2,1:dim3) ) allocate( psfc(1:dim1,1:dim2) ) allocate( u_mean(1:dim1,1:dim2,1:dim3) ) ! Note - interpolated to chi pts for output. allocate( v_mean(1:dim1,1:dim2,1:dim3) ) allocate( temp_mean(1:dim1,1:dim2,1:dim3) ) allocate( q_mean(1:dim1,1:dim2,1:dim3) ) + allocate( qcloud_mean(1:dim1,1:dim2,1:dim3) ) + allocate( qrain_mean(1:dim1,1:dim2,1:dim3) ) allocate( psfc_mean(1:dim1,1:dim2) ) allocate( u_mnsq(1:dim1,1:dim2,1:dim3) ) ! Note - interpolated to chi pts for output. allocate( v_mnsq(1:dim1,1:dim2,1:dim3) ) allocate( temp_mnsq(1:dim1,1:dim2,1:dim3) ) allocate( q_mnsq(1:dim1,1:dim2,1:dim3) ) + allocate( qcloud_mnsq(1:dim1,1:dim2,1:dim3) ) + allocate( qrain_mnsq(1:dim1,1:dim2,1:dim3) ) allocate( psfc_mnsq(1:dim1,1:dim2) ) u_mean = 0.0 v_mean = 0.0 temp_mean = 0.0 q_mean = 0.0 + qcloud_mean = 0.0 + qrain_mean = 0.0 psfc_mean = 0.0 u_mnsq = 0.0 v_mnsq = 0.0 temp_mnsq = 0.0 q_mnsq = 0.0 + qcloud_mnsq = 0.0 + qrain_mnsq = 0.0 psfc_mnsq = 0.0 ! Temporary arrays: @@ -184,6 +200,14 @@ program gen_be_ep2 call da_get_field( input_file, var, 3, dim1, dim2, dim3, k, dummy ) q(:,:,k) = dummy(:,:) / ( 1.0 + dummy(:,:) ) +! Read hydrometeors (need better method to read all e.g. qsn automatically): + var = "QCLOUD" + call da_get_field( input_file, var, 3, dim1, dim2, dim3, k, dummy ) + qcloud(:,:,k) = dummy(:,:) + var = "QRAIN" + call da_get_field( input_file, var, 3, dim1, dim2, dim3, k, dummy ) + qrain(:,:,k) = dummy(:,:) + end do ! Finally, extract surface pressure: @@ -198,6 +222,8 @@ program gen_be_ep2 write(gen_be_ounit)v write(gen_be_ounit)temp write(gen_be_ounit)q + write(gen_be_ounit)qcloud + write(gen_be_ounit)qrain write(gen_be_ounit)psfc close(gen_be_ounit) @@ -207,11 +233,15 @@ program gen_be_ep2 v_mean = ( real( member-1 ) * v_mean + v ) * member_inv temp_mean = ( real( member-1 ) * temp_mean + temp ) * member_inv q_mean = ( real( member-1 ) * q_mean + q ) * member_inv + qcloud_mean = ( real( member-1 ) * qcloud_mean + qcloud ) * member_inv + qrain_mean = ( real( member-1 ) * qrain_mean + qrain ) * member_inv psfc_mean = ( real( member-1 ) * psfc_mean + psfc ) * member_inv u_mnsq = ( real( member-1 ) * u_mnsq + u * u ) * member_inv v_mnsq = ( real( member-1 ) * v_mnsq + v * v ) * member_inv temp_mnsq = ( real( member-1 ) * temp_mnsq + temp * temp ) * member_inv q_mnsq = ( real( member-1 ) * q_mnsq + q * q ) * member_inv + qcloud_mnsq = ( real( member-1 ) * qcloud_mnsq + qcloud * qcloud ) * member_inv + qrain_mnsq = ( real( member-1 ) * qrain_mnsq + qrain * qrain ) * member_inv psfc_mnsq = ( real( member-1 ) * psfc_mnsq + psfc * psfc ) * member_inv end do @@ -242,6 +272,8 @@ program gen_be_ep2 read(gen_be_iunit)v read(gen_be_iunit)temp read(gen_be_iunit)q + read(gen_be_iunit)qcloud + read(gen_be_iunit)qrain read(gen_be_iunit)psfc close(gen_be_iunit) @@ -250,6 +282,8 @@ program gen_be_ep2 v = v - v_mean temp = temp - temp_mean q = q - q_mean + qcloud = qcloud - qcloud_mean + qrain = qrain - qrain_mean psfc = psfc - psfc_mean end if @@ -279,6 +313,18 @@ program gen_be_ep2 write(gen_be_ounit)q close(gen_be_ounit) + output_file = 'qcloud.e'//trim(ce) ! Output qcloud. + open (gen_be_ounit, file = output_file, form='unformatted') + write(gen_be_ounit)dim1, dim2, dim3 + write(gen_be_ounit)qcloud + close(gen_be_ounit) + + output_file = 'qrain.e'//trim(ce) ! Output qrain. + open (gen_be_ounit, file = output_file, form='unformatted') + write(gen_be_ounit)dim1, dim2, dim3 + write(gen_be_ounit)qrain + close(gen_be_ounit) + output_file = 'ps.e'//trim(ce) ! Output ps. open (gen_be_ounit, file = output_file, form='unformatted') write(gen_be_ounit)dim1, dim2, dim3 @@ -292,6 +338,8 @@ program gen_be_ep2 v_mnsq = sqrt( v_mnsq - v_mean * v_mean ) temp_mnsq = sqrt( temp_mnsq - temp_mean * temp_mean ) q_mnsq = sqrt( q_mnsq - q_mean * q_mean ) + qcloud_mnsq = sqrt( qcloud_mnsq - qcloud_mean * qcloud_mean ) + qrain_mnsq = sqrt( qrain_mnsq - qrain_mean * qrain_mean ) psfc_mnsq = sqrt( psfc_mnsq - psfc_mean * psfc_mean ) output_file = 'u.mean' ! Output u. @@ -342,6 +390,30 @@ program gen_be_ep2 write(gen_be_ounit)q_mnsq close(gen_be_ounit) + output_file = 'qcloud.mean' ! Output qcloud. + open (gen_be_ounit, file = output_file, form='unformatted') + write(gen_be_ounit)dim1, dim2, dim3 + write(gen_be_ounit)qcloud_mean + close(gen_be_ounit) + + output_file = 'qcloud.stdv' ! Output qcloud. + open (gen_be_ounit, file = output_file, form='unformatted') + write(gen_be_ounit)dim1, dim2, dim3 + write(gen_be_ounit)qcloud_mnsq + close(gen_be_ounit) + + output_file = 'qrain.mean' ! Output qrain. + open (gen_be_ounit, file = output_file, form='unformatted') + write(gen_be_ounit)dim1, dim2, dim3 + write(gen_be_ounit)qrain_mean + close(gen_be_ounit) + + output_file = 'qrain.stdv' ! Output qrain. + open (gen_be_ounit, file = output_file, form='unformatted') + write(gen_be_ounit)dim1, dim2, dim3 + write(gen_be_ounit)qrain_mnsq + close(gen_be_ounit) + output_file = 'ps.mean' ! Output ps. open (gen_be_ounit, file = output_file, form='unformatted') write(gen_be_ounit)dim1, dim2, dim3 diff --git a/wrfv2_fire/var/obsproc/MAP_plot/Dir_map/setup.F b/wrfv2_fire/var/obsproc/MAP_plot/Dir_map/setup.F index 75d91348..49e9860f 100644 --- a/wrfv2_fire/var/obsproc/MAP_plot/Dir_map/setup.F +++ b/wrfv2_fire/var/obsproc/MAP_plot/Dir_map/setup.F @@ -70,8 +70,8 @@ C if (abs(TRUELAT1-TRUELAT2)==0.0) then TRUELAT0 = TRUELAT1 - TRUELAT1 = TRUELAT0 - 1.e-5 - TRUELAT2 = TRUELAT0 + 1.e-5 + TRUELAT1 = TRUELAT0 - 1.e-2 + TRUELAT2 = TRUELAT0 + 1.e-2 endif XN = ALOG10(COS(TRUELAT1 / CONV)) - SETUP.164 diff --git a/wrfv2_fire/var/obsproc/src/Makefile b/wrfv2_fire/var/obsproc/src/Makefile index 0fc81cbf..87cd0c7e 100644 --- a/wrfv2_fire/var/obsproc/src/Makefile +++ b/wrfv2_fire/var/obsproc/src/Makefile @@ -74,13 +74,13 @@ obsproc.exe: $(MODULES) $(MODULES_MM5) $(MODULES_OBS) \ $(OBJS) \ obsproc.o if [ "$(BUFR)" = "-DBUFR" ] ; then \ - $(FC) -o $@ \ + $(SFC) -o $@ \ $(MODULES) $(MODULES_MM5) $(MODULES_OBS) \ $(MODULES_GTS) \ $(OBJS) $(BUFR_OBJS) \ obsproc.o $(LDFLAGS) $(LOCAL_LIBRARIES) ; \ else \ - $(FC) -o $@ \ + $(SFC) -o $@ \ $(MODULES) $(MODULES_MM5) $(MODULES_OBS) \ $(MODULES_GTS) \ $(OBJS) \ diff --git a/wrfv2_fire/var/obsproc/src/fm_decoder.F90 b/wrfv2_fire/var/obsproc/src/fm_decoder.F90 index e72b3331..9926ed7f 100644 --- a/wrfv2_fire/var/obsproc/src/fm_decoder.F90 +++ b/wrfv2_fire/var/obsproc/src/fm_decoder.F90 @@ -22,6 +22,7 @@ ! satem 86 'SATEM' ! satob 88 'SATOB' ! airep 96,97 'AIREP' +! tamdar 101 'TAMDAR' ! gpspw 111 'GPSPW' ! gpsztd 114 'GPSZD' ! gpsref 116 'GPSRF' diff --git a/wrfv2_fire/var/obsproc/src/module_diagnostics.F90 b/wrfv2_fire/var/obsproc/src/module_diagnostics.F90 index aaf163ef..8a5dce07 100644 --- a/wrfv2_fire/var/obsproc/src/module_diagnostics.F90 +++ b/wrfv2_fire/var/obsproc/src/module_diagnostics.F90 @@ -29,7 +29,7 @@ CONTAINS TYPE (measurement), POINTER :: current INTEGER :: i, fm REAL :: xj, yi - + CHARACTER (LEN= 5) :: bogus_type INCLUDE 'missing.inc' !------------------------------------------------------------------- @@ -44,6 +44,7 @@ loop_all_obs: & DO i = 1, number_of_obs READ (obs(i) % info % platform (4:6), '(I3)') fm + if (fm == 135) bogus_type = obs (i) % info % platform (8:12) valid_obs1:& IF (.NOT. obs(i)%info%discard) THEN @@ -66,13 +67,15 @@ all_levels:& else ! With fm = 116 (gpsref) and fm = 118 (gpseph), the field "dew_point" was ! used to store gpsref, no "diagnostics_moist" is allowed. - if ( fm /= 116 .and. (fm /= 118))& - CALL diagnostics_moist (current%meas) -! Typhoon bogus with FM = 135, no wind diagnostics need to be done: - if ( fm /= 135 .and.fm /= 116 .and. fm /= 118 .and. & - fm /=125) & - CALL diagnostics_wind (current%meas, & + if (fm /= 116 .and. fm /= 118) then + if (fm ==135.and.bogus_type /='BOGUS') then +! nothing to do if TCBOG... + else + CALL diagnostics_moist (current%meas) + CALL diagnostics_wind (current%meas, & obs(i)%location%longitude) + endif + endif endif current => current%next diff --git a/wrfv2_fire/var/obsproc/src/module_err_afwa.F90 b/wrfv2_fire/var/obsproc/src/module_err_afwa.F90 index 2512436f..b487a28d 100644 --- a/wrfv2_fire/var/obsproc/src/module_err_afwa.F90 +++ b/wrfv2_fire/var/obsproc/src/module_err_afwa.F90 @@ -434,8 +434,8 @@ record_valid: IF (obs(loop_index)%info%discard) THEN ! ----------------------------- obs (loop_index) % ground % slp % error = 200. ! 2hPa -! For TC bogus, slp error is obtained from psfc%data: - IF (fm == 135 .and. bogus_type == 'TCBOG') & +! For TC bogus, slp error is obtained from psfc%data, name:"BOGUS" is not TC bogus: + IF (fm == 135 .and. bogus_type /= 'BOGUS') & obs (loop_index) % ground % slp % error = obs (loop_index) % ground % psfc % data ! Some PW or ZTD data are read with their errors, don't modify them @@ -810,14 +810,25 @@ upper_level: DO WHILE (ASSOCIATED (current)) current % meas % direction % error = 5. ! 5 degree - IF (bogus_type == 'TCBOG') then + IF (bogus_type /= 'BOGUS') then current % meas % speed % error = current % meas % u % data current % meas % u % error = current % meas % u % data current % meas % v % error = current % meas % v % data + + current % meas % temperature % error = current % meas % dew_point % data + + current % meas % dew_point % error = current % meas % temperature % error + current % meas % rh % error = current % meas % thickness % data + +! current % meas % pressure % error = intplin (pres, err % level, & +! err % sound % pres) +! +! current % meas % height % error = intplog (pres, err % level, & +! err % sound % height) else current % meas % speed % error = intplin (pres, err_wind % level,& @@ -826,7 +837,6 @@ upper_level: DO WHILE (ASSOCIATED (current)) err_wind % sound % wind) current % meas % v % error = intplin (pres, err_wind % level, & err_wind % sound % wind) - endif ! Pressure @@ -851,6 +861,7 @@ upper_level: DO WHILE (ASSOCIATED (current)) current % meas % rh % error = intplog (pres, err % level, & err % sound % rh) + endif ! 4.6 Satem obs ! --------- diff --git a/wrfv2_fire/var/obsproc/src/obsproc.F90 b/wrfv2_fire/var/obsproc/src/obsproc.F90 index 141ea49f..9c39021d 100644 --- a/wrfv2_fire/var/obsproc/src/obsproc.F90 +++ b/wrfv2_fire/var/obsproc/src/obsproc.F90 @@ -505,9 +505,12 @@ PROGRAM main_obsproc ! 8.9 Time duplicate check within a slot for 4DVAR ! -------------------------------------------- - if (use_for == '4DVAR' ) & - CALL check_duplicate_time (obs ,index ,number_of_obs, total_dups_time, & - time_fg, print_duplicate_time) + if (use_for == '4DVAR' ) then + CALL sort_obs (obs ,number_of_obs , compare_loc, index ) + + CALL check_duplicate_time (obs ,index ,number_of_obs, total_dups_time, & + time_fg, print_duplicate_time) + endif ! 8.10 Print report per platform type and count the # levels per stations ! ------------------------------------------------------------------ -- 2.11.4.GIT